{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}

-- The default iteration limit is a bit too low for the definitions
-- in this module.
{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}

-----------------------------------------------------------------------------
--
-- Generating machine code (instruction selection)
--
-- (c) The University of Glasgow 1996-2004
--
-----------------------------------------------------------------------------

-- This is a big module, but, if you pay attention to
-- (a) the sectioning, and (b) the type signatures, the
-- structure should not be too overwhelming.

module X86.CodeGen (
        cmmTopCodeGen,
        generateJumpTableForInstr,
        extractUnwindPoints,
        invertCondBranches,
        InstrBlock
)

where

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

-- NCG stuff:
import GhcPrelude

import X86.Instr
import X86.Cond
import X86.Regs
import X86.Ppr (  )
import X86.RegInfo

--TODO: Remove - Just for development/debugging
import X86.Ppr()

import CodeGen.Platform
import CPrim
import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable
                        , UnwindExpr(UwReg), toUnwindExpr )
import Instruction
import PIC
import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat
                  , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat
                  , getPicBaseMaybeNat, getDebugBlock, getFileId
                  , addImmediateSuccessorNat, updateCfgNat)
import CFG
import Format
import Reg
import Platform

-- Our intermediate code:
import BasicTypes
import BlockId
import Module           ( primUnitId )
import PprCmm           ()
import CmmUtils
import CmmSwitch
import Cmm
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label
import CLabel
import CoreSyn          ( Tickish(..) )
import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )

-- The rest:
import ForeignCall      ( CCallConv(..) )
import OrdList
import Outputable
import FastString
import DynFlags
import Util
import UniqSupply       ( getUniqueM )

import Control.Monad
import Data.Bits
import Data.Foldable (fold)
import Data.Int
import Data.Maybe
import Data.Word

import qualified Data.Map as M

is32BitPlatform :: NatM Bool
is32BitPlatform :: NatM Bool
is32BitPlatform = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> NatM Bool) -> Bool -> NatM Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)

sse2Enabled :: NatM Bool
sse2Enabled :: NatM Bool
sse2Enabled = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Bool
isSse2Enabled DynFlags
dflags)

sse4_2Enabled :: NatM Bool
sse4_2Enabled :: NatM Bool
sse4_2Enabled = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Bool
isSse4_2Enabled DynFlags
dflags)

if_sse2 :: NatM a -> NatM a -> NatM a
if_sse2 :: NatM a -> NatM a -> NatM a
if_sse2 sse2 :: NatM a
sse2 x87 :: NatM a
x87 = do
  Bool
b <- NatM Bool
sse2Enabled
  if Bool
b then NatM a
sse2 else NatM a
x87

cmmTopCodeGen
        :: RawCmmDecl
        -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]

cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
cmmTopCodeGen (CmmProc info :: LabelMap CmmStatics
info lab :: CLabel
lab live :: [GlobalReg]
live graph :: CmmGraph
graph) = do
  let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
  (nat_blocks :: [[NatBasicBlock Instr]]
nat_blocks,statics :: [[NatCmmDecl (Alignment, CmmStatics) Instr]]
statics) <- (CmmBlock
 -> NatM
      ([NatBasicBlock Instr],
       [NatCmmDecl (Alignment, CmmStatics) Instr]))
-> [CmmBlock]
-> NatM
     ([[NatBasicBlock Instr]],
      [[NatCmmDecl (Alignment, CmmStatics) Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CmmBlock
-> NatM
     ([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
basicBlockCodeGen [CmmBlock]
blocks
  Maybe Reg
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let proc :: NatCmmDecl (Alignment, CmmStatics) Instr
proc = LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lab [GlobalReg]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock Instr]] -> [NatBasicBlock Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
nat_blocks)
      tops :: [NatCmmDecl (Alignment, CmmStatics) Instr]
tops = NatCmmDecl (Alignment, CmmStatics) Instr
proc NatCmmDecl (Alignment, CmmStatics) Instr
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl (Alignment, CmmStatics) Instr]]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl (Alignment, CmmStatics) Instr]]
statics
      os :: OS
os   = Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags

  case Maybe Reg
picBaseMb of
      Just picBase :: Reg
picBase -> Arch
-> OS
-> Reg
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
initializePicBase_x86 Arch
ArchX86 OS
os Reg
picBase [NatCmmDecl (Alignment, CmmStatics) Instr]
tops
      Nothing -> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl (Alignment, CmmStatics) Instr]
tops

cmmTopCodeGen (CmmData sec :: Section
sec dat :: CmmStatics
dat) = do
  [NatCmmDecl (Alignment, CmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Section
-> (Alignment, CmmStatics)
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (1, CmmStatics
dat)]  -- no translation, we just use CmmStatic

{- Note [Verifying basic blocks]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

   We want to guarantee a few things about the results
   of instruction selection.

   Namely that each basic blocks consists of:
    * A (potentially empty) sequence of straight line instructions
  followed by
    * A (potentially empty) sequence of jump like instructions.

    We can verify this by going through the instructions and
    making sure that any non-jumpish instruction can't appear
    after a jumpish instruction.

    There are gotchas however:
    * CALLs are strictly speaking control flow but here we care
      not about them. Hence we treat them as regular instructions.

      It's safe for them to appear inside a basic block
      as (ignoring side effects inside the call) they will result in
      straight line code.

    * NEWBLOCK marks the start of a new basic block so can
      be followed by any instructions.
-}

-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.
verifyBasicBlock :: [Instr] -> ()
verifyBasicBlock :: [Instr] -> ()
verifyBasicBlock instrs :: [Instr]
instrs
  | Bool
debugIsOn     = Bool -> [Instr] -> ()
go Bool
False [Instr]
instrs
  | Bool
otherwise     = ()
  where
    go :: Bool -> [Instr] -> ()
go _     [] = ()
    go atEnd :: Bool
atEnd (i :: Instr
i:instr :: [Instr]
instr)
        = case Instr
i of
            -- Start a new basic block
            NEWBLOCK {} -> Bool -> [Instr] -> ()
go Bool
False [Instr]
instr
            -- Calls are not viable block terminators
            CALL {}     | Bool
atEnd -> Instr -> ()
faultyBlockWith Instr
i
                        | Bool -> Bool
not Bool
atEnd -> Bool -> [Instr] -> ()
go Bool
atEnd [Instr]
instr
            -- All instructions ok, check if we reached the end and continue.
            _ | Bool -> Bool
not Bool
atEnd -> Bool -> [Instr] -> ()
go (Instr -> Bool
forall instr. Instruction instr => instr -> Bool
isJumpishInstr Instr
i) [Instr]
instr
              -- Only jumps allowed at the end of basic blocks.
              | Bool
otherwise -> if Instr -> Bool
forall instr. Instruction instr => instr -> Bool
isJumpishInstr Instr
i
                                then Bool -> [Instr] -> ()
go Bool
True [Instr]
instr
                                else Instr -> ()
faultyBlockWith Instr
i
    faultyBlockWith :: Instr -> ()
faultyBlockWith i :: Instr
i
        = String -> SDoc -> ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "Non control flow instructions after end of basic block."
                   (Instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Instr
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "in:" SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((Instr -> SDoc) -> [Instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Instr]
instrs))

basicBlockCodeGen
        :: CmmBlock
        -> NatM ( [NatBasicBlock Instr]
                , [NatCmmDecl (Alignment, CmmStatics) Instr])

basicBlockCodeGen :: CmmBlock
-> NatM
     ([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
basicBlockCodeGen block :: CmmBlock
block = do
  let (_, nodes :: Block CmmNode O O
nodes, tail :: CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      id :: Label
id = CmmBlock -> Label
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
  -- Generate location directive
  Maybe DebugBlock
dbg <- Label -> NatM (Maybe DebugBlock)
getDebugBlock (CmmBlock -> Label
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block)
  OrdList Instr
loc_instrs <- case DebugBlock -> Maybe CmmTickish
dblSourceTick (DebugBlock -> Maybe CmmTickish)
-> Maybe DebugBlock -> Maybe CmmTickish
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe DebugBlock
dbg of
    Just (SourceNote span :: RealSrcSpan
span name :: String
name)
      -> do Alignment
fileId <- FastString -> NatM Alignment
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line :: Alignment
line = RealSrcSpan -> Alignment
srcSpanStartLine RealSrcSpan
span; col :: Alignment
col = RealSrcSpan -> Alignment
srcSpanStartCol RealSrcSpan
span
            OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Alignment -> Alignment -> Alignment -> String -> Instr
LOCATION Alignment
fileId Alignment
line Alignment
col String
name
    _ -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
  (mid_instrs :: OrdList Instr
mid_instrs,mid_bid :: Label
mid_bid) <- Label -> [CmmNode O O] -> NatM (OrdList Instr, Label)
stmtsToInstrs Label
id [CmmNode O O]
stmts
  (tail_instrs :: OrdList Instr
tail_instrs,_) <- Label -> CmmNode O C -> NatM (OrdList Instr, Maybe Label)
forall e x.
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
mid_bid CmmNode O C
tail
  let instrs :: OrdList Instr
instrs = OrdList Instr
loc_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
mid_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
tail_instrs
  () -> NatM ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> NatM ()) -> () -> NatM ()
forall a b. (a -> b) -> a -> b
$! [Instr] -> ()
verifyBasicBlock (OrdList Instr -> [Instr]
forall a. OrdList a -> [a]
fromOL OrdList Instr
instrs)
  OrdList Instr
instrs' <- OrdList (OrdList Instr) -> OrdList Instr
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (OrdList (OrdList Instr) -> OrdList Instr)
-> NatM (OrdList (OrdList Instr)) -> NatM (OrdList Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList (OrdList Instr))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Instr -> NatM (OrdList Instr)
addSpUnwindings OrdList Instr
instrs
  -- code generation may introduce new basic block boundaries, which
  -- are indicated by the NEWBLOCK instruction.  We must split up the
  -- instruction stream into basic blocks again.  Also, we extract
  -- LDATAs here too.
  let
        (top :: [Instr]
top,other_blocks :: [NatBasicBlock Instr]
other_blocks,statics :: [NatCmmDecl (Alignment, CmmStatics) Instr]
statics) = (Instr
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl (Alignment, CmmStatics) Instr])
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl (Alignment, CmmStatics) Instr]))
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, CmmStatics) Instr])
-> OrdList Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, CmmStatics) Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, CmmStatics) Instr])
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, CmmStatics) Instr])
forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, CmmStatics) h g])
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, CmmStatics) h g])
mkBlocks ([],[],[]) OrdList Instr
instrs'

        mkBlocks :: Instr
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, CmmStatics) h g])
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, CmmStatics) h g])
mkBlocks (NEWBLOCK id :: Label
id) (instrs :: [Instr]
instrs,blocks :: [NatBasicBlock Instr]
blocks,statics :: [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
          = ([], Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
        mkBlocks (LDATA sec :: Section
sec dat :: (Alignment, CmmStatics)
dat) (instrs :: [Instr]
instrs,blocks :: [NatBasicBlock Instr]
blocks,statics :: [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
          = ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section
-> (Alignment, CmmStatics)
-> GenCmmDecl (Alignment, CmmStatics) h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (Alignment, CmmStatics)
datGenCmmDecl (Alignment, CmmStatics) h g
-> [GenCmmDecl (Alignment, CmmStatics) h g]
-> [GenCmmDecl (Alignment, CmmStatics) h g]
forall a. a -> [a] -> [a]
:[GenCmmDecl (Alignment, CmmStatics) h g]
statics)
        mkBlocks instr :: Instr
instr (instrs :: [Instr]
instrs,blocks :: [NatBasicBlock Instr]
blocks,statics :: [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
          = (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
  ([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
-> NatM
     ([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
forall (m :: * -> *) a. Monad m => a -> m a
return (Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
top NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
other_blocks, [NatCmmDecl (Alignment, CmmStatics) Instr]
statics)

-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
-- in the @sp@ register. See Note [What is this unwinding business?] in Debug
-- for details.
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings instr :: Instr
instr@(DELTA d :: Alignment
d) = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    if DynFlags -> Alignment
debugLevel DynFlags
dflags Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
>= 1
        then do CLabel
lbl <- Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel (Unique -> CLabel) -> NatM Unique -> NatM CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                let unwind :: Map GlobalReg (Maybe UnwindExpr)
unwind = GlobalReg -> Maybe UnwindExpr -> Map GlobalReg (Maybe UnwindExpr)
forall k a. k -> a -> Map k a
M.singleton GlobalReg
MachSp (UnwindExpr -> Maybe UnwindExpr
forall a. a -> Maybe a
Just (UnwindExpr -> Maybe UnwindExpr) -> UnwindExpr -> Maybe UnwindExpr
forall a b. (a -> b) -> a -> b
$ GlobalReg -> Alignment -> UnwindExpr
UwReg GlobalReg
MachSp (Alignment -> UnwindExpr) -> Alignment -> UnwindExpr
forall a b. (a -> b) -> a -> b
$ Alignment -> Alignment
forall a. Num a => a -> a
negate Alignment
d)
                OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr
instr, CLabel -> Map GlobalReg (Maybe UnwindExpr) -> Instr
UNWIND CLabel
lbl Map GlobalReg (Maybe UnwindExpr)
unwind ]
        else OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
instr)
addSpUnwindings instr :: Instr
instr = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
instr

{- Note [Keeping track of the current block]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When generating instructions for Cmm we sometimes require
the current block for things like retry loops.

We also sometimes change the current block, if a MachOP
results in branching control flow.

Issues arise if we have two statements in the same block,
which both depend on the current block id *and* change the
basic block after them. This happens for atomic primops
in the X86 backend where we want to update the CFG data structure
when introducing new basic blocks.

For example in #17334 we got this Cmm code:

        c3Bf: // global
            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);
            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);
            _s3sT::I64 = _s3sV::I64;
            goto c3B1;

This resulted in two new basic blocks being inserted:

        c3Bf:
                movl $18,%vI_n3Bo
                movq 88(%vI_s3sQ),%rax
                jmp _n3Bp
        n3Bp:
                ...
                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)
                jne _n3Bp
                ...
                jmp _n3Bs
        n3Bs:
                ...
                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)
                jne _n3Bs
                ...
                jmp _c3B1
        ...

Based on the Cmm we called stmtToInstrs we translated both atomic operations under
the assumption they would be placed into their Cmm basic block `c3Bf`.
However for the retry loop we introduce new labels, so this is not the case
for the second statement.
This resulted in a desync between the explicit control flow graph
we construct as a separate data type and the actual control flow graph in the code.

Instead we now return the new basic block if a statement causes a change
in the current block and use the block for all following statements.

For this reason genCCall is also split into two parts.
One for calls which *won't* change the basic blocks in
which successive instructions will be placed.
A different one for calls which *are* known to change the
basic block.

-}

-- See Note [Keeping track of the current block] for why
-- we pass the BlockId.
stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
              -> [CmmNode O O] -- ^ Cmm Statement
              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
stmtsToInstrs :: Label -> [CmmNode O O] -> NatM (OrdList Instr, Label)
stmtsToInstrs bid :: Label
bid stmts :: [CmmNode O O]
stmts =
    Label
-> [CmmNode O O] -> OrdList Instr -> NatM (OrdList Instr, Label)
forall e x.
Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
bid [CmmNode O O]
stmts OrdList Instr
forall a. OrdList a
nilOL
  where
    go :: Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go bid :: Label
bid  []        instrs :: OrdList Instr
instrs = (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs,Label
bid)
    go bid :: Label
bid (s :: CmmNode e x
s:stmts :: [CmmNode e x]
stmts)  instrs :: OrdList Instr
instrs = do
      (instrs' :: OrdList Instr
instrs',bid' :: Maybe Label
bid') <- Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
forall e x.
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid CmmNode e x
s
      -- If the statement introduced a new block, we use that one
      let newBid :: Label
newBid = Label -> Maybe Label -> Label
forall a. a -> Maybe a -> a
fromMaybe Label
bid Maybe Label
bid'
      Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
newBid [CmmNode e x]
stmts (OrdList Instr
instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
instrs')

-- | `bid` refers to the current block and is used to update the CFG
--   if new blocks are inserted in the control flow.
-- See Note [Keeping track of the current block] for more details.
stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
             -> CmmNode e x
             -> NatM (InstrBlock, Maybe BlockId)
             -- ^ Instructions, and bid of new block if successive
             -- statements are placed in a different basic block.
stmtToInstrs :: Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs bid :: Label
bid stmt :: CmmNode e x
stmt = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  case CmmNode e x
stmt of
    CmmUnsafeForeignCall target :: ForeignTarget
target result_regs :: [CmmFormal]
result_regs args :: [CmmActual]
args
       -> DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
result_regs [CmmActual]
args Label
bid

    _ -> (,Maybe Label
forall a. Maybe a
Nothing) (OrdList Instr -> (OrdList Instr, Maybe Label))
-> NatM (OrdList Instr) -> NatM (OrdList Instr, Maybe Label)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CmmNode e x
stmt of
      CmmComment s :: FastString
s   -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FastString -> Instr
COMMENT FastString
s))
      CmmTick {}     -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

      CmmUnwind regs :: [(GlobalReg, Maybe CmmActual)]
regs -> do
        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
            to_unwind_entry :: (GlobalReg, Maybe CmmActual) -> Map GlobalReg (Maybe UnwindExpr)
to_unwind_entry (reg :: GlobalReg
reg, expr :: Maybe CmmActual
expr) = GlobalReg -> Maybe UnwindExpr -> Map GlobalReg (Maybe UnwindExpr)
forall k a. k -> a -> Map k a
M.singleton GlobalReg
reg ((CmmActual -> UnwindExpr) -> Maybe CmmActual -> Maybe UnwindExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmActual -> UnwindExpr
toUnwindExpr Maybe CmmActual
expr)
        case ((GlobalReg, Maybe CmmActual) -> Map GlobalReg (Maybe UnwindExpr))
-> [(GlobalReg, Maybe CmmActual)]
-> Map GlobalReg (Maybe UnwindExpr)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GlobalReg, Maybe CmmActual) -> Map GlobalReg (Maybe UnwindExpr)
to_unwind_entry [(GlobalReg, Maybe CmmActual)]
regs of
          tbl :: Map GlobalReg (Maybe UnwindExpr)
tbl | Map GlobalReg (Maybe UnwindExpr) -> Bool
forall k a. Map k a -> Bool
M.null Map GlobalReg (Maybe UnwindExpr)
tbl -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
              | Bool
otherwise  -> do
                  CLabel
lbl <- Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel (Unique -> CLabel) -> NatM Unique -> NatM CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
                  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> Map GlobalReg (Maybe UnwindExpr) -> Instr
UNWIND CLabel
lbl Map GlobalReg (Maybe UnwindExpr)
tbl

      CmmAssign reg :: CmmReg
reg src :: CmmActual
src
        | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmActual
src
        | Bool
is32Bit Bool -> Bool -> Bool
&& CmmType -> Bool
isWord64 CmmType
ty -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_I64Code      CmmReg
reg CmmActual
src
        | Bool
otherwise              -> Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_IntCode Format
format CmmReg
reg CmmActual
src
          where ty :: CmmType
ty = DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

      CmmStore addr :: CmmActual
addr src :: CmmActual
src
        | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmActual
addr CmmActual
src
        | Bool
is32Bit Bool -> Bool -> Bool
&& CmmType -> Bool
isWord64 CmmType
ty -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_I64Code      CmmActual
addr CmmActual
src
        | Bool
otherwise              -> Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_IntCode Format
format CmmActual
addr CmmActual
src
          where ty :: CmmType
ty = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
src
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

      CmmBranch id :: Label
id          -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Label -> OrdList Instr
genBranch Label
id

      --We try to arrange blocks such that the likely branch is the fallthrough
      --in CmmContFlowOpt. So we can assume the condition is likely false here.
      CmmCondBranch arg :: CmmActual
arg true :: Label
true false :: Label
false _ -> Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch Label
bid Label
true Label
false CmmActual
arg
      CmmSwitch arg :: CmmActual
arg ids :: SwitchTargets
ids -> do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                              DynFlags -> CmmActual -> SwitchTargets -> NatM (OrdList Instr)
genSwitch DynFlags
dflags CmmActual
arg SwitchTargets
ids
      CmmCall { cml_target :: CmmNode O C -> CmmActual
cml_target = CmmActual
arg
              , cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args_regs = [GlobalReg]
gregs } -> do
                                  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                                  CmmActual -> [Reg] -> NatM (OrdList Instr)
genJump CmmActual
arg (DynFlags -> [GlobalReg] -> [Reg]
jumpRegs DynFlags
dflags [GlobalReg]
gregs)
      _ ->
        String -> NatM (OrdList Instr)
forall a. String -> a
panic "stmtToInstrs: statement should have been cps'd away"


jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
jumpRegs dflags :: DynFlags
dflags gregs :: [GlobalReg]
gregs = [ RealReg -> Reg
RegReal RealReg
r | Just r :: RealReg
r <- (GlobalReg -> Maybe RealReg) -> [GlobalReg] -> [Maybe RealReg]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform) [GlobalReg]
gregs ]
    where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

--------------------------------------------------------------------------------
-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
--      They are really trees of insns to facilitate fast appending, where a
--      left-to-right traversal yields the insns in the correct order.
--
type InstrBlock
        = OrdList Instr


-- | Condition codes passed up the tree.
--
data CondCode
        = CondCode Bool Cond InstrBlock


-- | a.k.a "Register64"
--      Reg is the lower 32-bit temporary which contains the result.
--      Use getHiVRegFromLo to find the other VRegUnique.
--
--      Rules of this simplified insn selection game are therefore that
--      the returned Reg may be modified
--
data ChildCode64
   = ChildCode64
        InstrBlock
        Reg


-- | Register's passed up the tree.  If the stix code forces the register
--      to live in a pre-decided machine register, it comes out as @Fixed@;
--      otherwise, it comes out as @Any@, and the parent can decide which
--      register to put it in.
--
data Register
        = Fixed Format Reg InstrBlock
        | Any   Format (Reg -> InstrBlock)


swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep (Fixed _ reg :: Reg
reg code :: OrdList Instr
code) format :: Format
format = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
reg OrdList Instr
code
swizzleRegisterRep (Any _ codefn :: Reg -> OrdList Instr
codefn)     format :: Format
format = Format -> (Reg -> OrdList Instr) -> Register
Any   Format
format Reg -> OrdList Instr
codefn


-- | Grab the Reg for a CmmReg
getRegisterReg :: Platform -> Bool -> CmmReg -> Reg

getRegisterReg :: Platform -> Bool -> CmmReg -> Reg
getRegisterReg _ use_sse2 :: Bool
use_sse2 (CmmLocal (LocalReg u :: Unique
u pk :: CmmType
pk))
  = let fmt :: Format
fmt = CmmType -> Format
cmmTypeFormat CmmType
pk in
    if Format -> Bool
isFloatFormat Format
fmt Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
use_sse2
       then VirtualReg -> Reg
RegVirtual (Unique -> Format -> VirtualReg
mkVirtualReg Unique
u Format
FF80)
       else VirtualReg -> Reg
RegVirtual (Unique -> Format -> VirtualReg
mkVirtualReg Unique
u Format
fmt)

getRegisterReg platform :: Platform
platform _ (CmmGlobal mid :: GlobalReg
mid)
  = case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
mid of
        Just reg :: RealReg
reg -> RealReg -> Reg
RegReal (RealReg -> Reg) -> RealReg -> Reg
forall a b. (a -> b) -> a -> b
$ RealReg
reg
        Nothing  -> String -> SDoc -> Reg
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getRegisterReg-memory" (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmReg -> SDoc) -> CmmReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalReg -> CmmReg
CmmGlobal GlobalReg
mid)
        -- By this stage, the only MagicIds remaining should be the
        -- ones which map to a real machine register on this
        -- platform.  Hence ...


-- | Memory addressing modes passed up the tree.
data Amode
        = Amode AddrMode InstrBlock

{-
Now, given a tree (the argument to a CmmLoad) that references memory,
produce a suitable addressing mode.

A Rule of the Game (tm) for Amodes: use of the addr bit must
immediately follow use of the code part, since the code part puts
values in registers which the addr then refers to.  So you can't put
anything in between, lest it overwrite some of those registers.  If
you need to do some other computation between the code part and use of
the addr bit, first store the effective address from the amode in a
temporary, then do the other computation, and then use the temporary:

    code
    LEA amode, tmp
    ... other computation ...
    ... (tmp) ...
-}


-- | Check whether an integer will fit in 32 bits.
--      A CmmInt is intended to be truncated to the appropriate
--      number of bits, so here we truncate it to Int64.  This is
--      important because e.g. -1 as a CmmInt might be either
--      -1 or 18446744073709551615.
--
is32BitInteger :: Integer -> Bool
is32BitInteger :: Integer -> Bool
is32BitInteger i :: Integer
i = Int64
i64 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7fffffff Bool -> Bool -> Bool
&& Int64
i64 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= -0x80000000
  where i64 :: Int64
i64 = Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Int64


-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry :: DynFlags -> Maybe Label -> CmmStatic
jumpTableEntry dflags :: DynFlags
dflags Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0 (DynFlags -> Width
wordWidth DynFlags
dflags))
jumpTableEntry _ (Just blockid :: Label
blockid) = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CmmLit
CmmLabel CLabel
blockLabel)
    where blockLabel :: CLabel
blockLabel = Label -> CLabel
blockLbl Label
blockid


-- -----------------------------------------------------------------------------
-- General things for putting together code sequences

-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr
mangleIndexTree :: DynFlags -> CmmReg -> Alignment -> CmmActual
mangleIndexTree dflags :: DynFlags
dflags reg :: CmmReg
reg off :: Alignment
off
  = MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmActual
CmmReg CmmReg
reg, CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt (Alignment -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Alignment
off) Width
width)]
  where width :: Width
width = CmmType -> Width
typeWidth (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg)

-- | The dual to getAnyReg: compute an expression into a register, but
--      we don't mind which one it is.
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg :: CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg expr :: CmmActual
expr = do
  Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
  case Register
r of
    Any rep :: Format
rep code :: Reg -> OrdList Instr
code -> do
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
    Fixed _ reg :: Reg
reg code :: OrdList Instr
code ->
        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, OrdList Instr
code)


assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_I64Code addrTree :: CmmActual
addrTree valueTree :: CmmActual
valueTree = do
  Amode addr :: AddrMode
addr addr_code :: OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
addrTree
  ChildCode64 vcode :: OrdList Instr
vcode rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
valueTree
  let
        rhi :: Reg
rhi = Reg -> Reg
getHiVRegFromLo Reg
rlo

        -- Little-endian store
        mov_lo :: Instr
mov_lo = Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rlo) (AddrMode -> Operand
OpAddr AddrMode
addr)
        mov_hi :: Instr
mov_hi = Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rhi) (AddrMode -> Operand
OpAddr (Maybe AddrMode -> AddrMode
forall a. HasCallStack => Maybe a -> a
fromJust (AddrMode -> Alignment -> Maybe AddrMode
addrOffset AddrMode
addr 4)))
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
vcode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)


assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_I64Code :: CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_I64Code (CmmLocal (LocalReg u_dst :: Unique
u_dst _)) valueTree :: CmmActual
valueTree = do
   ChildCode64 vcode :: OrdList Instr
vcode r_src_lo :: Reg
r_src_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
valueTree
   let
         r_dst_lo :: Reg
