{-# LANGUAGE CPP, TypeFamilies #-}

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

module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..),
                  getJumpDestBlockId, canShortcut, shortcutStatics,
                  shortcutJump, i386_insert_ffrees, allocMoreStack,
                  maxSpillSlots, archWordFormat )
where

#include "HsVersions.h"
#include "nativeGen/NCG.h"

import GhcPrelude

import X86.Cond
import X86.Regs
import Instruction
import Format
import RegClass
import Reg
import TargetReg

import BlockId
import Hoopl.Collections
import Hoopl.Label
import CodeGen.Platform
import Cmm
import FastString
import Outputable
import Platform

import BasicTypes       (Alignment)
import CLabel
import DynFlags
import UniqSet
import Unique
import UniqSupply
import Debug (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 is32Bit :: Bool
is32Bit
 | Bool
is32Bit   = Format
II32
 | Bool
otherwise = Format
II64

-- | Instruction instance for x86 instruction set.
instance Instruction Instr where
        regUsageOfInstr :: Platform -> Instr -> RegUsage
regUsageOfInstr         = Platform -> Instr -> RegUsage
x86_regUsageOfInstr
        patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
patchRegsOfInstr        = Instr -> (Reg -> Reg) -> Instr
x86_patchRegsOfInstr
        isJumpishInstr :: Instr -> Bool
isJumpishInstr          = Instr -> Bool
x86_isJumpishInstr
        jumpDestsOfInstr :: Instr -> [BlockId]
jumpDestsOfInstr        = Instr -> [BlockId]
x86_jumpDestsOfInstr
        patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
patchJumpInstr          = Instr -> (BlockId -> BlockId) -> Instr
x86_patchJumpInstr
        mkSpillInstr :: DynFlags -> Reg -> Int -> Int -> Instr
mkSpillInstr            = DynFlags -> Reg -> Int -> Int -> Instr
x86_mkSpillInstr
        mkLoadInstr :: DynFlags -> Reg -> Int -> Int -> Instr
mkLoadInstr             = DynFlags -> Reg -> Int -> Int -> Instr
x86_mkLoadInstr
        takeDeltaInstr :: Instr -> Maybe Int
takeDeltaInstr          = Instr -> Maybe Int
x86_takeDeltaInstr
        isMetaInstr :: Instr -> Bool
isMetaInstr             = Instr -> Bool
x86_isMetaInstr
        mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr
mkRegRegMoveInstr       = Platform -> Reg -> Reg -> Instr
x86_mkRegRegMoveInstr
        takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr     = Instr -> Maybe (Reg, Reg)
x86_takeRegRegMoveInstr
        mkJumpInstr :: BlockId -> [Instr]
mkJumpInstr             = BlockId -> [Instr]
x86_mkJumpInstr
        mkStackAllocInstr :: Platform -> Int -> [Instr]
mkStackAllocInstr       = Platform -> Int -> [Instr]
x86_mkStackAllocInstr
        mkStackDeallocInstr :: Platform -> Int -> [Instr]
mkStackDeallocInstr     = Platform -> Int -> [Instr]
x86_mkStackDeallocInstr


-- -----------------------------------------------------------------------------
-- 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, CmmStatics)

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

        -- x86 Float Arithmetic.
        -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles
        -- as single instructions right up until we spit them out.
        -- all the 3-operand fake fp insns are src1 src2 dst
        -- and furthermore are constrained to be fp regs only.
        -- IMPORTANT: keep is_G_insn up to date with any changes here
        | GMOV        Reg Reg -- src(fpreg), dst(fpreg)
        | GLD         Format AddrMode Reg -- src, dst(fpreg)
        | GST         Format Reg AddrMode -- src(fpreg), dst

        | GLDZ        Reg -- dst(fpreg)
        | GLD1        Reg -- dst(fpreg)

        | GFTOI       Reg Reg -- src(fpreg), dst(intreg)
        | GDTOI       Reg Reg -- src(fpreg), dst(intreg)

        | GITOF       Reg Reg -- src(intreg), dst(fpreg)
        | GITOD       Reg Reg -- src(intreg), dst(fpreg)

        | GDTOF       Reg Reg -- src(fpreg), dst(fpreg)

        | GADD        Format Reg Reg Reg -- src1, src2, dst
        | GDIV        Format Reg Reg Reg -- src1, src2, dst
        | GSUB        Format Reg Reg Reg -- src1, src2, dst
        | GMUL        Format Reg Reg Reg -- src1, src2, dst

                -- FP compare.  Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]
                -- Compare src1 with src2; set the Zero flag iff the numbers are
                -- comparable and the comparison is True.  Subsequent code must
                -- test the %eflags zero flag regardless of the supplied Cond.
        | GCMP        Cond Reg Reg -- src1, src2

        | GABS        Format Reg Reg -- src, dst
        | GNEG        Format Reg Reg -- src, dst
        | GSQRT       Format Reg Reg -- src, dst
        | GSIN        Format CLabel CLabel Reg Reg -- src, dst
        | GCOS        Format CLabel CLabel Reg Reg -- src, dst
        | GTAN        Format CLabel CLabel Reg Reg -- src, dst

        | GFREE         -- do ffree on all x86 regs; an ugly hack


        -- 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
        | 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
        | 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.
