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