r_dst_lo = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
u_dst Format
II32
         r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
         r_src_hi :: Reg
r_src_hi = Reg -> Reg
getHiVRegFromLo Reg
r_src_lo
         mov_lo :: Instr
mov_lo = Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r_src_lo) (Reg -> Operand
OpReg Reg
r_dst_lo)
         mov_hi :: Instr
mov_hi = Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r_src_hi) (Reg -> Operand
OpReg Reg
r_dst_hi)
   OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (
        OrdList Instr
vcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi
     )

assignReg_I64Code _ _
   = String -> NatM (OrdList Instr)
forall a. String -> a
panic "assignReg_I64Code(i386): invalid lvalue"


iselExpr64        :: CmmExpr -> NatM ChildCode64
iselExpr64 :: CmmActual -> NatM ChildCode64
iselExpr64 (CmmLit (CmmInt i :: Integer
i _)) = do
  (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
  let
        r :: Integer
r = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word32)
        q :: Integer
q = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Alignment -> Integer
forall a. Bits a => a -> Alignment -> a
`shiftR` 32) :: Word32)
        code :: OrdList Instr
code = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
r)) (Reg -> Operand
OpReg Reg
rlo),
                Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
q)) (Reg -> Operand
OpReg Reg
rhi)
                ]
  ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)

iselExpr64 (CmmLoad addrTree :: CmmActual
addrTree ty :: CmmType
ty) | CmmType -> Bool
isWord64 CmmType
ty = do
   Amode addr :: AddrMode
addr addr_code :: OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
addrTree
   (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
   let
        mov_lo :: Instr
mov_lo = Format -> Operand -> Operand -> Instr
MOV Format
II32 (AddrMode -> Operand
OpAddr AddrMode
addr) (Reg -> Operand
OpReg Reg
rlo)
        mov_hi :: Instr
mov_hi = Format -> Operand -> Operand -> Instr
MOV Format
II32 (AddrMode -> Operand
OpAddr (Maybe AddrMode -> AddrMode
forall a. HasCallStack => Maybe a -> a
fromJust (AddrMode -> Alignment -> Maybe AddrMode
addrOffset AddrMode
addr 4))) (Reg -> Operand
OpReg Reg
rhi)
   ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (
            OrdList Instr -> Reg -> ChildCode64
ChildCode64 (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
                        Reg
rlo
     )

iselExpr64 (CmmReg (CmmLocal (LocalReg vu :: Unique
vu ty :: CmmType
ty))) | CmmType -> Bool
isWord64 CmmType
ty
   = ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
forall a. OrdList a
nilOL (VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
vu Format
II32))

-- we handle addition, but rather badly
iselExpr64 (CmmMachOp (MO_Add _) [e1 :: CmmActual
e1, CmmLit (CmmInt i :: Integer
i _)]) = do
   ChildCode64 code1 :: OrdList Instr
code1 r1lo :: Reg
r1lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
   (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
   let
        r :: Integer
r = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word32)
        q :: Integer
q = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Alignment -> Integer
forall a. Bits a => a -> Alignment -> a
`shiftR` 32) :: Word32)
        r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
        code :: OrdList Instr
code =  OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1lo) (Reg -> Operand
OpReg Reg
rlo),
                       Format -> Operand -> Operand -> Instr
ADD Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
r)) (Reg -> Operand
OpReg Reg
rlo),
                       Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1hi) (Reg -> Operand
OpReg Reg
rhi),
                       Format -> Operand -> Operand -> Instr
ADC Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
q)) (Reg -> Operand
OpReg Reg
rhi) ]
   ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)

iselExpr64 (CmmMachOp (MO_Add _) [e1 :: CmmActual
e1,e2 :: CmmActual
e2]) = do
   ChildCode64 code1 :: OrdList Instr
code1 r1lo :: Reg
r1lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
   ChildCode64 code2 :: OrdList Instr
code2 r2lo :: Reg
r2lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e2
   (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
   let
        r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
        r2hi :: Reg
r2hi = Reg -> Reg
getHiVRegFromLo Reg
r2lo
        code :: OrdList Instr
code =  OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1lo) (Reg -> Operand
OpReg Reg
rlo),
                       Format -> Operand -> Operand -> Instr
ADD Format
II32 (Reg -> Operand
OpReg Reg
r2lo) (Reg -> Operand
OpReg Reg
rlo),
                       Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1hi) (Reg -> Operand
OpReg Reg
rhi),
                       Format -> Operand -> Operand -> Instr
ADC Format
II32 (Reg -> Operand
OpReg Reg
r2hi) (Reg -> Operand
OpReg Reg
rhi) ]
   ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)

iselExpr64 (CmmMachOp (MO_Sub _) [e1 :: CmmActual
e1,e2 :: CmmActual
e2]) = do
   ChildCode64 code1 :: OrdList Instr
code1 r1lo :: Reg
r1lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
   ChildCode64 code2 :: OrdList Instr
code2 r2lo :: Reg
r2lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e2
   (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
   let
        r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
        r2hi :: Reg
r2hi = Reg -> Reg
getHiVRegFromLo Reg
r2lo
        code :: OrdList Instr
code =  OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1lo) (Reg -> Operand
OpReg Reg
rlo),
                       Format -> Operand -> Operand -> Instr
SUB Format
II32 (Reg -> Operand
OpReg Reg
r2lo) (Reg -> Operand
OpReg Reg
rlo),
                       Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1hi) (Reg -> Operand
OpReg Reg
rhi),
                       Format -> Operand -> Operand -> Instr
SBB Format
II32 (Reg -> Operand
OpReg Reg
r2hi) (Reg -> Operand
OpReg Reg
rhi) ]
   ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)

iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr :: CmmActual
expr]) = do
     Reg -> OrdList Instr
fn <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr
     Reg
r_dst_lo <-  Format -> NatM Reg
getNewRegNat Format
II32
     let r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
         code :: OrdList Instr
code = Reg -> OrdList Instr
fn Reg
r_dst_lo
     ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (
             OrdList Instr -> Reg -> ChildCode64
ChildCode64 (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt 0)) (Reg -> Operand
OpReg Reg
r_dst_hi))
                          Reg
r_dst_lo
            )

iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr :: CmmActual
expr]) = do
     Reg -> OrdList Instr
fn <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr
     Reg
r_dst_lo <-  Format -> NatM Reg
getNewRegNat Format
II32
     let r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
         code :: OrdList Instr
code = Reg -> OrdList Instr
fn Reg
r_dst_lo
     ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (
             OrdList Instr -> Reg -> ChildCode64
ChildCode64 (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r_dst_lo) (Reg -> Operand
OpReg Reg
eax) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Instr
CLTD Format
II32 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
r_dst_lo) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
r_dst_hi))
                          Reg
r_dst_lo
            )

iselExpr64 expr :: CmmActual
expr
   = String -> SDoc -> NatM ChildCode64
forall a. HasCallStack => String -> SDoc -> a
pprPanic "iselExpr64(i386)" (CmmActual -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmActual
expr)


--------------------------------------------------------------------------------
getRegister :: CmmExpr -> NatM Register
getRegister :: CmmActual -> NatM Register
getRegister e :: CmmActual
e = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                   Bool
is32Bit <- NatM Bool
is32BitPlatform
                   DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit CmmActual
e

getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register

getRegister' :: DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (CmmReg reg :: CmmReg
reg)
  = case CmmReg
reg of
        CmmGlobal PicBaseReg
         | Bool
is32Bit ->
            -- on x86_64, we have %rip for PicBaseReg, but it's not
            -- a full-featured register, it can only be used for
            -- rip-relative addressing.
            do Reg
reg' <- Format -> NatM Reg
getPicBaseNat (Bool -> Format
archWordFormat Bool
is32Bit)
               Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed (Bool -> Format
archWordFormat Bool
is32Bit) Reg
reg' OrdList Instr
forall a. OrdList a
nilOL)
        _ ->
            do Bool
use_sse2 <- NatM Bool
sse2Enabled
               let
                 fmt :: Format
fmt = CmmType -> Format
cmmTypeFormat (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg)
                 format :: Format
format | Bool -> Bool
not Bool
use_sse2 Bool -> Bool -> Bool
&& Format -> Bool
isFloatFormat Format
fmt = Format
FF80
                        | Bool
otherwise                         = Format
fmt
               --
               let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
               Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format
                             (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 CmmReg
reg)
                             OrdList Instr
forall a. OrdList a
nilOL)


getRegister' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (CmmRegOff r :: CmmReg
r n :: Alignment
n)
  = DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit (CmmActual -> NatM Register) -> CmmActual -> NatM Register
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmReg -> Alignment -> CmmActual
mangleIndexTree DynFlags
dflags CmmReg
r Alignment
n

getRegister' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (CmmMachOp (MO_AlignmentCheck align :: Alignment
align _) [e :: CmmActual
e])
  = Alignment -> Register -> Register
addAlignmentCheck Alignment
align (Register -> Register) -> NatM Register -> NatM Register
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit CmmActual
e

-- for 32-bit architectuers, support some 64 -> 32 bit conversions:
-- TO_W_(x), TO_W_(x >> 32)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_UU_Conv W64 W32)
                     [CmmMachOp (MO_U_Shr W64) [x :: CmmActual
x,CmmLit (CmmInt 32 _)]])
 | Bool
is32Bit = do
  ChildCode64 code :: OrdList Instr
code rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
rlo) OrdList Instr
code

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_SS_Conv W64 W32)
                     [CmmMachOp (MO_U_Shr W64) [x :: CmmActual
x,CmmLit (CmmInt 32 _)]])
 | Bool
is32Bit = do
  ChildCode64 code :: OrdList Instr
code rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
rlo) OrdList Instr
code

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x :: CmmActual
x])
 | Bool
is32Bit = do
  ChildCode64 code :: OrdList Instr
code rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 Reg
rlo OrdList Instr
code

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x :: CmmActual
x])
 | Bool
is32Bit = do
  ChildCode64 code :: OrdList Instr
code rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 Reg
rlo OrdList Instr
code

getRegister' _ _ (CmmLit lit :: CmmLit
lit@(CmmFloat f :: Rational
f w :: Width
w)) =
  NatM Register -> NatM Register -> NatM Register
forall a. NatM a -> NatM a -> NatM a
if_sse2 NatM Register
float_const_sse2 NatM Register
float_const_x87
 where
  float_const_sse2 :: NatM Register
float_const_sse2
    | Rational
f Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== 0.0 = do
      let
          format :: Format
format = Width -> Format
floatFormat Width
w
          code :: Reg -> OrdList Instr
code dst :: Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL  (Format -> Operand -> Operand -> Instr
XOR Format
format (Reg -> Operand
OpReg Reg
dst) (Reg -> Operand
OpReg Reg
dst))
        -- I don't know why there are xorpd, xorps, and pxor instructions.
        -- They all appear to do the same thing --SDM
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

   | Bool
otherwise = do
      Amode addr :: AddrMode
addr code :: OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Width -> Alignment
widthInBytes Width
w) CmmLit
lit
      Bool -> Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode Bool
True Width
w AddrMode
addr OrdList Instr
code

  float_const_x87 :: NatM Register
float_const_x87 = case Width
w of
    W64
      | Rational
f Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== 0.0 ->
        let code :: Reg -> OrdList Instr
code dst :: Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Instr
GLDZ Reg
dst)
        in  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
FF80 Reg -> OrdList Instr
code)

      | Rational
f Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== 1.0 ->
        let code :: Reg -> OrdList Instr
code dst :: Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Instr
GLD1 Reg
dst)
        in  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
FF80 Reg -> OrdList Instr
code)

    _otherwise :: Width
_otherwise -> do
      Amode addr :: AddrMode
addr code :: OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Width -> Alignment
widthInBytes Width
w) CmmLit
lit
      Bool -> Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode Bool
False Width
w AddrMode
addr OrdList Instr
code

-- catch simple cases of zero- or sign-extended load
getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr :: CmmActual
addr _]) = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)

getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr :: CmmActual
addr _]) = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II8) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)

getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr :: CmmActual
addr _]) = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)

getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr :: CmmActual
addr _]) = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II16) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)

-- catch simple cases of zero- or sign-extended load
getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr :: CmmActual
addr _])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr :: CmmActual
addr _])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II8) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr :: CmmActual
addr _])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr :: CmmActual
addr _])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II16) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr :: CmmActual
addr _])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
II32) CmmActual
addr -- 32-bit loads zero-extend
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr :: CmmActual
addr _])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II32) CmmActual
addr
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
                                     CmmLit displacement :: CmmLit
displacement])
 | Bool -> Bool
not Bool
is32Bit = do
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 (\dst :: Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$
        Format -> Operand -> Operand -> Instr
LEA Format
II64 (AddrMode -> Operand
OpAddr (Imm -> AddrMode
ripRel (CmmLit -> Imm
litToImm CmmLit
displacement))) (Reg -> Operand
OpReg Reg
dst))

getRegister' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (CmmMachOp mop :: MachOp
mop [x :: CmmActual
x]) = do -- unary MachOps
    Bool
sse2 <- NatM Bool
sse2Enabled
    case MachOp
mop of
      MO_F_Neg w :: Width
w
         | Bool
sse2      -> Width -> CmmActual -> NatM Register
sse2NegCode Width
w CmmActual
x
         | Bool
otherwise -> Format -> (Reg -> Reg -> Instr) -> CmmActual -> NatM Register
trivialUFCode Format
FF80 (Format -> Reg -> Reg -> Instr
GNEG Format
FF80) CmmActual
x

      MO_S_Neg w :: Width
w -> (Format -> Operand -> Instr) -> Format -> NatM Register
triv_ucode Format -> Operand -> Instr
NEGI (Width -> Format
intFormat Width
w)
      MO_Not w :: Width
w   -> (Format -> Operand -> Instr) -> Format -> NatM Register
triv_ucode Format -> Operand -> Instr
NOT  (Width -> Format
intFormat Width
w)

      -- Nop conversions
      MO_UU_Conv W32 W8  -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W32 CmmActual
x
      MO_SS_Conv W32 W8  -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W32 CmmActual
x
      MO_XX_Conv W32 W8  -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W32 CmmActual
x
      MO_UU_Conv W16 W8  -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W16 CmmActual
x
      MO_SS_Conv W16 W8  -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W16 CmmActual
x
      MO_XX_Conv W16 W8  -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W16 CmmActual
x
      MO_UU_Conv W32 W16 -> Width -> CmmActual -> NatM Register
toI16Reg Width
W32 CmmActual
x
      MO_SS_Conv W32 W16 -> Width -> CmmActual -> NatM Register
toI16Reg Width
W32 CmmActual
x
      MO_XX_Conv W32 W16 -> Width -> CmmActual -> NatM Register
toI16Reg Width
W32 CmmActual
x

      MO_UU_Conv W64 W32 | Bool -> Bool
not Bool
is32Bit -> Format -> CmmActual -> NatM Register
conversionNop Format
II64 CmmActual
x
      MO_SS_Conv W64 W32 | Bool -> Bool
not Bool
is32Bit -> Format -> CmmActual -> NatM Register
conversionNop Format
II64 CmmActual
x
      MO_XX_Conv W64 W32 | Bool -> Bool
not Bool
is32Bit -> Format -> CmmActual -> NatM Register
conversionNop Format
II64 CmmActual
x
      MO_UU_Conv W64 W16 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI16Reg Width
W64 CmmActual
x
      MO_SS_Conv W64 W16 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI16Reg Width
W64 CmmActual
x
      MO_XX_Conv W64 W16 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI16Reg Width
W64 CmmActual
x
      MO_UU_Conv W64 W8  | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W64 CmmActual
x
      MO_SS_Conv W64 W8  | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W64 CmmActual
x
      MO_XX_Conv W64 W8  | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI8Reg  Width
W64 CmmActual
x

      MO_UU_Conv rep1 :: Width
rep1 rep2 :: Width
rep2 | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 -> Format -> CmmActual -> NatM Register
conversionNop (Width -> Format
intFormat Width
rep1) CmmActual
x
      MO_SS_Conv rep1 :: Width
rep1 rep2 :: Width
rep2 | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 -> Format -> CmmActual -> NatM Register
conversionNop (Width -> Format
intFormat Width
rep1) CmmActual
x
      MO_XX_Conv rep1 :: Width
rep1 rep2 :: Width
rep2 | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 -> Format -> CmmActual -> NatM Register
conversionNop (Width -> Format
intFormat Width
rep1) CmmActual
x

      -- widenings
      MO_UU_Conv W8  W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
      MO_UU_Conv W16 W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
      MO_UU_Conv W8  W16 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W16 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x

      MO_SS_Conv W8  W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W32 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
      MO_SS_Conv W16 W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
      MO_SS_Conv W8  W16 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W16 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x

      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we
      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register
      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.
      MO_XX_Conv W8  W32
          | Bool
is32Bit   -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
          | Bool
otherwise -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
      MO_XX_Conv W8  W16
          | Bool
is32Bit   -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
          | Bool
otherwise -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
      MO_XX_Conv W16 W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOV CmmActual
x

      MO_UU_Conv W8  W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
      MO_UU_Conv W16 W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
      MO_UU_Conv W32 W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
      MO_SS_Conv W8  W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
      MO_SS_Conv W16 W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
      MO_SS_Conv W32 W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.
      -- However, we don't want the register allocator to throw it
      -- away as an unnecessary reg-to-reg move, so we keep it in
      -- the form of a movzl and print it as a movl later.
      -- This doesn't apply to MO_XX_Conv since in this case we don't care about
      -- the upper bits. So we can just use MOV.
      MO_XX_Conv W8  W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8  Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
      MO_XX_Conv W16 W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
      MO_XX_Conv W32 W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmActual
x

      MO_FF_Conv W32 W64
        | Bool
sse2      -> Width -> CmmActual -> NatM Register
coerceFP2FP Width
W64 CmmActual
x
        | Bool
otherwise -> Format -> CmmActual -> NatM Register
conversionNop Format
FF80 CmmActual
x

      MO_FF_Conv W64 W32 -> Width -> CmmActual -> NatM Register
coerceFP2FP Width
W32 CmmActual
x

      MO_FS_Conv from :: Width
from to :: Width
to -> Width -> Width -> CmmActual -> NatM Register
coerceFP2Int Width
from Width
to CmmActual
x
      MO_SF_Conv from :: Width
from to :: Width
to -> Width -> Width -> CmmActual -> NatM Register
coerceInt2FP Width
from Width
to CmmActual
x

      MO_V_Insert {}   -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Extract {}  -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Add {}      -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Sub {}      -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Mul {}      -> NatM Register
forall a. NatM a
needLlvm
      MO_VS_Quot {}    -> NatM Register
forall a. NatM a
needLlvm
      MO_VS_Rem {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VS_Neg {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VU_Quot {}    -> NatM Register
forall a. NatM a
needLlvm
      MO_VU_Rem {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Insert {}  -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Extract {} -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Add {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Sub {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Mul {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Quot {}    -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Neg {}     -> NatM Register
forall a. NatM a
needLlvm

      _other :: MachOp
_other -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getRegister" (MachOp -> SDoc
pprMachOp MachOp
mop)
   where
        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register
        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register
triv_ucode instr :: Format -> Operand -> Instr
instr format :: Format
format = Format -> (Operand -> Instr) -> CmmActual -> NatM Register
trivialUCode Format
format (Format -> Operand -> Instr
instr Format
format) CmmActual
x

        -- signed or unsigned extension.
        integerExtend :: Width -> Width
                      -> (Format -> Operand -> Operand -> Instr)
                      -> CmmExpr -> NatM Register
        integerExtend :: Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend from :: Width
from to :: Width
to instr :: Format -> Operand -> Operand -> Instr
instr expr :: CmmActual
expr = do
            (reg :: Reg
reg,e_code :: OrdList Instr
e_code) <- if Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then CmmActual -> NatM (Reg, OrdList Instr)
getByteReg CmmActual
expr
                                          else CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
            let
                code :: Reg -> OrdList Instr
code dst :: Reg
dst =
                  OrdList Instr
e_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
instr (Width -> Format
intFormat Width
from) (Reg -> Operand
OpReg Reg
reg) (Reg -> Operand
OpReg Reg
dst)
            Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> OrdList Instr
code)

        toI8Reg :: Width -> CmmExpr -> NatM Register
        toI8Reg :: Width -> CmmActual -> NatM Register
toI8Reg new_rep :: Width
new_rep expr :: CmmActual
expr
            = do Reg -> OrdList Instr
codefn <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr
                 Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
new_rep) Reg -> OrdList Instr
codefn)
                -- HACK: use getAnyReg to get a byte-addressable register.
                -- If the source was a Fixed register, this will add the
                -- mov instruction to put it into the desired destination.
                -- We're assuming that the destination won't be a fixed
                -- non-byte-addressable register; it won't be, because all
                -- fixed registers are word-sized.

        toI16Reg :: Width -> CmmActual -> NatM Register
toI16Reg = Width -> CmmActual -> NatM Register
toI8Reg -- for now

        conversionNop :: Format -> CmmExpr -> NatM Register
        conversionNop :: Format -> CmmActual -> NatM Register
conversionNop new_format :: Format
new_format expr :: CmmActual
expr
            = do Register
e_code <- DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit CmmActual
expr
                 Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> Format -> Register
swizzleRegisterRep Register
e_code Format
new_format)


getRegister' _ is32Bit :: Bool
is32Bit (CmmMachOp mop :: MachOp
mop [x :: CmmActual
x, y :: CmmActual
y]) = do -- dyadic MachOps
  Bool
sse2 <- NatM Bool
sse2Enabled
  case MachOp
mop of
      MO_F_Eq _ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
EQQ CmmActual
x CmmActual
y
      MO_F_Ne _ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
NE  CmmActual
x CmmActual
y
      MO_F_Gt _ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GTT CmmActual
x CmmActual
y
      MO_F_Ge _ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GE  CmmActual
x CmmActual
y
      -- Invert comparison condition and swap operands
      -- See Note [SSE Parity Checks]
      MO_F_Lt _ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GTT  CmmActual
y CmmActual
x
      MO_F_Le _ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GE   CmmActual
y CmmActual
x

      MO_Eq _   -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
EQQ CmmActual
x CmmActual
y
      MO_Ne _   -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
NE  CmmActual
x CmmActual
y

      MO_S_Gt _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GTT CmmActual
x CmmActual
y
      MO_S_Ge _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GE  CmmActual
x CmmActual
y
      MO_S_Lt _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LTT CmmActual
x CmmActual
y
      MO_S_Le _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LE  CmmActual
x CmmActual
y

      MO_U_Gt _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GU  CmmActual
x CmmActual
y
      MO_U_Ge _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GEU CmmActual
x CmmActual
y
      MO_U_Lt _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LU  CmmActual
x CmmActual
y
      MO_U_Le _ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LEU CmmActual
x CmmActual
y

      MO_F_Add w :: Width
w  | Bool
sse2      -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
ADD  CmmActual
x CmmActual
y
                  | Bool
otherwise -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmActual -> CmmActual -> NatM Register
trivialFCode_x87    Format -> Reg -> Reg -> Reg -> Instr
GADD CmmActual
x CmmActual
y
      MO_F_Sub w :: Width
w  | Bool
sse2      -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
SUB  CmmActual
x CmmActual
y
                  | Bool
otherwise -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmActual -> CmmActual -> NatM Register
trivialFCode_x87    Format -> Reg -> Reg -> Reg -> Instr
GSUB CmmActual
x CmmActual
y
      MO_F_Quot w :: Width
w | Bool
sse2      -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
FDIV CmmActual
x CmmActual
y
                  | Bool
otherwise -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmActual -> CmmActual -> NatM Register
trivialFCode_x87    Format -> Reg -> Reg -> Reg -> Instr
GDIV CmmActual
x CmmActual
y
      MO_F_Mul w :: Width
w  | Bool
sse2      -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
MUL CmmActual
x CmmActual
y
                  | Bool
otherwise -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmActual -> CmmActual -> NatM Register
trivialFCode_x87    Format -> Reg -> Reg -> Reg -> Instr
GMUL CmmActual
x CmmActual
y

      MO_Add rep :: Width
rep -> Width -> CmmActual -> CmmActual -> NatM Register
add_code Width
rep CmmActual
x CmmActual
y
      MO_Sub rep :: Width
rep -> Width -> CmmActual -> CmmActual -> NatM Register
sub_code Width
rep CmmActual
x CmmActual
y

      MO_S_Quot rep :: Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
True  Bool
True  CmmActual
x CmmActual
y
      MO_S_Rem  rep :: Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
True  Bool
False CmmActual
x CmmActual
y
      MO_U_Quot rep :: Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
False Bool
True  CmmActual
x CmmActual
y
      MO_U_Rem  rep :: Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
False Bool
False CmmActual
x CmmActual
y

      MO_S_MulMayOflo rep :: Width
rep -> Width -> CmmActual -> CmmActual -> NatM Register
imulMayOflo Width
rep CmmActual
x CmmActual
y

      MO_Mul W8  -> CmmActual -> CmmActual -> NatM Register
imulW8 CmmActual
x CmmActual
y
      MO_Mul rep :: Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
IMUL
      MO_And rep :: Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
AND
      MO_Or  rep :: Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
OR
      MO_Xor rep :: Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
XOR

        {- Shift ops on x86s have constraints on their source, it
           either has to be Imm, CL or 1
            => trivialCode is not restrictive enough (sigh.)
        -}
      MO_Shl rep :: Width
rep   -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SHL CmmActual
x CmmActual
y {-False-}
      MO_U_Shr rep :: Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SHR CmmActual
x CmmActual
y {-False-}
      MO_S_Shr rep :: Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SAR CmmActual
x CmmActual
y {-False-}

      MO_V_Insert {}   -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Extract {}  -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Add {}      -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Sub {}      -> NatM Register
forall a. NatM a
needLlvm
      MO_V_Mul {}      -> NatM Register
forall a. NatM a
needLlvm
      MO_VS_Quot {}    -> NatM Register
forall a. NatM a
needLlvm
      MO_VS_Rem {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VS_Neg {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Insert {}  -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Extract {} -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Add {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Sub {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Mul {}     -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Quot {}    -> NatM Register
forall a. NatM a
needLlvm
      MO_VF_Neg {}     -> NatM Register
forall a. NatM a
needLlvm

      _other :: MachOp
_other -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getRegister(x86) - binary CmmMachOp (1)" (MachOp -> SDoc
pprMachOp MachOp
mop)
  where
    --------------------
    triv_op :: Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op width :: Width
width instr :: Format -> Operand -> Operand -> Instr
instr = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width Operand -> Operand -> Instr
op ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just Operand -> Operand -> Instr
op) CmmActual
x CmmActual
y
                        where op :: Operand -> Operand -> Instr
op   = Format -> Operand -> Operand -> Instr
instr (Width -> Format
intFormat Width
width)

    -- Special case for IMUL for bytes, since the result of IMULB will be in
    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider
    -- values.
    imulW8 :: CmmExpr -> CmmExpr -> NatM Register
    imulW8 :: CmmActual -> CmmActual -> NatM Register
imulW8 arg_a :: CmmActual
arg_a arg_b :: CmmActual
arg_b = do
        (a_reg :: Reg
a_reg, a_code :: OrdList Instr
a_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
arg_a
        Reg -> OrdList Instr
b_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_b

        let code :: OrdList Instr
code = OrdList Instr
a_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
b_code Reg
eax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                   [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Instr
IMUL2 Format
format (Reg -> Operand
OpReg Reg
a_reg) ]
            format :: Format
format = Width -> Format
intFormat Width
W8

        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
eax OrdList Instr
code)


    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
    imulMayOflo :: Width -> CmmActual -> CmmActual -> NatM Register
imulMayOflo rep :: Width
rep a :: CmmActual
a b :: CmmActual
b = do
         (a_reg :: Reg
a_reg, a_code :: OrdList Instr
a_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
a
         Reg -> OrdList Instr
b_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
b
         let
             shift_amt :: Alignment
shift_amt  = case Width
rep of
                           W32 -> 31
                           W64 -> 63
                           _ -> String -> Alignment
forall a. String -> a
panic "shift_amt"

             format :: Format
format = Width -> Format
intFormat Width
rep
             code :: OrdList Instr
code = OrdList Instr
a_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
b_code Reg
eax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                           Format -> Operand -> Instr
IMUL2 Format
format (Reg -> Operand
OpReg Reg
a_reg),   -- result in %edx:%eax
                           Format -> Operand -> Operand -> Instr
SAR Format
format (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
shift_amt)) (Reg -> Operand
OpReg Reg
eax),
                                -- sign extend lower part
                           Format -> Operand -> Operand -> Instr
SUB Format
format (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
eax)
                                -- compare against upper
                           -- eax==0 if high part == sign extended low part
                        ]
         Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
eax OrdList Instr
code)

    --------------------
    shift_code :: Width
               -> (Format -> Operand -> Operand -> Instr)
               -> CmmExpr
               -> CmmExpr
               -> NatM Register

    {- Case1: shift length as immediate -}
    shift_code :: Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code width :: Width
width instr :: Format -> Operand -> Operand -> Instr
instr x :: CmmActual
x (CmmLit lit :: CmmLit
lit) = do
          Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
          let
               format :: Format
format = Width -> Format
intFormat Width
width
               code :: Reg -> OrdList Instr
code dst :: Reg
dst
                  = Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Operand -> Operand -> Instr
instr Format
format (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit)) (Reg -> Operand
OpReg Reg
dst)
          Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

    {- Case2: shift length is complex (non-immediate)
      * y must go in %ecx.
      * we cannot do y first *and* put its result in %ecx, because
        %ecx might be clobbered by x.
      * if we do y second, then x cannot be
        in a clobbered reg.  Also, we cannot clobber x's reg
        with the instruction itself.
      * so we can either:
        - do y first, put its result in a fresh tmp, then copy it to %ecx later
        - do y second and put its result into %ecx.  x gets placed in a fresh
          tmp.  This is likely to be better, because the reg alloc can
          eliminate this reg->reg move here (it won't eliminate the other one,
          because the move is into the fixed %ecx).
    -}
    shift_code width :: Width