x86_regUsageOfInstr :: Platform -> Instr -> RegUsage
x86_regUsageOfInstr :: Platform -> Instr -> RegUsage
x86_regUsageOfInstr platform :: Platform
platform instr :: Instr
instr
 = case Instr
instr of
    MOV    _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRW Operand
src Operand
dst
    CMOV _ _ src :: Operand
src dst :: Reg
dst    -> [Reg] -> [Reg] -> RegUsage
mkRU (Operand -> [Reg] -> [Reg]
use_R Operand
src [Reg
dst]) [Reg
dst]
    MOVZxL _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRW Operand
src Operand
dst
    MOVSxL _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRW Operand
src Operand
dst
    LEA    _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRW Operand
src Operand
dst
    ADD    _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRM Operand
src Operand
dst
    ADC    _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRM Operand
src Operand
dst
    SUB    _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRM Operand
src Operand
dst
    SBB    _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRM Operand
src Operand
dst
    IMUL   _ src :: Operand
src dst :: Operand
dst    -> Operand -> Operand -> RegUsage
usageRM Operand
src Operand
dst

    -- Result of IMULB will be in just in %ax
    IMUL2  II8 src :: Operand
src       -> [Reg] -> [Reg] -> RegUsage
mkRU (Reg
eaxReg -> [Reg] -> [Reg]
forall 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  _ src :: Operand
src        -> [Reg] -> [Reg] -> RegUsage
mkRU (Reg
eaxReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:Operand -> [Reg] -> [Reg]
use_R Operand
src []) [Reg
eax,Reg
edx]

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

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

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

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

    GMOV   src :: Reg
src dst :: Reg
dst      -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GLD    _ src :: AddrMode
src dst :: Reg
dst    -> [Reg] -> [Reg] -> RegUsage
mkRU (AddrMode -> [Reg] -> [Reg]
use_EA AddrMode
src []) [Reg
dst]
    GST    _ src :: Reg
src dst :: AddrMode
dst    -> [Reg] -> RegUsage
mkRUR (Reg
src Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: AddrMode -> [Reg] -> [Reg]
use_EA AddrMode
dst [])

    GLDZ   dst :: Reg
dst          -> [Reg] -> [Reg] -> RegUsage
mkRU [] [Reg
dst]
    GLD1   dst :: Reg
dst          -> [Reg] -> [Reg] -> RegUsage
mkRU [] [Reg
dst]

    GFTOI  src :: Reg
src dst :: Reg
dst      -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GDTOI  src :: Reg
src dst :: Reg
dst      -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]

    GITOF  src :: Reg
src dst :: Reg
dst      -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GITOD  src :: Reg
src dst :: Reg
dst      -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]

    GDTOF  src :: Reg
src dst :: Reg
dst      -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]

    GADD   _ s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst  -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
s1,Reg
s2] [Reg
dst]
    GSUB   _ s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst  -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
s1,Reg
s2] [Reg
dst]
    GMUL   _ s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst  -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
s1,Reg
s2] [Reg
dst]
    GDIV   _ s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst  -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
s1,Reg
s2] [Reg
dst]

    GCMP   _ src1 :: Reg
src1 src2 :: Reg
src2   -> [Reg] -> RegUsage
mkRUR [Reg
src1,Reg
src2]
    GABS   _ src :: Reg
src dst :: Reg
dst     -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GNEG   _ src :: Reg
src dst :: Reg
dst     -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GSQRT  _ src :: Reg
src dst :: Reg
dst     -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GSIN   _ _ _ src :: Reg
src dst :: Reg
dst -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GCOS   _ _ _ src :: Reg
src dst :: Reg
dst -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]
    GTAN   _ _ _ src :: Reg
src dst :: Reg
dst -> [Reg] -> [Reg] -> RegUsage
mkRU [Reg
src] [Reg
dst]

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

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

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

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

    PDEP   _ src :: Operand
src mask :: Operand
mask dst :: Reg
dst -> [Reg] -> [Reg] -> RegUsage
mkRU (Operand -> [Reg] -> [Reg]
use_R Operand
src ([Reg] -> [Reg]) -> [Reg] -> [Reg]
forall a b. (a -> b) -> a -> b
$ Operand -> [Reg] -> [Reg]
use_R Operand
mask []) [Reg
dst]
    PEXT   _ src :: Operand
