    {-# LANGUAGE CPP, TypeFamilies #-}

    -----------------------------------------------------------------------------
    --
    -- Machine-dependent assembly language
    --
    -- (c) The University of Glasgow 1993-2004
    --
    -----------------------------------------------------------------------------

    module GHC.CmmToAsm.X86.Instr
       ( Instr(..)
       , Operand(..)
       , PrefetchVariant(..)
       , JumpDest(..)
       , getJumpDestBlockId
       , canShortcut
       , shortcutStatics
       , shortcutJump
       , allocMoreStack
       , maxSpillSlots
       , archWordFormat
       , takeRegRegMoveInstr
       , regUsageOfInstr
       , takeDeltaInstr
       , mkLoadInstr
       , mkJumpInstr
       , mkStackAllocInstr
       , mkStackDeallocInstr
       , mkSpillInstr
       , mkRegRegMoveInstr
       , jumpDestsOfInstr
       , patchRegsOfInstr
       , patchJumpInstr
       , isMetaInstr
       , isJumpishInstr
       )
    where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.CmmToAsm.X86.Cond
    import GHC.CmmToAsm.X86.Regs
    import GHC.CmmToAsm.Format
    import GHC.CmmToAsm.Types
    import GHC.CmmToAsm.Utils
    import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)
    import GHC.Platform.Reg.Class
    import GHC.Platform.Reg
    import GHC.CmmToAsm.Reg.Target
    import GHC.CmmToAsm.Config

    import GHC.Cmm.BlockId
    import GHC.Cmm.Dataflow.Collections
    import GHC.Cmm.Dataflow.Label
    import GHC.Platform.Regs
    import GHC.Cmm
    import GHC.Data.FastString
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Platform

    import GHC.Cmm.CLabel
    import GHC.Types.Unique.Set
    import GHC.Types.Unique
    import GHC.Types.Unique.Supply
    import GHC.Types.Basic (Alignment)
    import GHC.Cmm.DebugBlock (UnwindTable)

    import Control.Monad
    import Data.Maybe       (fromMaybe)

    -- Format of an x86/x86_64 memory address, in bytes.
    --
    archWordFormat :: Bool -> Format
    archWordFormat :: Bool -> Format
    archWordFormat Bool
    is32Bit
     | Bool
    is32Bit   = Format
    II32
     | Bool
    otherwise = Format
    II64

    -- -----------------------------------------------------------------------------
    -- Intel x86 instructions

    {-
    Intel, in their infinite wisdom, selected a stack model for floating
    point registers on x86.  That might have made sense back in 1979 --
    nowadays we can see it for the nonsense it really is.  A stack model
    fits poorly with the existing nativeGen infrastructure, which assumes
    flat integer and FP register sets.  Prior to this commit, nativeGen
    could not generate correct x86 FP code -- to do so would have meant
    somehow working the register-stack paradigm into the register
    allocator and spiller, which sounds very difficult.

    We have decided to cheat, and go for a simple fix which requires no
    infrastructure modifications, at the expense of generating ropey but
    correct FP code.  All notions of the x86 FP stack and its insns have
    been removed.  Instead, we pretend (to the instruction selector and
    register allocator) that x86 has six floating point registers, %fake0
    .. %fake5, which can be used in the usual flat manner.  We further
    claim that x86 has floating point instructions very similar to SPARC
    and Alpha, that is, a simple 3-operand register-register arrangement.
    Code generation and register allocation proceed on this basis.

    When we come to print out the final assembly, our convenient fiction
    is converted to dismal reality.  Each fake instruction is
    independently converted to a series of real x86 instructions.
    %fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg
    arithmetic operations, the two operands are pushed onto the top of the
    FP stack, the operation done, and the result copied back into the
    relevant register.  There are only six %fake registers because 2 are
    needed for the translation, and x86 has 8 in total.

    The translation is inefficient but is simple and it works.  A cleverer
    translation would handle a sequence of insns, simulating the FP stack
    contents, would not impose a fixed mapping from %fake to %st regs, and
    hopefully could avoid most of the redundant reg-reg moves of the
    current translation.

    We might as well make use of whatever unique FP facilities Intel have
    chosen to bless us with (let's not be churlish, after all).
    Hence GLDZ and GLD1.  Bwahahahahahahaha!
    -}

    {-
    Note [x86 Floating point precision]

    Intel's internal floating point registers are by default 80 bit
    extended precision.  This means that all operations done on values in
    registers are done at 80 bits, and unless the intermediate values are
    truncated to the appropriate size (32 or 64 bits) by storing in
    memory, calculations in registers will give different results from
    calculations which pass intermediate values in memory (eg. via
    function calls).

    One solution is to set the FPU into 64 bit precision mode.  Some OSs
    do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is
    that this will only affect 64-bit precision arithmetic; 32-bit
    calculations will still be done at 64-bit precision in registers.  So
    it doesn't solve the whole problem.

    There's also the issue of what the C library is expecting in terms of
    precision.  It seems to be the case that glibc on Linux expects the
    FPU to be set to 80 bit precision, so setting it to 64 bit could have
    unexpected effects.  Changing the default could have undesirable
    effects on other 3rd-party library code too, so the right thing would
    be to save/restore the FPU control word across Haskell code if we were
    to do this.

    gcc's -ffloat-store gives consistent results by always storing the
    results of floating-point calculations in memory, which works for both
    32 and 64-bit precision.  However, it only affects the values of
    user-declared floating point variables in C, not intermediate results.
    GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision
    flag).

    Another problem is how to spill floating point registers in the
    register allocator.  Should we spill the whole 80 bits, or just 64?
    On an OS which is set to 64 bit precision, spilling 64 is fine.  On
    Linux, spilling 64 bits will round the results of some operations.
    This is what gcc does.  Spilling at 80 bits requires taking up a full
    128 bit slot (so we get alignment).  We spill at 80-bits and ignore
    the alignment problems.

    In the future [edit: now available in GHC 7.0.1, with the -msse2
    flag], we'll use the SSE registers for floating point.  This requires
    a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision
    float ops), which means P4 or Xeon and above.  Using SSE will solve
    all these problems, because the SSE registers use fixed 32 bit or 64
    bit precision.

    --SDM 1/2003
    -}

    data Instr
            -- comment pseudo-op
            = COMMENT FastString

            -- location pseudo-op (file, line, col, name)
            | LOCATION Int Int Int String

            -- some static data spat out during code
            -- generation.  Will be extracted before
            -- pretty-printing.
            | LDATA   Section (Alignment, RawCmmStatics)

            -- start a new basic block.  Useful during
            -- codegen, removed later.  Preceding
            -- instruction should be a jump, as per the
            -- invariants for a BasicBlock (see Cmm).
            | NEWBLOCK BlockId

            -- unwinding information
            -- See Note [Unwinding information in the NCG].
            | UNWIND CLabel UnwindTable

            -- specify current stack offset for benefit of subsequent passes.
            -- This carries a BlockId so it can be used in unwinding information.
            | DELTA  Int

            -- Moves.
            | MOV         Format Operand Operand
            | CMOV   Cond Format Operand Reg
            | MOVZxL      Format Operand Operand -- format is the size of operand 1
            | MOVSxL      Format Operand Operand -- format is the size of operand 1
            -- x86_64 note: plain mov into a 32-bit register always zero-extends
            -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which
            -- don't affect the high bits of the register.

            -- Load effective address (also a very useful three-operand add instruction :-)
            | LEA         Format Operand Operand

            -- Int Arithmetic.
            | ADD         Format Operand Operand
            | ADC         Format Operand Operand
            | SUB         Format Operand Operand
            | SBB         Format Operand Operand

            | MUL         Format Operand Operand
            | MUL2        Format Operand         -- %edx:%eax = operand * %rax
            | IMUL        Format Operand Operand -- signed int mul
            | IMUL2       Format Operand         -- %edx:%eax = operand * %eax

            | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op
            | IDIV        Format Operand         -- ditto, but signed

            -- Int Arithmetic, where the effects on the condition register
            -- are important. Used in specialized sequences such as MO_Add2.
            -- Do not rewrite these instructions to "equivalent" ones that
            -- have different effect on the condition register! (See #9013.)
            | ADD_CC      Format Operand Operand
            | SUB_CC      Format Operand Operand

            -- Simple bit-twiddling.
            | AND         Format Operand Operand
            | OR          Format Operand Operand
            | XOR         Format Operand Operand
            | NOT         Format Operand
            | NEGI        Format Operand         -- NEG instruction (name clash with Cond)
            | BSWAP       Format Reg

            -- Shifts (amount may be immediate or %cl only)
            | SHL         Format Operand{-amount-} Operand
            | SAR         Format Operand{-amount-} Operand
            | SHR         Format Operand{-amount-} Operand

            | BT          Format Imm Operand
            | NOP

            -- We need to support the FSTP (x87 store and pop) instruction
            -- so that we can correctly read off the return value of an
            -- x86 CDECL C function call when its floating point.
            -- so we dont include a register argument, and just use st(0)
            -- this instruction is used ONLY for return values of C ffi calls
            -- in x86_32 abi
            | X87Store         Format  AddrMode -- st(0), dst

            -- SSE2 floating point: we use a restricted set of the available SSE2
            -- instructions for floating-point.
            -- use MOV for moving (either movss or movsd (movlpd better?))
            | CVTSS2SD      Reg Reg            -- F32 to F64
            | CVTSD2SS      Reg Reg            -- F64 to F32
            | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)
            | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)
            | CVTSI2SS      Format Operand Reg -- I32/I64 to F32
            | CVTSI2SD      Format Operand Reg -- I32/I64 to F64

            -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands
            -- are  Operand Reg.

            -- SSE2 floating-point division:
            | FDIV          Format Operand Operand   -- divisor, dividend(dst)

            -- use CMP for comparisons.  ucomiss and ucomisd instructions
            -- compare single/double prec floating point respectively.

            | SQRT          Format Operand Reg      -- src, dst

            -- Comparison
            | TEST          Format Operand Operand
            | CMP           Format Operand Operand
            | SETCC         Cond Operand

            -- Stack Operations.
            | PUSH          Format Operand
            | POP           Format Operand
            -- both unused (SDM):
            --  | PUSHA
            --  | POPA

            -- Jumping around.
            | JMP         Operand [Reg] -- including live Regs at the call
            | JXX         Cond BlockId  -- includes unconditional branches
            | JXX_GBL     Cond Imm      -- non-local version of JXX
            -- Table jump
            | JMP_TBL     Operand   -- Address to jump to
                          [Maybe JumpDest] -- Targets of the jump table
                          Section   -- Data section jump table should be put in
                          CLabel    -- Label of jump table
            -- | X86 call instruction
            | CALL        (Either Imm Reg) -- ^ Jump target
                          [Reg]            -- ^ Arguments (required for register allocation)

            -- Other things.
            | CLTD Format            -- sign extend %eax into %edx:%eax

            | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code
                                     -- pretty-prints as
                                     --       call 1f
                                     -- 1:    popl %reg
                                     --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg
            | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code
                                     -- pretty-prints as
                                     --       call 1f
                                     -- 1:    popl %reg

        -- bit counting instructions
            | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1
            | LZCNT       Format Operand Reg -- [BMI2] count number of leading zeros
            | TZCNT       Format Operand Reg -- [BMI2] count number of trailing zeros
            | BSF         Format Operand Reg -- bit scan forward
            | BSR         Format Operand Reg -- bit scan reverse

        -- bit manipulation instructions
            | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask
            | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask

        -- prefetch
            | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch
                                            -- variant can be NTA, Lvl0, Lvl1, or Lvl2

            | LOCK        Instr -- lock prefix
            | XADD        Format Operand Operand -- src (r), dst (r/m)
            | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit
            | XCHG        Format Operand Reg     -- src (r/m), dst (r/m)
            | MFENCE

    data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2

    data Operand
            = OpReg  Reg            -- register
            | OpImm  Imm            -- immediate value
            | OpAddr AddrMode       -- memory reference

    -- | Returns which registers are read and written as a (read, written)
    -- pair.
    regUsageOfInstr :: Platform -> Instr -> RegUsage
    regUsageOfInstr :: Platform -> Instr -> RegUsage
    regUsageOfInstr Platform
    platform Instr
    instr
     = case Instr
    instr of
        MOV    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRW Operand
    src Operand
    dst
        CMOV Cond
    _ Format
    _ Operand
    src Reg
    dst    -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src [Reg
    dst]) [Reg
    dst]
        MOVZxL Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRW Operand
    src Operand
    dst
        MOVSxL Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRW Operand
    src Operand
    dst
        LEA    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRW Operand
    src Operand
    dst
        ADD    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        ADC    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        SUB    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        SBB    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        IMUL   Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst

        -- Result of IMULB will be in just in %ax
        IMUL2  Format
    II8 Operand
    src       -> [Reg] -> [Reg] -> RegUsage
    mkRU (Reg
    eaxforall a. a -> [a] -> [a]
    :Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    eax]
        -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and
        -- %ax/%eax/%rax.
        IMUL2  Format
    _ Operand
    src        -> [Reg] -> [Reg] -> RegUsage
    mkRU (Reg
    eaxforall a. a -> [a] -> [a]
    :Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    eax,Reg
    edx]

        MUL    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        MUL2   Format
    _ Operand
    src        -> [Reg] -> [Reg] -> RegUsage
    mkRU (Reg
    eaxforall a. a -> [a] -> [a]
    :Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    eax,Reg
    edx]
        DIV    Format
    _ Operand
    op -> [Reg] -> [Reg] -> RegUsage
    mkRU (Reg
    eaxforall a. a -> [a] -> [a]
    :Reg
    edxforall a. a -> [a] -> [a]
    :Operand -> [Reg] -> [Reg]
    use_R Operand
    op []) [Reg
    eax,Reg
    edx]
        IDIV   Format
    _ Operand
    op -> [Reg] -> [Reg] -> RegUsage
    mkRU (Reg
    eaxforall a. a -> [a] -> [a]
    :Reg
    edxforall a. a -> [a] -> [a]
    :Operand -> [Reg] -> [Reg]
    use_R Operand
    op []) [Reg
    eax,Reg
    edx]
        ADD_CC Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        SUB_CC Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        AND    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        OR     Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst

        XOR    Format
    _ (OpReg Reg
    src) (OpReg Reg
    dst)
            | Reg
    src forall a. Eq a => a -> a -> Bool
    == Reg
    dst    -> [Reg] -> [Reg] -> RegUsage
    mkRU [] [Reg
    dst]

        XOR    Format
    _ Operand
    src Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        NOT    Format
    _ Operand
    op         -> Operand -> RegUsage
    usageM Operand
    op
        BSWAP  Format
    _ Reg
    reg        -> [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    reg] [Reg
    reg]
        NEGI   Format
    _ Operand
    op         -> Operand -> RegUsage
    usageM Operand
    op
        SHL    Format
    _ Operand
    imm Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    imm Operand
    dst
        SAR    Format
    _ Operand
    imm Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    imm Operand
    dst
        SHR    Format
    _ Operand
    imm Operand
    dst    -> Operand -> Operand -> RegUsage
    usageRM Operand
    imm Operand
    dst
        BT     Format
    _ Imm
    _   Operand
    src    -> [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    src [])

        PUSH   Format
    _ Operand
    op         -> [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    op [])
        POP    Format
    _ Operand
    op         -> [Reg] -> [Reg] -> RegUsage
    mkRU [] (Operand -> [Reg]
    def_W Operand
    op)
        TEST   Format
    _ Operand
    src Operand
    dst    -> [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    src forall a b. (a -> b) -> a -> b
    $! Operand -> [Reg] -> [Reg]
    use_R Operand
    dst [])
        CMP    Format
    _ Operand
    src Operand
    dst    -> [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    src forall a b. (a -> b) -> a -> b
    $! Operand -> [Reg] -> [Reg]
    use_R Operand
    dst [])
        SETCC  Cond
    _ Operand
    op         -> [Reg] -> [Reg] -> RegUsage
    mkRU [] (Operand -> [Reg]
    def_W Operand
    op)
        JXX    Cond
    _ BlockId
    _          -> [Reg] -> [Reg] -> RegUsage
    mkRU [] []
        JXX_GBL Cond
    _ Imm
    _         -> [Reg] -> [Reg] -> RegUsage
    mkRU [] []
        JMP     Operand
    op [Reg]
    regs     -> [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    op [Reg]
    regs)
        JMP_TBL Operand
    op [Maybe JumpDest]
    _ Section
    _ CLabel
    _    -> [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    op [])
        CALL (Left Imm
    _)  [Reg]
    params   -> [Reg] -> [Reg] -> RegUsage
    mkRU [Reg]
    params (Platform -> [Reg]
    callClobberedRegs Platform
    platform)
        CALL (Right Reg
    reg) [Reg]
    params -> [Reg] -> [Reg] -> RegUsage
    mkRU (Reg
    regforall a. a -> [a] -> [a]
    :[Reg]
    params) (Platform -> [Reg]
    callClobberedRegs Platform
    platform)
        CLTD   Format
    _            -> [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    eax] [Reg
    edx]
        Instr
    NOP                 -> [Reg] -> [Reg] -> RegUsage
    mkRU [] []

        X87Store    Format
    _  AddrMode
    dst    -> [Reg] -> RegUsage
    mkRUR ( AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    dst [])

        CVTSS2SD   Reg
    src Reg
    dst  -> [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    src] [Reg
    dst]
        CVTSD2SS   Reg
    src Reg
    dst  -> [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    src] [Reg
    dst]
        CVTTSS2SIQ Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        CVTTSD2SIQ Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        CVTSI2SS   Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        CVTSI2SD   Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        FDIV Format
    _     Operand
    src Operand
    dst  -> Operand -> Operand -> RegUsage
    usageRM Operand
    src Operand
    dst
        SQRT Format
    _ Operand
    src Reg
    dst      -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]

        FETCHGOT Reg
    reg        -> [Reg] -> [Reg] -> RegUsage
    mkRU [] [Reg
    reg]
        FETCHPC  Reg
    reg        -> [Reg] -> [Reg] -> RegUsage
    mkRU [] [Reg
    reg]

        COMMENT FastString
    _           -> RegUsage
    noUsage
        LOCATION{}          -> RegUsage
    noUsage
        UNWIND{}            -> RegUsage
    noUsage
        DELTA   Int
    _           -> RegUsage
    noUsage

        POPCNT Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        LZCNT  Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        TZCNT  Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        BSF    Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]
        BSR    Format
    _ Operand
    src Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) [Reg
    dst]

        PDEP   Format
    _ Operand
    src Operand
    mask Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src forall a b. (a -> b) -> a -> b
    $ Operand -> [Reg] -> [Reg]
    use_R Operand
    mask []) [Reg
    dst]
        PEXT   Format
    _ Operand
    src Operand
    mask Reg
    dst -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src forall a b. (a -> b) -> a -> b
    $ Operand -> [Reg] -> [Reg]
    use_R Operand
    mask []) [Reg
    dst]

        -- note: might be a better way to do this
        PREFETCH PrefetchVariant
    _  Format
    _ Operand
    src -> [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    src []) []
        LOCK Instr
    i              -> Platform -> Instr -> RegUsage
    regUsageOfInstr Platform
    platform Instr
    i
        XADD Format
    _ Operand
    src Operand
    dst      -> Operand -> Operand -> RegUsage
    usageMM Operand
    src Operand
    dst
        CMPXCHG Format
    _ Operand
    src Operand
    dst   -> Operand -> Operand -> Operand -> RegUsage
    usageRMM Operand
    src Operand
    dst (Reg -> Operand
    OpReg Reg
    eax)
        XCHG Format
    _ Operand
    src Reg
    dst      -> Operand -> Operand -> RegUsage
    usageMM Operand
    src (Reg -> Operand
    OpReg Reg
    dst)
        Instr
    MFENCE -> RegUsage
    noUsage

        Instr
    _other              -> forall a. String -> a
    panic String
    "regUsage: unrecognised instr"
     where
        -- # Definitions
        --
        -- Written: If the operand is a register, it's written. If it's an
        -- address, registers mentioned in the address are read.
        --
        -- Modified: If the operand is a register, it's both read and
        -- written. If it's an address, registers mentioned in the address
        -- are read.

        -- 2 operand form; first operand Read; second Written
        usageRW :: Operand -> Operand -> RegUsage
        usageRW :: Operand -> Operand -> RegUsage
    usageRW Operand
    op (OpReg Reg
    reg)      = [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    op []) [Reg
    reg]
        usageRW Operand
    op (OpAddr AddrMode
    ea)      = [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    op forall a b. (a -> b) -> a -> b
    $! AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [])
        usageRW Operand
    _ Operand
    _                 = forall a. String -> a
    panic String
    "X86.RegInfo.usageRW: no match"

        -- 2 operand form; first operand Read; second Modified
        usageRM :: Operand -> Operand -> RegUsage
        usageRM :: Operand -> Operand -> RegUsage
    usageRM Operand
    op (OpReg Reg
    reg)      = [Reg] -> [Reg] -> RegUsage
    mkRU (Operand -> [Reg] -> [Reg]
    use_R Operand
    op [Reg
    reg]) [Reg
    reg]
        usageRM Operand
    op (OpAddr AddrMode
    ea)      = [Reg] -> RegUsage
    mkRUR (Operand -> [Reg] -> [Reg]
    use_R Operand
    op forall a b. (a -> b) -> a -> b
    $! AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [])
        usageRM Operand
    _ Operand
    _                 = forall a. String -> a
    panic String
    "X86.RegInfo.usageRM: no match"

        -- 2 operand form; first operand Modified; second Modified
        usageMM :: Operand -> Operand -> RegUsage
        usageMM :: Operand -> Operand -> RegUsage
    usageMM (OpReg Reg
    src) (OpReg Reg
    dst) = [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    src, Reg
    dst] [Reg
    src, Reg
    dst]
        usageMM (OpReg Reg
    src) (OpAddr AddrMode
    ea) = [Reg] -> [Reg] -> RegUsage
    mkRU (AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [Reg
    src]) [Reg
    src]
        usageMM (OpAddr AddrMode
    ea) (OpReg Reg
    dst) = [Reg] -> [Reg] -> RegUsage
    mkRU (AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [Reg
    dst]) [Reg
    dst]
        usageMM Operand
    _ Operand
    _                     = forall a. String -> a
    panic String
    "X86.RegInfo.usageMM: no match"

        -- 3 operand form; first operand Read; second Modified; third Modified
        usageRMM :: Operand -> Operand -> Operand -> RegUsage
        usageRMM :: Operand -> Operand -> Operand -> RegUsage
    usageRMM (OpReg Reg
    src) (OpReg Reg
    dst) (OpReg Reg
    reg) = [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    src, Reg
    dst, Reg
    reg] [Reg
    dst, Reg
    reg]
        usageRMM (OpReg Reg
    src) (OpAddr AddrMode
    ea) (OpReg Reg
    reg) = [Reg] -> [Reg] -> RegUsage
    mkRU (AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [Reg
    src, Reg
    reg]) [Reg
    reg]
        usageRMM Operand
    _ Operand
    _ Operand
    _                               = forall a. String -> a
    panic String
    "X86.RegInfo.usageRMM: no match"

        -- 1 operand form; operand Modified
        usageM :: Operand -> RegUsage
        usageM :: Operand -> RegUsage
    usageM (OpReg Reg
    reg)          = [Reg] -> [Reg] -> RegUsage
    mkRU [Reg
    reg] [Reg
    reg]
        usageM (OpAddr AddrMode
    ea)          = [Reg] -> RegUsage
    mkRUR (AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [])
        usageM Operand
    _                    = forall a. String -> a
    panic String
    "X86.RegInfo.usageM: no match"

        -- Registers defd when an operand is written.
        def_W :: Operand -> [Reg]
    def_W (OpReg Reg
    reg)           = [Reg
    reg]
        def_W (OpAddr AddrMode
    _ )           = []
        def_W Operand
    _                     = forall a. String -> a
    panic String
    "X86.RegInfo.def_W: no match"

        -- Registers used when an operand is read.
        use_R :: Operand -> [Reg] -> [Reg]
    use_R (OpReg Reg
    reg)  [Reg]
    tl = Reg
    reg forall a. a -> [a] -> [a]
    : [Reg]
    tl
        use_R (OpImm Imm
    _)    [Reg]
    tl = [Reg]
    tl
        use_R (OpAddr AddrMode
    ea)  [Reg]
    tl = AddrMode -> [Reg] -> [Reg]
    use_EA AddrMode
    ea [Reg]
    tl

        -- Registers used to compute an effective address.
        use_EA :: AddrMode -> [Reg] -> [Reg]
    use_EA (ImmAddr Imm
    _ Int
    _) [Reg]
    tl = [Reg]
    tl
        use_EA (AddrBaseIndex EABase
    base EAIndex
    index Imm
    _) [Reg]
    tl =
            EABase -> [Reg] -> [Reg]
    use_base EABase
    base forall a b. (a -> b) -> a -> b
    $! EAIndex -> [Reg] -> [Reg]
    use_index EAIndex
    index [Reg]
    tl
            where use_base :: EABase -> [Reg] -> [Reg]
    use_base (EABaseReg Reg
    r)  [Reg]
    tl = Reg
    r forall a. a -> [a] -> [a]
    : [Reg]
    tl
                  use_base EABase
    _              [Reg]
    tl = [Reg]
    tl
                  use_index :: EAIndex -> [Reg] -> [Reg]
    use_index EAIndex
    EAIndexNone   [Reg]
    tl = [Reg]
    tl
                  use_index (EAIndex Reg
    i Int
    _) [Reg]
    tl = Reg
    i forall a. a -> [a] -> [a]
    : [Reg]
    tl

        mkRUR :: [Reg] -> RegUsage
    mkRUR [Reg]
    src = [Reg]
    src' seq :: forall a b. a -> b -> b
    `seq` [Reg] -> [Reg] -> RegUsage
    RU [Reg]
    src' []
            where src' :: [Reg]
    src' = forall a. (a -> Bool) -> [a] -> [a]
    filter (Platform -> Reg -> Bool
    interesting Platform
    platform) [Reg]
    src

        mkRU :: [Reg] -> [Reg] -> RegUsage
    mkRU [Reg]
    src [Reg]
    dst = [Reg]
    src' seq :: forall a b. a -> b -> b
    `seq` [Reg]
    dst' seq :: forall a b. a -> b -> b
    `seq` [Reg] -> [Reg] -> RegUsage
    RU [Reg]
    src' [Reg]
    dst'
            where src' :: [Reg]
    src' = forall a. (a -> Bool) -> [a] -> [a]
    filter (Platform -> Reg -> Bool
    interesting Platform
    platform) [Reg]
    src
                  dst' :: [Reg]
    dst' = forall a. (a -> Bool) -> [a] -> [a]
    filter (Platform -> Reg -> Bool
    interesting Platform
    platform) [Reg]
    dst

    -- | Is this register interesting for the register allocator?
    interesting :: Platform -> Reg -> Bool
    interesting :: Platform -> Reg -> Bool
    interesting Platform
    _        (RegVirtual VirtualReg
    _)              = Bool
    True
    interesting Platform
    platform (RegReal (RealRegSingle Int
    i)) = Platform -> Int -> Bool
    freeReg Platform
    platform Int
    i
    interesting Platform
    _        (RegReal (RealRegPair{}))   = forall a. String -> a
    panic String
    "X86.interesting: no reg pairs on this arch"

    -- | Applies the supplied function to all registers in instructions.
    -- Typically used to change virtual registers to real registers.
    patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
    patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
    patchRegsOfInstr Instr
    instr Reg -> Reg
    env
     = case Instr
    instr of
        MOV  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    MOV  Format
    fmt) Operand
    src Operand
    dst
        CMOV Cond
    cc Format
    fmt Operand
    src Reg
    dst  -> Cond -> Format -> Operand -> Reg -> Instr
    CMOV Cond
    cc Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        MOVZxL Format
    fmt Operand
    src Operand
    dst   -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    MOVZxL Format
    fmt) Operand
    src Operand
    dst
        MOVSxL Format
    fmt Operand
    src Operand
    dst   -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    MOVSxL Format
    fmt) Operand
    src Operand
    dst
        LEA  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    LEA  Format
    fmt) Operand
    src Operand
    dst
        ADD  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    ADD  Format
    fmt) Operand
    src Operand
    dst
        ADC  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    ADC  Format
    fmt) Operand
    src Operand
    dst
        SUB  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    SUB  Format
    fmt) Operand
    src Operand
    dst
        SBB  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    SBB  Format
    fmt) Operand
    src Operand
    dst
        IMUL Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    IMUL Format
    fmt) Operand
    src Operand
    dst
        IMUL2 Format
    fmt Operand
    src        -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    IMUL2 Format
    fmt) Operand
    src
        MUL Format
    fmt Operand
    src Operand
    dst      -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    MUL Format
    fmt) Operand
    src Operand
    dst
        MUL2 Format
    fmt Operand
    src         -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    MUL2 Format
    fmt) Operand
    src
        IDIV Format
    fmt Operand
    op          -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    IDIV Format
    fmt) Operand
    op
        DIV Format
    fmt Operand
    op           -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    DIV Format
    fmt) Operand
    op
        ADD_CC Format
    fmt Operand
    src Operand
    dst   -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    ADD_CC Format
    fmt) Operand
    src Operand
    dst
        SUB_CC Format
    fmt Operand
    src Operand
    dst   -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    SUB_CC Format
    fmt) Operand
    src Operand
    dst
        AND  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    AND  Format
    fmt) Operand
    src Operand
    dst
        OR   Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    OR   Format
    fmt) Operand
    src Operand
    dst
        XOR  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    XOR  Format
    fmt) Operand
    src Operand
    dst
        NOT  Format
    fmt Operand
    op          -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    NOT  Format
    fmt) Operand
    op
        BSWAP Format
    fmt Reg
    reg        -> Format -> Reg -> Instr
    BSWAP Format
    fmt (Reg -> Reg
    env Reg
    reg)
        NEGI Format
    fmt Operand
    op          -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    NEGI Format
    fmt) Operand
    op
        SHL  Format
    fmt Operand
    imm Operand
    dst     -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Operand -> Instr
    SHL Format
    fmt Operand
    imm) Operand
    dst
        SAR  Format
    fmt Operand
    imm Operand
    dst     -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Operand -> Instr
    SAR Format
    fmt Operand
    imm) Operand
    dst
        SHR  Format
    fmt Operand
    imm Operand
    dst     -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Operand -> Instr
    SHR Format
    fmt Operand
    imm) Operand
    dst
        BT   Format
    fmt Imm
    imm Operand
    src     -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Imm -> Operand -> Instr
    BT  Format
    fmt Imm
    imm) Operand
    src
        TEST Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    TEST Format
    fmt) Operand
    src Operand
    dst
        CMP  Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    CMP  Format
    fmt) Operand
    src Operand
    dst
        PUSH Format
    fmt Operand
    op          -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    PUSH Format
    fmt) Operand
    op
        POP  Format
    fmt Operand
    op          -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Format -> Operand -> Instr
    POP  Format
    fmt) Operand
    op
        SETCC Cond
    cond Operand
    op        -> forall a. (Operand -> a) -> Operand -> a
    patch1 (Cond -> Operand -> Instr
    SETCC Cond
    cond) Operand
    op
        JMP Operand
    op [Reg]
    regs          -> Operand -> [Reg] -> Instr
    JMP (Operand -> Operand
    patchOp Operand
    op) [Reg]
    regs
        JMP_TBL Operand
    op [Maybe JumpDest]
    ids Section
    s CLabel
    lbl -> Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
    JMP_TBL (Operand -> Operand
    patchOp Operand
    op) [Maybe JumpDest]
    ids Section
    s CLabel
    lbl

        -- literally only support storing the top x87 stack value st(0)
        X87Store  Format
    fmt  AddrMode
    dst     -> Format -> AddrMode -> Instr
    X87Store Format
    fmt  (AddrMode -> AddrMode
    lookupAddr AddrMode
    dst)

        CVTSS2SD Reg
    src Reg
    dst    -> Reg -> Reg -> Instr
    CVTSS2SD (Reg -> Reg
    env Reg
    src) (Reg -> Reg
    env Reg
    dst)
        CVTSD2SS Reg
    src Reg
    dst    -> Reg -> Reg -> Instr
    CVTSD2SS (Reg -> Reg
    env Reg
    src) (Reg -> Reg
    env Reg
    dst)
        CVTTSS2SIQ Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    CVTTSS2SIQ Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        CVTTSD2SIQ Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    CVTTSD2SIQ Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        CVTSI2SS Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    CVTSI2SS Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        CVTSI2SD Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    CVTSI2SD Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        FDIV Format
    fmt Operand
    src Operand
    dst     -> Format -> Operand -> Operand -> Instr
    FDIV Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Operand -> Operand
    patchOp Operand
    dst)
        SQRT Format
    fmt Operand
    src Reg
    dst    -> Format -> Operand -> Reg -> Instr
    SQRT Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)

        CALL (Left Imm
    _)  [Reg]
    _    -> Instr
    instr
        CALL (Right Reg
    reg) [Reg]
    p  -> Either Imm Reg -> [Reg] -> Instr
    CALL (forall a b. b -> Either a b
    Right (Reg -> Reg
    env Reg
    reg)) [Reg]
    p

        FETCHGOT Reg
    reg        -> Reg -> Instr
    FETCHGOT (Reg -> Reg
    env Reg
    reg)
        FETCHPC  Reg
    reg        -> Reg -> Instr
    FETCHPC  (Reg -> Reg
    env Reg
    reg)

        Instr
    NOP                 -> Instr
    instr
        COMMENT FastString
    _           -> Instr
    instr
        LOCATION {}         -> Instr
    instr
        UNWIND {}           -> Instr
    instr
        DELTA Int
    _             -> Instr
    instr

        JXX Cond
    _ BlockId
    _             -> Instr
    instr
        JXX_GBL Cond
    _ Imm
    _         -> Instr
    instr
        CLTD Format
    _              -> Instr
    instr

        POPCNT Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    POPCNT Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        LZCNT  Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    LZCNT  Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        TZCNT  Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    TZCNT  Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        PDEP   Format
    fmt Operand
    src Operand
    mask Reg
    dst -> Format -> Operand -> Operand -> Reg -> Instr
    PDEP   Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Operand -> Operand
    patchOp Operand
    mask) (Reg -> Reg
    env Reg
    dst)
        PEXT   Format
    fmt Operand
    src Operand
    mask Reg
    dst -> Format -> Operand -> Operand -> Reg -> Instr
    PEXT   Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Operand -> Operand
    patchOp Operand
    mask) (Reg -> Reg
    env Reg
    dst)
        BSF    Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    BSF    Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        BSR    Format
    fmt Operand
    src Reg
    dst -> Format -> Operand -> Reg -> Instr
    BSR    Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)

        PREFETCH PrefetchVariant
    lvl Format
    format Operand
    src -> PrefetchVariant -> Format -> Operand -> Instr
    PREFETCH PrefetchVariant
    lvl Format
    format (Operand -> Operand
    patchOp Operand
    src)

        LOCK Instr
    i               -> Instr -> Instr
    LOCK (Instr -> (Reg -> Reg) -> Instr
    patchRegsOfInstr Instr
    i Reg -> Reg
    env)
        XADD Format
    fmt Operand
    src Operand
    dst     -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    XADD Format
    fmt) Operand
    src Operand
    dst
        CMPXCHG Format
    fmt Operand
    src Operand
    dst  -> forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 (Format -> Operand -> Operand -> Instr
    CMPXCHG Format
    fmt) Operand
    src Operand
    dst
        XCHG Format
    fmt Operand
    src Reg
    dst     -> Format -> Operand -> Reg -> Instr
    XCHG Format
    fmt (Operand -> Operand
    patchOp Operand
    src) (Reg -> Reg
    env Reg
    dst)
        Instr
    MFENCE               -> Instr
    instr

        Instr
    _other              -> forall a. String -> a
    panic String
    "patchRegs: unrecognised instr"

      where
        patch1 :: (Operand -> a) -> Operand -> a
        patch1 :: forall a. (Operand -> a) -> Operand -> a
    patch1 Operand -> a
    insn Operand
    op      = Operand -> a
    insn forall a b. (a -> b) -> a -> b
    $! Operand -> Operand
    patchOp Operand
    op
        patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
        patch2 :: forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
    patch2 Operand -> Operand -> a
    insn Operand
    src Operand
    dst = (Operand -> Operand -> a
    insn forall a b. (a -> b) -> a -> b
    $! Operand -> Operand
    patchOp Operand
    src) forall a b. (a -> b) -> a -> b
    $! Operand -> Operand
    patchOp Operand
    dst

        patchOp :: Operand -> Operand
    patchOp (OpReg  Reg
    reg) = Reg -> Operand
    OpReg forall a b. (a -> b) -> a -> b
    $! Reg -> Reg
    env Reg
    reg
        patchOp (OpImm  Imm
    imm) = Imm -> Operand
    OpImm Imm
    imm
        patchOp (OpAddr AddrMode
    ea)  = AddrMode -> Operand
    OpAddr forall a b. (a -> b) -> a -> b
    $! AddrMode -> AddrMode
    lookupAddr AddrMode
    ea

        lookupAddr :: AddrMode -> AddrMode
    lookupAddr (ImmAddr Imm
    imm Int
    off) = Imm -> Int -> AddrMode
    ImmAddr Imm
    imm Int
    off
        lookupAddr (AddrBaseIndex EABase
    base EAIndex
    index Imm
    disp)
          = ((EABase -> EAIndex -> Imm -> AddrMode
    AddrBaseIndex forall a b. (a -> b) -> a -> b
    $! EABase -> EABase
    lookupBase EABase
    base) forall a b. (a -> b) -> a -> b
    $! EAIndex -> EAIndex
    lookupIndex EAIndex
    index) Imm
    disp
          where
            lookupBase :: EABase -> EABase
    lookupBase EABase
    EABaseNone       = EABase
    EABaseNone
            lookupBase EABase
    EABaseRip        = EABase
    EABaseRip
            lookupBase (EABaseReg Reg
    r)    = Reg -> EABase
    EABaseReg forall a b. (a -> b) -> a -> b
    $! Reg -> Reg
    env Reg
    r

            lookupIndex :: EAIndex -> EAIndex
    lookupIndex EAIndex
    EAIndexNone     = EAIndex
    EAIndexNone
            lookupIndex (EAIndex Reg
    r Int
    i)   = (Reg -> Int -> EAIndex
    EAIndex forall a b. (a -> b) -> a -> b
    $! Reg -> Reg
    env Reg
    r) Int
    i

    --------------------------------------------------------------------------------
    isJumpishInstr
            :: Instr -> Bool

    isJumpishInstr :: Instr -> Bool
    isJumpishInstr Instr
    instr
     = case Instr
    instr of
            JMP{}           -> Bool
    True
            JXX{}           -> Bool
    True
            JXX_GBL{}       -> Bool
    True
            JMP_TBL{}       -> Bool
    True
            CALL{}          -> Bool
    True
            Instr
    _               -> Bool
    False

    jumpDestsOfInstr
            :: Instr
            -> [BlockId]

    jumpDestsOfInstr :: Instr -> [BlockId]
    jumpDestsOfInstr Instr
    insn
      = case Instr
    insn of
            JXX Cond
    _ BlockId
    id        -> [BlockId
    id]
            JMP_TBL Operand
    _ [Maybe JumpDest]
    ids Section
    _ CLabel
    _ -> [BlockId
    id | Just (DestBlockId BlockId
    id) <- [Maybe JumpDest]
    ids]
            Instr
    _               -> []

    patchJumpInstr
            :: Instr -> (BlockId -> BlockId) -> Instr

    patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
    patchJumpInstr Instr
    insn BlockId -> BlockId
    patchF
      = case Instr
    insn of
            JXX Cond
    cc BlockId
    id       -> Cond -> BlockId -> Instr
    JXX Cond
    cc (BlockId -> BlockId
    patchF BlockId
    id)
            JMP_TBL Operand
    op [Maybe JumpDest]
    ids Section
    section CLabel
    lbl
              -> Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
    JMP_TBL Operand
    op (forall a b. (a -> b) -> [a] -> [b]
    map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((BlockId -> BlockId) -> JumpDest -> JumpDest
    patchJumpDest BlockId -> BlockId
    patchF)) [Maybe JumpDest]
    ids) Section
    section CLabel
    lbl
            Instr
    _               -> Instr
    insn
        where
            patchJumpDest :: (BlockId -> BlockId) -> JumpDest -> JumpDest
    patchJumpDest BlockId -> BlockId
    f (DestBlockId BlockId
    id) = BlockId -> JumpDest
    DestBlockId (BlockId -> BlockId
    f BlockId
    id)
            patchJumpDest BlockId -> BlockId
    _ JumpDest
    dest             = JumpDest
    dest

    -- -----------------------------------------------------------------------------
    -- | Make a spill instruction.
    mkSpillInstr
        :: NCGConfig
        -> Reg      -- register to spill
        -> Int      -- current stack delta
        -> Int      -- spill slot to use
        -> [Instr]

    mkSpillInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]
    mkSpillInstr NCGConfig
    config Reg
    reg Int
    delta Int
    slot
      = let off :: Int
    off     = Platform -> Int -> Int
    spillSlotToOffset Platform
    platform Int
    slot forall a. Num a => a -> a -> a
    - Int
    delta
        in
        case Platform -> Reg -> RegClass
    targetClassOfReg Platform
    platform Reg
    reg of
               RegClass
    RcInteger   -> [Format -> Operand -> Operand -> Instr
    MOV (Bool -> Format
    archWordFormat Bool
    is32Bit)
                                       (Reg -> Operand
    OpReg Reg
    reg) (AddrMode -> Operand
    OpAddr (Platform -> Int -> AddrMode
    spRel Platform
    platform Int
    off))]
               RegClass
    RcDouble    -> [Format -> Operand -> Operand -> Instr
    MOV Format
    FF64 (Reg -> Operand
    OpReg Reg
    reg) (AddrMode -> Operand
    OpAddr (Platform -> Int -> AddrMode
    spRel Platform
    platform Int
    off))]
               RegClass
    _         -> forall a. String -> a
    panic String
    "X86.mkSpillInstr: no match"
        where platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config
              is32Bit :: Bool
    is32Bit = Platform -> Bool
    target32Bit Platform
    platform

    -- | Make a spill reload instruction.
    mkLoadInstr
        :: NCGConfig
        -> Reg      -- register to load
        -> Int      -- current stack delta
        -> Int      -- spill slot to use
        -> [Instr]

    mkLoadInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]
    mkLoadInstr NCGConfig
    config Reg
    reg Int
    delta Int
    slot
      = let off :: Int
    off     = Platform -> Int -> Int
    spillSlotToOffset Platform
    platform Int
    slot forall a. Num a => a -> a -> a
    - Int
    delta
        in
            case Platform -> Reg -> RegClass
    targetClassOfReg Platform
    platform Reg
    reg of
                  RegClass
    RcInteger -> ([Format -> Operand -> Operand -> Instr
    MOV (Bool -> Format
    archWordFormat Bool
    is32Bit)
                                     (AddrMode -> Operand
    OpAddr (Platform -> Int -> AddrMode
    spRel Platform
    platform Int
    off)) (Reg -> Operand
    OpReg Reg
    reg)])
                  RegClass
    RcDouble  -> ([Format -> Operand -> Operand -> Instr
    MOV Format
    FF64 (AddrMode -> Operand
    OpAddr (Platform -> Int -> AddrMode
    spRel Platform
    platform Int
    off)) (Reg -> Operand
    OpReg Reg
    reg)])
                  RegClass
    _         -> forall a. String -> a
    panic String
    "X86.mkLoadInstr"
        where platform :: Platform
    platform = NCGConfig -> Platform
    ncgPlatform NCGConfig
    config
              is32Bit :: Bool
    is32Bit = Platform -> Bool
    target32Bit Platform
    platform

    spillSlotSize :: Platform -> Int
    spillSlotSize :: Platform -> Int
    spillSlotSize Platform
    platform
       | Platform -> Bool
    target32Bit Platform
    platform = Int
    12
       | Bool
    otherwise            = Int
    8

    maxSpillSlots :: NCGConfig -> Int
    maxSpillSlots :: NCGConfig -> Int
    maxSpillSlots NCGConfig
    config
        = ((NCGConfig -> Int
    ncgSpillPreallocSize NCGConfig
    config forall a. Num a => a -> a -> a
    - Int
    64) forall a. Integral a => a -> a -> a
    `div` Platform -> Int
    spillSlotSize (NCGConfig -> Platform
    ncgPlatform NCGConfig
    config)) forall a. Num a => a -> a -> a
    - Int
    1
    --  = 0 -- useful for testing allocMoreStack

    -- number of bytes that the stack pointer should be aligned to
    stackAlign :: Int
    stackAlign :: Int
    stackAlign = Int
    16

    -- convert a spill slot number to a *byte* offset, with no sign:
    -- decide on a per arch basis whether you are spilling above or below
    -- the C stack pointer.
    spillSlotToOffset :: Platform -> Int -> Int
    spillSlotToOffset :: Platform -> Int -> Int
    spillSlotToOffset Platform
    platform Int
    slot
       = Int
    64 forall a. Num a => a -> a -> a
    + Platform -> Int
    spillSlotSize Platform
    platform forall a. Num a => a -> a -> a
    * Int
    slot

    --------------------------------------------------------------------------------

    -- | See if this instruction is telling us the current C stack delta
    takeDeltaInstr
            :: Instr
            -> Maybe Int

    takeDeltaInstr :: Instr -> Maybe Int
    takeDeltaInstr Instr
    instr
     = case Instr
    instr of
            DELTA Int
    i         -> forall a. a -> Maybe a
    Just Int
    i
            Instr
    _               -> forall a. Maybe a
    Nothing

    isMetaInstr
            :: Instr
            -> Bool

    isMetaInstr :: Instr -> Bool
    isMetaInstr Instr
    instr
     = case Instr
    instr of
            COMMENT{}       -> Bool
    True
            LOCATION{}      -> Bool
    True
            LDATA{}         -> Bool
    True
            NEWBLOCK{}      -> Bool
    True
            UNWIND{}        -> Bool
    True
            DELTA{}         -> Bool
    True
            Instr
    _               -> Bool
    False

    ---  TODO: why is there
    -- | Make a reg-reg move instruction.
    --      On SPARC v8 there are no instructions to move directly between
    --      floating point and integer regs. If we need to do that then we
    --      have to go via memory.
    --
    mkRegRegMoveInstr
        :: Platform
        -> Reg
        -> Reg
        -> Instr

    mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr
    mkRegRegMoveInstr Platform
    platform Reg
    src Reg
    dst
     = case Platform -> Reg -> RegClass
    targetClassOfReg Platform
    platform Reg
    src of
            RegClass
    RcInteger -> case Platform -> Arch
    platformArch Platform
    platform of
                         Arch
    ArchX86    -> Format -> Operand -> Operand -> Instr
    MOV Format
    II32 (Reg -> Operand
    OpReg Reg
    src) (Reg -> Operand
    OpReg Reg
    dst)
                         Arch
    ArchX86_64 -> Format -> Operand -> Operand -> Instr
    MOV Format
    II64 (Reg -> Operand
    OpReg Reg
    src) (Reg -> Operand
    OpReg Reg
    dst)
                         Arch
    _          -> forall a. String -> a
    panic String
    "X86.mkRegRegMoveInstr: Bad arch"
            RegClass
    RcDouble    ->  Format -> Operand -> Operand -> Instr
    MOV Format
    FF64 (Reg -> Operand
    OpReg Reg
    src) (Reg -> Operand
    OpReg Reg
    dst)
            -- this code is the lie we tell ourselves because both float and double
            -- use the same register class.on x86_64 and x86 32bit with SSE2,
            -- more plainly, both use the XMM registers
            RegClass
    _     -> forall a. String -> a
    panic String
    "X86.RegInfo.mkRegRegMoveInstr: no match"

    -- | Check whether an instruction represents a reg-reg move.
    --      The register allocator attempts to eliminate reg->reg moves whenever it can,
    --      by assigning the src and dest temporaries to the same real register.
    --
    takeRegRegMoveInstr
            :: Instr
            -> Maybe (Reg,Reg)

    takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)
    takeRegRegMoveInstr (MOV Format
    _ (OpReg Reg
    r1) (OpReg Reg
    r2))
            = forall a. a -> Maybe a
    Just (Reg
    r1,Reg
    r2)

    takeRegRegMoveInstr Instr
    _  = forall a. Maybe a
    Nothing

    -- | Make an unconditional branch instruction.
    mkJumpInstr
            :: BlockId
            -> [Instr]

    mkJumpInstr :: BlockId -> [Instr]
    mkJumpInstr BlockId
    id
            = [Cond -> BlockId -> Instr
    JXX Cond
    ALWAYS BlockId
    id]

    -- Note [Windows stack layout]
    -- | On most OSes the kernel will place a guard page after the current stack
    --   page.  If you allocate larger than a page worth you may jump over this
    --   guard page.  Not only is this a security issue, but on certain OSes such
    --   as Windows a new page won't be allocated if you don't hit the guard.  This
    --   will cause a segfault or access fault.
    --
    --   This function defines if the current allocation amount requires a probe.
    --   On Windows (for now) we emit a call to _chkstk for this.  For other OSes
    --   this is not yet implemented.
    --   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk
    --   The Windows stack looks like this:
    --
    --                         +-------------------+
    --                         |        SP         |
    --                         +-------------------+
    --                         |                   |
    --                         |    GUARD PAGE     |
    --                         |                   |
    --                         +-------------------+
    --                         |                   |
    --                         |                   |
    --                         |     UNMAPPED      |
    --                         |                   |
    --                         |                   |
    --                         +-------------------+
    --
    --   In essence each allocation larger than a page size needs to be chunked and
    --   a probe emitted after each page allocation.  You have to hit the guard
    --   page so the kernel can map in the next page, otherwise you'll segfault.
    --   See Note [Windows stack allocations].
    --
    needs_probe_call :: Platform -> Int -> Bool
    needs_probe_call :: Platform -> Int -> Bool
    needs_probe_call Platform
    platform Int
    amount
      = case Platform -> OS
    platformOS Platform
    platform of
         OS
    OSMinGW32 -> case Platform -> Arch
    platformArch Platform
    platform of
                        Arch
    ArchX86    -> Int
    amount forall a. Ord a => a -> a -> Bool
    > (Int
    4 forall a. Num a => a -> a -> a
    * Int
    1024)
                        Arch
    ArchX86_64 -> Int
    amount forall a. Ord a => a -> a -> Bool
    > (Int
    4 forall a. Num a => a -> a -> a
    * Int
    1024)
                        Arch
    _          -> Bool
    False
         OS
    _         -> Bool
    False

    mkStackAllocInstr
            :: Platform
            -> Int
            -> [Instr]
    mkStackAllocInstr :: Platform -> Int -> [Instr]
    mkStackAllocInstr Platform
    platform Int
    amount
      = case Platform -> OS
    platformOS Platform
    platform of
          OS
    OSMinGW32 ->
            -- These will clobber AX but this should be ok because
            --
            -- 1. It is the first thing we do when entering the closure and AX is
            --    a caller saved registers on Windows both on x86_64 and x86.
            --
            -- 2. The closures are only entered via a call or longjmp in which case
            --    there are no expectations for volatile registers.
            --
            -- 3. When the target is a local branch point it is re-targeted
            --    after the dealloc, preserving #2.  See note [extra spill slots].
            --
            -- We emit a call because the stack probes are quite involved and
            -- would bloat code size a lot.  GHC doesn't really have an -Os.
            -- ___chkstk is guaranteed to leave all nonvolatile registers and AX
            -- untouched.  It's part of the standard prologue code for any Windows
            -- function dropping the stack more than a page.
            -- See Note [Windows stack layout]
            case Platform -> Arch
    platformArch Platform
    platform of
                Arch
    ArchX86    | Platform -> Int -> Bool
    needs_probe_call Platform
    platform Int
    amount ->
                               [ Format -> Operand -> Operand -> Instr
    MOV Format
    II32 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    eax)
                               , Either Imm Reg -> [Reg] -> Instr
    CALL (forall a b. a -> Either a b
    Left forall a b. (a -> b) -> a -> b
    $ String -> Imm
    strImmLit String
    "___chkstk_ms") [Reg
    eax]
                               , Format -> Operand -> Operand -> Instr
    SUB Format
    II32 (Reg -> Operand
    OpReg Reg
    eax) (Reg -> Operand
    OpReg Reg
    esp)
                               ]
                           | Bool
    otherwise ->
                               [ Format -> Operand -> Operand -> Instr
    SUB Format
    II32 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    esp)
                               , Format -> Operand -> Operand -> Instr
    TEST Format
    II32 (Reg -> Operand
    OpReg Reg
    esp) (Reg -> Operand
    OpReg Reg
    esp)
                               ]
                Arch
    ArchX86_64 | Platform -> Int -> Bool
    needs_probe_call Platform
    platform Int
    amount ->
                               [ Format -> Operand -> Operand -> Instr
    MOV Format
    II64 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    rax)
                               , Either Imm Reg -> [Reg] -> Instr
    CALL (forall a b. a -> Either a b
    Left forall a b. (a -> b) -> a -> b
    $ String -> Imm
    strImmLit String
    "___chkstk_ms") [Reg
    rax]
                               , Format -> Operand -> Operand -> Instr
    SUB Format
    II64 (Reg -> Operand
    OpReg Reg
    rax) (Reg -> Operand
    OpReg Reg
    rsp)
                               ]
                           | Bool
    otherwise ->
                               [ Format -> Operand -> Operand -> Instr
    SUB Format
    II64 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    rsp)
                               , Format -> Operand -> Operand -> Instr
    TEST Format
    II64 (Reg -> Operand
    OpReg Reg
    rsp) (Reg -> Operand
    OpReg Reg
    rsp)
                               ]
                Arch
    _ -> forall a. String -> a
    panic String
    "X86.mkStackAllocInstr"
          OS
    _       ->
            case Platform -> Arch
    platformArch Platform
    platform of
              Arch
    ArchX86    -> [ Format -> Operand -> Operand -> Instr
    SUB Format
    II32 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    esp) ]
              Arch
    ArchX86_64 -> [ Format -> Operand -> Operand -> Instr
    SUB Format
    II64 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    rsp) ]
              Arch
    _ -> forall a. String -> a
    panic String
    "X86.mkStackAllocInstr"

    mkStackDeallocInstr
            :: Platform
            -> Int
            -> [Instr]
    mkStackDeallocInstr :: Platform -> Int -> [Instr]
    mkStackDeallocInstr Platform
    platform Int
    amount
      = case Platform -> Arch
    platformArch Platform
    platform of
          Arch
    ArchX86    -> [Format -> Operand -> Operand -> Instr
    ADD Format
    II32 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    esp)]
          Arch
    ArchX86_64 -> [Format -> Operand -> Operand -> Instr
    ADD Format
    II64 (Imm -> Operand
    OpImm (Int -> Imm
    ImmInt Int
    amount)) (Reg -> Operand
    OpReg Reg
    rsp)]
          Arch
    _ -> forall a. String -> a
    panic String
    "X86.mkStackDeallocInstr"

    --
    -- Note [extra spill slots]
    --
    -- If the register allocator used more spill slots than we have
    -- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more
    -- C stack space on entry and exit from this proc.  Therefore we
    -- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"
    -- before every non-local jump.
    --
    -- This became necessary when the new codegen started bundling entire
    -- functions together into one proc, because the register allocator
    -- assigns a different stack slot to each virtual reg within a proc.
    -- To avoid using so many slots we could also:
    --
    --   - split up the proc into connected components before code generator
    --
    --   - rename the virtual regs, so that we re-use vreg names and hence
    --     stack slots for non-overlapping vregs.
    --
    -- Note that when a block is both a non-local entry point (with an
    -- info table) and a local branch target, we have to split it into
    -- two, like so:
    --
    --    <info table>
    --    L:
    --       <code>
    --
    -- becomes
    --
    --    <info table>
    --    L:
    --       subl $rsp, N
    --       jmp Lnew
    --    Lnew:
    --       <code>
    --
    -- and all branches pointing to L are retargetted to point to Lnew.
    -- Otherwise, we would repeat the $rsp adjustment for each branch to
    -- L.
    --
    -- Returns a list of (L,Lnew) pairs.
    --
    allocMoreStack
      :: Platform
      -> Int
      -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr
      -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)])

    allocMoreStack :: forall statics.
    Platform
    -> Int
    -> NatCmmDecl statics Instr
    -> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
    allocMoreStack Platform
    _ Int
    _ top :: NatCmmDecl statics Instr
    top@(CmmData Section
    _ statics
    _) = forall (m :: * -> *) a. Monad m => a -> m a
    return (NatCmmDecl statics Instr
    top,[])
    allocMoreStack Platform
    platform Int
    slots proc :: NatCmmDecl statics Instr
    proc@(CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live (ListGraph [GenBasicBlock Instr]
    code)) = do
        let entries :: [BlockId]
    entries = forall a i b. GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
    entryBlocks NatCmmDecl statics Instr
    proc

        [Unique]
    uniqs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
    replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
    length [BlockId]
    entries) forall (m :: * -> *). MonadUnique m => m Unique
    getUniqueM

        let
          delta :: Int
    delta = ((Int
    x forall a. Num a => a -> a -> a
    + Int
    stackAlign forall a. Num a => a -> a -> a
    - Int
    1) forall a. Integral a => a -> a -> a
    `quot` Int
    stackAlign) forall a. Num a => a -> a -> a
    * Int
    stackAlign -- round up
            where x :: Int
    x = Int
    slots forall a. Num a => a -> a -> a
    * Platform -> Int
    spillSlotSize Platform
    platform -- sp delta

          alloc :: [Instr]
    alloc   = Platform -> Int -> [Instr]
    mkStackAllocInstr   Platform
    platform Int
    delta
          dealloc :: [Instr]
    dealloc = Platform -> Int -> [Instr]
    mkStackDeallocInstr Platform
    platform Int
    delta

          retargetList :: [(BlockId, BlockId)]
    retargetList = (forall a b. [a] -> [b] -> [(a, b)]
    zip [BlockId]
    entries (forall a b. (a -> b) -> [a] -> [b]
    map Unique -> BlockId
    mkBlockId [Unique]
    uniqs))

          new_blockmap :: LabelMap BlockId
          new_blockmap :: LabelMap BlockId
    new_blockmap = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
    mapFromList [(BlockId, BlockId)]
    retargetList

          insert_stack_insns :: GenBasicBlock Instr -> [GenBasicBlock Instr]
    insert_stack_insns (BasicBlock BlockId
    id [Instr]
    insns)
             | Just BlockId
    new_blockid <- forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup BlockId
    id LabelMap BlockId
    new_blockmap
             = [ forall i. BlockId -> [i] -> GenBasicBlock i
    BasicBlock BlockId
    id forall a b. (a -> b) -> a -> b
    $ [Instr]
    alloc forall a. [a] -> [a] -> [a]
    ++ [Cond -> BlockId -> Instr
    JXX Cond
    ALWAYS BlockId
    new_blockid]
               , forall i. BlockId -> [i] -> GenBasicBlock i
    BasicBlock BlockId
    new_blockid [Instr]
    block' ]
             | Bool
    otherwise
             = [ forall i. BlockId -> [i] -> GenBasicBlock i
    BasicBlock BlockId
    id [Instr]
    block' ]
             where
               block' :: [Instr]
    block' = forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Instr -> [Instr] -> [Instr]
    insert_dealloc [] [Instr]
    insns

          insert_dealloc :: Instr -> [Instr] -> [Instr]
    insert_dealloc Instr
    insn [Instr]
    r = case Instr
    insn of
             JMP Operand
    _ [Reg]
    _     -> [Instr]
    dealloc forall a. [a] -> [a] -> [a]
    ++ (Instr
    insn forall a. a -> [a] -> [a]
    : [Instr]
    r)
             JXX_GBL Cond
    _ Imm
    _ -> forall a. String -> a
    panic String
    "insert_dealloc: cannot handle JXX_GBL"
             Instr
    _other      -> Instr -> (BlockId -> BlockId) -> Instr
    patchJumpInstr Instr
    insn BlockId -> BlockId
    retarget forall a. a -> [a] -> [a]
    : [Instr]
    r
               where retarget :: BlockId -> BlockId
    retarget BlockId
    b = forall a. a -> Maybe a -> a
    fromMaybe BlockId
    b (forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup BlockId
    b LabelMap BlockId
    new_blockmap)

          new_code :: [GenBasicBlock Instr]
    new_code = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap GenBasicBlock Instr -> [GenBasicBlock Instr]
    insert_stack_insns [GenBasicBlock Instr]
    code
        -- in
        forall (m :: * -> *) a. Monad m => a -> m a
    return (forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live (forall i. [GenBasicBlock i] -> ListGraph i
    ListGraph [GenBasicBlock Instr]
    new_code), [(BlockId, BlockId)]
    retargetList)

    data JumpDest = DestBlockId BlockId | DestImm Imm

    -- Debug Instance
    instance Outputable JumpDest where
      ppr :: JumpDest -> SDoc
    ppr (DestBlockId BlockId
    bid) = String -> SDoc
    text String
    "jd<blk>:" SDoc -> SDoc -> SDoc
    <> forall a. Outputable a => a -> SDoc
    ppr BlockId
    bid
      ppr (DestImm Imm
    _imm)    = String -> SDoc
    text String
    "jd<imm>:noShow"

    getJumpDestBlockId :: JumpDest -> Maybe BlockId
    getJumpDestBlockId :: JumpDest -> Maybe BlockId
    getJumpDestBlockId (DestBlockId BlockId
    bid) = forall a. a -> Maybe a
    Just BlockId
    bid
    getJumpDestBlockId JumpDest
    _                 = forall a. Maybe a
    Nothing

    canShortcut :: Instr -> Maybe JumpDest
    canShortcut :: Instr -> Maybe JumpDest
    canShortcut (JXX Cond
    ALWAYS BlockId
    id)      = forall a. a -> Maybe a
    Just (BlockId -> JumpDest
    DestBlockId BlockId
    id)
    canShortcut (JMP (OpImm Imm
    imm) [Reg]
    _)  = forall a. a -> Maybe a
    Just (Imm -> JumpDest
    DestImm Imm
    imm)
    canShortcut Instr
    _                    = forall a. Maybe a
    Nothing

    -- This helper shortcuts a sequence of branches.
    -- The blockset helps avoid following cycles.
    shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
    shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
    shortcutJump BlockId -> Maybe JumpDest
    fn Instr
    insn = (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
    shortcutJump' BlockId -> Maybe JumpDest
    fn (forall set. IsSet set => set
    setEmpty :: LabelSet) Instr
    insn
      where
        shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
        shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
    shortcutJump' BlockId -> Maybe JumpDest
    fn LabelSet
    seen insn :: Instr
    insn@(JXX Cond
    cc BlockId
    id) =
            if forall set. IsSet set => ElemOf set -> set -> Bool
    setMember BlockId
    id LabelSet
    seen then Instr
    insn
            else case BlockId -> Maybe JumpDest
    fn BlockId
    id of
                Maybe JumpDest
    Nothing                -> Instr
    insn
                Just (DestBlockId BlockId
    id') -> (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
    shortcutJump' BlockId -> Maybe JumpDest
    fn LabelSet
    seen' (Cond -> BlockId -> Instr
    JXX Cond
    cc BlockId
    id')
                Just (DestImm Imm
    imm)     -> (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
    shortcutJump' BlockId -> Maybe JumpDest
    fn LabelSet
    seen' (Cond -> Imm -> Instr
    JXX_GBL Cond
    cc Imm
    imm)
            where seen' :: LabelSet
    seen' = forall set. IsSet set => ElemOf set -> set -> set
    setInsert BlockId
    id LabelSet
    seen
        shortcutJump' BlockId -> Maybe JumpDest
    fn LabelSet
    _ (JMP_TBL Operand
    addr [Maybe JumpDest]
    blocks Section
    section CLabel
    tblId) =
            let updateBlock :: Maybe JumpDest -> Maybe JumpDest
    updateBlock (Just (DestBlockId BlockId
    bid))  =
                    case BlockId -> Maybe JumpDest
    fn BlockId
    bid of
                        Maybe JumpDest
    Nothing   -> forall a. a -> Maybe a
    Just (BlockId -> JumpDest
    DestBlockId BlockId
    bid )
                        Just JumpDest
    dest -> forall a. a -> Maybe a
    Just JumpDest
    dest
                updateBlock Maybe JumpDest
    dest = Maybe JumpDest
    dest
                blocks' :: [Maybe JumpDest]
    blocks' = forall a b. (a -> b) -> [a] -> [b]
    map Maybe JumpDest -> Maybe JumpDest
    updateBlock [Maybe JumpDest]
    blocks
            in  Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
    JMP_TBL Operand
    addr [Maybe JumpDest]
    blocks' Section
    section CLabel
    tblId
        shortcutJump' BlockId -> Maybe JumpDest
    _ LabelSet
    _ Instr
    other = Instr
    other

    -- Here because it knows about JumpDest
    shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics)
    shortcutStatics :: (BlockId -> Maybe JumpDest)
    -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics)
    shortcutStatics BlockId -> Maybe JumpDest
    fn (Alignment
    align, CmmStaticsRaw CLabel
    lbl [CmmStatic]
    statics)
      = (Alignment
    align, forall (a :: Bool). CLabel -> [CmmStatic] -> GenCmmStatics a
    CmmStaticsRaw CLabel
    lbl forall a b. (a -> b) -> a -> b
    $ forall a b. (a -> b) -> [a] -> [b]
    map ((BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
    shortcutStatic BlockId -> Maybe JumpDest
    fn) [CmmStatic]
    statics)
      -- we need to get the jump tables, so apply the mapping to the entries
      -- of a CmmData too.

    shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
    shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
    shortcutLabel BlockId -> Maybe JumpDest
    fn CLabel
    lab
      | Just BlockId
    blkId <- CLabel -> Maybe BlockId
    maybeLocalBlockLabel CLabel
    lab = (BlockId -> Maybe JumpDest) -> UniqSet Unique -> BlockId -> CLabel
    shortBlockId BlockId -> Maybe JumpDest
    fn forall a. UniqSet a
    emptyUniqSet BlockId
    blkId
      | Bool
    otherwise                              = CLabel
    lab

    shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
    shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
    shortcutStatic BlockId -> Maybe JumpDest
    fn (CmmStaticLit (CmmLabel CLabel
    lab))
      = CmmLit -> CmmStatic
    CmmStaticLit (CLabel -> CmmLit
    CmmLabel ((BlockId -> Maybe JumpDest) -> CLabel -> CLabel
    shortcutLabel BlockId -> Maybe JumpDest
    fn CLabel
    lab))
    shortcutStatic BlockId -> Maybe JumpDest
    fn (CmmStaticLit (CmmLabelDiffOff CLabel
    lbl1 CLabel
    lbl2 Int
    off Width
    w))
      = CmmLit -> CmmStatic
    CmmStaticLit (CLabel -> CLabel -> Int -> Width -> CmmLit
    CmmLabelDiffOff ((BlockId -> Maybe JumpDest) -> CLabel -> CLabel
    shortcutLabel BlockId -> Maybe JumpDest
    fn CLabel
    lbl1) CLabel
    lbl2 Int
    off Width
    w)
            -- slightly dodgy, we're ignoring the second label, but this
            -- works with the way we use CmmLabelDiffOff for jump tables now.
    shortcutStatic BlockId -> Maybe JumpDest
    _ CmmStatic
    other_static
            = CmmStatic
    other_static

    shortBlockId
            :: (BlockId -> Maybe JumpDest)
            -> UniqSet Unique
            -> BlockId
            -> CLabel

    shortBlockId :: (BlockId -> Maybe JumpDest) -> UniqSet Unique -> BlockId -> CLabel
    shortBlockId BlockId -> Maybe JumpDest
    fn UniqSet Unique
    seen BlockId
    blockid =
      case (forall a. Uniquable a => a -> UniqSet a -> Bool
    elementOfUniqSet Unique
    uq UniqSet Unique
    seen, BlockId -> Maybe JumpDest
    fn BlockId
    blockid) of
        (Bool
    True, Maybe JumpDest
    _)    -> BlockId -> CLabel
    blockLbl BlockId
    blockid
        (Bool
    _, Maybe JumpDest
    Nothing) -> BlockId -> CLabel
    blockLbl BlockId
    blockid
        (Bool
    _, Just (DestBlockId BlockId
    blockid'))  -> (BlockId -> Maybe JumpDest) -> UniqSet Unique -> BlockId -> CLabel
    shortBlockId BlockId -> Maybe JumpDest
    fn (forall a. Uniquable a => UniqSet a -> a -> UniqSet a
    addOneToUniqSet UniqSet Unique
    seen Unique
    uq) BlockId
    blockid'
        (Bool
    _, Just (DestImm (ImmCLbl CLabel
    lbl))) -> CLabel
    lbl
        (Bool
    _, Maybe JumpDest
    _other) -> forall a. String -> a
    panic String
    "shortBlockId"
      where uq :: Unique
    uq = forall a. Uniquable a => a -> Unique
    getUnique BlockId
    blockid