width instr :: Format -> Operand -> Operand -> Instr
instr x :: CmmActual
x y :: CmmActual
y{-amount-} = do
        Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
        let format :: Format
format = Width -> Format
intFormat Width
width
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
format
        Reg -> OrdList Instr
y_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
y
        let
           code :: OrdList Instr
code = Reg -> OrdList Instr
x_code Reg
tmp OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                  Reg -> OrdList Instr
y_code Reg
ecx OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
instr Format
format (Reg -> Operand
OpReg Reg
ecx) (Reg -> Operand
OpReg Reg
tmp)
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
tmp OrdList Instr
code)

    --------------------
    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
    add_code :: Width -> CmmActual -> CmmActual -> NatM Register
add_code rep :: Width
rep x :: CmmActual
x (CmmLit (CmmInt y :: Integer
y _))
        | Integer -> Bool
is32BitInteger Integer
y = Width -> CmmActual -> Integer -> NatM Register
add_int Width
rep CmmActual
x Integer
y
    add_code rep :: Width
rep x :: CmmActual
x y :: CmmActual
y = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
rep (Format -> Operand -> Operand -> Instr
ADD Format
format) ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just (Format -> Operand -> Operand -> Instr
ADD Format
format)) CmmActual
x CmmActual
y
      where format :: Format
format = Width -> Format
intFormat Width
rep
    -- TODO: There are other interesting patterns we want to replace
    --     with a LEA, e.g. `(x + offset) + (y << shift)`.

    --------------------
    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
    sub_code :: Width -> CmmActual -> CmmActual -> NatM Register
sub_code rep :: Width
rep x :: CmmActual
x (CmmLit (CmmInt y :: Integer
y _))
        | Integer -> Bool
is32BitInteger (-Integer
y) = Width -> CmmActual -> Integer -> NatM Register
add_int Width
rep CmmActual
x (-Integer
y)
    sub_code rep :: Width
rep x :: CmmActual
x y :: CmmActual
y = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
rep (Format -> Operand -> Operand -> Instr
SUB (Width -> Format
intFormat Width
rep)) Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing CmmActual
x CmmActual
y

    -- our three-operand add instruction:
    add_int :: Width -> CmmActual -> Integer -> NatM Register
add_int width :: Width
width x :: CmmActual
x y :: Integer
y = do
        (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
        let
            format :: Format
format = Width -> Format
intFormat Width
width
            imm :: Imm
imm = Alignment -> Imm
ImmInt (Integer -> Alignment
forall a. Num a => Integer -> a
fromInteger Integer
y)
            code :: Reg -> OrdList Instr
code dst :: Reg
dst
               = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                 Format -> Operand -> Operand -> Instr
LEA Format
format
                        (AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
x_reg) EAIndex
EAIndexNone Imm
imm))
                        (Reg -> Operand
OpReg Reg
dst)
        --
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

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

    -- See Note [DIV/IDIV for bytes]
    div_code :: Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code W8 signed :: Bool
signed quotient :: Bool
quotient x :: CmmActual
x y :: CmmActual
y = do
        let widen :: MachOp
widen | Bool
signed    = Width -> Width -> MachOp
MO_SS_Conv Width
W8 Width
W16
                  | Bool
otherwise = Width -> Width -> MachOp
MO_UU_Conv Width
W8 Width
W16
        Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code
            Width
W16
            Bool
signed
            Bool
quotient
            (MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
x])
            (MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
y])

    div_code width :: Width
width signed :: Bool
signed quotient :: Bool
quotient x :: CmmActual
x y :: CmmActual
y = do
           (y_op :: Operand
y_op, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
y -- cannot be clobbered
           Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
           let
             format :: Format
format = Width -> Format
intFormat Width
width
             widen :: Instr
widen | Bool
signed    = Format -> Instr
CLTD Format
format
                   | Bool
otherwise = Format -> Operand -> Operand -> Instr
XOR Format
format (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
edx)

             instr :: Format -> Operand -> Instr
instr | Bool
signed    = Format -> Operand -> Instr
IDIV
                   | Bool
otherwise = Format -> Operand -> Instr
DIV

             code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    Reg -> OrdList Instr
x_code Reg
eax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Instr
widen, Format -> Operand -> Instr
instr Format
format Operand
y_op]

             result :: Reg
result | Bool
quotient  = Reg
eax
                    | Bool
otherwise = Reg
edx

           Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
result OrdList Instr
code)


getRegister' _ _ (CmmLoad mem :: CmmActual
mem pk :: CmmType
pk)
  | CmmType -> Bool
isFloatType CmmType
pk
  = do
    Amode addr :: AddrMode
addr mem_code :: OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    Bool -> Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode Bool
use_sse2 (CmmType -> Width
typeWidth CmmType
pk) AddrMode
addr OrdList Instr
mem_code

getRegister' _ is32Bit :: Bool
is32Bit (CmmLoad mem :: CmmActual
mem pk :: CmmType
pk)
  | Bool
is32Bit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk)
  = do
    Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode Operand -> Operand -> Instr
instr CmmActual
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
  where
    width :: Width
width = CmmType -> Width
typeWidth CmmType
pk
    format :: Format
format = Width -> Format
intFormat Width
width
    instr :: Operand -> Operand -> Instr
instr = case Width
width of
                W8     -> Format -> Operand -> Operand -> Instr
MOVZxL Format
II8
                _other :: Width
_other -> Format -> Operand -> Operand -> Instr
MOV Format
format
        -- We always zero-extend 8-bit loads, if we
        -- can't think of anything better.  This is because
        -- we can't guarantee access to an 8-bit variant of every register
        -- (esi and edi don't have 8-bit variants), so to make things
        -- simpler we do our 8-bit arithmetic with full 32-bit registers.

-- Simpler memory load code on x86_64
getRegister' _ is32Bit :: Bool
is32Bit (CmmLoad mem :: CmmActual
mem pk :: CmmType
pk)
 | Bool -> Bool
not Bool
is32Bit
  = do
    Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
format) CmmActual
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
  where format :: Format
format = Width -> Format
intFormat (Width -> Format) -> Width -> Format
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
pk

getRegister' _ is32Bit :: Bool
is32Bit (CmmLit (CmmInt 0 width :: Width
width))
  = let
        format :: Format
format = Width -> Format
intFormat Width
width

        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
        format1 :: Format
format1 = if Bool
is32Bit then Format
format
                           else case Format
format of
                                II64 -> Format
II32
                                _ -> Format
format
        code :: Reg -> OrdList Instr
code dst :: Reg
dst
           = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
XOR Format
format1 (Reg -> Operand
OpReg Reg
dst) (Reg -> Operand
OpReg Reg
dst))
    in
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

  -- optimisation for loading small literals on x86_64: take advantage
  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
  -- instruction forms are shorter.
getRegister' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (CmmLit lit :: CmmLit
lit)
  | Bool -> Bool
not Bool
is32Bit, CmmType -> Bool
isWord64 (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit), Bool -> Bool
not (CmmLit -> Bool
isBigLit CmmLit
lit)
  = let
        imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
        code :: Reg -> OrdList Instr
code dst :: Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm Imm
imm) (Reg -> Operand
OpReg Reg
dst))
    in
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
  where
   isBigLit :: CmmLit -> Bool
isBigLit (CmmInt i :: Integer
i _) = Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0xffffffff
   isBigLit _ = Bool
False
        -- note1: not the same as (not.is32BitLit), because that checks for
        -- signed literals that fit in 32 bits, but we want unsigned
        -- literals here.
        -- note2: all labels are small, because we're assuming the
        -- small memory model (see gcc docs, -mcmodel=small).

getRegister' dflags :: DynFlags
dflags _ (CmmLit lit :: CmmLit
lit)
  = do let format :: Format
format = CmmType -> Format
cmmTypeFormat (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit)
           imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
           code :: Reg -> OrdList Instr
code dst :: Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
format (Imm -> Operand
OpImm Imm
imm) (Reg -> Operand
OpReg Reg
dst))
       Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

getRegister' _ _ other :: CmmActual
other
    | CmmActual -> Bool
isVecExpr CmmActual
other  = NatM Register
forall a. NatM a
needLlvm
    | Bool
otherwise        = String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getRegister(x86)" (CmmActual -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmActual
other)


intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
   -> NatM (Reg -> InstrBlock)
intLoadCode :: (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode instr :: Operand -> Operand -> Instr
instr mem :: CmmActual
mem = do
  Amode src :: AddrMode
src mem_code :: OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
  (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (\dst :: Reg
dst -> OrdList Instr
mem_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
instr (AddrMode -> Operand
OpAddr AddrMode
src) (Reg -> Operand
OpReg Reg
dst))

-- Compute an expression into *any* register, adding the appropriate
-- move instruction if necessary.
getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg :: CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg expr :: CmmActual
expr = do
  Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
  Register -> NatM (Reg -> OrdList Instr)
anyReg Register
r

anyReg :: Register -> NatM (Reg -> InstrBlock)
anyReg :: Register -> NatM (Reg -> OrdList Instr)
anyReg (Any _ code :: Reg -> OrdList Instr
code)          = (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return Reg -> OrdList Instr
code
anyReg (Fixed rep :: Format
rep reg :: Reg
reg fcode :: OrdList Instr
fcode) = (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (\dst :: Reg
dst -> OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
rep Reg
reg Reg
dst)

-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
-- Fixed registers might not be byte-addressable, so we make sure we've
-- got a temporary, inserting an extra reg copy if necessary.
getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
getByteReg :: CmmActual -> NatM (Reg, OrdList Instr)
getByteReg expr :: CmmActual
expr = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  if Bool
is32Bit
      then do Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
              case Register
r of
                Any rep :: Format
rep code :: Reg -> OrdList Instr
code -> do
                    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
                    (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
                Fixed rep :: Format
rep reg :: Reg
reg code :: OrdList Instr
code
                    | Reg -> Bool
isVirtualReg Reg
reg -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg,OrdList Instr
code)
                    | Bool
otherwise -> do
                        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
                        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
rep Reg
reg Reg
tmp)
                    -- ToDo: could optimise slightly by checking for
                    -- byte-addressable real registers, but that will
                    -- happen very rarely if at all.
      else CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr -- all regs are byte-addressable on x86_64

-- Another variant: this time we want the result in a register that cannot
-- be modified by code to evaluate an arbitrary expression.
getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg :: CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg expr :: CmmActual
expr = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
  case Register
r of
    Any rep :: Format
rep code :: Reg -> OrdList Instr
code -> do
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
    Fixed rep :: Format
rep reg :: Reg
reg code :: OrdList Instr
code
        -- only certain regs can be clobbered
        | Reg
reg Reg -> [Reg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Platform -> [Reg]
instrClobberedRegs (DynFlags -> Platform
targetPlatform DynFlags
dflags)
        -> do
                Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
                (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
rep Reg
reg Reg
tmp)
        | Bool
otherwise ->
                (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, OrdList Instr
code)

reg2reg :: Format -> Reg -> Reg -> Instr
reg2reg :: Format -> Reg -> Reg -> Instr
reg2reg format :: Format
format src :: Reg
src dst :: Reg
dst
  | Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
FF80 = Reg -> Reg -> Instr
GMOV Reg
src Reg
dst
  | Bool
otherwise    = Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
src) (Reg -> Operand
OpReg Reg
dst)


--------------------------------------------------------------------------------
getAmode :: CmmExpr -> NatM Amode
getAmode :: CmmActual -> NatM Amode
getAmode e :: CmmActual
e = do Bool
is32Bit <- NatM Bool
is32BitPlatform
                Bool -> CmmActual -> NatM Amode
getAmode' Bool
is32Bit CmmActual
e

getAmode' :: Bool -> CmmExpr -> NatM Amode
getAmode' :: Bool -> CmmActual -> NatM Amode
getAmode' _ (CmmRegOff r :: CmmReg
r n :: Alignment
n) = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                                 CmmActual -> NatM Amode
getAmode (CmmActual -> NatM Amode) -> CmmActual -> NatM Amode
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmReg -> Alignment -> CmmActual
mangleIndexTree DynFlags
dflags CmmReg
r Alignment
n

getAmode' is32Bit :: Bool
is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
                                                  CmmLit displacement :: CmmLit
displacement])
 | Bool -> Bool
not Bool
is32Bit
    = Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Imm -> AddrMode
ripRel (CmmLit -> Imm
litToImm CmmLit
displacement)) OrdList Instr
forall a. OrdList a
nilOL


-- This is all just ridiculous, since it carefully undoes
-- what mangleIndexTree has just done.
getAmode' is32Bit :: Bool
is32Bit (CmmMachOp (MO_Sub _rep :: Width
_rep) [x :: CmmActual
x, CmmLit lit :: CmmLit
lit@(CmmInt i :: Integer
i _)])
  | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
  -- ASSERT(rep == II32)???
  = do (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
       let off :: Imm
off = Alignment -> Imm
ImmInt (-(Integer -> Alignment
forall a. Num a => Integer -> a
fromInteger Integer
i))
       Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
x_reg) EAIndex
EAIndexNone Imm
off) OrdList Instr
x_code)

getAmode' is32Bit :: Bool
is32Bit (CmmMachOp (MO_Add _rep :: Width
_rep) [x :: CmmActual
x, CmmLit lit :: CmmLit
lit])
  | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
  -- ASSERT(rep == II32)???
  = do (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
       let off :: Imm
off = CmmLit -> Imm
litToImm CmmLit
lit
       Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
x_reg) EAIndex
EAIndexNone Imm
off) OrdList Instr
x_code)

-- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be
-- recognised by the next rule.
getAmode' is32Bit :: Bool
is32Bit (CmmMachOp (MO_Add rep :: Width
rep) [a :: CmmActual
a@(CmmMachOp (MO_Shl _) _),
                                  b :: CmmActual
b@(CmmLit _)])
  = Bool -> CmmActual -> NatM Amode
getAmode' Bool
is32Bit (MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Add Width
rep) [CmmActual
b,CmmActual
a])

-- Matches: (x + offset) + (y << shift)
getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x :: CmmReg
x offset :: Alignment
offset,
                                   CmmMachOp (MO_Shl _)
                                        [y :: CmmActual
y, CmmLit (CmmInt shift :: Integer
shift _)]])
  | Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 3
  = CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode (CmmReg -> CmmActual
CmmReg CmmReg
x) CmmActual
y Integer
shift (Alignment -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Alignment
offset)

getAmode' _ (CmmMachOp (MO_Add _) [x :: CmmActual
x, CmmMachOp (MO_Shl _)
                                        [y :: CmmActual
y, CmmLit (CmmInt shift :: Integer
shift _)]])
  | Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 3
  = CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
x CmmActual
y Integer
shift 0

getAmode' _ (CmmMachOp (MO_Add _)
                [x :: CmmActual
x, CmmMachOp (MO_Add _)
                        [CmmMachOp (MO_Shl _) [y :: CmmActual
y, CmmLit (CmmInt shift :: Integer
shift _)],
                         CmmLit (CmmInt offset :: Integer
offset _)]])
  | Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2 Bool -> Bool -> Bool
|| Integer
shift Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 3
  Bool -> Bool -> Bool
&& Integer -> Bool
is32BitInteger Integer
offset
  = CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
x CmmActual
y Integer
shift Integer
offset

getAmode' _ (CmmMachOp (MO_Add _) [x :: CmmActual
x,y :: CmmActual
y])
  = CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
x CmmActual
y 0 0

getAmode' is32Bit :: Bool
is32Bit (CmmLit lit :: CmmLit
lit) | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
  = Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Imm -> Alignment -> AddrMode
ImmAddr (CmmLit -> Imm
litToImm CmmLit
lit) 0) OrdList Instr
forall a. OrdList a
nilOL)

getAmode' _ expr :: CmmActual
expr = do
  (reg :: Reg
reg,code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
  Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
reg) EAIndex
EAIndexNone (Alignment -> Imm
ImmInt 0)) OrdList Instr
code)

-- | Like 'getAmode', but on 32-bit use simple register addressing
-- (i.e. no index register). This stops us from running out of
-- registers on x86 when using instructions such as cmpxchg, which can
-- use up to three virtual registers and one fixed register.
getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode
getSimpleAmode :: DynFlags -> Bool -> CmmActual -> NatM Amode
getSimpleAmode dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit addr :: CmmActual
addr
    | Bool
is32Bit = do
        Reg -> OrdList Instr
addr_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
addr
        Reg
addr_r <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags))
        let amode :: AddrMode
amode = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
addr_r) EAIndex
EAIndexNone (Alignment -> Imm
ImmInt 0)
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$! AddrMode -> OrdList Instr -> Amode
Amode AddrMode
amode (Reg -> OrdList Instr
addr_code Reg
addr_r)
    | Bool
otherwise = CmmActual -> NatM Amode
getAmode CmmActual
addr

x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
x86_complex_amode :: CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode base :: CmmActual
base index :: CmmActual
index shift :: Integer
shift offset :: Integer
offset
  = do (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
base
        -- x must be in a temp, because it has to stay live over y_code
        -- we could compre x_reg and y_reg and do something better here...
       (y_reg :: Reg
y_reg, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
index
       let
           code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
y_code
           base :: Alignment
base = case Integer
shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;
                                n :: Integer
n -> String -> Alignment
forall a. String -> a
panic (String -> Alignment) -> String -> Alignment
forall a b. (a -> b) -> a -> b
$ "x86_complex_amode: unhandled shift! (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
       Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
x_reg) (Reg -> Alignment -> EAIndex
EAIndex Reg
y_reg Alignment
base) (Alignment -> Imm
ImmInt (Integer -> Alignment
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
offset)))
               OrdList Instr
code)




-- -----------------------------------------------------------------------------
-- getOperand: sometimes any operand will do.

-- getNonClobberedOperand: the value of the operand will remain valid across
-- the computation of an arbitrary expression, unless the expression
-- is computed directly into a register which the operand refers to
-- (see trivialCode where this function is used for an example).

getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
getNonClobberedOperand :: CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand (CmmLit lit :: CmmLit
lit) = do
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  if Bool
use_sse2 Bool -> Bool -> Bool
&& CmmLit -> Bool
isSuitableFloatingPointLit CmmLit
lit
    then do
      let CmmFloat _ w :: Width
w = CmmLit
lit
      Amode addr :: AddrMode
addr code :: OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Width -> Alignment
widthInBytes Width
w) CmmLit
lit
      (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
addr, OrdList Instr
code)
     else do

  Bool
is32Bit <- NatM Bool
is32BitPlatform
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit))
    then (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit), OrdList Instr
forall a. OrdList a
nilOL)
    else CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic (CmmLit -> CmmActual
CmmLit CmmLit
lit)

getNonClobberedOperand (CmmLoad mem :: CmmActual
mem pk :: CmmType
pk) = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  if (Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
pk) Bool -> Bool -> Bool
|| Bool
use_sse2)
      Bool -> Bool -> Bool
&& (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
    then do
      DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      Amode src :: AddrMode
src mem_code :: OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
      (src' :: AddrMode
src',save_code :: OrdList Instr
save_code) <-
        if (Platform -> AddrMode -> Bool
amodeCouldBeClobbered Platform
platform AddrMode
src)
                then do
                   Reg
tmp <- Format -> NatM Reg
getNewRegNat (Bool -> Format
archWordFormat Bool
is32Bit)
                   (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
tmp) EAIndex
EAIndexNone (Alignment -> Imm
ImmInt 0),
                           Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
LEA (Bool -> Format
archWordFormat Bool
is32Bit)
                                       (AddrMode -> Operand
OpAddr AddrMode
src)
                                       (Reg -> Operand
OpReg Reg
tmp)))
                else
                   (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
src, OrdList Instr
forall a. OrdList a
nilOL)
      (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src', OrdList Instr
mem_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
save_code)
    else do
      CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic (CmmActual -> CmmType -> CmmActual
CmmLoad CmmActual
mem CmmType
pk)

getNonClobberedOperand e :: CmmActual
e = CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic CmmActual
e

getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
getNonClobberedOperand_generic :: CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic e :: CmmActual
e = do
    (reg :: Reg
reg, code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
e
    (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)

amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
amodeCouldBeClobbered platform :: Platform
platform amode :: AddrMode
amode = (Reg -> Bool) -> [Reg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Platform -> Reg -> Bool
regClobbered Platform
platform) (AddrMode -> [Reg]
addrModeRegs AddrMode
amode)

regClobbered :: Platform -> Reg -> Bool
regClobbered :: Platform -> Reg -> Bool
regClobbered platform :: Platform
platform (RegReal (RealRegSingle rr :: Alignment
rr)) = Platform -> Alignment -> Bool
freeReg Platform
platform Alignment
rr
regClobbered _ _ = Bool
False

-- getOperand: the operand is not required to remain valid across the
-- computation of an arbitrary expression.
getOperand :: CmmExpr -> NatM (Operand, InstrBlock)

getOperand :: CmmActual -> NatM (Operand, OrdList Instr)
getOperand (CmmLit lit :: CmmLit
lit) = do
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  if (Bool
use_sse2 Bool -> Bool -> Bool
&& CmmLit -> Bool
isSuitableFloatingPointLit CmmLit
lit)
    then do
      let CmmFloat _ w :: Width
w = CmmLit
lit
      Amode addr :: AddrMode
addr code :: OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Width -> Alignment
widthInBytes Width
w) CmmLit
lit
      (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
addr, OrdList Instr
code)
    else do

  Bool
is32Bit <- NatM Bool
is32BitPlatform
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  if Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit))
    then (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit), OrdList Instr
forall a. OrdList a
nilOL)
    else CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic (CmmLit -> CmmActual
CmmLit CmmLit
lit)

getOperand (CmmLoad mem :: CmmActual
mem pk :: CmmType
pk) = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  if (Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
pk) Bool -> Bool -> Bool
|| Bool
use_sse2) Bool -> Bool -> Bool
&& (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
     then do
       Amode src :: AddrMode
src mem_code :: OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
       (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src, OrdList Instr
mem_code)
     else
       CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic (CmmActual -> CmmType -> CmmActual
CmmLoad CmmActual
mem CmmType
pk)

getOperand e :: CmmActual
e = CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic CmmActual
e

getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
getOperand_generic :: CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic e :: CmmActual
e = do
    (reg :: Reg
reg, code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
e
    (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)

isOperand :: Bool -> CmmExpr -> Bool
isOperand :: Bool -> CmmActual -> Bool
isOperand _ (CmmLoad _ _) = Bool
True
isOperand is32Bit :: Bool
is32Bit (CmmLit lit :: CmmLit
lit)  = Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
                          Bool -> Bool -> Bool
|| CmmLit -> Bool
isSuitableFloatingPointLit CmmLit
lit
isOperand _ _            = Bool
False

-- | Given a 'Register', produce a new 'Register' with an instruction block
-- which will check the value for alignment. Used for @-falignment-sanitisation@.
addAlignmentCheck :: Int -> Register -> Register
addAlignmentCheck :: Alignment -> Register -> Register
addAlignmentCheck align :: Alignment
align reg :: Register
reg =
    case Register
reg of
      Fixed fmt :: Format
fmt reg :: Reg
reg code :: OrdList Instr
code -> Format -> Reg -> OrdList Instr -> Register
Fixed Format
fmt Reg
reg (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Format -> Reg -> OrdList Instr
check Format
fmt Reg
reg)
      Any fmt :: Format
fmt f :: Reg -> OrdList Instr
f          -> Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt (\reg :: Reg
reg -> Reg -> OrdList Instr
f Reg
reg OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Format -> Reg -> OrdList Instr
check Format
fmt Reg
reg)
  where
    check :: Format -> Reg -> InstrBlock
    check :: Format -> Reg -> OrdList Instr
check fmt :: Format
fmt reg :: Reg
reg =
        ASSERT(not $ isFloatFormat fmt)
        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
TEST Format
fmt (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ Alignment -> Imm
ImmInt (Alignment -> Imm) -> Alignment -> Imm
forall a b. (a -> b) -> a -> b
$ Alignment
alignAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-1) (Reg -> Operand
OpReg Reg
reg)
             , Cond -> Imm -> Instr
JXX_GBL Cond
NE (Imm -> Instr) -> Imm -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> Imm
ImmCLbl CLabel
mkBadAlignmentLabel
             ]

memConstant :: Int -> CmmLit -> NatM Amode
memConstant :: Alignment -> CmmLit -> NatM Amode
memConstant align :: Alignment
align lit :: CmmLit
lit = do
  CLabel
lbl <- NatM CLabel
getNewLabelNat
  let rosection :: Section
rosection = SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  (addr :: AddrMode
addr, addr_code :: OrdList Instr
addr_code) <- if Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                       then do CmmActual
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference
                                             DynFlags
dflags
                                             ReferenceKind
DataReference
                                             CLabel
lbl
                               Amode addr :: AddrMode
addr addr_code :: OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
dynRef
                               (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
addr, OrdList Instr
addr_code)
                       else (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> AddrMode
ripRel (CLabel -> Imm
ImmCLbl CLabel
lbl), OrdList Instr
forall a. OrdList a
nilOL)
  let code :: OrdList Instr
code =
        Section -> (Alignment, CmmStatics) -> Instr
LDATA Section
rosection (Alignment
align, CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit CmmLit
lit])
        Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList Instr