src mask :: Operand
mask dst :: Reg
dst -> [Reg] -> [Reg] -> RegUsage
mkRU (Operand -> [Reg] -> [Reg]
use_R Operand
src ([Reg] -> [Reg]) -> [Reg] -> [Reg]
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 _  _ src :: Operand
src -> [Reg] -> [Reg] -> RegUsage
mkRU (Operand -> [Reg] -> [Reg]
use_R Operand
src []) []
    LOCK i :: Instr
i              -> Platform -> Instr -> RegUsage
x86_regUsageOfInstr Platform
platform Instr
i
    XADD _ src :: Operand
src dst :: Operand
dst      -> Operand -> Operand -> RegUsage
usageMM Operand
src Operand
dst
    CMPXCHG _ src :: Operand
src dst :: Operand
dst   -> Operand -> Operand -> Operand -> RegUsage
usageRMM Operand
src Operand
dst (Reg -> Operand
OpReg Reg
eax)
    MFENCE -> RegUsage
noUsage

    _other :: Instr
_other              -> String -> RegUsage
forall a. String -> a
panic "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 op :: Operand
op (OpReg reg :: Reg
reg)      = [Reg] -> [Reg] -> RegUsage
mkRU (Operand -> [Reg] -> [Reg]
use_R Operand
op []) [Reg
reg]
    usageRW op :: Operand
op (OpAddr ea :: AddrMode
ea)      = [Reg] -> RegUsage
mkRUR (Operand -> [Reg] -> [Reg]
use_R Operand
op ([Reg] -> [Reg]) -> [Reg] -> [Reg]
forall a b. (a -> b) -> a -> b
$! AddrMode -> [Reg] -> [Reg]
use_EA AddrMode
ea [])
    usageRW _ _                 = String -> RegUsage
forall a. String -> a
panic "X86.RegInfo.usageRW: no match"

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

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

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

    -- Registers defd when an operand is written.
    def_W :: Operand -> [Reg]
def_W (OpReg reg :: Reg
reg)           = [Reg
reg]
    def_W (OpAddr _ )           = []
    def_W _                     = String -> [Reg]
forall a. String -> a
panic "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]
tl = Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
tl
    use_R (OpImm _)    tl :: [Reg]
tl = [Reg]
tl
    use_R (OpAddr ea :: AddrMode
ea)  tl :: [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 _ _) tl :: [Reg]
tl = [Reg]
tl
    use_EA (AddrBaseIndex base :: EABase
base index :: EAIndex
index _) tl :: [Reg]
tl =
        EABase -> [Reg] -> [Reg]
use_base EABase
base ([Reg] -> [Reg]) -> [Reg] -> [Reg]
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 r :: Reg
r)  tl :: [Reg]
tl = Reg
r Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
tl
              use_base _              tl :: [Reg]
tl = [Reg]
tl
              use_index :: EAIndex -> [Reg] -> [Reg]
use_index EAIndexNone   tl :: [Reg]
tl = [Reg]
tl
              use_index (EAIndex i :: Reg
i _) tl :: [Reg]
tl = Reg
i Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
tl

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

    mkRU :: [Reg] -> [Reg] -> RegUsage
mkRU src :: [Reg]
src dst :: [Reg]
dst = [Reg]
src' [Reg] -> RegUsage -> RegUsage
forall a b. a -> b -> b
`seq` [Reg]
dst' [Reg] -> RegUsage -> RegUsage
forall a b. a -> b -> b
`seq` [Reg] -> [Reg] -> RegUsage
RU [Reg]
src' [Reg]
dst'
        where src' :: [Reg]
src' = (Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> Reg -> Bool
interesting Platform
platform) [Reg]
src
              dst' :: [Reg]
dst' = (Reg -> Bool) -> [Reg] -> [Reg]
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 _        (RegVirtual _)              = Bool
True
interesting platform :: Platform
platform (RegReal (RealRegSingle i :: Int
i)) = Platform -> Int -> Bool
freeReg Platform
platform Int
i
interesting _        (RegReal (RealRegPair{}))   = String -> Bool
forall a. String -> a
panic "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.
x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
x86_patchRegsOfInstr instr :: Instr
instr env :: Reg -> Reg
env
 = case Instr
instr of
    MOV  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
MOV  Format
fmt) Operand
src Operand
dst
    CMOV cc :: Cond
cc fmt :: Format
fmt src :: Operand
src dst :: Reg
dst  -> Cond -> Format -> Operand -> Reg -> Instr
CMOV Cond
cc Format
fmt (Operand -> Operand
patchOp Operand
src) (Reg -> Reg
env Reg
dst)
    MOVZxL fmt :: Format
fmt src :: Operand
src dst :: Operand
dst   -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
MOVZxL Format
fmt) Operand
src Operand
dst
    MOVSxL fmt :: Format
fmt src :: Operand
src dst :: Operand
dst   -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
MOVSxL Format
fmt) Operand
src Operand
dst
    LEA  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
LEA  Format
fmt) Operand
src Operand
dst
    ADD  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
ADD  Format
fmt) Operand
src Operand
dst
    ADC  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
ADC  Format
fmt) Operand
src Operand
dst
    SUB  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
SUB  Format
fmt) Operand
src Operand
dst
    SBB  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
SBB  Format
fmt) Operand
src Operand
dst
    IMUL fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
IMUL Format
fmt) Operand
src Operand
dst
    IMUL2 fmt :: Format
fmt src :: Operand
src        -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
IMUL2 Format
fmt) Operand
src
    MUL fmt :: Format
fmt src :: Operand
src dst :: Operand
dst      -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
MUL Format
fmt) Operand
src Operand
dst
    MUL2 fmt :: Format
fmt src :: Operand
src         -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
MUL2 Format
fmt) Operand
src
    IDIV fmt :: Format
fmt op :: Operand
op          -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
IDIV Format
fmt) Operand
op
    DIV fmt :: Format
fmt op :: Operand
op           -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
DIV Format
fmt) Operand
op
    ADD_CC fmt :: Format
fmt src :: Operand
src dst :: Operand
dst   -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
ADD_CC Format
fmt) Operand
src Operand
dst
    SUB_CC fmt :: Format
fmt src :: Operand
src dst :: Operand
dst   -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
SUB_CC Format
fmt) Operand
src Operand
dst
    AND  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
AND  Format
fmt) Operand
src Operand
dst
    OR   fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
OR   Format
fmt) Operand
src Operand
dst
    XOR  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