addr_code
  Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode AddrMode
addr OrdList Instr
code)


loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register
loadFloatAmode :: Bool -> Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode use_sse2 :: Bool
use_sse2 w :: Width
w addr :: AddrMode
addr addr_code :: OrdList Instr
addr_code = do
  let format :: Format
format = Width -> Format
floatFormat Width
w
      code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                 if Bool
use_sse2
                    then Format -> Operand -> Operand -> Instr
MOV Format
format (AddrMode -> Operand
OpAddr AddrMode
addr) (Reg -> Operand
OpReg Reg
dst)
                    else Format -> AddrMode -> Reg -> Instr
GLD Format
format AddrMode
addr Reg
dst
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (if Bool
use_sse2 then Format
format else Format
FF80) Reg -> OrdList Instr
code)


-- if we want a floating-point literal as an operand, we can
-- use it directly from memory.  However, if the literal is
-- zero, we're better off generating it into a register using
-- xor.
isSuitableFloatingPointLit :: CmmLit -> Bool
isSuitableFloatingPointLit :: CmmLit -> Bool
isSuitableFloatingPointLit (CmmFloat f :: Rational
f _) = Rational
f Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= 0.0
isSuitableFloatingPointLit _ = Bool
False

getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
getRegOrMem :: CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem e :: CmmActual
e@(CmmLoad mem :: CmmActual
mem pk :: CmmType
pk) = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  if (Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
pk) Bool -> Bool -> Bool
|| Bool
use_sse2) Bool -> Bool -> Bool
&& (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
     then do
       Amode src :: AddrMode
src mem_code :: OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
       (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src, OrdList Instr
mem_code)
     else do
       (reg :: Reg
reg, code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
e
       (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)
getRegOrMem e :: CmmActual
e = do
    (reg :: Reg
reg, code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
e
    (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)

is32BitLit :: Bool -> CmmLit -> Bool
is32BitLit :: Bool -> CmmLit -> Bool
is32BitLit is32Bit :: Bool
is32Bit (CmmInt i :: Integer
i W64)
 | Bool -> Bool
not Bool
is32Bit
    = -- assume that labels are in the range 0-2^31-1: this assumes the
      -- small memory model (see gcc docs, -mcmodel=small).
      Integer -> Bool
is32BitInteger Integer
i
is32BitLit _ _ = Bool
True




-- Set up a condition code for a conditional branch.

getCondCode :: CmmExpr -> NatM CondCode

-- yes, they really do seem to want exactly the same!

getCondCode :: CmmActual -> NatM CondCode
getCondCode (CmmMachOp mop :: MachOp
mop [x :: CmmActual
x, y :: CmmActual
y])
  =
    case MachOp
mop of
      MO_F_Eq W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
EQQ CmmActual
x CmmActual
y
      MO_F_Ne W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
NE  CmmActual
x CmmActual
y
      MO_F_Gt W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
x CmmActual
y
      MO_F_Ge W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE  CmmActual
x CmmActual
y
      -- Invert comparison condition and swap operands
      -- See Note [SSE Parity Checks]
      MO_F_Lt W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT  CmmActual
y CmmActual
x
      MO_F_Le W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE   CmmActual
y CmmActual
x

      MO_F_Eq W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
EQQ CmmActual
x CmmActual
y
      MO_F_Ne W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
NE  CmmActual
x CmmActual
y
      MO_F_Gt W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
x CmmActual
y
      MO_F_Ge W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE  CmmActual
x CmmActual
y
      MO_F_Lt W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
y CmmActual
x
      MO_F_Le W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE  CmmActual
y CmmActual
x

      _ -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode (MachOp -> Cond
machOpToCond MachOp
mop) CmmActual
x CmmActual
y

getCondCode other :: CmmActual
other = String -> SDoc -> NatM CondCode
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getCondCode(2)(x86,x86_64)" (CmmActual -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmActual
other)

machOpToCond :: MachOp -> Cond
machOpToCond :: MachOp -> Cond
machOpToCond mo :: MachOp
mo = case MachOp
mo of
  MO_Eq _   -> Cond
EQQ
  MO_Ne _   -> Cond
NE
  MO_S_Gt _ -> Cond
GTT
  MO_S_Ge _ -> Cond
GE
  MO_S_Lt _ -> Cond
LTT
  MO_S_Le _ -> Cond
LE
  MO_U_Gt _ -> Cond
GU
  MO_U_Ge _ -> Cond
GEU
  MO_U_Lt _ -> Cond
LU
  MO_U_Le _ -> Cond
LEU
  _other :: MachOp
_other -> String -> SDoc -> Cond
forall a. HasCallStack => String -> SDoc -> a
pprPanic "machOpToCond" (MachOp -> SDoc
pprMachOp MachOp
mo)


-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
-- passed back up the tree.

condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode :: Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode cond :: Cond
cond x :: CmmActual
x y :: CmmActual
y = do Bool
is32Bit <- NatM Bool
is32BitPlatform
                          Bool -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode' Bool
is32Bit Cond
cond CmmActual
x CmmActual
y

condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode

-- memory vs immediate
condIntCode' :: Bool -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode' is32Bit :: Bool
is32Bit cond :: Cond
cond (CmmLoad x :: CmmActual
x pk :: CmmType
pk) (CmmLit lit :: CmmLit
lit)
 | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit = do
    Amode x_addr :: AddrMode
x_addr x_code :: OrdList Instr
x_code <- CmmActual -> NatM Amode
getAmode CmmActual
x
    let
        imm :: Imm
imm  = CmmLit -> Imm
litToImm CmmLit
lit
        code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat CmmType
pk) (Imm -> Operand
OpImm Imm
imm) (AddrMode -> Operand
OpAddr AddrMode
x_addr)
    --
    CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)

-- anything vs zero, using a mask
-- TODO: Add some sanity checking!!!!
condIntCode' is32Bit :: Bool
is32Bit cond :: Cond
cond (CmmMachOp (MO_And _) [x :: CmmActual
x,o2 :: CmmActual
o2]) (CmmLit (CmmInt 0 pk :: Width
pk))
    | (CmmLit lit :: CmmLit
lit@(CmmInt mask :: Integer
mask _)) <- CmmActual
o2, Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
    = do
      (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
      let
         code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Format -> Operand -> Operand -> Instr
TEST (Width -> Format
intFormat Width
pk) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
mask)) (Reg -> Operand
OpReg Reg
x_reg)
      --
      CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)

-- anything vs zero
condIntCode' _ cond :: Cond
cond x :: CmmActual
x (CmmLit (CmmInt 0 pk :: Width
pk)) = do
    (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
    let
        code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
TEST (Width -> Format
intFormat Width
pk) (Reg -> Operand
OpReg Reg
x_reg) (Reg -> Operand
OpReg Reg
x_reg)
    --
    CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)

-- anything vs operand
condIntCode' is32Bit :: Bool
is32Bit cond :: Cond
cond x :: CmmActual
x y :: CmmActual
y
 | Bool -> CmmActual -> Bool
isOperand Bool
is32Bit CmmActual
y = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
x
    (y_op :: Operand
y_op,  y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
y
    let
        code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
y_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
x)) Operand
y_op (Reg -> Operand
OpReg Reg
x_reg)
    CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)
-- operand vs. anything: invert the comparison so that we can use a
-- single comparison instruction.
 | Bool -> CmmActual -> Bool
isOperand Bool
is32Bit CmmActual
x
 , Just revcond :: Cond
revcond <- Cond -> Maybe Cond
maybeFlipCond Cond
cond = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (y_reg :: Reg
y_reg, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
y
    (x_op :: Operand
x_op,  x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
x
    let
        code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
x)) Operand
x_op (Reg -> Operand
OpReg Reg
y_reg)
    CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
revcond OrdList Instr
code)

-- anything vs anything
condIntCode' _ cond :: Cond
cond x :: CmmActual
x y :: CmmActual
y = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  (y_reg :: Reg
y_reg, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
y
  (x_op :: Operand
x_op, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
x
  let
        code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
               OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
x)) (Reg -> Operand
OpReg Reg
y_reg) Operand
x_op
  CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)



--------------------------------------------------------------------------------
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode

condFltCode :: Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode cond :: Cond
cond x :: CmmActual
x y :: CmmActual
y
  = NatM CondCode -> NatM CondCode -> NatM CondCode
forall a. NatM a -> NatM a -> NatM a
if_sse2 NatM CondCode
condFltCode_sse2 NatM CondCode
condFltCode_x87
  where

  condFltCode_x87 :: NatM CondCode
condFltCode_x87
    = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
    (x_reg, x_code) <- getNonClobberedReg x
    (y_reg, y_code) <- getSomeReg y
    let
        code = x_code `appOL` y_code `snocOL`
                GCMP cond x_reg y_reg
    -- The GCMP insn does the test and sets the zero flag if comparable
    -- and true.  Hence we always supply EQQ as the condition to test.
    return (CondCode True EQQ code)

  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
  -- an operand, but the right must be a reg.  We can probably do better
  -- than this general case...
  condFltCode_sse2 :: NatM CondCode
condFltCode_sse2 = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
x
    (y_op :: Operand
y_op, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
y
    let
        code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
               OrdList Instr
y_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
CMP (Width -> Format
floatFormat (Width -> Format) -> Width -> Format
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmActual -> Width
cmmExprWidth DynFlags
dflags CmmActual
x) Operand
y_op (Reg -> Operand
OpReg Reg
x_reg)
        -- NB(1): we need to use the unsigned comparison operators on the
        -- result of this comparison.
    CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
True (Cond -> Cond
condToUnsigned Cond
cond) OrdList Instr
code)

-- -----------------------------------------------------------------------------
-- Generating assignments

-- Assignments are really at the heart of the whole code generation
-- business.  Almost all top-level nodes of any real importance are
-- assignments, which correspond to loads, stores, or register
-- transfers.  If we're really lucky, some of the register transfers
-- will go away, because we can use the destination register to
-- complete the code generation for the right hand side.  This only
-- fails when the right hand side is forced into a fixed register
-- (e.g. the result of a call).

assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock

assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock


-- integer assignment to memory

-- specific case of adding/subtracting an integer to a particular address.
-- ToDo: catch other cases where we can use an operation directly on a memory
-- address.
assignMem_IntCode :: Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_IntCode pk :: Format
pk addr :: CmmActual
addr (CmmMachOp op :: MachOp
op [CmmLoad addr2 :: CmmActual
addr2 _,
                                                 CmmLit (CmmInt i :: Integer
i _)])
   | CmmActual
addr CmmActual -> CmmActual -> Bool
forall a. Eq a => a -> a -> Bool
== CmmActual
addr2, Format
pk Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
II64 Bool -> Bool -> Bool
|| Integer -> Bool
is32BitInteger Integer
i,
     Just instr :: Format -> Operand -> Operand -> Instr
instr <- MachOp -> Maybe (Format -> Operand -> Operand -> Instr)
check MachOp
op
   = do Amode amode :: AddrMode
amode code_addr :: OrdList Instr
code_addr <- CmmActual -> NatM Amode
getAmode CmmActual
addr
        let code :: OrdList Instr
code = OrdList Instr
code_addr OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                   Format -> Operand -> Operand -> Instr
instr Format
pk (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt (Integer -> Alignment
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i))) (AddrMode -> Operand
OpAddr AddrMode
amode)
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
   where
        check :: MachOp -> Maybe (Format -> Operand -> Operand -> Instr)
check (MO_Add _) = (Format -> Operand -> Operand -> Instr)
-> Maybe (Format -> Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just Format -> Operand -> Operand -> Instr
ADD
        check (MO_Sub _) = (Format -> Operand -> Operand -> Instr)
-> Maybe (Format -> Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just Format -> Operand -> Operand -> Instr
SUB
        check _ = Maybe (Format -> Operand -> Operand -> Instr)
forall a. Maybe a
Nothing
        -- ToDo: more?

-- general case
assignMem_IntCode pk :: Format
pk addr :: CmmActual
addr src :: CmmActual
src = do
    Bool
is32Bit <- NatM Bool
is32BitPlatform
    Amode addr :: AddrMode
addr code_addr :: OrdList Instr
code_addr <- CmmActual -> NatM Amode
getAmode CmmActual
addr
    (code_src :: OrdList Instr
code_src, op_src :: Operand
op_src)   <- Bool -> CmmActual -> NatM (OrdList Instr, Operand)
get_op_RI Bool
is32Bit CmmActual
src
    let
        code :: OrdList Instr
code = OrdList Instr
code_src OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
               OrdList Instr
code_addr OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                  Format -> Operand -> Operand -> Instr
MOV Format
pk Operand
op_src (AddrMode -> Operand
OpAddr AddrMode
addr)
        -- NOTE: op_src is stable, so it will still be valid
        -- after code_addr.  This may involve the introduction
        -- of an extra MOV to a temporary register, but we hope
        -- the register allocator will get rid of it.
    --
    OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
  where
    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator
    get_op_RI :: Bool -> CmmActual -> NatM (OrdList Instr, Operand)
get_op_RI is32Bit :: Bool
is32Bit (CmmLit lit :: CmmLit
lit) | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
      = (OrdList Instr, Operand) -> NatM (OrdList Instr, Operand)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit))
    get_op_RI _ op :: CmmActual
op
      = do (reg :: Reg
reg,code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
op
           (OrdList Instr, Operand) -> NatM (OrdList Instr, Operand)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, Reg -> Operand
OpReg Reg
reg)


-- Assign; dst is a reg, rhs is mem
assignReg_IntCode :: Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_IntCode pk :: Format
pk reg :: CmmReg
reg (CmmLoad src :: CmmActual
src _) = do
  Reg -> OrdList Instr
load_code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
pk) CmmActual
src
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
load_code (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
False{-no sse2-} CmmReg
reg))

-- dst is a reg, but src could be anything
assignReg_IntCode _ reg :: CmmReg
reg src :: CmmActual
src = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  Reg -> OrdList Instr
code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
code (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
False{-no sse2-} CmmReg
reg))


-- Floating point assignment to memory
assignMem_FltCode :: Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_FltCode pk :: Format
pk addr :: CmmActual
addr src :: CmmActual
src = do
  (src_reg :: Reg
src_reg, src_code :: OrdList Instr
src_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
src
  Amode addr :: AddrMode
addr addr_code :: OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
addr
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  let
        code :: OrdList Instr
code = OrdList Instr
src_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
               OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                if Bool
use_sse2 then Format -> Operand -> Operand -> Instr
MOV Format
pk (Reg -> Operand
OpReg Reg
src_reg) (AddrMode -> Operand
OpAddr AddrMode
addr)
                            else Format -> Reg -> AddrMode -> Instr
GST Format
pk Reg
src_reg AddrMode
addr
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code

-- Floating point assignment to a register/temporary
assignReg_FltCode :: Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_FltCode _ reg :: CmmReg
reg src :: CmmActual
src = do
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  Reg -> OrdList Instr
src_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
src_code (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 CmmReg
reg))


genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock

genJump :: CmmActual -> [Reg] -> NatM (OrdList Instr)
genJump (CmmLoad mem :: CmmActual
mem _) regs :: [Reg]
regs = do
  Amode target :: AddrMode
target code :: OrdList Instr
code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> [Reg] -> Instr
JMP (AddrMode -> Operand
OpAddr AddrMode
target) [Reg]
regs)

genJump (CmmLit lit :: CmmLit
lit) regs :: [Reg]
regs = do
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Operand -> [Reg] -> Instr
JMP (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit)) [Reg]
regs))

genJump expr :: CmmActual
expr regs :: [Reg]
regs = do
  (reg :: Reg
reg,code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> [Reg] -> Instr
JMP (Reg -> Operand
OpReg Reg
reg) [Reg]
regs)


-- -----------------------------------------------------------------------------
--  Unconditional branches

genBranch :: BlockId -> InstrBlock
genBranch :: Label -> OrdList Instr
genBranch = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL ([Instr] -> OrdList Instr)
-> (Label -> [Instr]) -> Label -> OrdList Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> [Instr]
forall instr. Instruction instr => Label -> [instr]
mkJumpInstr



-- -----------------------------------------------------------------------------
--  Conditional jumps/branches

{-
Conditional jumps are always to local labels, so we can use branch
instructions.  We peek at the arguments to decide what kind of
comparison to do.

I386: First, we have to ensure that the condition
codes are set according to the supplied comparison operation.
-}


genCondBranch
    :: BlockId      -- the source of the jump
    -> BlockId      -- the true branch target
    -> BlockId      -- the false branch target
    -> CmmExpr      -- the condition on which to branch
    -> NatM InstrBlock -- Instructions

genCondBranch :: Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch bid :: Label
bid id :: Label
id false :: Label
false expr :: CmmActual
expr = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Bool
-> Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch' Bool
is32Bit Label
bid Label
id Label
false CmmActual
expr

-- | We return the instructions generated.
genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
               -> NatM InstrBlock

-- 64-bit integer comparisons on 32-bit
genCondBranch' :: Bool
-> Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch' is32Bit :: Bool
is32Bit _bid :: Label
_bid true :: Label
true false :: Label
false (CmmMachOp mop :: MachOp
mop [e1 :: CmmActual
e1,e2 :: CmmActual
e2])
  | Bool
is32Bit, Just W64 <- MachOp -> Maybe Width
maybeIntComparison MachOp
mop = do
  ChildCode64 code1 :: OrdList Instr
code1 r1_lo :: Reg
r1_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
  ChildCode64 code2 :: OrdList Instr
code2 r2_lo :: Reg
r2_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e2
  let r1_hi :: Reg
r1_hi = Reg -> Reg
getHiVRegFromLo Reg
r1_lo
      r2_hi :: Reg
r2_hi = Reg -> Reg
getHiVRegFromLo Reg
r2_lo
      cond :: Cond
cond = MachOp -> Cond
machOpToCond MachOp
mop
      Just cond' :: Cond
cond' = Cond -> Maybe Cond
maybeFlipCond Cond
cond
  --TODO: Update CFG for x86
  let code :: OrdList Instr
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
        Format -> Operand -> Operand -> Instr
CMP Format
II32 (Reg -> Operand
OpReg Reg
r2_hi) (Reg -> Operand
OpReg Reg
r1_hi),
        Cond -> Label -> Instr
JXX Cond
cond Label
true,
        Cond -> Label -> Instr
JXX Cond
cond' Label
false,
        Format -> Operand -> Operand -> Instr
CMP Format
II32 (Reg -> Operand
OpReg Reg
r2_lo) (Reg -> Operand
OpReg Reg
r1_lo),
        Cond -> Label -> Instr
JXX Cond
cond Label
true] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Label -> OrdList Instr
genBranch Label
false
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code

genCondBranch' _ bid :: Label
bid id :: Label
id false :: Label
false bool :: CmmActual
bool = do
  CondCode is_float :: Bool
is_float cond :: Cond
cond cond_code :: OrdList Instr
cond_code <- CmmActual -> NatM CondCode
getCondCode CmmActual
bool
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  if Bool -> Bool
not Bool
is_float Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
use_sse2
    then
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
cond_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Cond -> Label -> Instr
JXX Cond
cond Label
id OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Label -> OrdList Instr
genBranch Label
false)
    else do
        -- See Note [SSE Parity Checks]
        let jmpFalse :: OrdList Instr
jmpFalse = Label -> OrdList Instr
genBranch Label
false
            code :: OrdList Instr
code
                = case Cond
cond of
                  NE  -> OrdList Instr
or_unordered
                  GU  -> OrdList Instr
plain_test
                  GEU -> OrdList Instr
plain_test
                  -- Use ASSERT so we don't break releases if
                  -- LTT/LE creep in somehow.
                  LTT ->
                    ASSERT2(False, ppr "Should have been turned into >")
                    OrdList Instr
and_ordered
                  LE  ->
                    ASSERT2(False, ppr "Should have been turned into >=")
                    OrdList Instr
and_ordered
                  _   -> OrdList Instr
and_ordered

            plain_test :: OrdList Instr
plain_test = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (
                  Cond -> Label -> Instr
JXX Cond
cond Label
id
                ) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
jmpFalse
            or_unordered :: OrdList Instr
or_unordered = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                  Cond -> Label -> Instr
JXX Cond
cond Label
id,
                  Cond -> Label -> Instr
JXX Cond
PARITY Label
id
                ] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
jmpFalse
            and_ordered :: OrdList Instr
and_ordered = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                  Cond -> Label -> Instr
JXX Cond
PARITY Label
false,
                  Cond -> Label -> Instr
JXX Cond
cond Label
id,
                  Cond -> Label -> Instr
JXX Cond
ALWAYS Label
false
                ]
        (CFG -> CFG) -> NatM ()
updateCfgNat (\cfg :: CFG
cfg -> CFG -> (EdgeWeight -> EdgeWeight) -> Label -> Label -> CFG
adjustEdgeWeight CFG
cfg (EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+3) Label
bid Label
false)
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
cond_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code)

{-  Note [Introducing cfg edges inside basic blocks]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    During instruction selection a statement `s`
    in a block B with control of the sort: B -> C
    will sometimes result in control
    flow of the sort:

            ┌ < ┐
            v   ^
      B ->  B1  ┴ -> C

    as is the case for some atomic operations.

    Now to keep the CFG in sync when introducing B1 we clearly
    want to insert it between B and C. However there is
    a catch when we have to deal with self loops.

    We might start with code and a CFG of these forms:

    loop:
        stmt1               ┌ < ┐
        ....                v   ^
        stmtX              loop ┘
        stmtY
        ....
        goto loop:

    Now we introduce B1:
                            ┌ ─ ─ ─ ─ ─┐
        loop:               │   ┌ <  ┐ │
        instrs              v   │    │ ^
        ....               loop ┴ B1 ┴ ┘
        instrsFromX
        stmtY
        goto loop:

    This is simple, all outgoing edges from loop now simply
    start from B1 instead and the code generator knows which
    new edges it introduced for the self loop of B1.

    Disaster strikes if the statement Y follows the same pattern.
    If we apply the same rule that all outgoing edges change then
    we end up with:

        loop ─> B1 ─> B2 ┬─┐
          │      │    └─<┤ │
          │      └───<───┘ │
          └───────<────────┘

    This is problematic. The edge B1->B1 is modified as expected.
    However the modification is wrong!

    The assembly in this case looked like this:

    _loop:
        <instrs>
    _B1:
        ...
        cmpxchgq ...
        jne _B1
        <instrs>
        <end _B1>
    _B2:
        ...
        cmpxchgq ...
        jne _B2
        <instrs>
        jmp loop

    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.

    The problem here is that really B1 should be two basic blocks.
    Otherwise we have control flow in the *middle* of a basic block.
    A contradiction!

    So to account for this we add yet another basic block marker:

    _B:
        <instrs>
    _B1:
        ...
        cmpxchgq ...
        jne _B1
        jmp _B1'
    _B1':
        <instrs>
        <end _B1>
    _B2:
        ...

    Now when inserting B2 we will only look at the outgoing edges of B1' and
    everything will work out nicely.

    You might also wonder why we don't insert jumps at the end of _B1'. There is
    no way another block ends up jumping to the labels _B1 or _B2 since they are
    essentially invisible to other blocks. View them as control flow labels local
    to the basic block if you'd like.

    Not doing this ultimately caused (part 2 of) #17334.
-}


-- -----------------------------------------------------------------------------
--  Generating C calls

-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
-- @get_arg@, which moves the arguments to the correct registers/stack
-- locations.  Apart from that, the code is easy.
--
-- (If applicable) Do not fill the delay slots here; you will confuse the
-- register allocator.

genCCall
    :: DynFlags
    -> Bool                     -- 32 bit platform?
    -> ForeignTarget            -- function to call
    -> [CmmFormal]        -- where to put the result
    -> [CmmActual]        -- arguments (of mixed type)
    -> BlockId      -- The block we are in
    -> NatM (InstrBlock, Maybe BlockId)

-- First we deal with cases which might introduce new blocks in the stream.

genCCall :: DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_AtomicRMW width :: Width
width amop :: AtomicMachOp
amop))
                                           [dst :: CmmFormal
dst] [addr :: CmmActual
addr, n :: CmmActual
n] bid :: Label
bid = do
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    Amode amode :: AddrMode
amode addr_code :: OrdList Instr
addr_code <-
        if AtomicMachOp
amop AtomicMachOp -> [AtomicMachOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AtomicMachOp
AMO_Add, AtomicMachOp
AMO_Sub]
        then CmmActual -> NatM Amode
getAmode CmmActual
addr
        else DynFlags -> Bool -> CmmActual -> NatM Amode
getSimpleAmode DynFlags
dflags Bool
is32Bit CmmActual
addr  -- See genCCall for MO_Cmpxchg
    Reg
arg <- Format -> NatM Reg
getNewRegNat Format
format
    Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
n
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        dst_r :: Reg
dst_r    = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
    (code :: OrdList Instr
code, lbl :: Label
lbl) <- Reg -> Reg -> AddrMode -> NatM (OrdList Instr, Label)
op_code Reg
dst_r Reg
arg AddrMode
amode
    (OrdList Instr, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
addr_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
arg OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code, Label -> Maybe Label
forall a. a -> Maybe a
Just Label
lbl)
  where
    -- Code for the operation
    op_code :: Reg       -- Destination reg
            -> Reg       -- Register containing argument
            -> AddrMode  -- Address of location to mutate
            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId
    op_code :: Reg -> Reg -> AddrMode -> NatM (OrdList Instr, Label)
op_code dst_r :: Reg
dst_r arg :: Reg
arg amode :: AddrMode
amode = case AtomicMachOp
amop of
        -- In the common case where dst_r is a virtual register the
        -- final move should go away, because it's the last use of arg
        -- and the first use of dst_r.
        AMO_Add  -> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList Instr, Label) -> NatM (OrdList Instr, Label))
-> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a b. (a -> b) -> a -> b
$ ([Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
XADD Format
format (Reg -> Operand
OpReg Reg
arg) (AddrMode -> Operand
OpAddr AddrMode
amode))
                                  , Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
arg) (Reg -> Operand
OpReg Reg
dst_r)
                                  ], Label
bid)
        AMO_Sub  -> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList Instr, Label) -> NatM (OrdList Instr, Label))
-> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a b. (a -> b) -> a -> b
$ ([Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Instr
NEGI Format
format (Reg -> Operand
OpReg Reg
arg)
                                  , Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
XADD Format
format (Reg -> Operand
OpReg Reg
arg) (AddrMode -> Operand
OpAddr AddrMode
amode))
                                  , Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
arg) (Reg -> Operand
OpReg Reg
dst_r)
                                  ], Label
bid)
        -- In these cases we need a new block id, and have to return it so
        -- that later instruction selection can reference it.
        AMO_And  -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ src :: Operand
src dst :: Operand
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
AND Format
format Operand
src Operand
dst)
        AMO_Nand -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ src :: Operand
src dst :: Operand
dst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
AND Format
format Operand
src Operand
dst
                                                    , Format -> Operand -> Instr
NOT Format
format Operand
dst
                                                    ])
        AMO_Or   -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ src :: Operand
src dst :: Operand
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
OR Format
format Operand
src Operand
dst)
        AMO_Xor  -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ src :: Operand
src dst :: Operand
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
XOR Format
format Operand
src Operand
dst)
      where
        -- Simulate operation that lacks a dedicated instruction using
        -- cmpxchg.
        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)
                     -> NatM (OrdList Instr, BlockId)
        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code instrs :: Operand -> Operand -> OrdList Instr
instrs = do
            Label
lbl1 <- NatM Label
getBlockIdNat
            Label
lbl2 <- NatM Label
getBlockIdNat
            Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
format

            --Record inserted blocks
            --  We turn A -> B into A -> A' -> A'' -> B
            --  with a self loop on A'.
            HasDebugCallStack => Label -> Label -> NatM ()
Label -> Label -> NatM ()
addImmediateSuccessorNat Label
bid Label
lbl1
            HasDebugCallStack => Label -> Label -> NatM ()
Label -> Label -> NatM ()
addImmediateSuccessorNat Label
lbl1 Label
lbl2
            (CFG -> CFG) -> NatM ()
updateCfgNat (Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
lbl1 Label
lbl1 0)

            (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList Instr, Label) -> NatM (OrdList Instr, Label))
-> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a b. (a -> b) -> a -> b
$ ([Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                [ Format -> Operand -> Operand -> Instr
MOV Format
format (AddrMode -> Operand
OpAddr AddrMode
amode) (Reg -> Operand
OpReg Reg
eax)
                , Cond -> Label -> Instr
JXX Cond
ALWAYS Label
lbl1
                , Label -> Instr
NEWBLOCK Label
lbl1
                  -- Keep old value so we can return it:
                , Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
dst_r)
                , Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
tmp)
                ]
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> OrdList Instr
instrs (Reg -> Operand
OpReg Reg
arg) (Reg -> Operand
OpReg Reg
tmp) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                [ Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
CMPXCHG Format
format (Reg -> Operand
OpReg Reg
tmp) (AddrMode -> Operand
OpAddr AddrMode
amode))
                , Cond -> Label -> Instr
JXX Cond
NE Label
lbl1
                -- See Note [Introducing cfg edges inside basic blocks]
                -- why this basic block is required.
                , Cond -> Label -> Instr
JXX Cond
ALWAYS Label
lbl2
                , Label -> Instr
NEWBLOCK Label
lbl2
                ],
                Label
lbl2)
    format :: Format
format = Width -> Format
intFormat Width
width

genCCall dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_Ctz width :: Width
width)) [dst :: CmmFormal
dst] [src :: CmmActual
src] bid :: Label
bid
  | Bool
is32Bit, Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = do
      ChildCode64 vcode :: OrdList Instr
vcode rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
src
      Bool
use_sse2 <- NatM Bool
sse2Enabled
      let rhi :: Reg
rhi     = Reg -> Reg
getHiVRegFromLo Reg
rlo
          dst_r :: Reg
dst_r   = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
      Label
lbl1 <- NatM Label
getBlockIdNat
      Label
lbl2 <- NatM Label
getBlockIdNat
      let format :: Format
format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then Format
II16 else Width -> Format
intFormat Width
width
      Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format

      -- New CFG Edges:
      --  bid -> lbl2
      --  bid -> lbl1 -> lbl2
      --  We also changes edges originating at bid to start at lbl2 instead.
      (CFG -> CFG) -> NatM ()
updateCfgNat (Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
bid Label
lbl1 110 (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
lbl1 Label
lbl2 110 (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    HasDebugCallStack => Label -> Label -> CFG -> CFG
Label -> Label -> CFG -> CFG
addImmediateSuccessor Label
bid Label
lbl2)

      -- The following instruction sequence corresponds to the pseudo-code
      --
      --  if (src) {
      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);
      --  } else {
      --    dst = 64;
      --  }
      let instrs :: OrdList Instr
instrs = OrdList Instr
vcode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
               ([ Format -> Operand -> Operand -> Instr
MOV      Format
II32 (Reg -> Operand
OpReg Reg
rhi)         (Reg -> Operand
OpReg Reg
tmp_r)
                , Format -> Operand -> Operand -> Instr
OR       Format
II32 (Reg -> Operand
OpReg Reg
rlo)         (Reg -> Operand
OpReg Reg
tmp_r)
                , Format -> Operand -> Operand -> Instr
MOV      Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt 64)) (Reg -> Operand
OpReg Reg
dst_r)
                , Cond -> Label -> Instr
JXX Cond
EQQ    Label
lbl2
                , Cond -> Label -> Instr
JXX Cond
ALWAYS Label
lbl1

                , Label -> Instr
NEWBLOCK   Label
lbl1
                , Format -> Operand -> Reg -> Instr
BSF     Format
II32 (Reg -> Operand
OpReg Reg
rhi)         Reg
dst_r
                , Format -> Operand -> Operand -> Instr
ADD     Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt 32)) (Reg -> Operand
OpReg Reg
dst_r)
                , Format -> Operand -> Reg -> Instr
BSF     Format
II32 (Reg -> Operand
OpReg Reg
rlo)         Reg
tmp_r
                , Cond -> Format -> Operand -> Reg -> Instr
CMOV Cond
NE Format
II32 (Reg -> Operand
OpReg Reg
tmp_r)       Reg
dst_r
                , Cond -> Label -> Instr
JXX Cond
ALWAYS Label
lbl2

                , Label -> Instr
NEWBLOCK   Label
lbl2
                ])
      (OrdList Instr, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, Label -> Maybe Label
forall a. a -> Maybe a
Just Label
lbl2)

  | Bool
otherwise = do
    Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    let dst_r :: Reg
dst_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)

    -- The following insn sequence makes sure 'ctz 0' has a defined value.
    -- starting with Haswell, one could use the TZCNT insn instead.
    let format :: Format
format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then Format
II16 else Width -> Format
intFormat Width
width
    Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
    Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
    let instrs :: OrdList Instr
instrs = Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
              ([ Format -> Operand -> Operand -> Instr
MOVZxL  Format
II8    (Reg -> Operand
OpReg Reg
src_r) (Reg -> Operand
OpReg Reg
src_r) | Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 ] [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
              [ Format -> Operand -> Reg -> Instr
BSF     Format
format (Reg -> Operand
OpReg Reg
src_r) Reg
tmp_r
              , Format -> Operand -> Operand -> Instr
MOV     Format
II32   (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
bw)) (Reg -> Operand
OpReg Reg
dst_r)
              , Cond -> Format -> Operand -> Reg -> Instr
CMOV Cond
NE Format
format (Reg -> Operand
OpReg Reg
tmp_r) Reg
dst_r
              ]) -- NB: We don't need to zero-extend the result for the
                  -- W8/W16 cases because the 'MOV' insn already
                  -- took care of implicitly clearing the upper bits
    (OrdList Instr, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, Maybe Label
forall a. Maybe a
Nothing)
  where
    bw :: Alignment
bw = Width -> Alignment
widthInBits Width
width
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

genCCall dflags :: DynFlags
dflags bits :: Bool
bits mop :: ForeignTarget
mop dst :: [CmmFormal]
dst args :: [CmmActual]
args bid :: Label
bid = do
  OrdList Instr
instr <- DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
bits ForeignTarget
mop [CmmFormal]
dst [CmmActual]
args Label
bid
  (OrdList Instr, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instr, Maybe Label
forall a. Maybe a
Nothing)

-- genCCall' handles cases not introducing new code blocks.
genCCall'
    :: DynFlags
    -> Bool                     -- 32 bit platform?
    -> ForeignTarget            -- function to call
    -> [CmmFormal]        -- where to put the result
    -> [CmmActual]        -- arguments (of mixed type)
    -> BlockId      -- The block we are in
    -> NatM InstrBlock

-- Unroll memcpy calls if the number of bytes to copy isn't too
-- large.  Otherwise, call C's memcpy.
genCCall' :: DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_Memcpy align :: Alignment
align)) _
         [dst :: CmmActual
dst, src :: CmmActual
src, CmmLit (CmmInt n :: Integer
n _)] _
    | Integer -> Alignment
forall a. Num a => Integer -> a
fromInteger Integer
insns Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Alignment
maxInlineMemcpyInsns DynFlags
dflags Bool -> Bool -> Bool
&& Alignment
align Alignment -> Alignment -> Alignment
forall a. Bits a => a -> a -> a
.&. 3 Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = do
        Reg -> OrdList Instr
code_dst <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
dst
        Reg
dst_r <- Format -> NatM Reg
getNewRegNat Format
format
        Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
        Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
        Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_dst Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst_r Reg
src_r Reg
tmp_r (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n)
  where
    -- The number of instructions we will generate (approx). We need 2
    -- instructions per move.
    insns :: Integer
insns = 2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* ((Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sizeBytes Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
sizeBytes)

    format :: Format
format = if Alignment
align Alignment -> Alignment -> Alignment
forall a. Bits a => a -> a -> a
.&. 4 Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then Format
II32 else (Bool -> Format
archWordFormat Bool
is32Bit)

    -- The size of each move, in bytes.
    sizeBytes :: Integer
    sizeBytes :: Integer
sizeBytes = Alignment -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Alignment
formatInBytes Format
format)

    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
go dst :: Reg
dst src :: Reg
src tmp :: Reg
tmp i :: Integer
i
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
sizeBytes =
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
format (AddrMode -> Operand
OpAddr AddrMode
src_addr) (Reg -> Operand
OpReg Reg
tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
tmp) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst Reg
src Reg
tmp (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
sizeBytes)
        -- Deal with remaining bytes.
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 =  -- Will never happen on 32-bit
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (AddrMode -> Operand
OpAddr AddrMode
src_addr) (Reg -> Operand
OpReg Reg
tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
tmp) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst Reg
src Reg
tmp (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 4)
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 =
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (AddrMode -> Operand
OpAddr AddrMode
src_addr) (Reg -> Operand
OpReg Reg
tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II16 (Reg -> Operand
OpReg Reg
tmp) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst Reg
src Reg
tmp (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 2)
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 =
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (AddrMode -> Operand
OpAddr AddrMode
src_addr) (Reg -> Operand
OpReg Reg
tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II8 (Reg -> Operand
OpReg Reg
tmp) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst Reg
src Reg
tmp (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1)
        | Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
      where
        src_addr :: AddrMode
src_addr = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
src) EAIndex
EAIndexNone
                   (Integer -> Imm
ImmInteger (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i))
        dst_addr :: AddrMode
dst_addr = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
dst) EAIndex
EAIndexNone
                   (Integer -> Imm
ImmInteger (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i))

genCCall' dflags :: DynFlags
dflags _ (PrimTarget (MO_Memset align :: Alignment
align)) _
         [dst :: CmmActual
dst,
          CmmLit (CmmInt c :: Integer
c _),
          CmmLit (CmmInt n :: Integer
n _)]
         _
    | Integer -> Alignment
forall a. Num a => Integer -> a
fromInteger Integer
insns Alignment -> Alignment -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Alignment
maxInlineMemsetInsns DynFlags
dflags Bool -> Bool -> Bool
&& Alignment
align Alignment -> Alignment -> Alignment
forall a. Bits a => a -> a -> a
.&. 3 Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = do
        Reg -> OrdList Instr
code_dst <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
dst
        Reg
dst_r <- Format -> NatM Reg
getNewRegNat Format
format
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_dst Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> Integer -> OrdList Instr
go Reg
dst_r (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n)
  where
    (format :: Format
format, val :: Integer
val) = case Alignment
align Alignment -> Alignment -> Alignment
forall a. Bits a => a -> a -> a
.&. 3 of
        2 -> (Format
II16, Integer
c2)
        0 -> (Format
II32, Integer
c4)
        _ -> (Format
II8, Integer
c)
    c2 :: Integer
c2 = Integer
c Integer -> Alignment -> Integer
forall a. Bits a => a -> Alignment -> a
`shiftL` 8 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
c
    c4 :: Integer
c4 = Integer
c2 Integer -> Alignment -> Integer
forall a. Bits a => a -> Alignment -> a
`shiftL` 16 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
c2

    -- The number of instructions we will generate (approx). We need 1
    -- instructions per move.
    insns :: Integer
insns = (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
sizeBytes Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
sizeBytes

    -- The size of each move, in bytes.
    sizeBytes :: Integer
    sizeBytes :: Integer
sizeBytes = Alignment -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Alignment
formatInBytes Format
format)

    go :: Reg -> Integer -> OrdList Instr
    go :: Reg -> Integer -> OrdList Instr
go dst :: Reg
dst i :: Integer
i
        -- TODO: Add movabs instruction and support 64-bit sets.
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
sizeBytes =  -- This might be smaller than the below sizes
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
format (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
val)) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Integer -> OrdList Instr
go Reg
dst (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
sizeBytes)
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 =  -- Will never happen on 32-bit
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
c4)) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Integer -> OrdList Instr
go Reg
dst (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 4)
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 =
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II16 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
c2)) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Integer -> OrdList Instr
go Reg
dst (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 2)
        | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 =
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II8 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
c)) (AddrMode -> Operand
OpAddr AddrMode
dst_addr)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Reg -> Integer -> OrdList Instr
go Reg
dst (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1)
        | Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
      where
        dst_addr :: AddrMode
dst_addr = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
dst) EAIndex
EAIndexNone
                   (Integer -> Imm
ImmInteger (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i))

genCCall' _ _ (PrimTarget MO_ReadBarrier) _ _ _  = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _ _ = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
        -- barriers compile to no code on x86/x86-64;
        -- we keep it this long in order to prevent earlier optimisations.

genCCall' _ _ (PrimTarget MO_Touch) _ _ _ = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

genCCall' _ is32bit :: Bool
is32bit (PrimTarget (MO_Prefetch_Data n :: Alignment
n )) _  [src :: CmmActual
src] _ =
        case Alignment
n of
            0 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
NTA  Format
format
            1 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
Lvl2 Format
format
            2 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
Lvl1 Format
format
            3 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
Lvl0 Format
format
            l :: Alignment
l -> String -> NatM (OrdList Instr)
forall a. String -> a
panic (String -> NatM (OrdList Instr)) -> String -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ "unexpected prefetch level in genCCall MO_Prefetch_Data: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Alignment -> String
forall a. Show a => a -> String
show Alignment
l)
            -- the c / llvm prefetch convention is 0, 1, 2, and 3
            -- the x86 corresponding names are : NTA, 2 , 1, and 0
   where
        format :: Format
format = Bool -> Format
archWordFormat Bool
is32bit
        -- need to know what register width for pointers!
        genPrefetch :: CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch inRegSrc :: CmmActual
inRegSrc prefetchCTor :: Operand -> Instr
prefetchCTor =
            do
                Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
inRegSrc
                Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
                OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                  (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Operand -> Instr
prefetchCTor  (AddrMode -> Operand
OpAddr
                              ((EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
src_r )   EAIndex
EAIndexNone (Alignment -> Imm
ImmInt 0))))  ))
                  -- prefetch always takes an address

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_BSwap width :: Width
width)) [dst :: CmmFormal
dst] [src :: CmmActual
src] _ = do
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    let dst_r :: Reg
dst_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
    case Width
width of
        W64 | Bool
is32Bit -> do
               ChildCode64 vcode :: OrdList Instr
vcode rlo :: Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
src
               let dst_rhi :: Reg
dst_rhi = Reg -> Reg
getHiVRegFromLo Reg
dst_r
                   rhi :: Reg
rhi     = Reg -> Reg
getHiVRegFromLo Reg
rlo
               OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
vcode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rlo) (Reg -> Operand
OpReg Reg
dst_rhi),
                               Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rhi) (Reg -> Operand
OpReg Reg
dst_r),
                               Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_rhi,
                               Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_r ]
        W16 -> do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
                  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                           Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_r) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                           Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
SHR Format
II32 (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ Alignment -> Imm
ImmInt 16) (Reg -> Operand
OpReg Reg
dst_r))
        _   -> do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
                  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Instr
BSWAP Format
format Reg
dst_r)
  where
    format :: Format
format = Width -> Format
intFormat Width
width

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_PopCnt width :: Width
width)) dest_regs :: [CmmFormal]
dest_regs@[dst :: CmmFormal
dst]
         args :: [CmmActual]
args@[src :: CmmActual
src] bid :: Label
bid = do
    Bool
sse4_2 <- NatM Bool
sse4_2Enabled
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    if Bool
sse4_2
        then do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
                Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
                let dst_r :: Reg
dst_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
False (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
                OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    (if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then
                         -- The POPCNT instruction doesn't take a r/m8
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
src_r) (Reg -> Operand
OpReg Reg
src_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Reg -> Instr
POPCNT Format
II16 (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)
                     else
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Reg -> Instr
POPCNT Format
format (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    (if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 then
                         -- We used a 16-bit destination register above,
                         -- so zero-extend
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r))
                     else OrdList Instr
forall a. OrdList a
nilOL)
        else do
            CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
                          ReferenceKind
CallReference CLabel
lbl
            let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
                                                           [ForeignHint
NoHint] [ForeignHint
NoHint]
                                                           CmmReturnInfo
CmmMayReturn)
            DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
  where
    format :: Format
format = Width -> Format
intFormat Width
width
    lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
popCntLabel Width
width))

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_Pdep width :: Width
width)) dest_regs :: [CmmFormal]
dest_regs@[dst :: CmmFormal
dst]
         args :: [CmmActual]
args@[src :: CmmActual
src, mask :: CmmActual
mask] bid :: Label
bid = do
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
        then do Reg -> OrdList Instr
code_src  <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
                Reg -> OrdList Instr
code_mask <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
mask
                Reg
src_r     <- Format -> NatM Reg
getNewRegNat Format
format
                Reg
mask_r    <- Format -> NatM Reg
getNewRegNat Format
format
                let dst_r :: Reg
dst_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
                OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
code_mask Reg
mask_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    (if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then
                         -- The PDEP instruction doesn't take a r/m8
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8  (Reg -> Operand
OpReg Reg
src_r ) (Reg -> Operand
OpReg Reg
src_r )) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8  (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
mask_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PDEP   Format
II16 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r ) Reg
dst_r)
                     else
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PDEP Format
format (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    (if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 then
                         -- We used a 16-bit destination register above,
                         -- so zero-extend
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r))
                     else OrdList Instr
forall a. OrdList a
nilOL)
        else do
            CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
                          ReferenceKind
CallReference CLabel
lbl
            let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
                                                           [ForeignHint
NoHint] [ForeignHint
NoHint]
                                                           CmmReturnInfo
CmmMayReturn)
            DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
  where
    format :: Format
format = Width -> Format
intFormat Width
width
    lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
pdepLabel Width
width))

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_Pext width :: Width
width)) dest_regs :: [CmmFormal]
dest_regs@[dst :: CmmFormal
dst]
         args :: [CmmActual]
args@[src :: CmmActual
src, mask :: CmmActual
mask] bid :: Label
bid = do
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
        then do Reg -> OrdList Instr
code_src  <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
                Reg -> OrdList Instr
code_mask <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
mask
                Reg
src_r     <- Format -> NatM Reg
getNewRegNat Format
format
                Reg
mask_r    <- Format -> NatM Reg
getNewRegNat Format
format
                let dst_r :: Reg
dst_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
                OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
code_mask Reg
mask_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    (if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then
                         -- The PEXT instruction doesn't take a r/m8
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
src_r ) (Reg -> Operand
OpReg Reg
src_r )) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
mask_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PEXT Format
II16 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)
                     else
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PEXT Format
format (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                    (if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 then
                         -- We used a 16-bit destination register above,
                         -- so zero-extend
                         Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r))
                     else OrdList Instr
forall a. OrdList a
nilOL)
        else do
            CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
                          ReferenceKind
CallReference CLabel
lbl
            let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
                                                           [ForeignHint
NoHint] [ForeignHint
NoHint]
                                                           CmmReturnInfo
CmmMayReturn)
            DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
  where
    format :: Format
format = Width -> Format
intFormat Width
width
    lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
pextLabel Width
width))

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_Clz width :: Width
width)) dest_regs :: [CmmFormal]
dest_regs@[dst :: CmmFormal
dst] args :: [CmmActual]
args@[src :: CmmActual
src] bid :: Label
bid
  | Bool
is32Bit Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = do
    -- Fallback to `hs_clz64` on i386
    CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
CallReference CLabel
lbl
    let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
                                           [ForeignHint
NoHint] [ForeignHint
NoHint]
                                           CmmReturnInfo
CmmMayReturn)
    DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid

  | Bool
otherwise = do
    Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
    Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
    Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
    let dst_r :: Reg
dst_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
False (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)

    -- The following insn sequence makes sure 'clz 0' has a defined value.
    -- starting with Haswell, one could use the LZCNT insn instead.
    OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
             ([ Format -> Operand -> Operand -> Instr
MOVZxL  Format
II8    (Reg -> Operand
OpReg Reg
src_r) (Reg -> Operand
OpReg Reg
src_r) | Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 ] [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
              [ Format -> Operand -> Reg -> Instr
BSR     Format
format (Reg -> Operand
OpReg Reg
src_r) Reg
tmp_r
              , Format -> Operand -> Operand -> Instr
MOV     Format
II32   (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt (2Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
*Alignment
bwAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-1))) (Reg -> Operand
OpReg Reg
dst_r)
              , Cond -> Format -> Operand -> Reg -> Instr
CMOV Cond
NE Format
format (Reg -> Operand
OpReg Reg
tmp_r) Reg
dst_r
              , Format -> Operand -> Operand -> Instr
XOR     Format
format (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt (Alignment
bwAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-1))) (Reg -> Operand
OpReg Reg
dst_r)
              ]) -- NB: We don't need to zero-extend the result for the
                 -- W8/W16 cases because the 'MOV' insn already
                 -- took care of implicitly clearing the upper bits
  where
    bw :: Alignment
bw = Width -> Alignment
widthInBits Width
width
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
    format :: Format
format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then Format
II16 else Width -> Format
intFormat Width
width
    lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
clzLabel Width
width))

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_UF_Conv width :: Width
width)) dest_regs :: [CmmFormal]
dest_regs args :: [CmmActual]
args bid :: Label
bid = do
    CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
                  ReferenceKind
CallReference CLabel
lbl
    let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
                                           [ForeignHint
NoHint] [ForeignHint
NoHint]
                                           CmmReturnInfo
CmmMayReturn)
    DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
  where
    lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
word2FloatLabel Width
width))

genCCall' dflags :: DynFlags
dflags _ (PrimTarget (MO_AtomicRead width :: Width
width)) [dst :: CmmFormal
dst] [addr :: CmmActual
addr] _ = do
  Reg -> OrdList Instr
load_code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV (Width -> Format
intFormat Width
width)) CmmActual
addr
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  Bool
use_sse2 <- NatM Bool
sse2Enabled

  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
load_code (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)))

genCCall' _ _ (PrimTarget (MO_AtomicWrite width :: Width
width)) [] [addr :: CmmActual
addr, val :: CmmActual
val] _ = do
    OrdList Instr
code <- Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmActual
addr CmmActual
val
    OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
MFENCE

genCCall' dflags :: DynFlags
dflags is32Bit :: Bool
is32Bit (PrimTarget (MO_Cmpxchg width :: Width
width)) [dst :: CmmFormal
dst] [addr :: CmmActual
addr, old :: CmmActual
old, new :: CmmActual
new] _ = do
    -- On x86 we don't have enough registers to use cmpxchg with a
    -- complicated addressing mode, so on that architecture we
    -- pre-compute the address first.
    Bool
use_sse2 <- NatM Bool
sse2Enabled
    Amode amode :: AddrMode
amode addr_code :: OrdList Instr
addr_code <- DynFlags -> Bool -> CmmActual -> NatM Amode
getSimpleAmode DynFlags
dflags Bool
is32Bit CmmActual
addr
    Reg
newval <- Format -> NatM Reg
getNewRegNat Format
format
    Reg -> OrdList Instr
newval_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
new
    Reg
oldval <- Format -> NatM Reg
getNewRegNat Format
format
    Reg -> OrdList Instr
oldval_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
old
    let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        dst_r :: Reg
dst_r    = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
        code :: OrdList Instr
code     = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                   [ Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
oldval) (Reg -> Operand
OpReg Reg
eax)
                   , Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
CMPXCHG Format
format (Reg -> Operand
OpReg Reg
newval) (AddrMode -> Operand
OpAddr AddrMode
amode))
                   , Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
dst_r)
                   ]
    OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
addr_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
newval_code Reg
newval OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
oldval_code Reg
oldval
        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code
  where
    format :: Format
format = Width -> Format
intFormat Width
width

genCCall' _ is32Bit :: Bool
is32Bit target :: ForeignTarget
target dest_regs :: [CmmFormal]
dest_regs args :: [CmmActual]
args bid :: Label
bid = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
      sse2 :: Bool
sse2     = DynFlags -> Bool
isSse2Enabled DynFlags
dflags
  case (ForeignTarget
target, [CmmFormal]
dest_regs) of
    -- void return type prim op
    (PrimTarget op :: CallishMachOp
op, []) ->
        Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
op Maybe CmmFormal
forall a. Maybe a
Nothing [CmmActual]
args
    -- we only cope with a single result for foreign calls
    (PrimTarget op :: CallishMachOp
op, [r :: CmmFormal
r])
      | Bool
sse2 -> case CallishMachOp
op of
          MO_F32_Fabs -> case [CmmActual]
args of
            [x :: CmmActual
x] -> Width -> CmmActual -> NatM (OrdList Instr)
sse2FabsCode Width
W32 CmmActual
x
            _ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments for fabs"
          MO_F64_Fabs -> case [CmmActual]
args of
            [x :: CmmActual
x] -> Width -> CmmActual -> NatM (OrdList Instr)
sse2FabsCode Width
W64 CmmActual
x
            _ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments for fabs"

          MO_F32_Sqrt -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineSSE2Op (\fmt :: Format
fmt r :: Reg
r -> Format -> Operand -> Reg -> Instr
SQRT Format
fmt (Reg -> Operand
OpReg Reg
r)) Format
FF32 [CmmActual]
args
          MO_F64_Sqrt -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineSSE2Op (\fmt :: Format
fmt r :: Reg
r -> Format -> Operand -> Reg -> Instr
SQRT Format
fmt (Reg -> Operand
OpReg Reg
r)) Format
FF64 [CmmActual]
args
          _other_op :: CallishMachOp
_other_op -> Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
op (CmmFormal -> Maybe CmmFormal
forall a. a -> Maybe a
Just CmmFormal
r) [CmmActual]
args
      | Bool
otherwise -> do
        CLabel
l1 <- NatM CLabel
getNewLabelNat
        CLabel
l2 <- NatM CLabel
getNewLabelNat
        if Bool
sse2
          then Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
op (CmmFormal -> Maybe CmmFormal
forall a. a -> Maybe a
Just CmmFormal
r) [CmmActual]
args
          else case CallishMachOp
op of
              MO_F32_Sqrt -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp Format -> Reg -> Reg -> Instr
GSQRT Format
FF32 [CmmActual]
args
              MO_F64_Sqrt -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp Format -> Reg -> Reg -> Instr