XOR  Format
fmt) Operand
src Operand
dst
    NOT  fmt :: Format
fmt op :: Operand
op          -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
NOT  Format
fmt) Operand
op
    BSWAP fmt :: Format
fmt reg :: Reg
reg        -> Format -> Reg -> Instr
BSWAP Format
fmt (Reg -> Reg
env Reg
reg)
    NEGI fmt :: Format
fmt op :: Operand
op          -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
NEGI Format
fmt) Operand
op
    SHL  fmt :: Format
fmt imm :: Operand
imm dst :: Operand
dst     -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Operand -> Instr
SHL Format
fmt Operand
imm) Operand
dst
    SAR  fmt :: Format
fmt imm :: Operand
imm dst :: Operand
dst     -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Operand -> Instr
SAR Format
fmt Operand
imm) Operand
dst
    SHR  fmt :: Format
fmt imm :: Operand
imm dst :: Operand
dst     -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Operand -> Instr
SHR Format
fmt Operand
imm) Operand
dst
    BT   fmt :: Format
fmt imm :: Imm
imm src :: Operand
src     -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Imm -> Operand -> Instr
BT  Format
fmt Imm
imm) Operand
src
    TEST fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
TEST Format
fmt) Operand
src Operand
dst
    CMP  fmt :: Format
fmt src :: Operand
src dst :: Operand
dst     -> (Operand -> Operand -> Instr) -> Operand -> Operand -> Instr
forall a. (Operand -> Operand -> a) -> Operand -> Operand -> a
patch2 (Format -> Operand -> Operand -> Instr
CMP  Format
fmt) Operand
src Operand
dst
    PUSH fmt :: Format
fmt op :: Operand
op          -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
PUSH Format
fmt) Operand
op
    POP  fmt :: Format
fmt op :: Operand
op          -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Format -> Operand -> Instr
POP  Format
fmt) Operand
op
    SETCC cond :: Cond
cond op :: Operand
op        -> (Operand -> Instr) -> Operand -> Instr
forall a. (Operand -> a) -> Operand -> a
patch1 (Cond -> Operand -> Instr
SETCC Cond
cond) Operand
op
    JMP op :: Operand
op regs :: [Reg]
regs          -> Operand -> [Reg] -> Instr
JMP (Operand -> Operand
patchOp Operand
op) [Reg]
regs
    JMP_TBL op :: Operand
op ids :: [Maybe JumpDest]
ids s :: Section
s lbl :: CLabel
lbl -> Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL (Operand -> Operand
patchOp Operand
op) [Maybe JumpDest]
ids Section
s CLabel
lbl

    GMOV src :: Reg