GSQRT Format
FF64 [CmmActual]
args

              MO_F32_Sin  -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp (\s :: Format
s -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GSIN Format
s CLabel
l1 CLabel
l2) Format
FF32 [CmmActual]
args
              MO_F64_Sin  -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp (\s :: Format
s -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GSIN Format
s CLabel
l1 CLabel
l2) Format
FF64 [CmmActual]
args

              MO_F32_Cos  -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp (\s :: Format
s -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GCOS Format
s CLabel
l1 CLabel
l2) Format
FF32 [CmmActual]
args
              MO_F64_Cos  -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp (\s :: Format
s -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GCOS Format
s CLabel
l1 CLabel
l2) Format
FF64 [CmmActual]
args

              MO_F32_Tan  -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp (\s :: Format
s -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GTAN Format
s CLabel
l1 CLabel
l2) Format
FF32 [CmmActual]
args
              MO_F64_Tan  -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp (\s :: Format
s -> Format -> CLabel -> CLabel -> Reg -> Reg -> Instr
GTAN Format
s CLabel
l1 CLabel
l2) Format
FF64 [CmmActual]
args

              _other_op :: CallishMachOp
_other_op   -> Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
op (CmmFormal -> Maybe CmmFormal
forall a. a -> Maybe a
Just CmmFormal
r) [CmmActual]
args

       where
        actuallyInlineFloatOp :: (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp = Bool
-> (Format -> Reg -> Reg -> Instr)
-> Format
-> [CmmActual]
-> NatM (OrdList Instr)
actuallyInlineFloatOp' Bool
False
        actuallyInlineSSE2Op :: (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineSSE2Op = Bool
-> (Format -> Reg -> Reg -> Instr)
-> Format
-> [CmmActual]
-> NatM (OrdList Instr)
actuallyInlineFloatOp' Bool
True

        actuallyInlineFloatOp' :: Bool
-> (Format -> Reg -> Reg -> Instr)
-> Format
-> [CmmActual]
-> NatM (OrdList Instr)
actuallyInlineFloatOp' usesSSE :: Bool
usesSSE instr :: Format -> Reg -> Reg -> Instr
instr format :: Format
format [x :: CmmActual
x]
              = do Register
res <- Format -> (Reg -> Reg -> Instr) -> CmmActual -> NatM Register
trivialUFCode Format
format (Format -> Reg -> Reg -> Instr
instr Format
format) CmmActual
x
                   Reg -> OrdList Instr
any <- Register -> NatM (Reg -> OrdList Instr)
anyReg Register
res
                   OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
any (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
usesSSE (CmmFormal -> CmmReg
CmmLocal CmmFormal
r)))

        actuallyInlineFloatOp' _ _ _ args :: [CmmActual]
args
              = String -> NatM (OrdList Instr)
forall a. String -> a
panic (String -> NatM (OrdList Instr)) -> String -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Alignment -> String
forall a. Show a => a -> String
show ([CmmActual] -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length [CmmActual]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"

        sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock
        sse2FabsCode :: Width -> CmmActual -> NatM (OrdList Instr)
sse2FabsCode w :: Width
w x :: CmmActual
x = do
          let fmt :: Format
fmt = Width -> Format
floatFormat Width
w
          Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
          let
            const :: CmmLit
const | Format
FF32 <- Format
fmt = Integer -> Width -> CmmLit
CmmInt 0x7fffffff Width
W32
                  | Bool
otherwise   = Integer -> Width -> CmmLit
CmmInt 0x7fffffffffffffff Width
W64
          Amode amode :: AddrMode
amode amode_code :: OrdList Instr
amode_code <- Alignment -> CmmLit -> NatM Amode
memConstant (Width -> Alignment
widthInBytes Width
w) CmmLit
const
          Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
          let
            code :: Reg -> OrdList Instr
code dst :: Reg
dst = Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
amode_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                Format -> Operand -> Operand -> Instr
MOV Format
fmt (AddrMode -> Operand
OpAddr AddrMode
amode) (Reg -> Operand
OpReg Reg
tmp),
                Format -> Operand -> Operand -> Instr
AND Format
fmt (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
                ]

          OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code (Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
r))

    (PrimTarget (MO_S_QuotRem  width :: Width
width), _) -> Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp1 Platform
platform Bool
True  Width
width [CmmFormal]
dest_regs [CmmActual]
args
    (PrimTarget (MO_U_QuotRem  width :: Width
width), _) -> Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp1 Platform
platform Bool
False Width
width [CmmFormal]
dest_regs [CmmActual]
args
    (PrimTarget (MO_U_QuotRem2 width :: Width
width), _) -> Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp2 Platform
platform Bool
False Width
width [CmmFormal]
dest_regs [CmmActual]
args
    (PrimTarget (MO_Add2 width :: Width
width), [res_h :: CmmFormal
res_h, res_l :: CmmFormal
res_l]) ->
        case [CmmActual]
args of
        [arg_x :: CmmActual
arg_x, arg_y :: CmmActual
arg_y] ->
            do Reg -> OrdList Instr
hCode <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg (CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt 0 Width
width))
               let format :: Format
format = Width -> Format
intFormat Width
width
               Reg -> OrdList Instr
lCode <- Register -> NatM (Reg -> OrdList Instr)
anyReg (Register -> NatM (Reg -> OrdList Instr))
-> NatM Register -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width (Format -> Operand -> Operand -> Instr
ADD_CC Format
format)
                                     ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just (Format -> Operand -> Operand -> Instr
ADD_CC Format
format)) CmmActual
arg_x CmmActual
arg_y
               let reg_l :: Reg
reg_l = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_l)
                   reg_h :: Reg
reg_h = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_h)
                   code :: OrdList Instr
code = Reg -> OrdList Instr
hCode Reg
reg_h OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                          Reg -> OrdList Instr
lCode Reg
reg_l OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Operand -> Operand -> Instr
ADC Format
format (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger 0)) (Reg -> Operand
OpReg Reg
reg_h)
               OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
        _ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments/results for add2"
    (PrimTarget (MO_AddWordC width :: Width
width), [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c]) ->
        Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
ADD_CC (Maybe (Operand -> Operand -> Instr)
-> Format -> Maybe (Operand -> Operand -> Instr)
forall a b. a -> b -> a
const Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing) Cond
CARRY Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
    (PrimTarget (MO_SubWordC width :: Width
width), [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c]) ->
        Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
SUB_CC (Maybe (Operand -> Operand -> Instr)
-> Format -> Maybe (Operand -> Operand -> Instr)
forall a b. a -> b -> a
const Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing) Cond
CARRY Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
    (PrimTarget (MO_AddIntC width :: Width
width), [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c]) ->
        Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
ADD_CC ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just ((Operand -> Operand -> Instr)
 -> Maybe (Operand -> Operand -> Instr))
-> (Format -> Operand -> Operand -> Instr)
-> Format
-> Maybe (Operand -> Operand -> Instr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Operand -> Operand -> Instr
ADD_CC) Cond
OFLO Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
    (PrimTarget (MO_SubIntC width :: Width
width), [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c]) ->
        Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
SUB_CC (Maybe (Operand -> Operand -> Instr)
-> Format -> Maybe (Operand -> Operand -> Instr)
forall a b. a -> b -> a
const Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing) Cond
OFLO Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
    (PrimTarget (MO_U_Mul2 width :: Width
width), [res_h :: CmmFormal
res_h, res_l :: CmmFormal
res_l]) ->
        case [CmmActual]
args of
        [arg_x :: CmmActual
arg_x, arg_y :: CmmActual
arg_y] ->
            do (y_reg :: Operand
y_reg, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
arg_y
               Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_x
               let format :: Format
format = Width -> Format
intFormat Width
width
                   reg_h :: Reg
reg_h = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_h)
                   reg_l :: Reg
reg_l = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_l)
                   code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                          Reg -> OrdList Instr
x_code Reg
rax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                          [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Instr
MUL2 Format
format Operand
y_reg,
                                Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
reg_h),
                                Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rax) (Reg -> Operand
OpReg Reg
reg_l)]
               OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
        _ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments/results for mul2"

    _ -> if Bool
is32Bit
         then DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall32' DynFlags
dflags ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args
         else DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall64' DynFlags
dflags ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args

  where divOp1 :: Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp1 platform :: Platform
platform signed :: Bool
signed width :: Width
width results :: [CmmFormal]
results [arg_x :: CmmActual
arg_x, arg_y :: CmmActual
arg_y]
            = Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp Platform
platform Bool
signed Width
width [CmmFormal]
results Maybe CmmActual
forall a. Maybe a
Nothing CmmActual
arg_x CmmActual
arg_y
        divOp1 _ _ _ _ _
            = String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments for divOp1"
        divOp2 :: Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp2 platform :: Platform
platform signed :: Bool
signed width :: Width
width results :: [CmmFormal]
results [arg_x_high :: CmmActual
arg_x_high, arg_x_low :: CmmActual
arg_x_low, arg_y :: CmmActual
arg_y]
            = Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp Platform
platform Bool
signed Width
width [CmmFormal]
results (CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
arg_x_high) CmmActual
arg_x_low CmmActual
arg_y
        divOp2 _ _ _ _ _
            = String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments for divOp2"

        -- See Note [DIV/IDIV for bytes]
        divOp :: Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp platform :: Platform
platform signed :: Bool
signed W8 [res_q :: CmmFormal
res_q, res_r :: CmmFormal
res_r] m_arg_x_high :: Maybe CmmActual
m_arg_x_high arg_x_low :: CmmActual
arg_x_low arg_y :: CmmActual
arg_y =
            let widen :: MachOp
widen | Bool
signed = Width -> Width -> MachOp
MO_SS_Conv Width
W8 Width
W16
                      | Bool
otherwise = Width -> Width -> MachOp
MO_UU_Conv Width
W8 Width
W16
                arg_x_low_16 :: CmmActual
arg_x_low_16 = MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
arg_x_low]
                arg_y_16 :: CmmActual
arg_y_16 = MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
arg_y]
                m_arg_x_high_16 :: Maybe CmmActual
m_arg_x_high_16 = (\p :: CmmActual
p -> MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
p]) (CmmActual -> CmmActual) -> Maybe CmmActual -> Maybe CmmActual
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CmmActual
m_arg_x_high
            in Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp
                  Platform
platform Bool
signed Width
W16 [CmmFormal
res_q, CmmFormal
res_r]
                  Maybe CmmActual
m_arg_x_high_16 CmmActual
arg_x_low_16 CmmActual
arg_y_16

        divOp platform :: Platform
platform signed :: Bool
signed width :: Width
width [res_q :: CmmFormal
res_q, res_r :: CmmFormal
res_r]
              m_arg_x_high :: Maybe CmmActual
m_arg_x_high arg_x_low :: CmmActual
arg_x_low arg_y :: CmmActual
arg_y
            = do let format :: Format
format = Width -> Format
intFormat Width
width
                     reg_q :: Reg
reg_q = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_q)
                     reg_r :: Reg
reg_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_r)
                     widen :: Instr
widen | Bool
signed    = Format -> Instr
CLTD Format
format
                           | Bool
otherwise = Format -> Operand -> Operand -> Instr
XOR Format
format (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
rdx)
                     instr :: Format -> Operand -> Instr
instr | Bool
signed    = Format -> Operand -> Instr
IDIV
                           | Bool
otherwise = Format -> Operand -> Instr
DIV
                 (y_reg :: Operand
y_reg, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
arg_y
                 Reg -> OrdList Instr
x_low_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_x_low
                 Reg -> OrdList Instr
x_high_code <- case Maybe CmmActual
m_arg_x_high of
                                Just arg_x_high :: CmmActual
arg_x_high ->
                                    CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_x_high
                                Nothing ->
                                    (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr))
-> (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Reg -> OrdList Instr
forall a b. a -> b -> a
const (OrdList Instr -> Reg -> OrdList Instr)
-> OrdList Instr -> Reg -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
widen
                 OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                          Reg -> OrdList Instr
x_low_code Reg
rax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                          Reg -> OrdList Instr
x_high_code Reg
rdx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                          [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Instr
instr Format
format Operand
y_reg,
                                Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rax) (Reg -> Operand
OpReg Reg
reg_q),
                                Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
reg_r)]
        divOp _ _ _ _ _ _ _
            = String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of results for divOp"

        addSubIntC :: Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC platform :: Platform
platform instr :: Format -> Operand -> Operand -> Instr
instr mrevinstr :: Format -> Maybe (Operand -> Operand -> Instr)
mrevinstr cond :: Cond
cond width :: Width
width
                   res_r :: CmmFormal
res_r res_c :: CmmFormal
res_c [arg_x :: CmmActual
arg_x, arg_y :: CmmActual
arg_y]
            = do let format :: Format
format = Width -> Format
intFormat Width
width
                 Reg -> OrdList Instr
rCode <- Register -> NatM (Reg -> OrdList Instr)
anyReg (Register -> NatM (Reg -> OrdList Instr))
-> NatM Register -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width (Format -> Operand -> Operand -> Instr
instr Format
format)
                                       (Format -> Maybe (Operand -> Operand -> Instr)
mrevinstr Format
format) CmmActual
arg_x CmmActual
arg_y
                 Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
II8
                 let reg_c :: Reg
reg_c = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_c)
                     reg_r :: Reg
reg_r = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_r)
                     code :: OrdList Instr
code = Reg -> OrdList Instr
rCode Reg
reg_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                            Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
reg_tmp) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                            Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
reg_tmp) (Reg -> Operand
OpReg Reg
reg_c)

                 OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
        addSubIntC _ _ _ _ _ _ _ _
            = String -> NatM (OrdList Instr)
forall a. String -> a
panic "genCCall: Wrong number of arguments/results for addSubIntC"

-- Note [DIV/IDIV for bytes]
--
-- IDIV reminder:
--   Size    Dividend   Divisor   Quotient    Remainder
--   byte    %ax         r/m8      %al          %ah
--   word    %dx:%ax     r/m16     %ax          %dx
--   dword   %edx:%eax   r/m32     %eax         %edx
--   qword   %rdx:%rax   r/m64     %rax         %rdx
--
-- We do a special case for the byte division because the current
-- codegen doesn't deal well with accessing %ah register (also,
-- accessing %ah in 64-bit mode is complicated because it cannot be an
-- operand of many instructions). So we just widen operands to 16 bits
-- and get the results from %al, %dl. This is not optimal, but a few
-- register moves are probably not a huge deal when doing division.

genCCall32' :: DynFlags
            -> ForeignTarget            -- function to call
            -> [CmmFormal]        -- where to put the result
            -> [CmmActual]        -- arguments (of mixed type)
            -> NatM InstrBlock
genCCall32' :: DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall32' dflags :: DynFlags
dflags target :: ForeignTarget
target dest_regs :: [CmmFormal]
dest_regs args :: [CmmActual]
args = do
        let
            prom_args :: [CmmActual]
prom_args = (CmmActual -> CmmActual) -> [CmmActual] -> [CmmActual]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Width -> CmmActual -> CmmActual
maybePromoteCArg DynFlags
dflags Width
W32) [CmmActual]
args

            -- Align stack to 16n for calls, assuming a starting stack
            -- alignment of 16n - word_size on procedure entry. Which we
            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
            sizes :: [Alignment]
sizes               = (CmmActual -> Alignment) -> [CmmActual] -> [Alignment]
forall a b. (a -> b) -> [a] -> [b]
map (CmmType -> Alignment
arg_size_bytes (CmmType -> Alignment)
-> (CmmActual -> CmmType) -> CmmActual -> Alignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags) ([CmmActual] -> [CmmActual]
forall a. [a] -> [a]
reverse [CmmActual]
args)
            raw_arg_size :: Alignment
raw_arg_size        = [Alignment] -> Alignment
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Alignment]
sizes Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ DynFlags -> Alignment
wORD_SIZE DynFlags
dflags
            arg_pad_size :: Alignment
arg_pad_size        = (Alignment -> Alignment -> Alignment
forall a. Integral a => a -> a -> a
roundTo 16 (Alignment -> Alignment) -> Alignment -> Alignment
forall a b. (a -> b) -> a -> b
$ Alignment
raw_arg_size) Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- Alignment
raw_arg_size
            tot_arg_size :: Alignment
tot_arg_size        = Alignment
raw_arg_size Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ Alignment
arg_pad_size Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- DynFlags -> Alignment
wORD_SIZE DynFlags
dflags
        Alignment
delta0 <- NatM Alignment
getDeltaNat
        Alignment -> NatM ()
setDeltaNat (Alignment
delta0 Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- Alignment
arg_pad_size)

        Bool
use_sse2 <- NatM Bool
sse2Enabled
        [OrdList Instr]
push_codes <- (CmmActual -> NatM (OrdList Instr))
-> [CmmActual] -> NatM [OrdList Instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> CmmActual -> NatM (OrdList Instr)
push_arg Bool
use_sse2) ([CmmActual] -> [CmmActual]
forall a. [a] -> [a]
reverse [CmmActual]
prom_args)
        Alignment
delta <- NatM Alignment
getDeltaNat
        MASSERT(delta == delta0 - tot_arg_size)

        -- deal with static vs dynamic call targets
        (callinsns :: OrdList Instr
callinsns,cconv :: ForeignConvention
cconv) <-
          case ForeignTarget
target of
            ForeignTarget (CmmLit (CmmLabel lbl :: CLabel
lbl)) conv :: ForeignConvention
conv
               -> -- ToDo: stdcall arg sizes
                  (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Either Imm Reg -> [Reg] -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left Imm
fn_imm) []), ForeignConvention
conv)
               where fn_imm :: Imm
fn_imm = CLabel -> Imm
ImmCLbl CLabel
lbl
            ForeignTarget expr :: CmmActual
expr conv :: ForeignConvention
conv
               -> do { (dyn_r :: Reg
dyn_r, dyn_c :: OrdList Instr
dyn_c) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
                     ; ASSERT( isWord32 (cmmExprType dflags expr) )
                       (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
dyn_c OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Either Imm Reg -> [Reg] -> Instr
CALL (Reg -> Either Imm Reg
forall a b. b -> Either a b
Right Reg
dyn_r) [], ForeignConvention
conv) }
            PrimTarget _
                -> String -> NatM (OrdList Instr, ForeignConvention)
forall a. String -> a
panic (String -> NatM (OrdList Instr, ForeignConvention))
-> String -> NatM (OrdList Instr, ForeignConvention)
forall a b. (a -> b) -> a -> b
$ "genCCall: Can't handle PrimTarget call type here, error "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ "probably because too many return values."

        let push_code :: OrdList Instr
push_code
                | Alignment
arg_pad_size Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
                = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Operand -> Instr
SUB Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
arg_pad_size)) (Reg -> Operand
OpReg Reg
esp),
                        Alignment -> Instr
DELTA (Alignment
delta0 Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- Alignment
arg_pad_size)]
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [OrdList Instr] -> OrdList Instr
forall a. [OrdList a] -> OrdList a
concatOL [OrdList Instr]
push_codes
                | Bool
otherwise
                = [OrdList Instr] -> OrdList Instr
forall a. [OrdList a] -> OrdList a
concatOL [OrdList Instr]
push_codes

              -- Deallocate parameters after call for ccall;
              -- but not for stdcall (callee does it)
              --
              -- We have to pop any stack padding we added
              -- even if we are doing stdcall, though (#5052)
            pop_size :: Alignment
pop_size
               | ForeignConvention StdCallConv _ _ _ <- ForeignConvention
cconv = Alignment
arg_pad_size
               | Bool
otherwise = Alignment
tot_arg_size

            call :: OrdList Instr
call = OrdList Instr
callinsns OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                   [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL (
                      (if Alignment
pop_sizeAlignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
==0 then [] else
                       [Format -> Operand -> Operand -> Instr
ADD Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
pop_size)) (Reg -> Operand
OpReg Reg
esp)])
                      [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
                      [Alignment -> Instr
DELTA Alignment
delta0]
                   )
        Alignment -> NatM ()
setDeltaNat Alignment
delta0

        DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

        let
            -- assign the results, if necessary
            assign_code :: [CmmFormal] -> OrdList Instr
assign_code []     = OrdList Instr
forall a. OrdList a
nilOL
            assign_code [dest :: CmmFormal
dest]
              | CmmType -> Bool
isFloatType CmmType
ty =
                 if Bool
use_sse2
                    then let tmp_amode :: AddrMode
tmp_amode = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
esp)
                                                       EAIndex
EAIndexNone
                                                       (Alignment -> Imm
ImmInt 0)
                             fmt :: Format
fmt = Width -> Format
floatFormat Width
w
                         in [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
SUB Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
b)) (Reg -> Operand
OpReg Reg
esp),
                                   Alignment -> Instr
DELTA (Alignment
delta0 Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- Alignment
b),
                                   Format -> Reg -> AddrMode -> Instr
GST Format
fmt Reg
fake0 AddrMode
tmp_amode,
                                   Format -> Operand -> Operand -> Instr
MOV Format
fmt (AddrMode -> Operand
OpAddr AddrMode
tmp_amode) (Reg -> Operand
OpReg Reg
r_dest),
                                   Format -> Operand -> Operand -> Instr
ADD Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
b)) (Reg -> Operand
OpReg Reg
esp),
                                   Alignment -> Instr
DELTA Alignment
delta0]
                    else Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
GMOV Reg
fake0 Reg
r_dest)
              | CmmType -> Bool
isWord64 CmmType
ty    = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
r_dest),
                                        Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
r_dest_hi)]
              | Bool
otherwise      = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV (Width -> Format
intFormat Width
w)
                                             (Reg -> Operand
OpReg Reg
eax)
                                             (Reg -> Operand
OpReg Reg
r_dest))
              where
                    ty :: CmmType
ty = CmmFormal -> CmmType
localRegType CmmFormal
dest
                    w :: Width
w  = CmmType -> Width
typeWidth CmmType
ty
                    b :: Alignment
b  = Width -> Alignment
widthInBytes Width
w
                    r_dest_hi :: Reg
r_dest_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dest
                    r_dest :: Reg
r_dest    = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
use_sse2 (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
            assign_code many :: [CmmFormal]
many = String -> SDoc -> OrdList Instr
forall a. HasCallStack => String -> SDoc -> a
pprPanic "genCCall.assign_code - too many return values:" ([CmmFormal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
many)

        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
push_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
call OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [CmmFormal] -> OrdList Instr
assign_code [CmmFormal]
dest_regs)

      where
        -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
        arg_size_bytes :: CmmType -> Int
        arg_size_bytes :: CmmType -> Alignment
arg_size_bytes ty :: CmmType
ty = Alignment -> Alignment -> Alignment
forall a. Ord a => a -> a -> a
max (Width -> Alignment
widthInBytes (CmmType -> Width
typeWidth CmmType
ty)) (Width -> Alignment
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags))

        roundTo :: a -> a -> a
roundTo a :: a
a x :: a
x | a
x a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = a
x
                    | Bool
otherwise = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
a a -> a -> a
forall a. Num a => a -> a -> a
- (a
x a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
a)

        push_arg :: Bool -> CmmActual {-current argument-}
                        -> NatM InstrBlock  -- code

        push_arg :: Bool -> CmmActual -> NatM (OrdList Instr)
push_arg use_sse2 :: Bool
use_sse2 arg :: CmmActual
arg -- we don't need the hints on x86
          | CmmType -> Bool
isWord64 CmmType
arg_ty = do
            ChildCode64 code :: OrdList Instr
code r_lo :: Reg
r_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
arg
            Alignment
delta <- NatM Alignment
getDeltaNat
            Alignment -> NatM ()
setDeltaNat (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- 8)
            let r_hi :: Reg
r_hi = Reg -> Reg
getHiVRegFromLo Reg
r_lo
            OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (       OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                           [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Instr
PUSH Format
II32 (Reg -> Operand
OpReg Reg
r_hi), Alignment -> Instr
DELTA (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- 4),
                                 Format -> Operand -> Instr
PUSH Format
II32 (Reg -> Operand
OpReg Reg
r_lo), Alignment -> Instr
DELTA (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- 8),
                                 Alignment -> Instr
DELTA (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-8)]
                )

          | CmmType -> Bool
isFloatType CmmType
arg_ty = do
            (reg :: Reg
reg, code :: OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
arg
            Alignment
delta <- NatM Alignment
getDeltaNat
            Alignment -> NatM ()
setDeltaNat (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
size)
            OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                            [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Operand -> Instr
SUB Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
size)) (Reg -> Operand
OpReg Reg
esp),
                                  Alignment -> Instr
DELTA (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
size),
                                  let addr :: AddrMode
addr = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
esp)
                                                            EAIndex
EAIndexNone
                                                            (Alignment -> Imm
ImmInt 0)
                                      format :: Format
format = Width -> Format
floatFormat (CmmType -> Width
typeWidth CmmType
arg_ty)
                                  in
                                  if Bool
use_sse2
                                     then Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
reg) (AddrMode -> Operand
OpAddr AddrMode
addr)
                                     else Format -> Reg -> AddrMode -> Instr
GST Format
format Reg
reg AddrMode
addr
                                 ]
                           )

          | Bool
otherwise = do
            -- Arguments can be smaller than 32-bit, but we still use @PUSH
            -- II32@ - the usual calling conventions expect integers to be
            -- 4-byte aligned.
            ASSERT((typeWidth arg_ty) <= W32) return ()
            (operand :: Operand
operand, code :: OrdList Instr
code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
arg
            Alignment
delta <- NatM Alignment
getDeltaNat
            Alignment -> NatM ()
setDeltaNat (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
size)
            OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Operand -> Instr
PUSH Format
II32 Operand
operand OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Alignment -> Instr
DELTA (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
size))

          where
             arg_ty :: CmmType
arg_ty = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
             size :: Alignment
size = CmmType -> Alignment
arg_size_bytes CmmType
arg_ty -- Byte size

genCCall64' :: DynFlags
            -> ForeignTarget      -- function to call
            -> [CmmFormal]        -- where to put the result
            -> [CmmActual]        -- arguments (of mixed type)
            -> NatM InstrBlock
genCCall64' :: DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall64' dflags :: DynFlags
dflags target :: ForeignTarget
target dest_regs :: [CmmFormal]
dest_regs args :: [CmmActual]
args = do
    -- load up the register arguments
    let prom_args :: [CmmActual]
prom_args = (CmmActual -> CmmActual) -> [CmmActual] -> [CmmActual]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Width -> CmmActual -> CmmActual
maybePromoteCArg DynFlags
dflags Width
W32) [CmmActual]
args

    (stack_args :: [CmmActual]
stack_args, int_regs_used :: [Reg]
int_regs_used, fp_regs_used :: [Reg]
fp_regs_used, load_args_code :: OrdList Instr
load_args_code, assign_args_code :: OrdList Instr
assign_args_code)
         <-
        if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
        then [CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
prom_args [] [] (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform) OrdList Instr
forall a. OrdList a
nilOL
        else do
           (stack_args :: [CmmActual]
stack_args, aregs :: [Reg]
aregs, fregs :: [Reg]
fregs, load_args_code :: OrdList Instr
load_args_code, assign_args_code :: OrdList Instr
assign_args_code)
               <- [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
prom_args (Platform -> [Reg]
allIntArgRegs Platform
platform)
                                      (Platform -> [Reg]
allFPArgRegs Platform
platform)
                                      OrdList Instr
forall a. OrdList a
nilOL OrdList Instr
forall a. OrdList a
nilOL
           let used_regs :: t a -> [a] -> [a]
used_regs rs :: t a
rs as :: [a]
as = [a] -> [a]
forall a. [a] -> [a]
reverse (Alignment -> [a] -> [a]
forall a. Alignment -> [a] -> [a]
drop (t a -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length t a
rs) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
as))
               fregs_used :: [Reg]
fregs_used      = [Reg] -> [Reg] -> [Reg]
forall (t :: * -> *) a a. Foldable t => t a -> [a] -> [a]
used_regs [Reg]
fregs (Platform -> [Reg]
allFPArgRegs Platform
platform)
               aregs_used :: [Reg]
aregs_used      = [Reg] -> [Reg] -> [Reg]
forall (t :: * -> *) a a. Foldable t => t a -> [a] -> [a]
used_regs [Reg]
aregs (Platform -> [Reg]
allIntArgRegs Platform
platform)
           ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmActual]
stack_args, [Reg]
aregs_used, [Reg]
fregs_used, OrdList Instr
load_args_code
                                                      , OrdList Instr
assign_args_code)

    let
        arg_regs_used :: [Reg]
arg_regs_used = [Reg]
int_regs_used [Reg] -> [Reg] -> [Reg]
forall a. [a] -> [a] -> [a]
++ [Reg]
fp_regs_used
        arg_regs :: [Reg]
arg_regs = [Reg
eax] [Reg] -> [Reg] -> [Reg]
forall a. [a] -> [a] -> [a]
++ [Reg]
arg_regs_used
                -- for annotating the call instruction with
        sse_regs :: Alignment
sse_regs = [Reg] -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length [Reg]
fp_regs_used
        arg_stack_slots :: Alignment
arg_stack_slots = if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                          then [CmmActual] -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length [CmmActual]
stack_args Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ [(Reg, Reg)] -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform)
                          else [CmmActual] -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length [CmmActual]
stack_args
        tot_arg_size :: Alignment
tot_arg_size = Alignment
arg_size Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
* Alignment
arg_stack_slots


    -- Align stack to 16n for calls, assuming a starting stack
    -- alignment of 16n - word_size on procedure entry. Which we
    -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]
    (real_size :: Alignment
real_size, adjust_rsp :: OrdList Instr
adjust_rsp) <-
        if (Alignment
tot_arg_size Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ DynFlags -> Alignment
wORD_SIZE DynFlags
dflags) Alignment -> Alignment -> Alignment
forall a. Integral a => a -> a -> a
`rem` 16 Alignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
== 0
            then (Alignment, OrdList Instr) -> NatM (Alignment, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alignment
tot_arg_size, OrdList Instr
forall a. OrdList a
nilOL)
            else do -- we need to adjust...
                Alignment
delta <- NatM Alignment
getDeltaNat
                Alignment -> NatM ()
setDeltaNat (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- DynFlags -> Alignment
wORD_SIZE DynFlags
dflags)
                (Alignment, OrdList Instr) -> NatM (Alignment, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Alignment
tot_arg_size Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ DynFlags -> Alignment
wORD_SIZE DynFlags
dflags, [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                Format -> Operand -> Operand -> Instr
SUB Format
II64 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt (DynFlags -> Alignment
wORD_SIZE DynFlags
dflags))) (Reg -> Operand
OpReg Reg
rsp),
                                Alignment -> Instr
DELTA (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- DynFlags -> Alignment
wORD_SIZE DynFlags
dflags) ])

    -- push the stack args, right to left
    OrdList Instr
push_code <- [CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args ([CmmActual] -> [CmmActual]
forall a. [a] -> [a]
reverse [CmmActual]
stack_args) OrdList Instr
forall a. OrdList a
nilOL
    -- On Win64, we also have to leave stack space for the arguments
    -- that we are passing in registers
    OrdList Instr
lss_code <- if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                then Alignment -> NatM (OrdList Instr)
leaveStackSpace ([(Reg, Reg)] -> Alignment
forall (t :: * -> *) a. Foldable t => t a -> Alignment
length (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform))
                else OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
    Alignment
delta <- NatM Alignment
getDeltaNat

    -- deal with static vs dynamic call targets
    (callinsns :: OrdList Instr
callinsns,_cconv :: ForeignConvention
_cconv) <-
      case ForeignTarget
target of
        ForeignTarget (CmmLit (CmmLabel lbl :: CLabel
lbl)) conv :: ForeignConvention
conv
           -> -- ToDo: stdcall arg sizes
              (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Either Imm Reg -> [Reg] -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left Imm
fn_imm) [Reg]
arg_regs), ForeignConvention
conv)
           where fn_imm :: Imm
fn_imm = CLabel -> Imm
ImmCLbl CLabel
lbl
        ForeignTarget expr :: CmmActual
expr conv :: ForeignConvention
conv
           -> do (dyn_r :: Reg
dyn_r, dyn_c :: OrdList Instr
dyn_c) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
                 (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
dyn_c OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Either Imm Reg -> [Reg] -> Instr
CALL (Reg -> Either Imm Reg
forall a b. b -> Either a b
Right Reg
dyn_r) [Reg]
arg_regs, ForeignConvention
conv)
        PrimTarget _
            -> String -> NatM (OrdList Instr, ForeignConvention)
forall a. String -> a
panic (String -> NatM (OrdList Instr, ForeignConvention))
-> String -> NatM (OrdList Instr, ForeignConvention)
forall a b. (a -> b) -> a -> b
$ "genCCall: Can't handle PrimTarget call type here, error "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ "probably because too many return values."

    let
        -- The x86_64 ABI requires us to set %al to the number of SSE2
        -- registers that contain arguments, if the called routine
        -- is a varargs function.  We don't know whether it's a
        -- varargs function or not, so we have to assume it is.
        --
        -- It's not safe to omit this assignment, even if the number
        -- of SSE2 regs in use is zero.  If %al is larger than 8
        -- on entry to a varargs function, seg faults ensue.
        assign_eax :: Alignment -> OrdList Instr
assign_eax n :: Alignment
n = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
n)) (Reg -> Operand
OpReg Reg
eax))

    let call :: OrdList Instr
call = OrdList Instr
callinsns OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
               [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL (
                    -- Deallocate parameters after call for ccall;
                    -- stdcall has callee do it, but is not supported on
                    -- x86_64 target (see #3336)
                  (if Alignment
real_sizeAlignment -> Alignment -> Bool
forall a. Eq a => a -> a -> Bool
==0 then [] else
                   [Format -> Operand -> Operand -> Instr
ADD (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags)) (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
real_size)) (Reg -> Operand
OpReg Reg
esp)])
                  [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
                  [Alignment -> Instr
DELTA (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ Alignment
real_size)]
               )
    Alignment -> NatM ()
setDeltaNat (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
+ Alignment
real_size)

    let
        -- assign the results, if necessary
        assign_code :: [CmmFormal] -> OrdList Instr
assign_code []     = OrdList Instr
forall a. OrdList a
nilOL
        assign_code [dest :: CmmFormal
dest] =
          case CmmType -> Width
typeWidth CmmType
rep of
                W32 | CmmType -> Bool
isFloatType CmmType
rep -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV (Width -> Format
floatFormat Width
W32)
                                                     (Reg -> Operand
OpReg Reg
xmm0)
                                                     (Reg -> Operand
OpReg Reg
r_dest))
                W64 | CmmType -> Bool
isFloatType CmmType
rep -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV (Width -> Format
floatFormat Width
W64)
                                                     (Reg -> Operand
OpReg Reg
xmm0)
                                                     (Reg -> Operand
OpReg Reg
r_dest))
                _ -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV (CmmType -> Format
cmmTypeFormat CmmType
rep) (Reg -> Operand
OpReg Reg
rax) (Reg -> Operand
OpReg Reg
r_dest))
          where
                rep :: CmmType
rep = CmmFormal -> CmmType
localRegType CmmFormal
dest
                r_dest :: Reg
r_dest = Platform -> Bool -> CmmReg -> Reg
getRegisterReg Platform
platform Bool
True (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
        assign_code _many :: [CmmFormal]
_many = String -> OrdList Instr
forall a. String -> a
panic "genCCall.assign_code many"

    OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
adjust_rsp          OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
push_code           OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
load_args_code      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
assign_args_code    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
lss_code            OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Alignment -> OrdList Instr
assign_eax Alignment
sse_regs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
call                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            [CmmFormal] -> OrdList Instr
assign_code [CmmFormal]
dest_regs)

  where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        arg_size :: Alignment
arg_size = 8 -- always, at the mo


        load_args :: [CmmExpr]
                  -> [Reg]         -- int regs avail for args
                  -> [Reg]         -- FP regs avail for args
                  -> InstrBlock    -- code computing args
                  -> InstrBlock    -- code assigning args to ABI regs
                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
        -- no more regs to use
        load_args :: [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args args :: [CmmActual]
args [] [] code :: OrdList Instr
code acode :: OrdList Instr
acode     =
            ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmActual]
args, [], [], OrdList Instr
code, OrdList Instr
acode)

        -- no more args to push
        load_args [] aregs :: [Reg]
aregs fregs :: [Reg]
fregs code :: OrdList Instr
code acode :: OrdList Instr
acode =
            ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Reg]
aregs, [Reg]
fregs, OrdList Instr
code, OrdList Instr
acode)

        load_args (arg :: CmmActual
arg : rest :: [CmmActual]
rest) aregs :: [Reg]
aregs fregs :: [Reg]
fregs code :: OrdList Instr
code acode :: OrdList Instr
acode
            | CmmType -> Bool
isFloatType CmmType
arg_rep = case [Reg]
fregs of
                 []     -> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg
                 (r :: Reg
r:rs :: [Reg]
rs) -> do
                    (code' :: OrdList Instr
code',acode' :: OrdList Instr
acode') <- Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg Reg
r
                    [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
rest [Reg]
aregs [Reg]
rs OrdList Instr
code' OrdList Instr
acode'
            | Bool
otherwise           = case [Reg]
aregs of
                 []     -> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg
                 (r :: Reg
r:rs :: [Reg]
rs) -> do
                    (code' :: OrdList Instr
code',acode' :: OrdList Instr
acode') <- Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg Reg
r
                    [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
rest [Reg]
rs [Reg]
fregs OrdList Instr
code' OrdList Instr
acode'
            where

              -- put arg into the list of stack pushed args
              push_this_arg :: NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg = do
                 (args' :: [CmmActual]
args',ars :: [Reg]
ars,frs :: [Reg]
frs,code' :: OrdList Instr
code',acode' :: OrdList Instr
acode')
                     <- [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
rest [Reg]
aregs [Reg]
fregs OrdList Instr
code OrdList Instr
acode
                 ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmActual
argCmmActual -> [CmmActual] -> [CmmActual]
forall a. a -> [a] -> [a]
:[CmmActual]
args', [Reg]
ars, [Reg]
frs, OrdList Instr
code', OrdList Instr
acode')

              -- pass the arg into the given register
              reg_this_arg :: Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg r :: Reg
r
                -- "operand" args can be directly assigned into r
                | Bool -> CmmActual -> Bool
isOperand Bool
False CmmActual
arg = do
                    Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
                    (OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, (OrdList Instr
acode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
r))
                -- The last non-operand arg can be directly assigned after its
                -- computation without going into a temporary register
                | (CmmActual -> Bool) -> [CmmActual] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> CmmActual -> Bool
isOperand Bool
False) [CmmActual]
rest = do
                    Reg -> OrdList Instr
arg_code   <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
                    (OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
r,OrdList Instr
acode)

                -- other args need to be computed beforehand to avoid clobbering
                -- previously assigned registers used to pass parameters (see
                -- #11792, #12614). They are assigned into temporary registers
                -- and get assigned to proper call ABI registers after they all
                -- have been computed.
                | Bool
otherwise     = do
                    Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
                    Reg
tmp      <- Format -> NatM Reg
getNewRegNat Format
arg_fmt
                    let
                      code' :: OrdList Instr
code'  = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
tmp
                      acode' :: OrdList Instr
acode' = OrdList Instr
acode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
arg_fmt Reg
tmp Reg
r
                    (OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code',OrdList Instr
acode')

              arg_rep :: CmmType
arg_rep = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
              arg_fmt :: Format
arg_fmt = CmmType -> Format
cmmTypeFormat CmmType
arg_rep

        load_args_win :: [CmmExpr]
                      -> [Reg]        -- used int regs
                      -> [Reg]        -- used FP regs
                      -> [(Reg, Reg)] -- (int, FP) regs avail for args
                      -> InstrBlock
                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
        load_args_win :: [CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win args :: [CmmActual]
args usedInt :: [Reg]
usedInt usedFP :: [Reg]
usedFP [] code :: OrdList Instr
code
            = ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmActual]
args, [Reg]
usedInt, [Reg]
usedFP, OrdList Instr
code, OrdList Instr
forall a. OrdList a
nilOL)
            -- no more regs to use
        load_args_win [] usedInt :: [Reg]
usedInt usedFP :: [Reg]
usedFP _ code :: OrdList Instr
code
            = ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Reg]
usedInt, [Reg]
usedFP, OrdList Instr
code, OrdList Instr
forall a. OrdList a
nilOL)
            -- no more args to push
        load_args_win (arg :: CmmActual
arg : rest :: [CmmActual]
rest) usedInt :: [Reg]
usedInt usedFP :: [Reg]
usedFP
                      ((ireg :: Reg
ireg, freg :: Reg
freg) : regs :: [(Reg, Reg)]
regs) code :: OrdList Instr
code
            | CmmType -> Bool
isFloatType CmmType
arg_rep = do
                 Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
                 [CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
rest (Reg
ireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
usedInt) (Reg
freg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
usedFP) [(Reg, Reg)]
regs
                               (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                Reg -> OrdList Instr
arg_code Reg
freg OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                -- If we are calling a varargs function
                                -- then we need to define ireg as well
                                -- as freg
                                Format -> Operand -> Operand -> Instr
MOV Format
II64 (Reg -> Operand
OpReg Reg
freg) (Reg -> Operand
OpReg Reg
ireg))
            | Bool
otherwise = do
                 Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
                 [CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
rest (Reg
ireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
usedInt) [Reg]
usedFP [(Reg, Reg)]
regs
                               (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
ireg)
            where
              arg_rep :: CmmType
arg_rep = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg

        push_args :: [CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args [] code :: OrdList Instr
code = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
        push_args (arg :: CmmActual
arg:rest :: [CmmActual]
rest) code :: OrdList Instr
code
           | CmmType -> Bool
isFloatType CmmType
arg_rep = do
             (arg_reg :: Reg
arg_reg, arg_code :: OrdList Instr
arg_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
arg
             Alignment
delta <- NatM Alignment
getDeltaNat
             Alignment -> NatM ()
setDeltaNat (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
arg_size)
             let code' :: OrdList Instr
code' = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
arg_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                            Format -> Operand -> Operand -> Instr
SUB (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags)) (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt Alignment
arg_size)) (Reg -> Operand
OpReg Reg
rsp),
                            Alignment -> Instr
DELTA (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
arg_size),
                            Format -> Operand -> Operand -> Instr
MOV (Width -> Format
floatFormat Width
width) (Reg -> Operand
OpReg Reg
arg_reg) (AddrMode -> Operand
OpAddr (DynFlags -> Alignment -> AddrMode
spRel DynFlags
dflags 0))]
             [CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args [CmmActual]
rest OrdList Instr
code'

           | Bool
otherwise = do
             -- Arguments can be smaller than 64-bit, but we still use @PUSH
             -- II64@ - the usual calling conventions expect integers to be
             -- 8-byte aligned.
             ASSERT(width <= W64) return ()
             (arg_op :: Operand
arg_op, arg_code :: OrdList Instr
arg_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
arg
             Alignment
delta <- NatM Alignment
getDeltaNat
             Alignment -> NatM ()
setDeltaNat (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
arg_size)
             let code' :: OrdList Instr
code' = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
arg_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                    Format -> Operand -> Instr
PUSH Format
II64 Operand
arg_op,
                                    Alignment -> Instr
DELTA (Alignment
deltaAlignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
-Alignment
arg_size)]
             [CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args [CmmActual]
rest OrdList Instr
code'
            where
              arg_rep :: CmmType
arg_rep = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
              width :: Width
width = CmmType -> Width
typeWidth CmmType
arg_rep

        leaveStackSpace :: Alignment -> NatM (OrdList Instr)
leaveStackSpace n :: Alignment
n = do
             Alignment
delta <- NatM Alignment
getDeltaNat
             Alignment -> NatM ()
setDeltaNat (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- Alignment
n Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
* Alignment
arg_size)
             OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                         Format -> Operand -> Operand -> Instr
SUB Format
II64 (Imm -> Operand
OpImm (Alignment -> Imm
ImmInt (Alignment
n Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
* DynFlags -> Alignment
wORD_SIZE DynFlags
dflags))) (Reg -> Operand
OpReg Reg
rsp),
                         Alignment -> Instr
DELTA (Alignment
delta Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
- Alignment
n Alignment -> Alignment -> Alignment
forall a. Num a => a -> a -> a
* Alignment
arg_size)]

maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr
maybePromoteCArg :: DynFlags -> Width -> CmmActual -> CmmActual
maybePromoteCArg dflags :: DynFlags
dflags wto :: Width
wto arg :: CmmActual
arg
 | Width
wfrom Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
wto = MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv Width
wfrom Width
wto) [CmmActual
arg]
 | Bool
otherwise   = CmmActual
arg
 where
   wfrom :: Width
wfrom = DynFlags -> CmmActual -> Width
cmmExprWidth DynFlags
dflags CmmActual
arg

outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]
               -> NatM InstrBlock
outOfLineCmmOp :: Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp bid :: Label
bid mop :: CallishMachOp
mop res :: Maybe CmmFormal
res args :: [CmmActual]
args
  = do
      DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
CallReference CLabel
lbl
      let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr
                           (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [] [] CmmReturnInfo
CmmMayReturn)

      (instrs :: OrdList Instr
instrs, _) <- Label -> CmmNode O O -> NatM (OrdList Instr, Maybe Label)
forall e x.
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid (ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmNode O O
CmmUnsafeForeignCall ForeignTarget
target ([Maybe CmmFormal] -> [CmmFormal]
forall a. [Maybe a] -> [a]
catMaybes [Maybe CmmFormal
res]) [CmmActual]
args)
      OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
instrs
  where
        -- Assume we can call these functions directly, and that they're not in a dynamic library.
        -- TODO: Why is this ok? Under linux this code will be in libm.so
        --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31
        lbl :: CLabel
lbl = FastString
-> Maybe Alignment
-> ForeignLabelSource
-> FunctionOrData
-> CLabel
mkForeignLabel FastString
fn Maybe Alignment
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction

        fn :: FastString
fn = case CallishMachOp
mop of
              MO_F32_Sqrt  -> String -> FastString
fsLit "sqrtf"
              MO_F32_Fabs  -> String -> FastString
fsLit "fabsf"
              MO_F32_Sin   -> String -> FastString
fsLit "sinf"
              MO_F32_Cos   -> String -> FastString
fsLit "cosf"
              MO_F32_Tan   -> String -> FastString
fsLit "tanf"
              MO_F32_Exp   -> String -> FastString
fsLit "expf"
              MO_F32_Log   -> String -> FastString
fsLit "logf"

              MO_F32_Asin  -> String -> FastString
fsLit "asinf"
              MO_F32_Acos  -> String -> FastString
fsLit "acosf"
              MO_F32_Atan  -> String -> FastString
fsLit "atanf"

              MO_F32_Sinh  -> String -> FastString
fsLit "sinhf"
              MO_F32_Cosh  -> String -> FastString
fsLit "coshf"
              MO_F32_Tanh  -> String -> FastString
fsLit "tanhf"
              MO_F32_Pwr   -> String -> FastString
fsLit "powf"

              MO_F32_Asinh -> String -> FastString
fsLit "asinhf"
              MO_F32_Acosh -> String -> FastString
fsLit "acoshf"
              MO_F32_Atanh -> String -> FastString
fsLit "atanhf"

              MO_F64_Sqrt  -> String -> FastString
fsLit "sqrt"
              MO_F64_Fabs  -> String -> FastString
fsLit "fabs"
              MO_F64_Sin   -> String -> FastString
fsLit "sin"
              MO_F64_Cos   -> String -> FastString
fsLit "cos"
              MO_F64_Tan   -> String -> FastString
fsLit "tan"
              MO_F64_Exp   -> String -> FastString
fsLit "exp"
              MO_F64_Log   -> String -> FastString
fsLit "log"

              MO_F64_Asin  -> String -> FastString
fsLit "asin"
              MO_F64_Acos  -> String -> FastString
fsLit "acos"
              MO_F64_Atan  -> String -> FastString
fsLit "atan"

              MO_F64_Sinh  -> String -> FastString
fsLit "sinh"
              MO_F64_Cosh  -> String -> FastString
fsLit "cosh"
              MO_F64_Tanh  -> String -> FastString
fsLit "tanh"
              MO_F64_Pwr   -> String -> FastString
fsLit "pow"

              MO_F64_Asinh  -> String -> FastString
fsLit "asinh"
              MO_F64_Acosh  -> String -> FastString
fsLit "acosh"
              MO_F64_Atanh  -> String -> FastString
fsLit "atanh"

              MO_Memcpy _  -> String -> FastString
fsLit "memcpy"
              MO_Memset _  -> String -> FastString
fsLit "memset"
              MO_Memmove _ -> String -> FastString
fsLit "memmove"
              MO_Memcmp _  -> String -> FastString
fsLit "memcmp"

              MO_PopCnt _  -> String -> FastString
fsLit "popcnt"
              MO_BSwap _   -> String -> FastString
fsLit "bswap"
              MO_Clz w :: Width
w     -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
clzLabel Width
w
              MO_Ctz _     -> FastString
unsupported

              MO_Pdep w :: Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pdepLabel Width
w
              MO_Pext w :: Width
w    -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pextLabel Width
w

              MO_AtomicRMW _ _ -> String -> FastString
fsLit "atomicrmw"
              MO_AtomicRead _  -> String -> FastString
fsLit "atomicread"
              MO_AtomicWrite _ -> String -> FastString
fsLit "atomicwrite"
              MO_Cmpxchg _     -> String -> FastString
fsLit "cmpxchg"

              MO_UF_Conv _ -> FastString
unsupported

              MO_S_QuotRem {}  -> FastString
unsupported
              MO_U_QuotRem {}  -> FastString
unsupported
              MO_U_QuotRem2 {} -> FastString
unsupported
              MO_Add2 {}       -> FastString
unsupported
              MO_AddIntC {}    -> FastString
unsupported
              MO_SubIntC {}    -> FastString
unsupported
              MO_AddWordC {}   -> FastString
unsupported
              MO_SubWordC {}   -> FastString
unsupported
              MO_U_Mul2 {}     -> FastString
unsupported
              MO_ReadBarrier   -> FastString
unsupported
              MO_WriteBarrier  -> FastString
unsupported
              MO_Touch         -> FastString
unsupported
              (MO_Prefetch_Data _ ) -> FastString
unsupported
        unsupported :: FastString
unsupported = String -> FastString
forall a. String -> a
panic ("outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ " not supported here")

-- -----------------------------------------------------------------------------
-- Generating a table-branch

genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock

genSwitch :: DynFlags -> CmmActual -> SwitchTargets -> NatM (OrdList Instr)
genSwitch dflags :: DynFlags
dflags expr :: CmmActual
expr targets :: SwitchTargets
targets
  | DynFlags -> Bool
positionIndependent DynFlags
dflags
  = do
        (reg :: Reg
reg,e_code :: OrdList Instr
e_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg (DynFlags -> CmmActual -> Alignment -> CmmActual
cmmOffset DynFlags
dflags CmmActual
expr Alignment
offset)
           -- getNonClobberedReg because it needs to survive across t_code
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let is32bit :: Bool
is32bit = Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
            os :: OS
os = Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
            -- Might want to use .rodata.<function we're in> instead, but as
            -- long as it's something unique it'll work out since the
            -- references to the jump table are in the appropriate section.
            rosection :: Section
rosection = case OS
os of
              -- on Mac OS X/x86_64, put the jump table in the text section to
              -- work around a limitation of the linker.
              -- ld64 is unable to handle the relocations for
              --     .quad L1 - L0
              -- if L0 is not preceded by a non-anonymous label in its section.
              OSDarwin | Bool -> Bool
not Bool
is32bit -> SectionType -> CLabel -> Section
Section SectionType
Text CLabel
lbl
              _ -> SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl
        CmmActual
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
        (tableReg :: Reg
tableReg,t_code :: OrdList Instr
t_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg (CmmActual -> NatM (Reg, OrdList Instr))
-> CmmActual -> NatM (Reg, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmActual
dynRef
        let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
tableReg)
                                       (Reg -> Alignment -> EAIndex
EAIndex Reg
reg (DynFlags -> Alignment
wORD_SIZE DynFlags
dflags)) (Alignment -> Imm
ImmInt 0))

        Reg
offsetReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags))
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ if Bool
is32bit Bool -> Bool -> Bool
|| OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
                 then OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                Format -> Operand -> Operand -> Instr
ADD (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags)) Operand
op (Reg -> Operand
OpReg Reg
tableReg),
                                Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL (Reg -> Operand
OpReg Reg
tableReg) [Maybe JumpDest]
ids Section
rosection CLabel
lbl
                       ]
                 else -- HACK: On x86_64 binutils<2.17 is only able to generate
                      -- PC32 relocations, hence we only get 32-bit offsets in
                      -- the jump table. As these offsets are always negative
                      -- we need to properly sign extend them to 64-bit. This
                      -- hack should be removed in conjunction with the hack in
                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.
                      OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                               Format -> Operand -> Operand -> Instr
MOVSxL Format
II32 Operand
op (Reg -> Operand
OpReg Reg
offsetReg),
                               Format -> Operand -> Operand -> Instr
ADD (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags))
                                   (Reg -> Operand
OpReg Reg
offsetReg)
                                   (Reg -> Operand
OpReg Reg
tableReg),
                               Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL (Reg -> Operand
OpReg Reg
tableReg) [Maybe JumpDest]
ids Section
rosection CLabel
lbl
                       ]
  | Bool
otherwise
  = do
        (reg :: Reg
reg,e_code :: OrdList Instr
e_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg (DynFlags -> CmmActual -> Alignment -> CmmActual
cmmOffset DynFlags
dflags CmmActual
expr Alignment
offset)
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex EABase
EABaseNone (Reg -> Alignment -> EAIndex
EAIndex Reg
reg (DynFlags -> Alignment
wORD_SIZE DynFlags
dflags)) (CLabel -> Imm
ImmCLbl CLabel
lbl))
            code :: OrdList Instr
code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                    Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL Operand
op [Maybe JumpDest]
ids (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) CLabel
lbl
                 ]
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
  where
    (offset :: Alignment
offset, blockIds :: [Maybe Label]
blockIds) = SwitchTargets -> (Alignment, [Maybe Label])
switchTargetsToTable SwitchTargets
targets
    ids :: [Maybe JumpDest]
ids = (Maybe Label -> Maybe JumpDest)
-> [Maybe Label] -> [Maybe JumpDest]
forall a b. (a -> b) -> [a] -> [b]
map ((Label -> JumpDest) -> Maybe Label -> Maybe JumpDest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> JumpDest
DestBlockId) [Maybe Label]
blockIds

generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
generateJumpTableForInstr :: DynFlags
-> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
generateJumpTableForInstr dflags :: DynFlags
dflags (JMP_TBL _ ids :: [Maybe JumpDest]
ids section :: Section
section lbl :: CLabel
lbl)
    = let getBlockId :: JumpDest -> Label
getBlockId (DestBlockId id :: Label
id) = Label
id
          getBlockId _ = String -> Label
forall a. String -> a
panic "Non-Label target in Jump Table"
          blockIds :: [Maybe Label]