src dst :: Reg
dst         -> Reg -> Reg -> Instr
GMOV (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GLD  fmt :: Format
fmt src :: AddrMode
src dst :: Reg
dst     -> Format -> AddrMode -> Reg -> Instr
GLD Format
fmt (AddrMode -> AddrMode
lookupAddr AddrMode
src) (Reg -> Reg
env Reg
dst)
    GST  fmt :: Format
fmt src :: Reg
src dst :: AddrMode
dst     -> Format -> Reg -> AddrMode -> Instr
GST Format
fmt (Reg -> Reg
env Reg
src) (AddrMode -> AddrMode
lookupAddr AddrMode
dst)

    GLDZ dst :: Reg
dst            -> Reg -> Instr
GLDZ (Reg -> Reg
env Reg
dst)
    GLD1 dst :: Reg
dst            -> Reg -> Instr
GLD1 (Reg -> Reg
env Reg
dst)

    GFTOI src :: Reg
src dst :: Reg
dst       -> Reg -> Reg -> Instr
GFTOI (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GDTOI src :: Reg
src dst :: Reg
dst       -> Reg -> Reg -> Instr
GDTOI (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)

    GITOF src :: Reg
src dst :: Reg
dst       -> Reg -> Reg -> Instr
GITOF (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GITOD src :: Reg
src dst :: Reg
dst       -> Reg -> Reg -> Instr
GITOD (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)

    GDTOF src :: Reg
src dst :: Reg
dst       -> Reg -> Reg -> Instr
GDTOF (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)

    GADD fmt :: Format
fmt s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst   -> Format -> Reg -> Reg -> Reg -> Instr
GADD Format
fmt (Reg -> Reg
env Reg
s1) (Reg -> Reg
env Reg
s2) (Reg -> Reg
env Reg
dst)
    GSUB fmt :: Format
fmt s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst   -> Format -> Reg -> Reg -> Reg -> Instr
GSUB Format
fmt (Reg -> Reg
env Reg
s1) (Reg -> Reg
env Reg
s2) (Reg -> Reg
env Reg
dst)
    GMUL fmt :: Format
fmt s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst   -> Format -> Reg -> Reg -> Reg -> Instr
GMUL Format
fmt (Reg -> Reg
env Reg
s1) (Reg -> Reg
env Reg
s2) (Reg -> Reg
env Reg
dst)
    GDIV fmt :: Format
fmt s1 :: Reg
s1 s2 :: Reg
s2 dst :: Reg
dst   -> Format -> Reg -> Reg -> Reg -> Instr
GDIV Format
fmt (Reg -> Reg
env Reg
s1) (Reg -> Reg
env Reg
s2) (Reg -> Reg
env Reg
dst)

    GCMP fmt :: Cond
fmt src1 :: Reg
src1 src2 :: Reg
src2   -> Cond -> Reg -> Reg -> Instr
GCMP Cond
fmt (Reg -> Reg
env Reg
src1) (Reg -> Reg
env Reg
src2)
    GABS fmt :: Format
fmt src :: Reg
src dst :: Reg
dst     -> Format -> Reg -> Reg -> Instr
GABS Format
fmt (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GNEG fmt :: Format
fmt src :: Reg
src dst :: Reg
dst     -> Format -> Reg -> Reg -> Instr
GNEG Format
fmt (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GSQRT fmt :: Format
fmt src :: Reg
src dst :: Reg
dst    -> Format -> Reg -> Reg -> Instr
GSQRT Format
fmt (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GSIN fmt :: Format
fmt l1 :: CLabel
l1 l2 :: CLabel
l2 src :: Reg
src dst :: Reg
dst       -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GSIN Format
fmt CLabel
l1 CLabel
l2 (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GCOS fmt :: Format
fmt l1 :: CLabel
l1 l2 :: CLabel
l2 src :: Reg
src dst :: Reg
dst       -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GCOS Format
fmt CLabel
l1 CLabel
l2 (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)
    GTAN fmt :: Format
fmt l1 :: CLabel
l1 l2 :: CLabel
l2 src :: Reg
src dst :: Reg
dst       -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GTAN Format
fmt CLabel
l1 CLabel
l2 (Reg -> Reg
env Reg
src) (Reg -> Reg
env Reg
dst)

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

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

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

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

    JXX _ _             -> Instr
instr
    JXX_GBL _ _         -> Instr
instr
    CLTD _              -> Instr
instr

    POPCNT fmt :: Format
fmt src :: Operand
src dst :: Reg
dst -> Format -> Operand -> Reg -> Instr
POPCNT Format
fmt (Operand -> Operand
patchOp Operand
src) (Reg -> Reg
env Reg
dst)
    PDEP   fmt :: Format
fmt src :: Operand
src mask :: Operand
mask dst :: 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   fmt :: Format
fmt src :: Operand
src mask :: Operand
mask dst :: 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    fmt :: Format
fmt src :: Operand
src dst :: Reg
dst -> Format -> Operand -> Reg -> Instr
BSF    Format
fmt (Operand -> Operand
patchOp Operand
src) (Reg -> Reg
env Reg
dst)
    BSR    fmt :: Format
fmt src :: Operand
src dst :: Reg
dst -> Format -> Operand -> Reg -> Instr
BSR    Format
fmt (Operand -> Operand
patchOp Operand
src) (Reg -> Reg
env Reg
dst)

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

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

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

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

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

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

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


--------------------------------------------------------------------------------
x86_isJumpishInstr
        :: Instr -> Bool

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


x86_jumpDestsOfInstr
        :: Instr
        -> [BlockId]

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


x86_patchJumpInstr
        :: Instr -> (BlockId -> BlockId) -> Instr

x86_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
x86_patchJumpInstr insn :: Instr
insn patchF :: BlockId -> BlockId
patchF
  = case Instr
insn of
        JXX cc :: Cond
cc id :: BlockId
id       -> Cond -> BlockId -> Instr
JXX Cond
cc (BlockId -> BlockId
patchF BlockId
id)
        JMP_TBL op :: Operand
op ids :: [Maybe JumpDest]
ids section :: Section
section lbl :: CLabel
lbl
          -> Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL Operand
op ((Maybe JumpDest -> Maybe JumpDest)
-> [Maybe JumpDest] -> [Maybe JumpDest]
forall a b. (a -> b) -> [a] -> [b]
map ((JumpDest -> JumpDest) -> Maybe JumpDest -> Maybe JumpDest
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
insn
    where
        patchJumpDest :: (BlockId -> BlockId) -> JumpDest -> JumpDest
patchJumpDest f :: BlockId -> BlockId
f (DestBlockId id :: BlockId
id) = BlockId -> JumpDest
DestBlockId (BlockId -> BlockId
f BlockId
id)
        patchJumpDest _ dest :: JumpDest
dest             = JumpDest
dest





-- -----------------------------------------------------------------------------
-- | Make a spill instruction.
x86_mkSpillInstr
    :: DynFlags
    -> Reg      -- register to spill
    -> Int      -- current stack delta
    -> Int      -- spill slot to use
    -> Instr

x86_mkSpillInstr :: DynFlags -> Reg -> Int -> Int -> Instr
x86_mkSpillInstr dflags :: DynFlags
dflags reg :: Reg
reg delta :: Int
delta slot :: Int
slot
  = let off :: Int
off     = Platform -> Int -> Int
spillSlotToOffset Platform
platform Int
slot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
delta
    in
    case Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
reg of
           RcInteger   -> Format -> Operand -> Operand -> Instr
MOV (Bool -> Format
archWordFormat Bool
is32Bit)
                              (Reg -> Operand
OpReg Reg
reg) (AddrMode -> Operand
OpAddr (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
off))
           RcDouble    -> Format -> Reg -> AddrMode -> Instr
GST Format
FF80 Reg
reg (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
off) {- RcFloat/RcDouble -}
           RcDoubleSSE -> Format -> Operand -> Operand -> Instr
MOV Format
FF64 (Reg -> Operand
OpReg Reg
reg) (AddrMode -> Operand
OpAddr (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
off))
           _         -> String -> Instr
forall a. String -> a
panic "X86.mkSpillInstr: no match"
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          is32Bit :: Bool
is32Bit = Platform -> Bool
target32Bit Platform
platform

-- | Make a spill reload instruction.
x86_mkLoadInstr
    :: DynFlags
    -> Reg      -- register to load
    -> Int      -- current stack delta
    -> Int      -- spill slot to use
    -> Instr

x86_mkLoadInstr :: DynFlags -> Reg -> Int -> Int -> Instr
x86_mkLoadInstr dflags :: DynFlags
dflags reg :: Reg
reg delta :: Int
delta slot :: Int
slot
  = let off :: Int
off     = Platform -> Int -> Int
spillSlotToOffset Platform
platform Int
slot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
delta
    in
        case Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
reg of
              RcInteger -> Format -> Operand -> Operand -> Instr
MOV (Bool -> Format
archWordFormat Bool
is32Bit)
                               (AddrMode -> Operand
OpAddr (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
off)) (Reg -> Operand
OpReg Reg
reg)
              RcDouble  -> Format -> AddrMode -> Reg -> Instr
GLD Format
FF80 (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
off) Reg
reg {- RcFloat/RcDouble -}
              RcDoubleSSE -> Format -> Operand -> Operand -> Instr
MOV Format
FF64 (AddrMode -> Operand
OpAddr (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
off)) (Reg -> Operand
OpReg Reg
reg)
              _           -> String -> Instr
forall a. String -> a
panic "X86.x86_mkLoadInstr"
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          is32Bit :: Bool
is32Bit = Platform -> Bool
target32Bit Platform
platform

spillSlotSize :: Platform -> Int
spillSlotSize :: Platform -> Int
spillSlotSize dflags :: Platform
dflags = if Bool
is32Bit then 12 else 8
    where is32Bit :: Bool
is32Bit = Platform -> Bool
target32Bit Platform
dflags

maxSpillSlots :: DynFlags -> Int
maxSpillSlots :: DynFlags -> Int
maxSpillSlots dflags :: DynFlags
dflags
    = ((DynFlags -> Int
rESERVED_C_STACK_BYTES DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
- 64) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Platform -> Int
spillSlotSize (DynFlags -> Platform
targetPlatform DynFlags
dflags)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
--     = 0 -- useful for testing allocMoreStack

-- number of bytes that the stack pointer should be aligned to
stackAlign :: Int
stackAlign :: Int
stackAlign = 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
platform slot :: Int
slot
   = 64 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Platform -> Int
spillSlotSize Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
slot

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

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

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


x86_isMetaInstr
        :: Instr
        -> Bool

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



-- | 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.
--
x86_mkRegRegMoveInstr
    :: Platform
    -> Reg
    -> Reg
    -> Instr

x86_mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr
x86_mkRegRegMoveInstr platform :: Platform
platform src :: Reg
src dst :: Reg
dst
 = case Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
src of
        RcInteger -> case Platform -> Arch
platformArch Platform
platform of
                     ArchX86    -> Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
src) (Reg -> Operand
OpReg Reg
dst)
                     ArchX86_64 -> Format -> Operand -> Operand -> Instr
MOV Format
II64 (Reg -> Operand
OpReg Reg
src) (Reg -> Operand
OpReg Reg
dst)
                     _          -> String -> Instr
forall a. String -> a
panic "x86_mkRegRegMoveInstr: Bad arch"
        RcDouble    -> Reg -> Reg -> Instr
GMOV Reg
src Reg
dst
        RcDoubleSSE -> Format -> Operand -> Operand -> Instr
MOV Format
FF64 (Reg -> Operand
OpReg Reg
src) (Reg -> Operand
OpReg Reg
dst)
        _     -> String -> Instr
forall a. String -> a
panic "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.
--
x86_takeRegRegMoveInstr
        :: Instr
        -> Maybe (Reg,Reg)

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

x86_takeRegRegMoveInstr _  = Maybe (Reg, Reg)
forall a. Maybe a
Nothing


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

x86_mkJumpInstr :: BlockId -> [Instr]
x86_mkJumpInstr id :: 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 essense 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.
--
needs_probe_call :: Platform -> Int -> Bool
needs_probe_call :: Platform -> Int -> Bool
needs_probe_call platform :: Platform
platform amount :: Int
amount
  = case Platform -> OS
platformOS Platform
platform of
     OSMinGW32 -> case Platform -> Arch
platformArch Platform
platform of
                    ArchX86    -> Int
amount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1024)
                    ArchX86_64 -> Int
amount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> (8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* 1024)
                    _          -> Bool
False
     _         -> Bool
False

x86_mkStackAllocInstr
        :: Platform
        -> Int
        -> [Instr]
x86_mkStackAllocInstr :: Platform -> Int -> [Instr]
x86_mkStackAllocInstr platform :: Platform
platform amount :: Int
amount
  = case Platform -> OS
platformOS Platform
platform of
      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
            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 (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left (Imm -> Either Imm Reg) -> Imm -> Either Imm Reg
forall a b. (a -> b) -> a -> b
$ String -> Imm
strImmLit "___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)
                           ]
            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 (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left (Imm -> Either Imm Reg) -> Imm -> Either Imm Reg
forall a b. (a -> b) -> a -> b
$ String -> Imm
strImmLit "__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)
                           ]
            _ -> String -> [Instr]
forall a. String -> a
panic "x86_mkStackAllocInstr"
      _       ->
        case Platform -> Arch
platformArch Platform
platform of
          ArchX86    -> [ Format -> Operand -> Operand -> Instr
SUB Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
amount)) (Reg -> Operand
OpReg Reg
esp) ]
          ArchX86_64 -> [ Format -> Operand -> Operand -> Instr
SUB Format
II64 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
amount)) (Reg -> Operand
OpReg Reg
rsp) ]
          _ -> String -> [Instr]
forall a. String -> a
panic "x86_mkStackAllocInstr"

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

i386_insert_ffrees
        :: [GenBasicBlock Instr]
        -> [GenBasicBlock Instr]

i386_insert_ffrees :: [GenBasicBlock Instr] -> [GenBasicBlock Instr]
i386_insert_ffrees blocks :: [GenBasicBlock Instr]
blocks
   | ([Instr] -> Bool) -> [[Instr]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Instr -> Bool) -> [Instr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Instr -> Bool
is_G_instr) [ [Instr]
instrs | BasicBlock _ instrs :: [Instr]
instrs <- [GenBasicBlock Instr]
blocks ]
   = (GenBasicBlock Instr -> GenBasicBlock Instr)
-> [GenBasicBlock Instr] -> [GenBasicBlock Instr]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock Instr -> GenBasicBlock Instr
insertGFREEs [GenBasicBlock Instr]
blocks
   | Bool
otherwise
   = [GenBasicBlock Instr]
blocks
 where
   insertGFREEs :: GenBasicBlock Instr -> GenBasicBlock Instr
insertGFREEs (BasicBlock id :: BlockId
id insns :: [Instr]
insns)
     = BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id (Instr -> [Instr] -> [Instr]
insertBeforeNonlocalTransfers Instr
GFREE [Instr]
insns)

insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]
insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]
insertBeforeNonlocalTransfers insert :: Instr
insert insns :: [Instr]
insns
     = (Instr -> [Instr] -> [Instr]) -> [Instr] -> [Instr] -> [Instr]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Instr -> [Instr] -> [Instr]
p [] [Instr]
insns
     where p :: Instr -> [Instr] -> [Instr]
p insn :: Instr
insn r :: [Instr]
r = case Instr
insn of
                        CALL _ _    -> Instr
insert Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
                        JMP _ _     -> Instr
insert Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
                        JXX_GBL _ _ -> String -> [Instr]
forall a. String -> a
panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"
                        _           -> Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r


-- if you ever add a new FP insn to the fake x86 FP insn set,
-- you must update this too
is_G_instr :: Instr -> Bool
is_G_instr :: Instr -> Bool
is_G_instr instr :: Instr
instr
   = case Instr
instr of
        GMOV{}          -> Bool
True
        GLD{}           -> Bool
True
        GST{}           -> Bool
True
        GLDZ{}          -> Bool
True
        GLD1{}          -> Bool
True
        GFTOI{}         -> Bool
True
        GDTOI{}         -> Bool
True
        GITOF{}         -> Bool
True
        GITOD{}         -> Bool
True
        GDTOF{}         -> Bool
True
        GADD{}          -> Bool
True
        GDIV{}          -> Bool
True
        GSUB{}          -> Bool
True
        GMUL{}          -> Bool
True
        GCMP{}          -> Bool
True
        GABS{}          -> Bool
True
        GNEG{}          -> Bool
True
        GSQRT{}         -> Bool
True
        GSIN{}          -> Bool
True
        GCOS{}          -> Bool
True
        GTAN{}          -> Bool
True
        GFREE           -> String -> Bool
forall a. String -> a
panic "is_G_instr: GFREE (!)"
        _               -> Bool
False


--
-- 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 X86.Instr.Instr
  -> UniqSM (NatCmmDecl statics X86.Instr.Instr, [(BlockId,BlockId)])

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

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

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

      alloc :: [Instr]
alloc   = Platform -> Int -> [Instr]
forall instr. Instruction instr => Platform -> Int -> [instr]
mkStackAllocInstr   Platform
platform Int
delta
      dealloc :: [Instr]
dealloc = Platform -> Int -> [Instr]
forall instr. Instruction instr => Platform -> Int -> [instr]
mkStackDeallocInstr Platform
platform Int
delta

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

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

      insert_stack_insns :: GenBasicBlock Instr -> [GenBasicBlock Instr]
insert_stack_insns (BasicBlock id :: BlockId
id insns :: [Instr]
insns)
         | Just new_blockid :: BlockId
new_blockid <- KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
id LabelMap BlockId
new_blockmap
         = [ BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id ([Instr] -> GenBasicBlock Instr) -> [Instr] -> GenBasicBlock Instr
forall a b. (a -> b) -> a -> b
$ [Instr]
alloc [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Cond -> BlockId -> Instr
JXX Cond
ALWAYS BlockId
new_blockid]
           , BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
new_blockid [Instr]
block' ]
         | Bool
otherwise
         = [ BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [Instr]
block' ]
         where
           block' :: [Instr]
block' = (Instr -> [Instr] -> [Instr]) -> [Instr] -> [Instr] -> [Instr]
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 insn :: Instr
insn r :: [Instr]
r = case Instr
insn of
         JMP _ _     -> [Instr]
dealloc [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ (Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r)
         JXX_GBL _ _ -> String -> [Instr]
forall a. String -> a
panic "insert_dealloc: cannot handle JXX_GBL"
         _other :: Instr
_other      -> Instr -> (BlockId -> BlockId) -> Instr
x86_patchJumpInstr Instr
insn BlockId -> BlockId
retarget Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
           where retarget :: BlockId -> BlockId
retarget b :: BlockId
b = BlockId -> Maybe BlockId -> BlockId
forall a. a -> Maybe a -> a
fromMaybe BlockId
b (KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
b LabelMap BlockId
new_blockmap)

      new_code :: [GenBasicBlock Instr]
new_code = (GenBasicBlock Instr -> [GenBasicBlock Instr])
-> [GenBasicBlock Instr] -> [GenBasicBlock Instr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenBasicBlock Instr -> [GenBasicBlock Instr]
insert_stack_insns [GenBasicBlock Instr]
code
    -- in
    (NatCmmDecl statics Instr, [(BlockId, BlockId)])
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl statics Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live ([GenBasicBlock Instr] -> ListGraph Instr
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 bid :: BlockId
bid) = String -> SDoc
text "jd<blk>:" SDoc -> SDoc -> SDoc
<> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
bid
  ppr (DestImm _imm :: Imm
_imm)    = String -> SDoc
text "jd<imm>:noShow"


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

canShortcut :: Instr -> Maybe JumpDest
canShortcut :: Instr -> Maybe JumpDest
canShortcut (JXX ALWAYS id :: BlockId
id)      = JumpDest -> Maybe JumpDest
forall a. a -> Maybe a
Just (BlockId -> JumpDest
DestBlockId BlockId
id)
canShortcut (JMP (OpImm imm :: Imm
imm) _)  = JumpDest -> Maybe JumpDest
forall a. a -> Maybe a
Just (Imm -> JumpDest
DestImm Imm
imm)
canShortcut _                    = Maybe JumpDest
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 fn :: BlockId -> Maybe JumpDest
fn insn :: Instr
insn = (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
shortcutJump' BlockId -> Maybe JumpDest
fn (LabelSet
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' fn :: BlockId -> Maybe JumpDest
fn seen :: LabelSet
seen insn :: Instr
insn@(JXX cc :: Cond
cc id :: BlockId
id) =
        if ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
id LabelSet
seen then Instr
insn
        else case BlockId -> Maybe JumpDest
fn BlockId
id of
            Nothing                -> Instr
insn
            Just (DestBlockId id' :: 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
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' = ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
id LabelSet
seen
    shortcutJump' fn :: BlockId -> Maybe JumpDest
fn _ (JMP_TBL addr :: Operand
addr blocks :: [Maybe JumpDest]
blocks section :: Section
section tblId :: CLabel
tblId) =
        let updateBlock :: Maybe JumpDest -> Maybe JumpDest
updateBlock (Just (DestBlockId bid :: BlockId
bid))  =
                case BlockId -> Maybe JumpDest
fn BlockId
bid of
                    Nothing   -> JumpDest -> Maybe JumpDest
forall a. a -> Maybe a
Just (BlockId -> JumpDest
DestBlockId BlockId
bid )
                    Just dest :: JumpDest
dest -> JumpDest -> Maybe JumpDest
forall a. a -> Maybe a
Just JumpDest
dest
            updateBlock dest :: Maybe JumpDest
dest = Maybe JumpDest
dest
            blocks' :: [Maybe JumpDest]
blocks' = (Maybe JumpDest -> Maybe JumpDest)
-> [Maybe JumpDest] -> [Maybe JumpDest]
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' _ _ other :: Instr
other = Instr
other

-- Here because it knows about JumpDest
shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
shortcutStatics :: (BlockId -> Maybe JumpDest)
-> (Int, CmmStatics) -> (Int, CmmStatics)
shortcutStatics fn :: BlockId -> Maybe JumpDest
fn (align :: Int
align, Statics lbl :: CLabel
lbl statics :: [CmmStatic]
statics)
  = (Int
align, CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl ([CmmStatic] -> CmmStatics) -> [CmmStatic] -> CmmStatics
forall a b. (a -> b) -> a -> b
$ (CmmStatic -> CmmStatic) -> [CmmStatic] -> [CmmStatic]
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 fn :: BlockId -> Maybe JumpDest
fn lab :: CLabel
lab
  | Just blkId :: BlockId
blkId <- CLabel -> Maybe BlockId
maybeLocalBlockLabel CLabel
lab = (BlockId -> Maybe JumpDest) -> UniqSet Unique -> BlockId -> CLabel
shortBlockId BlockId -> Maybe JumpDest
fn UniqSet Unique
forall a. UniqSet a
emptyUniqSet BlockId
blkId
  | Bool
otherwise                              = CLabel
lab

shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn :: BlockId -> Maybe JumpDest
fn (CmmStaticLit (CmmLabel lab :: CLabel
lab))
  = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CmmLit
CmmLabel ((BlockId -> Maybe JumpDest) -> CLabel -> CLabel
shortcutLabel BlockId -> Maybe JumpDest
fn CLabel
lab))
shortcutStatic fn :: BlockId -> Maybe JumpDest
fn (CmmStaticLit (CmmLabelDiffOff lbl1 :: CLabel
lbl1 lbl2 :: CLabel
lbl2 off :: Int
off w :: 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 _ other_static :: CmmStatic
other_static
        = CmmStatic
other_static

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

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