blockIds = (Maybe JumpDest -> Maybe Label)
-> [Maybe JumpDest] -> [Maybe Label]
forall a b. (a -> b) -> [a] -> [b]
map ((JumpDest -> Label) -> Maybe JumpDest -> Maybe Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JumpDest -> Label
getBlockId) [Maybe JumpDest]
ids
      in NatCmmDecl (Alignment, CmmStatics) Instr
-> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
forall a. a -> Maybe a
Just (DynFlags
-> [Maybe Label]
-> Section
-> CLabel
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall h g.
DynFlags
-> [Maybe Label]
-> Section
-> CLabel
-> GenCmmDecl (Alignment, CmmStatics) h g
createJumpTable DynFlags
dflags [Maybe Label]
blockIds Section
section CLabel
lbl)
generateJumpTableForInstr _ _ = Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
forall a. Maybe a
Nothing

createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel
                -> GenCmmDecl (Alignment, CmmStatics) h g
createJumpTable :: DynFlags
-> [Maybe Label]
-> Section
-> CLabel
-> GenCmmDecl (Alignment, CmmStatics) h g
createJumpTable dflags :: DynFlags
dflags ids :: [Maybe Label]
ids section :: Section
section lbl :: CLabel
lbl
    = let jumpTable :: [CmmStatic]
jumpTable
            | DynFlags -> Bool
positionIndependent DynFlags
dflags =
                  let ww :: Width
ww = DynFlags -> Width
wordWidth DynFlags
dflags
                      jumpTableEntryRel :: Maybe Label -> CmmStatic
jumpTableEntryRel Nothing
                          = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0 Width
ww)
                      jumpTableEntryRel (Just blockid :: Label
blockid)
                          = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CLabel -> Alignment -> Width -> CmmLit
CmmLabelDiffOff CLabel
blockLabel CLabel
lbl 0 Width
ww)
                          where blockLabel :: CLabel
blockLabel = Label -> CLabel
blockLbl Label
blockid
                  in (Maybe Label -> CmmStatic) -> [Maybe Label] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Label -> CmmStatic
jumpTableEntryRel [Maybe Label]
ids
            | Bool
otherwise = (Maybe Label -> CmmStatic) -> [Maybe Label] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Maybe Label -> CmmStatic
jumpTableEntry DynFlags
dflags) [Maybe Label]
ids
      in Section
-> (Alignment, CmmStatics)
-> GenCmmDecl (Alignment, CmmStatics) h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
section (1, CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmStatic]
jumpTable)

extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints instrs :: [Instr]
instrs =
    [ CLabel -> Map GlobalReg (Maybe UnwindExpr) -> UnwindPoint
UnwindPoint CLabel
lbl Map GlobalReg (Maybe UnwindExpr)
unwinds | UNWIND lbl :: CLabel
lbl unwinds :: Map GlobalReg (Maybe UnwindExpr)
unwinds <- [Instr]
instrs]

-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers

-- Turn those condition codes into integers now (when they appear on
-- the right hand side of an assignment).
--
-- (If applicable) Do not fill the delay slots here; you will confuse the
-- register allocator.

condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register

condIntReg :: Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg cond :: Cond
cond x :: CmmActual
x y :: CmmActual
y = do
  CondCode _ cond :: Cond
cond cond_code :: OrdList Instr
cond_code <- Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode Cond
cond CmmActual
x CmmActual
y
  Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II8
  let
        code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
cond_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                    Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
tmp),
                    Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
                  ]
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)


-----------------------------------------------------------
---          Note [SSE Parity Checks]                   ---
-----------------------------------------------------------

-- We have to worry about unordered operands (eg. comparisons
-- against NaN).  If the operands are unordered, the comparison
-- sets the parity flag, carry flag and zero flag.
-- All comparisons are supposed to return false for unordered
-- operands except for !=, which returns true.
--
-- Optimisation: we don't have to test the parity flag if we
-- know the test has already excluded the unordered case: eg >
-- and >= test for a zero carry flag, which can only occur for
-- ordered operands.
--
-- By reversing comparisons we can avoid testing the parity
-- for < and <= as well. If any of the arguments is an NaN we
-- return false either way. If both arguments are valid then
-- x <= y  <->  y >= x  holds. So it's safe to swap these.
--
-- We invert the condition inside getRegister'and  getCondCode
-- which should cover all invertable cases.
-- All other functions translating FP comparisons to assembly
-- use these to two generate the comparison code.
--
-- As an example consider a simple check:
--
-- func :: Float -> Float -> Int
-- func x y = if x < y then 1 else 0
--
-- Which in Cmm gives the floating point comparison.
--
--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;
--
-- We used to compile this to an assembly code block like this:
-- _c2gh:
--  ucomiss %xmm2,%xmm1
--  jp _c2gf
--  jb _c2gg
--  jmp _c2gf
--
-- Where we have to introduce an explicit
-- check for unordered results (using jmp parity):
--
-- We can avoid this by exchanging the arguments and inverting the direction
-- of the comparison. This results in the sequence of:
--
--  ucomiss %xmm1,%xmm2
--  ja _c2g2
--  jmp _c2g1
--
-- Removing the jump reduces the pressure on the branch predidiction system
-- and plays better with the uOP cache.

condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg :: Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg is32Bit :: Bool
is32Bit cond :: Cond
cond x :: CmmActual
x y :: CmmActual
y = NatM Register -> NatM Register -> NatM Register
forall a. NatM a -> NatM a -> NatM a
if_sse2 NatM Register
condFltReg_sse2 NatM Register
condFltReg_x87
 where
  condFltReg_x87 :: NatM Register
condFltReg_x87 = do
    CondCode _ cond :: Cond
cond cond_code :: OrdList Instr
cond_code <- Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
cond CmmActual
x CmmActual
y
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II8
    let
        code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
cond_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                    Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
tmp),
                    Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
                  ]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)

  condFltReg_sse2 :: NatM Register
condFltReg_sse2 = do
    CondCode _ cond :: Cond
cond cond_code :: OrdList Instr
cond_code <- Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
cond CmmActual
x CmmActual
y
    Reg
tmp1 <- Format -> NatM Reg
getNewRegNat (Bool -> Format
archWordFormat Bool
is32Bit)
    Reg
tmp2 <- Format -> NatM Reg
getNewRegNat (Bool -> Format
archWordFormat Bool
is32Bit)
    let -- See Note [SSE Parity Checks]
        code :: Reg -> OrdList Instr
code dst :: Reg
dst =
           OrdList Instr
cond_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
             (case Cond
cond of
                NE  -> Reg -> OrdList Instr
or_unordered Reg
dst
                GU  -> Reg -> OrdList Instr
plain_test   Reg
dst
                GEU -> Reg -> OrdList Instr
plain_test   Reg
dst
                -- Use ASSERT so we don't break releases if these creep in.
                LTT -> ASSERT2(False, ppr "Should have been turned into >")
                       Reg -> OrdList Instr
and_ordered  Reg
dst
                LE  -> ASSERT2(False, ppr "Should have been turned into >=")
                       Reg -> OrdList Instr
and_ordered  Reg
dst
                _   -> Reg -> OrdList Instr
and_ordered  Reg
dst)

        plain_test :: Reg -> OrdList Instr
plain_test dst :: Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                    Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
tmp1),
                    Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
tmp1) (Reg -> Operand
OpReg Reg
dst)
                 ]
        or_unordered :: Reg -> OrdList Instr
or_unordered dst :: Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                    Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
tmp1),
                    Cond -> Operand -> Instr
SETCC Cond
PARITY (Reg -> Operand
OpReg Reg
tmp2),
                    Format -> Operand -> Operand -> Instr
OR Format
II8 (Reg -> Operand
OpReg Reg
tmp1) (Reg -> Operand
OpReg Reg
tmp2),
                    Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
tmp2) (Reg -> Operand
OpReg Reg
dst)
                  ]
        and_ordered :: Reg -> OrdList Instr
and_ordered dst :: Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                    Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
tmp1),
                    Cond -> Operand -> Instr
SETCC Cond
NOTPARITY (Reg -> Operand
OpReg Reg
tmp2),
                    Format -> Operand -> Operand -> Instr
AND Format
II8 (Reg -> Operand
OpReg Reg
tmp1) (Reg -> Operand
OpReg Reg
tmp2),
                    Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
tmp2) (Reg -> Operand
OpReg Reg
dst)
                  ]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)


-- -----------------------------------------------------------------------------
-- 'trivial*Code': deal with trivial instructions

-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
-- Only look for constants on the right hand side, because that's
-- where the generic optimizer will have put them.

-- Similarly, for unary instructions, we don't have to worry about
-- matching an StInt as the argument, because genericOpt will already
-- have handled the constant-folding.


{-
The Rules of the Game are:

* You cannot assume anything about the destination register dst;
  it may be anything, including a fixed reg.

* You may compute an operand into a fixed reg, but you may not
  subsequently change the contents of that fixed reg.  If you
  want to do so, first copy the value either to a temporary
  or into dst.  You are free to modify dst even if it happens
  to be a fixed reg -- that's not your problem.

* You cannot assume that a fixed reg will stay live over an
  arbitrary computation.  The same applies to the dst reg.

* Temporary regs obtained from getNewRegNat are distinct from
  each other and from all other regs, and stay live over
  arbitrary computations.

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

SDM's version of The Rules:

* If getRegister returns Any, that means it can generate correct
  code which places the result in any register, period.  Even if that
  register happens to be read during the computation.

  Corollary #1: this means that if you are generating code for an
  operation with two arbitrary operands, you cannot assign the result
  of the first operand into the destination register before computing
  the second operand.  The second operand might require the old value
  of the destination register.

  Corollary #2: A function might be able to generate more efficient
  code if it knows the destination register is a new temporary (and
  therefore not read by any of the sub-computations).

* If getRegister returns Any, then the code it generates may modify only:
        (a) fresh temporaries
        (b) the destination register
        (c) known registers (eg. %ecx is used by shifts)
  In particular, it may *not* modify global registers, unless the global
  register happens to be the destination register.
-}

trivialCode :: Width -> (Operand -> Operand -> Instr)
            -> Maybe (Operand -> Operand -> Instr)
            -> CmmExpr -> CmmExpr -> NatM Register
trivialCode :: Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode width :: Width
width instr :: Operand -> Operand -> Instr
instr m :: Maybe (Operand -> Operand -> Instr)
m a :: CmmActual
a b :: CmmActual
b
    = do Bool
is32Bit <- NatM Bool
is32BitPlatform
         Bool
-> Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode' Bool
is32Bit Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
m CmmActual
a CmmActual
b

trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)
             -> Maybe (Operand -> Operand -> Instr)
             -> CmmExpr -> CmmExpr -> NatM Register
trivialCode' :: Bool
-> Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode' is32Bit :: Bool
is32Bit width :: Width
width _ (Just revinstr :: Operand -> Operand -> Instr
revinstr) (CmmLit lit_a :: CmmLit
lit_a) b :: CmmActual
b
  | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit_a = do
  Reg -> OrdList Instr
b_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
b
  let
       code :: Reg -> OrdList Instr
code dst :: Reg
dst
         = Reg -> OrdList Instr
b_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
           Operand -> Operand -> Instr
revinstr (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit_a)) (Reg -> Operand
OpReg Reg
dst)
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
width) Reg -> OrdList Instr
code)

trivialCode' _ width :: Width
width instr :: Operand -> Operand -> Instr
instr _ a :: CmmActual
a b :: CmmActual
b
  = Format
-> (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
genTrivialCode (Width -> Format
intFormat Width
width) Operand -> Operand -> Instr
instr CmmActual
a CmmActual
b

-- This is re-used for floating pt instructions too.
genTrivialCode :: Format -> (Operand -> Operand -> Instr)
               -> CmmExpr -> CmmExpr -> NatM Register
genTrivialCode :: Format
-> (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
genTrivialCode rep :: Format
rep instr :: Operand -> Operand -> Instr
instr a :: CmmActual
a b :: CmmActual
b = do
  (b_op :: Operand
b_op, b_code :: OrdList Instr
b_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand CmmActual
b
  Reg -> OrdList Instr
a_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
a
  Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
  let
     -- We want the value of b to stay alive across the computation of a.
     -- But, we want to calculate a straight into the destination register,
     -- because the instruction only has two operands (dst := dst `op` src).
     -- The troublesome case is when the result of b is in the same register
     -- as the destination reg.  In this case, we have to save b in a
     -- new temporary across the computation of a.
     code :: Reg -> OrdList Instr
code dst :: Reg
dst
        | Reg
dst Reg -> Operand -> Bool
`regClashesWithOp` Operand
b_op =
                OrdList Instr
b_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
rep Operand
b_op (Reg -> Operand
OpReg Reg
tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Reg -> OrdList Instr
a_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Operand -> Operand -> Instr
instr (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
        | Bool
otherwise =
                OrdList Instr
b_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Reg -> OrdList Instr
a_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Operand -> Operand -> Instr
instr Operand
b_op (Reg -> Operand
OpReg Reg
dst)
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
rep Reg -> OrdList Instr
code)

regClashesWithOp :: Reg -> Operand -> Bool
reg :: Reg
reg regClashesWithOp :: Reg -> Operand -> Bool
`regClashesWithOp` OpReg reg2 :: Reg
reg2   = Reg
reg Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
reg2
reg :: Reg
reg `regClashesWithOp` OpAddr amode :: AddrMode
amode = (Reg -> Bool) -> [Reg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
==Reg
reg) (AddrMode -> [Reg]
addrModeRegs AddrMode
amode)
_   `regClashesWithOp` _            = Bool
False

-----------

trivialUCode :: Format -> (Operand -> Instr)
             -> CmmExpr -> NatM Register
trivialUCode :: Format -> (Operand -> Instr) -> CmmActual -> NatM Register
trivialUCode rep :: Format
rep instr :: Operand -> Instr
instr x :: CmmActual
x = do
  Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
  let
     code :: Reg -> OrdList Instr
code dst :: Reg
dst =
        Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Operand -> Instr
instr (Reg -> Operand
OpReg Reg
dst)
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
rep Reg -> OrdList Instr
code)

-----------

trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr)
                 -> CmmExpr -> CmmExpr -> NatM Register
trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmActual -> CmmActual -> NatM Register
trivialFCode_x87 instr :: Format -> Reg -> Reg -> Reg -> Instr
instr x :: CmmActual
x y :: CmmActual
y = do
  (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
x -- these work for float regs too
  (y_reg :: Reg
y_reg, y_code :: OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
y
  let
     format :: Format
format = Format
FF80 -- always, on x87
     code :: Reg -> OrdList Instr
code dst :: Reg
dst =
        OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
        OrdList Instr
y_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Format -> Reg -> Reg -> Reg -> Instr
instr Format
format Reg
x_reg Reg
y_reg Reg
dst
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)
                  -> CmmExpr -> CmmExpr -> NatM Register
trivialFCode_sse2 :: Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 pk :: Width
pk instr :: Format -> Operand -> Operand -> Instr
instr x :: CmmActual
x y :: CmmActual
y
    = Format
-> (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
genTrivialCode Format
format (Format -> Operand -> Operand -> Instr
instr Format
format) CmmActual
x CmmActual
y
    where format :: Format
format = Width -> Format
floatFormat Width
pk


trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmActual -> NatM Register
trivialUFCode format :: Format
format instr :: Reg -> Reg -> Instr
instr x :: CmmActual
x = do
  (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
  let
     code :: Reg -> OrdList Instr
code dst :: Reg
dst =
        OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Reg -> Reg -> Instr
instr Reg
x_reg Reg
dst
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)


--------------------------------------------------------------------------------
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP :: Width -> Width -> CmmActual -> NatM Register
coerceInt2FP from :: Width
from to :: Width
to x :: CmmActual
x = NatM Register -> NatM Register -> NatM Register
forall a. NatM a -> NatM a -> NatM a
if_sse2 NatM Register
coerce_sse2 NatM Register
coerce_x87
 where
   coerce_x87 :: NatM Register
coerce_x87 = do
     (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
     let
           opc :: Reg -> Reg -> Instr
opc  = case Width
to of W32 -> Reg -> Reg -> Instr
GITOF; W64 -> Reg -> Reg -> Instr
GITOD;
                             n :: Width
n -> String -> Reg -> Reg -> Instr
forall a. String -> a
panic (String -> Reg -> Reg -> Instr) -> String -> Reg -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ "coerceInt2FP.x87: unhandled width ("
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
           code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
opc Reg
x_reg Reg
dst
        -- ToDo: works for non-II32 reps?
     Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
FF80 Reg -> OrdList Instr
code)

   coerce_sse2 :: NatM Register
coerce_sse2 = do
     (x_op :: Operand
x_op, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
x  -- ToDo: could be a safe operand
     let
           opc :: Format -> Operand -> Reg -> Instr
opc  = case Width
to of W32 -> Format -> Operand -> Reg -> Instr
CVTSI2SS; W64 -> Format -> Operand -> Reg -> Instr
CVTSI2SD
                             n :: Width
n -> String -> Format -> Operand -> Reg -> Instr
forall a. String -> a
panic (String -> Format -> Operand -> Reg -> Instr)
-> String -> Format -> Operand -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ "coerceInt2FP.sse: unhandled width ("
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
           code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Reg -> Instr
opc (Width -> Format
intFormat Width
from) Operand
x_op Reg
dst
     Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) Reg -> OrdList Instr
code)
        -- works even if the destination rep is <II32

--------------------------------------------------------------------------------
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int :: Width -> Width -> CmmActual -> NatM Register
coerceFP2Int from :: Width
from to :: Width
to x :: CmmActual
x = NatM Register -> NatM Register -> NatM Register
forall a. NatM a -> NatM a -> NatM a
if_sse2 NatM Register
coerceFP2Int_sse2 NatM Register
coerceFP2Int_x87
 where
   coerceFP2Int_x87 :: NatM Register
coerceFP2Int_x87 = do
     (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
     let
           opc :: Reg -> Reg -> Instr
opc  = case Width
from of W32 -> Reg -> Reg -> Instr
GFTOI; W64 -> Reg -> Reg -> Instr
GDTOI
                               n :: Width
n -> String -> Reg -> Reg -> Instr
forall a. String -> a
panic (String -> Reg -> Reg -> Instr) -> String -> Reg -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ "coerceFP2Int.x87: unhandled width ("
                                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
           code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
opc Reg
x_reg Reg
dst
        -- ToDo: works for non-II32 reps?
     Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> OrdList Instr
code)

   coerceFP2Int_sse2 :: NatM Register
coerceFP2Int_sse2 = do
     (x_op :: Operand
x_op, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
x  -- ToDo: could be a safe operand
     let
           opc :: Format -> Operand -> Reg -> Instr
opc  = case Width
from of W32 -> Format -> Operand -> Reg -> Instr
CVTTSS2SIQ; W64 -> Format -> Operand -> Reg -> Instr
CVTTSD2SIQ;
                               n :: Width
n -> String -> Format -> Operand -> Reg -> Instr
forall a. String -> a
panic (String -> Format -> Operand -> Reg -> Instr)
-> String -> Format -> Operand -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ "coerceFP2Init.sse: unhandled width ("
                                           String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
           code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Reg -> Instr
opc (Width -> Format
intFormat Width
to) Operand
x_op Reg
dst
     Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> OrdList Instr
code)
         -- works even if the destination rep is <II32


--------------------------------------------------------------------------------
coerceFP2FP :: Width -> CmmExpr -> NatM Register
coerceFP2FP :: Width -> CmmActual -> NatM Register
coerceFP2FP to :: Width
to x :: CmmActual
x = do
  Bool
use_sse2 <- NatM Bool
sse2Enabled
  (x_reg :: Reg
x_reg, x_code :: OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
  let
        opc :: Reg -> Reg -> Instr
opc | Bool
use_sse2  = case Width
to of W32 -> Reg -> Reg -> Instr
CVTSD2SS; W64 -> Reg -> Reg -> Instr
CVTSS2SD;
                                     n :: Width
n -> String -> Reg -> Reg -> Instr
forall a. String -> a
panic (String -> Reg -> Reg -> Instr) -> String -> Reg -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ "coerceFP2FP: unhandled width ("
                                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
            | Bool
otherwise = Reg -> Reg -> Instr
GDTOF
        code :: Reg -> OrdList Instr
code dst :: Reg
dst = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
opc Reg
x_reg Reg
dst
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (if Bool
use_sse2 then Width -> Format
floatFormat Width
to else Format
FF80) Reg -> OrdList Instr
code)

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

sse2NegCode :: Width -> CmmExpr -> NatM Register
sse2NegCode :: Width -> CmmActual -> NatM Register
sse2NegCode w :: Width
w x :: CmmActual
x = do
  let fmt :: Format
fmt = Width -> Format
floatFormat Width
w
  Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
  -- This is how gcc does it, so it can't be that bad:
  let
    const :: CmmLit
const = case Format
fmt of
      FF32 -> Integer -> Width -> CmmLit
CmmInt 0x80000000 Width
W32
      FF64 -> Integer -> Width -> CmmLit
CmmInt 0x8000000000000000 Width
W64
      x :: Format
x@Format
II8  -> Format -> CmmLit
forall a a. Show a => a -> a
wrongFmt Format
x
      x :: Format
x@Format
II16 -> Format -> CmmLit
forall a a. Show a => a -> a
wrongFmt Format
x
      x :: Format
x@Format
II32 -> Format -> CmmLit
forall a a. Show a => a -> a
wrongFmt Format
x
      x :: Format
x@Format
II64 -> Format -> CmmLit
forall a a. Show a => a -> a
wrongFmt Format
x
      x :: Format
x@Format
FF80 -> Format -> CmmLit
forall a a. Show a => a -> a
wrongFmt Format
x
      where
        wrongFmt :: a -> a
wrongFmt x :: a
x = String -> a
forall a. String -> a
panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "sse2NegCode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
  Amode amode :: AddrMode
amode amode_code :: OrdList Instr
amode_code <- Alignment -> CmmLit -> NatM Amode
memConstant (Width -> Alignment
widthInBytes Width
w) CmmLit
const
  Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
  let
    code :: Reg -> OrdList Instr
code dst :: Reg
dst = Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
amode_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
        Format -> Operand -> Operand -> Instr
MOV Format
fmt (AddrMode -> Operand
OpAddr AddrMode
amode) (Reg -> Operand
OpReg Reg
tmp),
        Format -> Operand -> Operand -> Instr
XOR Format
fmt (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
        ]
  --
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt Reg -> OrdList Instr
code)

isVecExpr :: CmmExpr -> Bool
isVecExpr :: CmmActual -> Bool
isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = Bool
True
isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = Bool
True
isVecExpr (CmmMachOp (MO_V_Add {}) _)      = Bool
True
isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = Bool
True
isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = Bool
True
isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = Bool
True
isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = Bool
True
isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = Bool
True
isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = Bool
True
isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = Bool
True
isVecExpr (CmmMachOp _ [e :: CmmActual
e])                = CmmActual -> Bool
isVecExpr CmmActual
e
isVecExpr _                                = Bool
False

needLlvm :: NatM a
needLlvm :: NatM a
needLlvm =
    String -> NatM a
forall a. String -> a
sorry (String -> NatM a) -> String -> NatM a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ["The native code generator does not support vector"
                    ,"instructions. Please use -fllvm."]

-- | This works on the invariant that all jumps in the given blocks are required.
--   Starting from there we try to make a few more jumps redundant by reordering
--   them.
--   We depend on the information in the CFG to do so. Without a given CFG
--   we do nothing.
invertCondBranches :: Maybe CFG  -- ^ CFG if present
                   -> LabelMap a -- ^ Blocks with info tables
                   -> [NatBasicBlock Instr] -- ^ List of basic blocks
                   -> [NatBasicBlock Instr]
invertCondBranches :: Maybe CFG
-> LabelMap a -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invertCondBranches Nothing _       bs :: [NatBasicBlock Instr]
bs = [NatBasicBlock Instr]
bs
invertCondBranches (Just cfg :: CFG
cfg) keep :: LabelMap a
keep bs :: [NatBasicBlock Instr]
bs =
    [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invert [NatBasicBlock Instr]
bs
  where
    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invert ((BasicBlock lbl1 :: Label
lbl1 ins :: [Instr]
ins@(_:_:_xs :: [Instr]
_xs)):b2 :: NatBasicBlock Instr
b2@(BasicBlock lbl2 :: Label
lbl2 _):bs :: [NatBasicBlock Instr]
bs)
      | --pprTrace "Block" (ppr lbl1) True,
        (jmp1 :: Instr
jmp1,jmp2 :: Instr
jmp2) <- [Instr] -> (Instr, Instr)
forall a. [a] -> (a, a)
last2 [Instr]
ins
      , JXX cond1 :: Cond
cond1 target1 :: Label
target1 <- Instr
jmp1
      , Label
target1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
lbl2
      --, pprTrace "CutChance" (ppr b1) True
      , JXX ALWAYS target2 :: Label
target2 <- Instr
jmp2
      -- We have enough information to check if we can perform the inversion
      -- TODO: We could also check for the last asm instruction which sets
      -- status flags instead. Which I suspect is worse in terms of compiler
      -- performance, but might be applicable to more cases
      , Just edgeInfo1 :: EdgeInfo
edgeInfo1 <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
lbl1 Label
target1 CFG
cfg
      , Just edgeInfo2 :: EdgeInfo
edgeInfo2 <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
lbl1 Label
target2 CFG
cfg
      -- Both jumps come from the same cmm statement
      , EdgeInfo -> TransitionSource
transitionSource EdgeInfo
edgeInfo1 TransitionSource -> TransitionSource -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeInfo -> TransitionSource
transitionSource EdgeInfo
edgeInfo2
      , CmmSource cmmCondBranch :: CmmNode O C
cmmCondBranch <- EdgeInfo -> TransitionSource
transitionSource EdgeInfo
edgeInfo1

      --Int comparisons are invertable
      , CmmCondBranch (CmmMachOp op :: MachOp
op _args :: [CmmActual]
_args) _ _ _ <- CmmNode O C
cmmCondBranch
      , Just _ <- MachOp -> Maybe Width
maybeIntComparison MachOp
op
      , Just invCond :: Cond
invCond <- Cond -> Maybe Cond
maybeInvertCond Cond
cond1

      --Swap the last two jumps, invert the conditional jumps condition.
      = let jumps :: [Instr]
jumps =
              case () of
                -- We are free the eliminate the jmp. So we do so.
                _ | Bool -> Bool
not (KeyOf LabelMap -> LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
Label
target1 LabelMap a
keep)
                    -> [Cond -> Label -> Instr
JXX Cond
invCond Label
target2]
                -- If the conditional target is unlikely we put the other
                -- target at the front.
                  | EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo2 EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
> EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo1
                    -> [Cond -> Label -> Instr
JXX Cond
invCond Label
target2, Cond -> Label -> Instr
JXX Cond
ALWAYS Label
target1]
                -- Keep things as-is otherwise
                  | Bool
otherwise
                    -> [Instr
jmp1, Instr
jmp2]
        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $
           (Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
lbl1
            (Alignment -> [Instr] -> [Instr]
forall a. Alignment -> [a] -> [a]
dropTail 2 [Instr]
ins [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Instr]
jumps))
            NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invert (NatBasicBlock Instr
b2NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
:[NatBasicBlock Instr]
bs)
    invert (b :: NatBasicBlock Instr
b:bs :: [NatBasicBlock Instr]
bs) = NatBasicBlock Instr
b NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invert [NatBasicBlock Instr]
bs
    invert [] = []