{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}

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

-----------------------------------------------------------------------------
--
-- 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 GHC.CmmToAsm.X86.CodeGen (
        cmmTopCodeGen,
        generateJumpTableForInstr,
        extractUnwindPoints,
        invertCondBranches,
        InstrBlock
)

where

-- NCG stuff:
import GHC.Prelude

import GHC.CmmToAsm.X86.Instr
import GHC.CmmToAsm.X86.Cond
import GHC.CmmToAsm.X86.Regs
import GHC.CmmToAsm.X86.Ppr
import GHC.CmmToAsm.X86.RegInfo

import GHC.Platform.Regs
import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Types
import GHC.Cmm.DebugBlock
   ( DebugBlock(..), UnwindPoint(..), UnwindTable
   , UnwindExpr(UwReg), toUnwindExpr
   )
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Monad
   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat
   , getDeltaNat, getBlockIdNat, getPicBaseNat
   , Reg64(..), RegCode64(..), getNewReg64, localReg64
   , getPicBaseMaybeNat, getDebugBlock, getFileId
   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform
   , getCfgWeights
   )
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Config
import GHC.Platform.Reg
import GHC.Platform

-- Our intermediate code:
import GHC.Types.Basic
import GHC.Cmm.BlockId
import GHC.Unit.Types ( primUnitId )
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.CLabel
import GHC.Types.Tickish ( GenTickish(..) )
import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )

-- The rest:
import GHC.Types.ForeignCall ( CCallConv(..) )
import GHC.Data.OrdList
import GHC.Utils.Outputable
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Types.Unique.Supply ( getUniqueM )

import Control.Monad
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
    Platform
platform <- NatM Platform
getPlatform
    Bool -> NatM Bool
forall a. a -> NatM a
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 Platform
platform

expect32BitPlatform :: SDoc -> NatM ()
expect32BitPlatform :: SDoc -> NatM ()
expect32BitPlatform SDoc
doc = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Bool -> NatM () -> NatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
is32Bit) (NatM () -> NatM ()) -> NatM () -> NatM ()
forall a b. (a -> b) -> a -> b
$
    String -> SDoc -> NatM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Expecting 32-bit platform" SDoc
doc

sse2Enabled :: NatM Bool
sse2Enabled :: NatM Bool
sse2Enabled = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  Bool -> NatM Bool
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (NCGConfig -> Maybe SseVersion
ncgSseVersion NCGConfig
config Maybe SseVersion -> Maybe SseVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= SseVersion -> Maybe SseVersion
forall a. a -> Maybe a
Just SseVersion
SSE2)

sse4_2Enabled :: NatM Bool
sse4_2Enabled :: NatM Bool
sse4_2Enabled = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  Bool -> NatM Bool
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (NCGConfig -> Maybe SseVersion
ncgSseVersion NCGConfig
config Maybe SseVersion -> Maybe SseVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= SseVersion -> Maybe SseVersion
forall a. a -> Maybe a
Just SseVersion
SSE42)

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

cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
cmmTopCodeGen (CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalReg]
live CmmGraph
graph) = do
  let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
  ([[NatBasicBlock Instr]]
nat_blocks,[[NatCmmDecl (Alignment, RawCmmStatics) Instr]]
statics) <- (CmmBlock
 -> NatM
      ([NatBasicBlock Instr],
       [NatCmmDecl (Alignment, RawCmmStatics) Instr]))
-> [CmmBlock]
-> NatM
     ([[NatBasicBlock Instr]],
      [[NatCmmDecl (Alignment, RawCmmStatics) Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CmmBlock
-> NatM
     ([NatBasicBlock Instr],
      [NatCmmDecl (Alignment, RawCmmStatics) Instr])
basicBlockCodeGen [CmmBlock]
blocks
  Maybe Reg
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat
  Platform
platform <- NatM Platform
getPlatform
  let proc :: NatCmmDecl (Alignment, RawCmmStatics) Instr
proc = LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl (Alignment, RawCmmStatics) Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
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, RawCmmStatics) Instr]
tops = NatCmmDecl (Alignment, RawCmmStatics) Instr
proc NatCmmDecl (Alignment, RawCmmStatics) Instr
-> [NatCmmDecl (Alignment, RawCmmStatics) Instr]
-> [NatCmmDecl (Alignment, RawCmmStatics) Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl (Alignment, RawCmmStatics) Instr]]
-> [NatCmmDecl (Alignment, RawCmmStatics) Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl (Alignment, RawCmmStatics) Instr]]
statics
      os :: OS
os   = Platform -> OS
platformOS Platform
platform

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

cmmTopCodeGen (CmmData Section
sec RawCmmStatics
dat) =
  [NatCmmDecl (Alignment, RawCmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Section
-> (Alignment, RawCmmStatics)
-> NatCmmDecl (Alignment, RawCmmStatics) Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (Int -> Alignment
mkAlignment Int
1, RawCmmStatics
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 :: Platform -> [Instr] -> ()
verifyBasicBlock :: Platform -> [Instr] -> ()
verifyBasicBlock Platform
platform [Instr]
instrs
  | Bool
debugIsOn     = Bool -> [Instr] -> ()
go Bool
False [Instr]
instrs
  | Bool
otherwise     = ()
  where
    go :: Bool -> [Instr] -> ()
go Bool
_     [] = ()
    go Bool
atEnd (Instr
i:[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.
            Instr
_ | Bool -> Bool
not Bool
atEnd -> Bool -> [Instr] -> ()
go (Instr -> Bool
isJumpishInstr Instr
i) [Instr]
instr
              -- Only jumps allowed at the end of basic blocks.
              | Bool
otherwise -> if Instr -> Bool
isJumpishInstr Instr
i
                                then Bool -> [Instr] -> ()
go Bool
True [Instr]
instr
                                else Instr -> ()
faultyBlockWith Instr
i
    faultyBlockWith :: Instr -> ()
faultyBlockWith Instr
i
        = String -> SDoc -> ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Non control flow instructions after end of basic block."
                   (Platform -> Instr -> SDoc
forall doc. IsDoc doc => Platform -> Instr -> doc
pprInstr Platform
platform Instr
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Instr -> SDoc) -> [Instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Instr -> SDoc
forall doc. IsDoc doc => Platform -> Instr -> doc
pprInstr Platform
platform) [Instr]
instrs))

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

basicBlockCodeGen :: CmmBlock
-> NatM
     ([NatBasicBlock Instr],
      [NatCmmDecl (Alignment, RawCmmStatics) Instr])
basicBlockCodeGen CmmBlock
block = do
  let (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      id :: Label
id = CmmBlock -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
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 (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
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 RealSrcSpan
span (LexicalFastString FastString
name))
      -> do Int
fileId <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line :: Int
line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col :: Int
col = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
            OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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
$ Int -> Int -> Int -> String -> Instr
LOCATION Int
fileId Int
line Int
col (FastString -> String
unpackFS FastString
name)
    Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
  (OrdList Instr
mid_instrs,Label
mid_bid) <- Label -> [CmmNode O O] -> NatM (OrdList Instr, Label)
stmtsToInstrs Label
id [CmmNode O O]
stmts
  (!OrdList Instr
tail_instrs,Maybe Label
_) <- Label -> CmmNode O C -> NatM (OrdList Instr, Maybe Label)
forall (e :: Extensibility) (x :: Extensibility).
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
  Platform
platform <- NatM Platform
getPlatform
  () -> NatM ()
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> NatM ()) -> () -> NatM ()
forall a b. (a -> b) -> a -> b
$! Platform -> [Instr] -> ()
verifyBasicBlock Platform
platform (OrdList Instr -> [Instr]
forall a. OrdList a -> [a]
fromOL OrdList Instr
instrs)
  OrdList Instr
instrs' <- OrdList (OrdList Instr) -> OrdList Instr
forall m. Monoid m => OrdList m -> m
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OrdList a -> f (OrdList 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
        ([Instr]
top,[NatBasicBlock Instr]
other_blocks,[NatCmmDecl (Alignment, RawCmmStatics) Instr]
statics) = (Instr
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl (Alignment, RawCmmStatics) Instr])
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl (Alignment, RawCmmStatics) Instr]))
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, RawCmmStatics) Instr])
-> OrdList Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, RawCmmStatics) Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, RawCmmStatics) Instr])
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl (Alignment, RawCmmStatics) Instr])
forall {h} {g}.
Instr
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, RawCmmStatics) h g])
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, RawCmmStatics) h g])
mkBlocks ([],[],[]) OrdList Instr
instrs'

        mkBlocks :: Instr
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, RawCmmStatics) h g])
-> ([Instr], [NatBasicBlock Instr],
    [GenCmmDecl (Alignment, RawCmmStatics) h g])
mkBlocks (NEWBLOCK Label
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl (Alignment, RawCmmStatics) 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, RawCmmStatics) h g]
statics)
        mkBlocks (LDATA Section
sec (Alignment, RawCmmStatics)
dat) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl (Alignment, RawCmmStatics) h g]
statics)
          = ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section
-> (Alignment, RawCmmStatics)
-> GenCmmDecl (Alignment, RawCmmStatics) h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (Alignment, RawCmmStatics)
datGenCmmDecl (Alignment, RawCmmStatics) h g
-> [GenCmmDecl (Alignment, RawCmmStatics) h g]
-> [GenCmmDecl (Alignment, RawCmmStatics) h g]
forall a. a -> [a] -> [a]
:[GenCmmDecl (Alignment, RawCmmStatics) h g]
statics)
        mkBlocks Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl (Alignment, RawCmmStatics) h g]
statics)
          = (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl (Alignment, RawCmmStatics) h g]
statics)
  ([NatBasicBlock Instr],
 [NatCmmDecl (Alignment, RawCmmStatics) Instr])
-> NatM
     ([NatBasicBlock Instr],
      [NatCmmDecl (Alignment, RawCmmStatics) Instr])
forall a. a -> NatM a
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, RawCmmStatics) Instr]
statics)

-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
-- for details.
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings instr :: Instr
instr@(DELTA Int
d) = do
    NCGConfig
config <- NatM NCGConfig
getConfig
    let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
    if NCGConfig -> Bool
ncgDwarfUnwindings NCGConfig
config
        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
$ GlobalRegUse -> Int -> UnwindExpr
UwReg (GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
MachSp (Platform -> CmmType
bWord Platform
platform)) (Int -> UnwindExpr) -> Int -> UnwindExpr
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
negate Int
d)
                OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
instr)
addSpUnwindings Instr
instr = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 genForeignCall is also split into two parts.  One for calls which
*won't* change the basic blocks in which successive instructions will be
placed (since they only evaluate CmmExpr, which can only contain MachOps, which
cannot introduce basic blocks in their lowerings).  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 Label
bid [CmmNode O O]
stmts =
    Label
-> [CmmNode O O] -> OrdList Instr -> NatM (OrdList Instr, Label)
forall {e :: Extensibility} {x :: Extensibility}.
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 Label
bid  []        OrdList Instr
instrs = (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs,Label
bid)
    go Label
bid (CmmNode e x
s:[CmmNode e x]
stmts)  OrdList Instr
instrs = do
      (OrdList Instr
instrs',Maybe Label
bid') <- Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
forall (e :: Extensibility) (x :: Extensibility).
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 :: forall (e :: Extensibility) (x :: Extensibility).
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid CmmNode e x
stmt = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Platform
platform <- NatM Platform
getPlatform
  case CmmNode e x
stmt of
    CmmUnsafeForeignCall ForeignTarget
target [LocalReg]
result_regs [CmmExpr]
args
       -> ForeignTarget
-> [LocalReg]
-> [CmmExpr]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genForeignCall ForeignTarget
target [LocalReg]
result_regs [CmmExpr]
args Label
bid

    CmmNode e x
_ -> (,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 FastString
s   -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

      CmmUnwind [(GlobalReg, Maybe CmmExpr)]
regs -> do
        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
            to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> Map GlobalReg (Maybe UnwindExpr)
to_unwind_entry (GlobalReg
reg, Maybe CmmExpr
expr) = GlobalReg -> Maybe UnwindExpr -> Map GlobalReg (Maybe UnwindExpr)
forall k a. k -> a -> Map k a
M.singleton GlobalReg
reg ((CmmExpr -> UnwindExpr) -> Maybe CmmExpr -> Maybe UnwindExpr
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform -> CmmExpr -> UnwindExpr
toUnwindExpr Platform
platform) Maybe CmmExpr
expr)
        case ((GlobalReg, Maybe CmmExpr) -> Map GlobalReg (Maybe UnwindExpr))
-> [(GlobalReg, Maybe CmmExpr)] -> Map GlobalReg (Maybe UnwindExpr)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GlobalReg, Maybe CmmExpr) -> Map GlobalReg (Maybe UnwindExpr)
to_unwind_entry [(GlobalReg, Maybe CmmExpr)]
regs of
          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 a. a -> NatM a
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 a. a -> NatM a
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 CmmReg
reg CmmExpr
src
        | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmExpr
src
        | Bool
is32Bit Bool -> Bool -> Bool
&& CmmType -> Bool
isWord64 CmmType
ty -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_I64Code      CmmReg
reg CmmExpr
src
        | Bool
otherwise              -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
format CmmReg
reg CmmExpr
src
          where ty :: CmmType
ty = CmmReg -> CmmType
cmmRegType CmmReg
reg
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

      CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
_alignment
        | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
        | Bool
is32Bit Bool -> Bool -> Bool
&& CmmType -> Bool
isWord64 CmmType
ty -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code      CmmExpr
addr CmmExpr
src
        | Bool
otherwise              -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
format CmmExpr
addr CmmExpr
src
          where ty :: CmmType
ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
src
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

      CmmBranch Label
id          -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
      CmmCondBranch CmmExpr
arg Label
true Label
false Maybe Bool
_ -> Label -> Label -> Label -> CmmExpr -> NatM (OrdList Instr)
genCondBranch Label
bid Label
true Label
false CmmExpr
arg
      CmmSwitch CmmExpr
arg SwitchTargets
ids -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch CmmExpr
arg SwitchTargets
ids
      CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg
              , cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args_regs = [GlobalReg]
gregs } -> CmmExpr -> [Reg] -> NatM (OrdList Instr)
genJump CmmExpr
arg (Platform -> [GlobalReg] -> [Reg]
jumpRegs Platform
platform [GlobalReg]
gregs)
      CmmNode e x
_ ->
        String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"stmtToInstrs: statement should have been cps'd away"


jumpRegs :: Platform -> [GlobalReg] -> [Reg]
jumpRegs :: Platform -> [GlobalReg] -> [Reg]
jumpRegs Platform
platform [GlobalReg]
gregs = [ RealReg -> Reg
RegReal RealReg
r | Just 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 ]

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


-- | 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 Format
_ Reg
reg OrdList Instr
code) Format
format = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
reg OrdList Instr
code
swizzleRegisterRep (Any Format
_ Reg -> OrdList Instr
codefn)     Format
format = Format -> (Reg -> OrdList Instr) -> Register
Any   Format
format Reg -> OrdList Instr
codefn

getLocalRegReg :: LocalReg -> Reg
getLocalRegReg :: LocalReg -> Reg
getLocalRegReg (LocalReg Unique
u CmmType
pk)
  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated
    VirtualReg -> Reg
RegVirtual (Unique -> Format -> VirtualReg
mkVirtualReg Unique
u (CmmType -> Format
cmmTypeFormat CmmType
pk))

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

getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg Platform
_   (CmmLocal LocalReg
lreg) = LocalReg -> Reg
getLocalRegReg LocalReg
lreg

getRegisterReg Platform
platform  (CmmGlobal GlobalRegUse
mid)
  = case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform (GlobalReg -> Maybe RealReg) -> GlobalReg -> Maybe RealReg
forall a b. (a -> b) -> a -> b
$ GlobalRegUse -> GlobalReg
globalRegUseGlobalReg GlobalRegUse
mid of
        Just RealReg
reg -> RealReg -> Reg
RegReal (RealReg -> Reg) -> RealReg -> Reg
forall a b. (a -> b) -> a -> b
$ RealReg
reg
        Maybe RealReg
Nothing  -> String -> SDoc -> Reg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmReg -> SDoc) -> CmmReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
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) ...
-}

{-
Note [%rip-relative addressing on x86-64]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,
"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of
specification version 0.99).

In general the small code model would allow us to assume that code is located
between 0 and 2^31 - 1. However, this is not true on Windows which, due to
high-entropy ASLR, may place the executable image anywhere in 64-bit address
space. This is problematic since immediate operands in x86-64 are generally
32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).
Consequently, to avoid overflowing we use %rip-relative addressing universally.
Since %rip-relative addressing comes essentially for free and makes linking far
easier, we use it even on non-Windows platforms.

See also: the documentation for GCC's `-mcmodel=small` flag.
-}


-- | 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 Integer
i = Int64
i64 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
0x7fffffff Bool -> Bool -> Bool
&& Int64
i64 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= -Int64
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 :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry :: NCGConfig -> Maybe Label -> CmmStatic
jumpTableEntry NCGConfig
config Maybe Label
Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
jumpTableEntry NCGConfig
_ (Just 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 :: CmmReg -> Int -> CmmExpr
mangleIndexTree :: CmmReg -> Int -> CmmExpr
mangleIndexTree CmmReg
reg Int
off
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)]
  where width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType 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 :: CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr = do
  Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  case Register
r of
    Any Format
rep Reg -> OrdList Instr
code -> do
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
    Fixed Format
_ Reg
reg OrdList Instr
code ->
        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, OrdList Instr
code)


assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code CmmExpr
addrTree CmmExpr
valueTree = do
  Amode AddrMode
addr OrdList Instr
addr_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
addrTree
  RegCode64 OrdList Instr
vcode Reg
rhi Reg
rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
valueTree
  let
        -- 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 -> Int -> Maybe AddrMode
addrOffset AddrMode
addr Int
4)))
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 -> CmmExpr -> NatM (OrdList Instr)
assignReg_I64Code (CmmLocal LocalReg
dst) CmmExpr
valueTree = do
   RegCode64 OrdList Instr
vcode Reg
r_src_hi Reg
r_src_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
valueTree
   let
         Reg64 Reg
r_dst_hi Reg
r_dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
         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 a. a -> NatM a
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 CmmReg
_ CmmExpr
_
   = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"assignReg_I64Code(i386): invalid lvalue"


iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 (CmmLit (CmmInt Integer
i Width
_)) = do
  Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
  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 -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
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)
                ]
  RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
code Reg
rhi Reg
rlo)

iselExpr64 (CmmLoad CmmExpr
addrTree CmmType
ty AlignmentSpec
_) | CmmType -> Bool
isWord64 CmmType
ty = do
   Amode AddrMode
addr OrdList Instr
addr_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
addrTree
   Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
   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 -> Int -> Maybe AddrMode
addrOffset AddrMode
addr Int
4))) (Reg -> Operand
OpReg Reg
rhi)
   RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (
            OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 (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
rhi Reg
rlo
     )

iselExpr64 (CmmReg (CmmLocal LocalReg
local_reg)) = do
  let Reg64 Reg
hi Reg
lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
local_reg
  RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
forall a. OrdList a
nilOL Reg
hi Reg
lo)

-- we handle addition, but rather badly
iselExpr64 (CmmMachOp (MO_Add Width
_) [CmmExpr
e1, CmmLit (CmmInt Integer
i Width
_)]) = do
   RegCode64 OrdList Instr
code1 Reg
r1hi Reg
r1lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
   Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
   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 -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word32)
        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) ]
   RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
code Reg
rhi Reg
rlo)

iselExpr64 (CmmMachOp (MO_Add Width
_) [CmmExpr
e1,CmmExpr
e2]) = do
   RegCode64 OrdList Instr
code1 Reg
r1hi Reg
r1lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
   RegCode64 OrdList Instr
code2 Reg
r2hi Reg
r2lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e2
   Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
   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
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) ]
   RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
code Reg
rhi Reg
rlo)

iselExpr64 (CmmMachOp (MO_Sub Width
_) [CmmExpr
e1,CmmExpr
e2]) = do
   RegCode64 OrdList Instr
code1 Reg
r1hi Reg
r1lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
   RegCode64 OrdList Instr
code2 Reg
r2hi Reg
r2lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e2
   Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
   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
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) ]
   RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
code Reg
rhi Reg
rlo)

iselExpr64 (CmmMachOp (MO_UU_Conv Width
_ Width
W64) [CmmExpr
expr]) = do
     Reg -> OrdList Instr
code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
expr
     Reg64 Reg
r_dst_hi Reg
r_dst_lo <- NatM Reg64
getNewReg64
     RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr)))
-> RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 (Reg -> OrdList Instr
code Reg
r_dst_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                          Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) (Reg -> Operand
OpReg Reg
r_dst_hi))
                          Reg
r_dst_hi
                          Reg
r_dst_lo

iselExpr64 (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmExpr
expr]) = do
     Reg -> OrdList Instr
code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
expr
     Reg64 Reg
r_dst_hi Reg
r_dst_lo <- NatM Reg64
getNewReg64
     RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr)))
-> RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 (Reg -> OrdList Instr
code 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
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_hi
                          Reg
r_dst_lo

iselExpr64 CmmExpr
expr
   = do
      Platform
platform <- NatM Platform
getPlatform
      String -> SDoc -> NatM (RegCode64 (OrdList Instr))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"iselExpr64(i386)" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)


--------------------------------------------------------------------------------
getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister CmmExpr
e = do Platform
platform <- NatM Platform
getPlatform
                   Bool
is32Bit <- NatM Bool
is32BitPlatform
                   Platform -> Bool -> CmmExpr -> NatM Register
getRegister' Platform
platform Bool
is32Bit CmmExpr
e

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

getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register
getRegister' Platform
_ Bool
is32Bit (CmmReg CmmReg
reg)
  = case CmmReg
reg of
        CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)
         | 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 a. a -> NatM a
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)
        CmmReg
_ ->
            do
               let
                 fmt :: Format
fmt = CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg)
                 format :: Format
format  = Format
fmt
               --
               Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
               Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format
                             (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg)
                             OrdList Instr
forall a. OrdList a
nilOL)


getRegister' Platform
platform Bool
is32Bit (CmmRegOff CmmReg
r Int
n)
  = Platform -> Bool -> CmmExpr -> NatM Register
getRegister' Platform
platform Bool
is32Bit (CmmExpr -> NatM Register) -> CmmExpr -> NatM Register
forall a b. (a -> b) -> a -> b
$ CmmReg -> Int -> CmmExpr
mangleIndexTree CmmReg
r Int
n

getRegister' Platform
platform Bool
is32Bit (CmmMachOp (MO_AlignmentCheck Int
align Width
_) [CmmExpr
e])
  = Int -> Register -> Register
addAlignmentCheck Int
align (Register -> Register) -> NatM Register -> NatM Register
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Platform -> Bool -> CmmExpr -> NatM Register
getRegister' Platform
platform Bool
is32Bit CmmExpr
e

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

getRegister' Platform
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W64 Width
W32)
                     [CmmMachOp (MO_U_Shr Width
W64) [CmmExpr
x,CmmLit (CmmInt Integer
32 Width
_)]])
 | Bool
is32Bit = do
  RegCode64 OrdList Instr
code Reg
rhi Reg
_rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall a. a -> NatM a
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
rhi OrdList Instr
code

getRegister' Platform
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W64 Width
W32)
                     [CmmMachOp (MO_U_Shr Width
W64) [CmmExpr
x,CmmLit (CmmInt Integer
32 Width
_)]])
 | Bool
is32Bit = do
  RegCode64 OrdList Instr
code Reg
rhi Reg
_rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall a. a -> NatM a
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
rhi OrdList Instr
code

getRegister' Platform
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W64 Width
W32) [CmmExpr
x])
 | Bool
is32Bit = do
  RegCode64 OrdList Instr
code Reg
_rhi Reg
rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall a. a -> NatM a
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' Platform
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W64 Width
W32) [CmmExpr
x])
 | Bool
is32Bit = do
  RegCode64 OrdList Instr
code Reg
_rhi Reg
rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall a. a -> NatM a
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' Platform
_ Bool
_ (CmmLit lit :: CmmLit
lit@(CmmFloat Rational
f Width
w)) =
  NatM Register
float_const_sse2  where
  float_const_sse2 :: NatM Register
float_const_sse2
    | Rational
f Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0.0 = do
      let
          format :: Format
format = Width -> Format
floatFormat Width
w
          code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 AddrMode
addr OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Int -> Alignment
mkAlignment (Int -> Alignment) -> Int -> Alignment
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBytes Width
w) CmmLit
lit
      Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode Width
w AddrMode
addr OrdList Instr
code

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

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

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

getRegister' Platform
_ Bool
_ (CmmMachOp (MO_SS_Conv Width
W16 Width
W32) [CmmLoad CmmExpr
addr CmmType
_ AlignmentSpec
_]) = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II16) CmmExpr
addr
  Register -> NatM Register
forall a. a -> NatM a
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' Platform
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W8 Width
W64) [CmmLoad CmmExpr
addr CmmType
_ AlignmentSpec
_])
 | Bool -> Bool
not Bool
is32Bit = do
  Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8) CmmExpr
addr
  Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)

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

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

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

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

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

getRegister' Platform
_ Bool
is32Bit (CmmMachOp (MO_Add Width
W64) [CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)),
                                     CmmLit CmmLit
displacement])
 | Bool -> Bool
not Bool
is32Bit =
      Register -> NatM Register
forall a. a -> NatM a
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 (\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' Platform
platform Bool
is32Bit (CmmMachOp MachOp
mop [CmmExpr
x]) = -- unary MachOps
    case MachOp
mop of
      MO_F_Neg Width
w  -> Width -> CmmExpr -> NatM Register
sse2NegCode Width
w CmmExpr
x


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

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

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

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

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

      MO_SS_Conv Width
W8  Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8  Width
W32 Format -> Operand -> Operand -> Instr
MOVSxL CmmExpr
x
      MO_SS_Conv Width
W16 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOVSxL CmmExpr
x
      MO_SS_Conv Width
W8  Width
W16 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8  Width
W16 Format -> Operand -> Operand -> Instr
MOVSxL CmmExpr
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 Width
W8  Width
W32
          | Bool
is32Bit   -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmExpr
x
          | Bool
otherwise -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOV CmmExpr
x
      MO_XX_Conv Width
W8  Width
W16
          | Bool
is32Bit   -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOVZxL CmmExpr
x
          | Bool
otherwise -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOV CmmExpr
x
      MO_XX_Conv Width
W16 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOV CmmExpr
x

      MO_UU_Conv Width
W8  Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8  Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmExpr
x
      MO_UU_Conv Width
W16 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmExpr
x
      MO_UU_Conv Width
W32 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmExpr
x
      MO_SS_Conv Width
W8  Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8  Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmExpr
x
      MO_SS_Conv Width
W16 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmExpr
x
      MO_SS_Conv Width
W32 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmExpr
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 Width
W8  Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W8  Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmExpr
x
      MO_XX_Conv Width
W16 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmExpr
x
      MO_XX_Conv Width
W32 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmExpr
x

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


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

      MO_FS_Conv Width
from Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
from Width
to CmmExpr
x
      MO_SF_Conv Width
from Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
from Width
to CmmExpr
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

      MachOp
_other -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 Format -> Operand -> Instr
instr Format
format = Format -> (Operand -> Instr) -> CmmExpr -> NatM Register
trivialUCode Format
format (Format -> Operand -> Instr
instr Format
format) CmmExpr
x

        -- signed or unsigned extension.
        integerExtend :: Width -> Width
                      -> (Format -> Operand -> Operand -> Instr)
                      -> CmmExpr -> NatM Register
        integerExtend :: Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> NatM Register
integerExtend Width
from Width
to Format -> Operand -> Operand -> Instr
instr CmmExpr
expr = do
            (Reg
reg,OrdList Instr
e_code) <- if Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then CmmExpr -> NatM (Reg, OrdList Instr)
getByteReg CmmExpr
expr
                                          else CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
            let
                code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 -> CmmExpr -> NatM Register
toI8Reg Width
new_rep CmmExpr
expr
            = do Reg -> OrdList Instr
codefn <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
expr
                 Register -> NatM Register
forall a. a -> NatM a
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 -> CmmExpr -> NatM Register
toI16Reg = Width -> CmmExpr -> NatM Register
toI8Reg -- for now

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


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

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

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

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

      MO_F_Add  Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
ADD  CmmExpr
x CmmExpr
y
      MO_F_Sub  Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
SUB  CmmExpr
x CmmExpr
y
      MO_F_Quot Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
FDIV CmmExpr
x CmmExpr
y
      MO_F_Mul  Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
MUL  CmmExpr
x CmmExpr
y

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

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

      MO_S_MulMayOflo Width
rep -> Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo Width
rep CmmExpr
x CmmExpr
y

      MO_Mul Width
W8  -> CmmExpr -> CmmExpr -> NatM Register
imulW8 CmmExpr
x CmmExpr
y
      MO_Mul Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
IMUL
      MO_And Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
AND
      MO_Or  Width
rep -> Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
rep Format -> Operand -> Operand -> Instr
OR
      MO_Xor 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 Width
rep   -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SHL CmmExpr
x CmmExpr
y {-False-}
      MO_U_Shr Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SHR CmmExpr
x CmmExpr
y {-False-}
      MO_S_Shr Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SAR CmmExpr
x CmmExpr
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

      MachOp
_other -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(x86) - binary CmmMachOp (1)" (MachOp -> SDoc
pprMachOp MachOp
mop)
  where
    --------------------
    triv_op :: Width -> (Format -> Operand -> Operand -> Instr) -> NatM Register
triv_op Width
width Format -> Operand -> Operand -> Instr
instr = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> 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) CmmExpr
x CmmExpr
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 :: CmmExpr -> CmmExpr -> NatM Register
imulW8 CmmExpr
arg_a CmmExpr
arg_b = do
        (Reg
a_reg, OrdList Instr
a_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
arg_a
        Reg -> OrdList Instr
b_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
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 a. a -> NatM a
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 -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo Width
W8 CmmExpr
a CmmExpr
b = do
         -- The general case (W16, W32, W64) doesn't work for W8 as its
         -- multiplication doesn't use two registers.
         --
         -- The plan is:
         -- 1. truncate and sign-extend a and b to 8bit width
         -- 2. multiply a' = a * b in 32bit width
         -- 3. copy and sign-extend 8bit from a' to c
         -- 4. compare a' and c: they are equal if there was no overflow
         (Reg
a_reg, OrdList Instr
a_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
a
         (Reg
b_reg, OrdList Instr
b_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
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` 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
toOL [
                           Format -> Operand -> Operand -> Instr
MOVSxL Format
II8 (Reg -> Operand
OpReg Reg
a_reg) (Reg -> Operand
OpReg Reg
a_reg),
                           Format -> Operand -> Operand -> Instr
MOVSxL Format
II8 (Reg -> Operand
OpReg Reg
b_reg) (Reg -> Operand
OpReg Reg
b_reg),
                           Format -> Operand -> Operand -> Instr
IMUL Format
II32 (Reg -> Operand
OpReg Reg
b_reg) (Reg -> Operand
OpReg Reg
a_reg),
                           Format -> Operand -> Operand -> Instr
MOVSxL Format
II8 (Reg -> Operand
OpReg Reg
a_reg) (Reg -> Operand
OpReg Reg
eax),
                           Format -> Operand -> Operand -> Instr
CMP Format
II16 (Reg -> Operand
OpReg Reg
a_reg) (Reg -> Operand
OpReg Reg
eax),
                           Cond -> Operand -> Instr
SETCC Cond
NE (Reg -> Operand
OpReg Reg
eax)
                        ]
         Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
II8 Reg
eax OrdList Instr
code)
    imulMayOflo Width
rep CmmExpr
a CmmExpr
b = do
         (Reg
a_reg, OrdList Instr
a_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
a
         Reg -> OrdList Instr
b_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
b
         let
             shift_amt :: Int
shift_amt  = case Width
rep of
                           Width
W16 -> Int
15
                           Width
W32 -> Int
31
                           Width
W64 -> Int
63
                           Width
w -> String -> Int
forall a. HasCallStack => String -> a
panic (String
"shift_amt: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
w)

             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 (Int -> Imm
ImmInt Int
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 a. a -> NatM a
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)
-> CmmExpr
-> CmmExpr
-> NatM Register
shift_code Width
width Format -> Operand -> Operand -> Instr
instr CmmExpr
x (CmmLit CmmLit
lit)
      -- Handle the case of a shift larger than the width of the shifted value.
      -- This is necessary since x86 applies a mask of 0x1f to the shift
      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by
      -- `47 & 0x1f == 15`. See #20626.
      | CmmInt Integer
n Width
_ <- CmmLit
lit
      , Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
width)
      = CmmExpr -> NatM Register
getRegister (CmmExpr -> NatM Register) -> CmmExpr -> NatM Register
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
0 Width
width

      | Bool
otherwise = do
          Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
x
          let
               format :: Format
format = Width -> Format
intFormat Width
width
               code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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).
      * in the case of C calls the use of ecx here can interfere with arguments.
        We avoid this with the hack described in Note [Evaluate C-call
        arguments before placing in destination registers]
    -}
    shift_code Width
width Format -> Operand -> Operand -> Instr
instr CmmExpr
x CmmExpr
y{-amount-} = do
        Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
x
        let format :: Format
format = Width -> Format
intFormat Width
width
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
format
        Reg -> OrdList Instr
y_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
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 a. a -> NatM a
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 -> CmmExpr -> CmmExpr -> NatM Register
add_code Width
rep CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
        | Integer -> Bool
is32BitInteger Integer
y
        , Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= Width
W8 -- LEA doesn't support byte size (#18614)
        = Width -> CmmExpr -> Integer -> NatM Register
add_int Width
rep CmmExpr
x Integer
y
    add_code Width
rep CmmExpr
x CmmExpr
y = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> 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)) CmmExpr
x CmmExpr
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 -> CmmExpr -> CmmExpr -> NatM Register
sub_code Width
rep CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
        | Integer -> Bool
is32BitInteger (-Integer
y)
        , Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= Width
W8 -- LEA doesn't support byte size (#18614)
        = Width -> CmmExpr -> Integer -> NatM Register
add_int Width
rep CmmExpr
x (-Integer
y)
    sub_code Width
rep CmmExpr
x CmmExpr
y = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep (Format -> Operand -> Operand -> Instr
SUB (Width -> Format
intFormat Width
rep)) Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing CmmExpr
x CmmExpr
y

    -- our three-operand add instruction:
    add_int :: Width -> CmmExpr -> Integer -> NatM Register
add_int Width
width CmmExpr
x Integer
y = do
        (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        let
            format :: Format
format = Width -> Format
intFormat Width
width
            imm :: Imm
imm = Int -> Imm
ImmInt (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
y)
            code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 -> CmmExpr -> CmmExpr -> NatM Register
div_code Width
W8 Bool
signed Bool
quotient CmmExpr
x CmmExpr
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 -> CmmExpr -> CmmExpr -> NatM Register
div_code
            Width
W16
            Bool
signed
            Bool
quotient
            (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
widen [CmmExpr
x])
            (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
widen [CmmExpr
y])

    div_code Width
width Bool
signed Bool
quotient CmmExpr
x CmmExpr
y = do
           (Operand
y_op, OrdList Instr
y_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getRegOrMem CmmExpr
y -- cannot be clobbered
           Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
result OrdList Instr
code)

getRegister' Platform
_plat Bool
_is32Bit (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y, CmmExpr
z]) = -- ternary MachOps
  case MachOp
mop of
      -- Floating point fused multiply-add operations @ ± x*y ± z@
      MO_FMA FMASign
var Width
w -> Width -> FMASign -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register
genFMA3Code Width
w FMASign
var CmmExpr
x CmmExpr
y CmmExpr
z

      MachOp
_other -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(x86) - ternary CmmMachOp (1)"
                  (MachOp -> SDoc
pprMachOp MachOp
mop)

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

getRegister' Platform
_ Bool
is32Bit (CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_)
  | Bool
is32Bit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk)
  = do
    Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode Operand -> Operand -> Instr
instr CmmExpr
mem
    Register -> NatM Register
forall a. a -> NatM a
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
                Width
W8     -> Format -> Operand -> Operand -> Instr
MOVZxL Format
II8
                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' Platform
_ Bool
is32Bit (CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_)
 | Bool -> Bool
not Bool
is32Bit
  = do
    Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
format) CmmExpr
mem
    Register -> NatM Register
forall a. a -> NatM a
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' Platform
_ Bool
is32Bit (CmmLit (CmmInt Integer
0 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
                                Format
II64 -> Format
II32
                                Format
_ -> Format
format
        code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

-- Handle symbol references with LEA and %rip-relative addressing.
-- See Note [%rip-relative addressing on x86-64].
getRegister' Platform
platform Bool
is32Bit (CmmLit CmmLit
lit)
  | CmmLit -> Bool
is_label CmmLit
lit
  , Bool -> Bool
not Bool
is32Bit
  = do let format :: Format
format = CmmType -> Format
cmmTypeFormat (Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit)
           imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
           op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex EABase
EABaseRip EAIndex
EAIndexNone Imm
imm)
           code :: Reg -> OrdList Instr
code Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
LEA Format
format Operand
op (Reg -> Operand
OpReg Reg
dst))
       Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
  where
    is_label :: CmmLit -> Bool
is_label (CmmLabel {})        = Bool
True
    is_label (CmmLabelOff {})     = Bool
True
    is_label (CmmLabelDiffOff {}) = Bool
True
    is_label CmmLit
_                    = Bool
False

  -- 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' Platform
platform Bool
is32Bit (CmmLit CmmLit
lit)
  | Bool -> Bool
not Bool
is32Bit, CmmType -> Bool
isWord64 (Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit), Bool -> Bool
not (CmmLit -> Bool
isBigLit CmmLit
lit)
  = let
        imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
        code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 Integer
i Width
_) = Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0xffffffff
   isBigLit CmmLit
_ = 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 Note [%rip-relative addressing on x86-64].

getRegister' Platform
platform Bool
_ (CmmLit CmmLit
lit)
  = do let format :: Format
format = CmmType -> Format
cmmTypeFormat (Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit)
           imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
           code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)

getRegister' Platform
platform Bool
_ CmmExpr
other
    | CmmExpr -> Bool
isVecExpr CmmExpr
other  = NatM Register
forall a. NatM a
needLlvm
    | Bool
otherwise        = String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(x86)" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
other)


intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
   -> NatM (Reg -> InstrBlock)
intLoadCode :: (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode Operand -> Operand -> Instr
instr CmmExpr
mem = do
  Amode AddrMode
src OrdList Instr
mem_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
  (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (\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 :: CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
expr = do
  Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  Register -> NatM (Reg -> OrdList Instr)
anyReg Register
r

anyReg :: Register -> NatM (Reg -> InstrBlock)
anyReg :: Register -> NatM (Reg -> OrdList Instr)
anyReg (Any Format
_ Reg -> OrdList Instr
code)          = (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return Reg -> OrdList Instr
code
anyReg (Fixed Format
rep Reg
reg OrdList Instr
fcode) = (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (\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 :: CmmExpr -> NatM (Reg, OrdList Instr)
getByteReg CmmExpr
expr = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  if Bool
is32Bit
      then do Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
              case Register
r of
                Any Format
rep Reg -> OrdList Instr
code -> do
                    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
                    (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
                Fixed Format
rep Reg
reg OrdList Instr
code
                    | Reg -> Bool
isVirtualReg Reg
reg -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
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 a. a -> NatM a
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 CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 :: CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
expr = do
  Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
  case Register
r of
    Any Format
rep Reg -> OrdList Instr
code -> do
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
    Fixed Format
rep Reg
reg OrdList Instr
code
        -- only certain regs can be clobbered
        | Reg
reg Reg -> [Reg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Platform -> [Reg]
instrClobberedRegs Platform
platform
        -> do
                Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
                (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
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 a. a -> NatM a
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 Reg
src Reg
dst = Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
src) (Reg -> Operand
OpReg Reg
dst)


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

-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.
--
-- An 'Amode' is a datatype representing a valid address form for the target
-- (e.g. "Base + Index + disp" or immediate) and the code to compute it.
getAmode :: CmmExpr -> NatM Amode
getAmode :: CmmExpr -> NatM Amode
getAmode CmmExpr
e = do
   Platform
platform <- NatM Platform
getPlatform
   let is32Bit :: Bool
is32Bit = Platform -> Bool
target32Bit Platform
platform

   case CmmExpr
e of
      CmmRegOff CmmReg
r Int
n
         -> CmmExpr -> NatM Amode
getAmode (CmmExpr -> NatM Amode) -> CmmExpr -> NatM Amode
forall a b. (a -> b) -> a -> b
$ CmmReg -> Int -> CmmExpr
mangleIndexTree CmmReg
r Int
n

      CmmMachOp (MO_Add Width
W64) [CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)), CmmLit CmmLit
displacement]
         | Bool -> Bool
not Bool
is32Bit
         -> Amode -> NatM Amode
forall a. a -> NatM a
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.
      CmmMachOp (MO_Sub Width
_rep) [CmmExpr
x, CmmLit lit :: CmmLit
lit@(CmmInt Integer
i Width
_)]
         | Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit
         -- assert (rep == II32)???
         -> do
            (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
            let off :: Imm
off = Int -> Imm
ImmInt (-(Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i))
            Amode -> NatM Amode
forall a. a -> NatM a
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)

      CmmMachOp (MO_Add Width
_rep) [CmmExpr
x, CmmLit CmmLit
lit]
         | Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit
         -- assert (rep == II32)???
         -> do
            (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
            let off :: Imm
off = CmmLit -> Imm
litToImm CmmLit
lit
            Amode -> NatM Amode
forall a. a -> NatM a
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.
      CmmMachOp (MO_Add Width
rep) [a :: CmmExpr
a@(CmmMachOp (MO_Shl Width
_) [CmmExpr]
_), b :: CmmExpr
b@(CmmLit CmmLit
_)]
         -> CmmExpr -> NatM Amode
getAmode (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
rep) [CmmExpr
b,CmmExpr
a])

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

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

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

      CmmMachOp (MO_Add Width
_) [CmmExpr
x,CmmExpr
y]
         | Bool -> Bool
not (CmmExpr -> Bool
isLit CmmExpr
y) -- we already handle valid literals above.
         -> CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmExpr
x CmmExpr
y Integer
0 Integer
0

      -- Handle labels with %rip-relative addressing since in general the image
      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows
      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].
      CmmLit CmmLit
lit
         | Bool -> Bool
not Bool
is32Bit
         , CmmLit -> Bool
is_label CmmLit
lit
         -> Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex EABase
EABaseRip EAIndex
EAIndexNone (CmmLit -> Imm
litToImm CmmLit
lit)) OrdList Instr
forall a. OrdList a
nilOL)

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

      -- Literal with offsets too big (> 32 bits) fails during the linking phase
      -- (#15570). We already handled valid literals above so we don't have to
      -- test anything here.
      CmmLit (CmmLabelOff CLabel
l Int
off)
         -> CmmExpr -> NatM Amode
getAmode (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
W64) [ CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
l)
                                             , CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
W64)
                                             ])
      CmmLit (CmmLabelDiffOff CLabel
l1 CLabel
l2 Int
off Width
w)
         -> CmmExpr -> NatM Amode
getAmode (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
W64) [ CmmLit -> CmmExpr
CmmLit (CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
l1 CLabel
l2 Int
0 Width
w)
                                             , CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
W64)
                                             ])

      -- in case we can't do something better, we just compute the expression
      -- and put the result in a register
      CmmExpr
_ -> do
        (Reg
reg,OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
e
        Amode -> NatM Amode
forall a. a -> NatM a
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 (Int -> Imm
ImmInt Int
0)) OrdList Instr
code)
  where
    is_label :: CmmLit -> Bool
is_label (CmmLabel{}) = Bool
True
    is_label (CmmLabelOff{}) = Bool
True
    is_label (CmmLabelDiffOff{}) = Bool
True
    is_label CmmLit
_ = Bool
False


-- | 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 :: CmmExpr -> NatM Amode
getSimpleAmode :: CmmExpr -> NatM Amode
getSimpleAmode CmmExpr
addr = NatM Bool
is32BitPlatform NatM Bool -> (Bool -> NatM Amode) -> NatM Amode
forall a b. NatM a -> (a -> NatM b) -> NatM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> CmmExpr -> NatM Amode
getAmode CmmExpr
addr
  Bool
True  -> do
    Reg -> OrdList Instr
addr_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
addr
    NCGConfig
config <- NatM NCGConfig
getConfig
    Reg
addr_r <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
    let amode :: AddrMode
amode = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
addr_r) EAIndex
EAIndexNone (Int -> Imm
ImmInt Int
0)
    Amode -> NatM Amode
forall a. a -> NatM a
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)

x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmExpr
base CmmExpr
index Integer
shift Integer
offset
  = do (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
base
        -- x must be in a temp, because it has to stay live over y_code
        -- we could compare x_reg and y_reg and do something better here...
       (Reg
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 :: Int
base = case Integer
shift of Integer
0 -> Int
1; Integer
1 -> Int
2; Integer
2 -> Int
4; Integer
3 -> Int
8;
                                Integer
n -> String -> Int
forall a. HasCallStack => String -> a
panic (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
")"
       Amode -> NatM Amode
forall a. a -> NatM a
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 -> Int -> EAIndex
EAIndex Reg
y_reg Int
base) (Int -> Imm
ImmInt (Integer -> Int
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 :: CmmExpr -> NatM (Operand, OrdList Instr)
getNonClobberedOperand (CmmLit CmmLit
lit) =
  if CmmLit -> Bool
isSuitableFloatingPointLit CmmLit
lit
  then do
    let CmmFloat Rational
_ Width
w = CmmLit
lit
    Amode AddrMode
addr OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Int -> Alignment
mkAlignment (Int -> Alignment) -> Int -> Alignment
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBytes Width
w) CmmLit
lit
    (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
addr, OrdList Instr
code)
  else do
    Platform
platform <- NatM Platform
getPlatform
    if Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType (Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit))
    then (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
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 CmmExpr -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic (CmmLit -> CmmExpr
CmmLit CmmLit
lit)

getNonClobberedOperand (CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_) = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  -- this logic could be simplified
  -- TODO FIXME
  if   (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
      -- if 32bit and pk is at float/double/simd value
      -- or if 64bit
      --  this could use some eyeballs or i'll need to stare at it more later
    then do
      Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
      Amode AddrMode
src OrdList Instr
mem_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
      (AddrMode
src',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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
tmp) EAIndex
EAIndexNone (Int -> Imm
ImmInt Int
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 a. a -> NatM a
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 a. a -> NatM a
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
      -- if its a word or gcptr on 32bit?
      CmmExpr -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
NaturallyAligned)

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

getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic CmmExpr
e = do
  (Reg
reg, OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
e
  (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
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 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 (RegReal (RealRegSingle Int
rr)) = Platform -> Int -> Bool
freeReg Platform
platform Int
rr
regClobbered Platform
_ Reg
_ = Bool
False

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

getOperand :: CmmExpr -> NatM (Operand, OrdList Instr)
getOperand (CmmLit 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 Rational
_ Width
w = CmmLit
lit
      Amode AddrMode
addr OrdList Instr
code <- Alignment -> CmmLit -> NatM Amode
memConstant (Int -> Alignment
mkAlignment (Int -> Alignment) -> Int -> Alignment
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBytes Width
w) CmmLit
lit
      (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
addr, OrdList Instr
code)
    else do

  Platform
platform <- NatM Platform
getPlatform
  if Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType (Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit))
    then (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
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 CmmExpr -> NatM (Operand, OrdList Instr)
getOperand_generic (CmmLit -> CmmExpr
CmmLit CmmLit
lit)

getOperand (CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_) = 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 AddrMode
src OrdList Instr
mem_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
       (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src, OrdList Instr
mem_code)
     else
       CmmExpr -> NatM (Operand, OrdList Instr)
getOperand_generic (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
NaturallyAligned)

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

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

isOperand :: Platform -> CmmExpr -> Bool
isOperand :: Platform -> CmmExpr -> Bool
isOperand Platform
_ (CmmLoad CmmExpr
_ CmmType
_ AlignmentSpec
_) = Bool
True
isOperand Platform
platform (CmmLit CmmLit
lit)
                          = Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit
                          Bool -> Bool -> Bool
|| CmmLit -> Bool
isSuitableFloatingPointLit CmmLit
lit
isOperand Platform
_ CmmExpr
_            = 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 :: Int -> Register -> Register
addAlignmentCheck Int
align Register
reg =
    case Register
reg of
      Fixed Format
fmt Reg
reg 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 Format
fmt Reg -> OrdList Instr
f          -> Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt (\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 Format
fmt Reg
reg =
        Bool -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Format -> Bool
isFloatFormat Format
fmt) (OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$
        [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
$ Int -> Imm
ImmInt (Int -> Imm) -> Int -> Imm
forall a b. (a -> b) -> a -> b
$ Int
alignInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 :: Alignment -> CmmLit -> NatM Amode
memConstant :: Alignment -> CmmLit -> NatM Amode
memConstant Alignment
align CmmLit
lit = do
  CLabel
lbl <- NatM CLabel
getNewLabelNat
  let rosection :: Section
rosection = SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl
  NCGConfig
config <- NatM NCGConfig
getConfig
  Platform
platform <- NatM Platform
getPlatform
  (AddrMode
addr, OrdList Instr
addr_code) <- if Platform -> Bool
target32Bit Platform
platform
                       then do CmmExpr
dynRef <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference
                                             NCGConfig
config
                                             ReferenceKind
DataReference
                                             CLabel
lbl
                               Amode AddrMode
addr OrdList Instr
addr_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
dynRef
                               (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
addr, OrdList Instr
addr_code)
                       else (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall a. a -> NatM a
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, RawCmmStatics) -> Instr
LDATA Section
rosection (Alignment
align, CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw 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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode AddrMode
addr OrdList Instr
code)


loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register
loadFloatAmode :: Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode Width
w AddrMode
addr OrdList Instr
addr_code = do
  let format :: Format
format = Width -> Format
floatFormat Width
w
      code :: Reg -> OrdList Instr
code Reg
dst = OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Operand -> Operand -> Instr
MOV Format
format (AddrMode -> Operand
OpAddr AddrMode
addr) (Reg -> Operand
OpReg Reg
dst)

  Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format 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 Rational
f Width
_) = Rational
f Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0.0
isSuitableFloatingPointLit CmmLit
_ = Bool
False

getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
getRegOrMem :: CmmExpr -> NatM (Operand, OrdList Instr)
getRegOrMem e :: CmmExpr
e@(CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_) = 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 AddrMode
src OrdList Instr
mem_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
       (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src, OrdList Instr
mem_code)
     else do
       (Reg
reg, OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
e
       (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)
getRegOrMem CmmExpr
e = do
    (Reg
reg, OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
e
    (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)

is32BitLit :: Platform -> CmmLit -> Bool
is32BitLit :: Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
_lit
   | Platform -> Bool
target32Bit Platform
platform = Bool
True
is32BitLit Platform
platform CmmLit
lit =
   case CmmLit
lit of
      CmmInt Integer
i Width
W64              -> Integer -> Bool
is32BitInteger Integer
i
      -- Except on Windows, assume that labels are in the range 0-2^31-1: this
      -- assumes the small memory model. Note [%rip-relative addressing on
      -- x86-64].
      CmmLabel CLabel
_                -> Bool
low_image
      -- however we can't assume that label offsets are in this range
      -- (see #15570)
      CmmLabelOff CLabel
_ Int
off         -> Bool
low_image Bool -> Bool -> Bool
&& Integer -> Bool
is32BitInteger (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off)
      CmmLabelDiffOff CLabel
_ CLabel
_ Int
off Width
_ -> Bool
low_image Bool -> Bool -> Bool
&& Integer -> Bool
is32BitInteger (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off)
      CmmLit
_                         -> Bool
True
  where
    -- Is the executable image certain to be located below 4GB? As noted in
    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.
    low_image :: Bool
low_image =
      case Platform -> OS
platformOS Platform
platform of
        OS
OSMinGW32 -> Bool
False   -- See Note [%rip-relative addressing on x86-64]
        OS
_         -> 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 :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y])
  =
    case MachOp
mop of
      MO_F_Eq Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
EQQ CmmExpr
x CmmExpr
y
      MO_F_Ne Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
NE  CmmExpr
x CmmExpr
y
      MO_F_Gt Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT CmmExpr
x CmmExpr
y
      MO_F_Ge Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE  CmmExpr
x CmmExpr
y
      -- Invert comparison condition and swap operands
      -- See Note [SSE Parity Checks]
      MO_F_Lt Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT  CmmExpr
y CmmExpr
x
      MO_F_Le Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE   CmmExpr
y CmmExpr
x

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

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

getCondCode CmmExpr
other = do
   Platform
platform <- NatM Platform
getPlatform
   String -> SDoc -> NatM CondCode
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getCondCode(2)(x86,x86_64)" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
other)

machOpToCond :: MachOp -> Cond
machOpToCond :: MachOp -> Cond
machOpToCond MachOp
mo = case MachOp
mo of
  MO_Eq Width
_   -> Cond
EQQ
  MO_Ne Width
_   -> Cond
NE
  MO_S_Gt Width
_ -> Cond
GTT
  MO_S_Ge Width
_ -> Cond
GE
  MO_S_Lt Width
_ -> Cond
LTT
  MO_S_Le Width
_ -> Cond
LE
  MO_U_Gt Width
_ -> Cond
GU
  MO_U_Ge Width
_ -> Cond
GEU
  MO_U_Lt Width
_ -> Cond
LU
  MO_U_Le Width
_ -> Cond
LEU
  MachOp
_other -> String -> SDoc -> Cond
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond CmmExpr
x CmmExpr
y = do Platform
platform <- NatM Platform
getPlatform
                          Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' Platform
platform Cond
cond CmmExpr
x CmmExpr
y

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

-- memory vs immediate
condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' Platform
platform Cond
cond (CmmLoad CmmExpr
x CmmType
pk AlignmentSpec
_) (CmmLit CmmLit
lit)
 | Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit = do
    Amode AddrMode
x_addr OrdList Instr
x_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
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 a. a -> NatM a
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' Platform
platform Cond
cond (CmmMachOp (MO_And Width
_) [CmmExpr
x,CmmExpr
o2]) (CmmLit (CmmInt Integer
0 Width
pk))
    | (CmmLit lit :: CmmLit
lit@(CmmInt Integer
mask Width
_)) <- CmmExpr
o2, Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit
    = do
      (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 a. a -> NatM a
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' Platform
_ Cond
cond CmmExpr
x (CmmLit (CmmInt Integer
0 Width
pk)) = do
    (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 a. a -> NatM a
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' Platform
platform Cond
cond CmmExpr
x CmmExpr
y
 | Platform -> CmmExpr -> Bool
isOperand Platform
platform CmmExpr
y = do
    (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
x
    (Operand
y_op,  OrdList Instr
y_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
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 (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
x)) Operand
y_op (Reg -> Operand
OpReg Reg
x_reg)
    CondCode -> NatM CondCode
forall a. a -> NatM a
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.
 | Platform -> CmmExpr -> Bool
isOperand Platform
platform CmmExpr
x
 , Just Cond
revcond <- Cond -> Maybe Cond
maybeFlipCond Cond
cond = do
    (Reg
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
y
    (Operand
x_op,  OrdList Instr
x_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
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 (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
x)) Operand
x_op (Reg -> Operand
OpReg Reg
y_reg)
    CondCode -> NatM CondCode
forall a. a -> NatM a
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' Platform
platform Cond
cond CmmExpr
x CmmExpr
y = do
  (Reg
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
y
  (Operand
x_op, OrdList Instr
x_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getRegOrMem CmmExpr
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 (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
x)) (Reg -> Operand
OpReg Reg
y_reg) Operand
x_op
  CondCode -> NatM CondCode
forall a. a -> NatM a
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 -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y
  =  NatM CondCode
condFltCode_sse2
  where


  -- 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
    Platform
platform <- NatM Platform
getPlatform
    (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
x
    (Operand
y_op, OrdList Instr
y_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
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
$ Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
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 a. a -> NatM a
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 -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
pk CmmExpr
addr (CmmMachOp MachOp
op [CmmLoad CmmExpr
addr2 CmmType
_ AlignmentSpec
_,
                                                 CmmLit (CmmInt Integer
i Width
_)])
   | CmmExpr
addr CmmExpr -> CmmExpr -> Bool
forall a. Eq a => a -> a -> Bool
== CmmExpr
addr2, Format
pk Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
II64 Bool -> Bool -> Bool
|| Integer -> Bool
is32BitInteger Integer
i,
     Just Format -> Operand -> Operand -> Instr
instr <- MachOp -> Maybe (Format -> Operand -> Operand -> Instr)
check MachOp
op
   = do Amode AddrMode
amode OrdList Instr
code_addr <- CmmExpr -> NatM Amode
getAmode CmmExpr
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 (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i))) (AddrMode -> Operand
OpAddr AddrMode
amode)
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
   where
        check :: MachOp -> Maybe (Format -> Operand -> Operand -> Instr)
check (MO_Add Width
_) = (Format -> Operand -> Operand -> Instr)
-> Maybe (Format -> Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just Format -> Operand -> Operand -> Instr
ADD
        check (MO_Sub Width
_) = (Format -> Operand -> Operand -> Instr)
-> Maybe (Format -> Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just Format -> Operand -> Operand -> Instr
SUB
        check MachOp
_ = Maybe (Format -> Operand -> Operand -> Instr)
forall a. Maybe a
Nothing
        -- ToDo: more?

-- general case
assignMem_IntCode Format
pk CmmExpr
addr CmmExpr
src = do
    Platform
platform <- NatM Platform
getPlatform
    Amode AddrMode
addr OrdList Instr
code_addr <- CmmExpr -> NatM Amode
getAmode CmmExpr
addr
    (OrdList Instr
code_src, Operand
op_src)   <- Platform -> CmmExpr -> NatM (OrdList Instr, Operand)
get_op_RI Platform
platform CmmExpr
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
  where
    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator
    get_op_RI :: Platform -> CmmExpr -> NatM (OrdList Instr, Operand)
get_op_RI Platform
platform (CmmLit CmmLit
lit) | Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit
      = (OrdList Instr, Operand) -> NatM (OrdList Instr, Operand)
forall a. a -> NatM a
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 Platform
_ CmmExpr
op
      = do (Reg
reg,OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
op
           (OrdList Instr, Operand) -> NatM (OrdList Instr, Operand)
forall a. a -> NatM a
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 -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
pk CmmReg
reg (CmmLoad CmmExpr
src CmmType
_ AlignmentSpec
_) = do
  Reg -> OrdList Instr
load_code <- (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
pk) CmmExpr
src
  Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
load_code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg))

-- dst is a reg, but src could be anything
assignReg_IntCode Format
_ CmmReg
reg CmmExpr
src = do
  Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
  Reg -> OrdList Instr
code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg))


-- Floating point assignment to memory
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode Format
pk CmmExpr
addr CmmExpr
src = do
  (Reg
src_reg, OrdList Instr
src_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
src
  Amode AddrMode
addr OrdList Instr
addr_code <- CmmExpr -> NatM Amode
getAmode CmmExpr
addr
  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`
               Format -> Operand -> Operand -> Instr
MOV Format
pk (Reg -> Operand
OpReg Reg
src_reg) (AddrMode -> Operand
OpAddr AddrMode
addr)

  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code

-- Floating point assignment to a register/temporary
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode Format
_ CmmReg
reg CmmExpr
src = do
  Reg -> OrdList Instr
src_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
src_code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg))


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

genJump :: CmmExpr -> [Reg] -> NatM (OrdList Instr)
genJump (CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_) [Reg]
regs = do
  Amode AddrMode
target OrdList Instr
code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 CmmLit
lit) [Reg]
regs =
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 CmmExpr
expr [Reg]
regs = do
  (Reg
reg,OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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]
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.
-}

{-  Note [64-bit integer comparisons on 32-bit]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    When doing these comparisons there are 2 kinds of
    comparisons.

    * Comparison for equality (or lack thereof)

    We use xor to check if high/low bits are
    equal. Then combine the results using or and
    perform a single conditional jump based on the
    result.

    * Other comparisons:

    We map all other comparisons to the >= operation.
    Why? Because it's easy to encode it with a single
    conditional jump.

    We do this by first computing [r1_lo - r2_lo]
    and use the carry flag to compute
    [r1_high - r2_high - CF].

    At which point if r1 >= r2 then the result will be
    positive. Otherwise negative so we can branch on this
    condition.

-}


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 -> CmmExpr -> NatM (OrdList Instr)
genCondBranch Label
bid Label
id Label
false CmmExpr
expr = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  Bool -> Label -> Label -> Label -> CmmExpr -> NatM (OrdList Instr)
genCondBranch' Bool
is32Bit Label
bid Label
id Label
false CmmExpr
expr

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

-- 64-bit integer comparisons on 32-bit
-- See Note [64-bit integer comparisons on 32-bit]
genCondBranch' :: Bool -> Label -> Label -> Label -> CmmExpr -> NatM (OrdList Instr)
genCondBranch' Bool
is32Bit Label
_bid Label
true Label
false (CmmMachOp MachOp
mop [CmmExpr
e1,CmmExpr
e2])
  | Bool
is32Bit, Just Width
W64 <- MachOp -> Maybe Width
maybeIntComparison MachOp
mop = do

  RegCode64 OrdList Instr
code1 Reg
r1hi Reg
r1lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
  RegCode64 OrdList Instr
code2 Reg
r2hi Reg
r2lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e2
  let cond :: Cond
cond = MachOp -> Cond
machOpToCond MachOp
mop :: Cond

  -- we mustn't clobber r1/r2 so we use temporaries
  Reg
tmp1 <- Format -> NatM Reg
getNewRegNat Format
II32
  Reg
tmp2 <- Format -> NatM Reg
getNewRegNat Format
II32

  let cmpCode :: OrdList Instr
cmpCode = Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
cond Label
true Label
false Reg
r1hi Reg
r1lo Reg
r2hi Reg
r2lo Reg
tmp1 Reg
tmp2
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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
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` OrdList Instr
cmpCode

  where
    intComparison :: Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
cond Label
true Label
false Reg
r1_hi Reg
r1_lo Reg
r2_hi Reg
r2_lo Reg
tmp1 Reg
tmp2 =
      case Cond
cond of
        -- Impossible results of machOpToCond
        Cond
ALWAYS  -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        Cond
NEG     -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        Cond
POS     -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        Cond
CARRY   -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        Cond
OFLO    -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        Cond
PARITY  -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        Cond
NOTPARITY -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
        -- Special case #1 x == y and x != y
        Cond
EQQ -> OrdList Instr
cmpExact
        Cond
NE  -> OrdList Instr
cmpExact
        -- [x >= y]
        Cond
GE  -> OrdList Instr
cmpGE
        Cond
GEU -> OrdList Instr
cmpGE
        -- [x >  y] <==> ![y >= x]
        Cond
GTT -> Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
GE  Label
false Label
true Reg
r2_hi Reg
r2_lo Reg
r1_hi Reg
r1_lo Reg
tmp1 Reg
tmp2
        Cond
GU  -> Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
GEU Label
false Label
true Reg
r2_hi Reg
r2_lo Reg
r1_hi Reg
r1_lo Reg
tmp1 Reg
tmp2
        -- [x <= y] <==> [y >= x]
        Cond
LE  -> Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
GE  Label
true Label
false Reg
r2_hi Reg
r2_lo Reg
r1_hi Reg
r1_lo Reg
tmp1 Reg
tmp2
        Cond
LEU -> Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
GEU Label
true Label
false Reg
r2_hi Reg
r2_lo Reg
r1_hi Reg
r1_lo Reg
tmp1 Reg
tmp2
        -- [x <  y] <==> ![x >= x]
        Cond
LTT -> Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
GE  Label
false Label
true Reg
r1_hi Reg
r1_lo Reg
r2_hi Reg
r2_lo Reg
tmp1 Reg
tmp2
        Cond
LU  -> Cond
-> Label
-> Label
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> Reg
-> OrdList Instr
intComparison Cond
GEU Label
false Label
true Reg
r1_hi Reg
r1_lo Reg
r2_hi Reg
r2_lo Reg
tmp1 Reg
tmp2
      where
        cmpExact :: OrdList Instr
        cmpExact :: OrdList Instr
cmpExact =
          [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
            [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1_hi) (Reg -> Operand
OpReg Reg
tmp1)
            , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1_lo) (Reg -> Operand
OpReg Reg
tmp2)
            , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
r2_hi) (Reg -> Operand
OpReg Reg
tmp1)
            , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
r2_lo) (Reg -> Operand
OpReg Reg
tmp2)
            , Format -> Operand -> Operand -> Instr
OR  Format
II32 (Reg -> Operand
OpReg Reg
tmp1)  (Reg -> Operand
OpReg Reg
tmp2)
            , Cond -> Label -> Instr
JXX Cond
cond Label
true
            , Cond -> Label -> Instr
JXX Cond
ALWAYS Label
false
            ]
        cmpGE :: OrdList Instr
cmpGE = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
            [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1_hi) (Reg -> Operand
OpReg Reg
tmp1)
            , Format -> Operand -> Operand -> Instr
CMP Format
II32 (Reg -> Operand
OpReg Reg
r2_lo) (Reg -> Operand
OpReg Reg
r1_lo)
            , Format -> Operand -> Operand -> Instr
SBB Format
II32 (Reg -> Operand
OpReg Reg
r2_hi) (Reg -> Operand
OpReg Reg
tmp1)
            , Cond -> Label -> Instr
JXX Cond
cond Label
true
            , Cond -> Label -> Instr
JXX Cond
ALWAYS Label
false ]

genCondBranch' Bool
_ Label
bid Label
id Label
false CmmExpr
bool = do
  CondCode Bool
is_float Cond
cond OrdList Instr
cond_code <- CmmExpr -> NatM CondCode
getCondCode CmmExpr
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 a. a -> NatM a
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
                  Cond
NE  -> OrdList Instr
or_unordered
                  Cond
GU  -> OrdList Instr
plain_test
                  Cond
GEU -> OrdList Instr
plain_test
                  -- Use ASSERT so we don't break releases if
                  -- LTT/LE creep in somehow.
                  Cond
LTT ->
                    Bool -> SDoc -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should have been turned into >")
                    OrdList Instr
and_ordered
                  Cond
LE  ->
                    Bool -> SDoc -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should have been turned into >=")
                    OrdList Instr
and_ordered
                  Cond
_   -> 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 -> (EdgeWeight -> EdgeWeight) -> Label -> Label -> CFG
adjustEdgeWeight CFG
cfg (EdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Num a => a -> a -> a
+EdgeWeight
3) Label
bid Label
false)
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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.
--
-- See Note [Keeping track of the current block] for information why we need
-- to take/return a block id.

genForeignCall
    :: 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)

genForeignCall :: ForeignTarget
-> [LocalReg]
-> [CmmExpr]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genForeignCall ForeignTarget
target [LocalReg]
dst [CmmExpr]
args Label
bid = do
  case ForeignTarget
target of
    PrimTarget CallishMachOp
prim         -> Label
-> CallishMachOp
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr, Maybe Label)
genPrim Label
bid CallishMachOp
prim [LocalReg]
dst [CmmExpr]
args
    ForeignTarget CmmExpr
addr ForeignConvention
conv -> (,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
<$> Label
-> CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall Label
bid CmmExpr
addr ForeignConvention
conv [LocalReg]
dst [CmmExpr]
args

genPrim
    :: BlockId       -- ^ The block we are in
    -> CallishMachOp -- ^ MachOp
    -> [CmmFormal]   -- ^ where to put the result
    -> [CmmActual]   -- ^ arguments (of mixed type)
    -> NatM (InstrBlock, Maybe BlockId)

-- First we deal with cases which might introduce new blocks in the stream.
genPrim :: Label
-> CallishMachOp
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr, Maybe Label)
genPrim Label
bid (MO_AtomicRMW Width
width AtomicMachOp
amop) [LocalReg
dst] [CmmExpr
addr, CmmExpr
n]
  = Label
-> Width
-> AtomicMachOp
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr, Maybe Label)
genAtomicRMW Label
bid Width
width AtomicMachOp
amop LocalReg
dst CmmExpr
addr CmmExpr
n
genPrim Label
bid (MO_Ctz Width
width) [LocalReg
dst] [CmmExpr
src]
  = Label
-> Width
-> LocalReg
-> CmmExpr
-> NatM (OrdList Instr, Maybe Label)
genCtz Label
bid Width
width LocalReg
dst CmmExpr
src

-- Then we deal with cases which not introducing new blocks in the stream.
genPrim Label
bid CallishMachOp
prim [LocalReg]
dst [CmmExpr]
args
  = (,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
<$> Label
-> CallishMachOp -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genSimplePrim Label
bid CallishMachOp
prim [LocalReg]
dst [CmmExpr]
args

genSimplePrim
    :: BlockId       -- ^ the block we are in
    -> CallishMachOp -- ^ MachOp
    -> [CmmFormal]   -- ^ where to put the result
    -> [CmmActual]   -- ^ arguments (of mixed type)
    -> NatM InstrBlock
genSimplePrim :: Label
-> CallishMachOp -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genSimplePrim Label
bid (MO_Memcpy Int
align)    []      [CmmExpr
dst,CmmExpr
src,CmmExpr
n]    = Label
-> Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genMemCpy  Label
bid Int
align CmmExpr
dst CmmExpr
src CmmExpr
n
genSimplePrim Label
bid (MO_Memmove Int
align)   []      [CmmExpr
dst,CmmExpr
src,CmmExpr
n]    = Label
-> Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
forall p.
Label -> p -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genMemMove Label
bid Int
align CmmExpr
dst CmmExpr
src CmmExpr
n
genSimplePrim Label
bid (MO_Memcmp Int
align)    [LocalReg
res]   [CmmExpr
dst,CmmExpr
src,CmmExpr
n]    = Label
-> Int
-> LocalReg
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
forall p.
Label
-> p
-> LocalReg
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genMemCmp  Label
bid Int
align LocalReg
res CmmExpr
dst CmmExpr
src CmmExpr
n
genSimplePrim Label
bid (MO_Memset Int
align)    []      [CmmExpr
dst,CmmExpr
c,CmmExpr
n]      = Label
-> Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genMemSet  Label
bid Int
align CmmExpr
dst CmmExpr
c CmmExpr
n
genSimplePrim Label
_   CallishMachOp
MO_ReadBarrier       []      []             = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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;
genSimplePrim Label
_   CallishMachOp
MO_WriteBarrier      []      []             = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL -- we keep it this long in order to prevent earlier optimisations.
genSimplePrim Label
_   CallishMachOp
MO_Touch             []      [CmmExpr
_]            = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
genSimplePrim Label
_   (MO_Prefetch_Data Int
n) []      [CmmExpr
src]          = Int -> CmmExpr -> NatM (OrdList Instr)
genPrefetchData Int
n CmmExpr
src
genSimplePrim Label
_   (MO_BSwap Width
width)     [LocalReg
dst]   [CmmExpr
src]          = Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genByteSwap Width
width LocalReg
dst CmmExpr
src
genSimplePrim Label
bid (MO_BRev Width
width)      [LocalReg
dst]   [CmmExpr
src]          = Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genBitRev Label
bid Width
width LocalReg
dst CmmExpr
src
genSimplePrim Label
bid (MO_PopCnt Width
width)    [LocalReg
dst]   [CmmExpr
src]          = Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genPopCnt Label
bid Width
width LocalReg
dst CmmExpr
src
genSimplePrim Label
bid (MO_Pdep Width
width)      [LocalReg
dst]   [CmmExpr
src,CmmExpr
mask]     = Label
-> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPdep Label
bid Width
width LocalReg
dst CmmExpr
src CmmExpr
mask
genSimplePrim Label
bid (MO_Pext Width
width)      [LocalReg
dst]   [CmmExpr
src,CmmExpr
mask]     = Label
-> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPext Label
bid Width
width LocalReg
dst CmmExpr
src CmmExpr
mask
genSimplePrim Label
bid (MO_Clz Width
width)       [LocalReg
dst]   [CmmExpr
src]          = Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genClz Label
bid Width
width LocalReg
dst CmmExpr
src
genSimplePrim Label
bid (MO_UF_Conv Width
width)   [LocalReg
dst]   [CmmExpr
src]          = Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genWordToFloat Label
bid Width
width LocalReg
dst CmmExpr
src
genSimplePrim Label
_   (MO_AtomicRead Width
w MemoryOrdering
mo)  [LocalReg
dst]  [CmmExpr
addr]         = Width
-> MemoryOrdering -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genAtomicRead Width
w MemoryOrdering
mo LocalReg
dst CmmExpr
addr
genSimplePrim Label
_   (MO_AtomicWrite Width
w MemoryOrdering
mo) []     [CmmExpr
addr,CmmExpr
val]     = Width
-> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genAtomicWrite Width
w MemoryOrdering
mo CmmExpr
addr CmmExpr
val
genSimplePrim Label
bid (MO_Cmpxchg Width
width)   [LocalReg
dst]   [CmmExpr
addr,CmmExpr
old,CmmExpr
new] = Label
-> Width
-> LocalReg
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genCmpXchg Label
bid Width
width LocalReg
dst CmmExpr
addr CmmExpr
old CmmExpr
new
genSimplePrim Label
_   (MO_Xchg Width
width)      [LocalReg
dst]   [CmmExpr
addr, CmmExpr
value]  = Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genXchg Width
width LocalReg
dst CmmExpr
addr CmmExpr
value
genSimplePrim Label
_   (MO_AddWordC Width
w)      [LocalReg
r,LocalReg
c]   [CmmExpr
x,CmmExpr
y]          = Width
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddSubRetCarry Width
w 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 LocalReg
r LocalReg
c CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_SubWordC Width
w)      [LocalReg
r,LocalReg
c]   [CmmExpr
x,CmmExpr
y]          = Width
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddSubRetCarry Width
w 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 LocalReg
r LocalReg
c CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_AddIntC Width
w)       [LocalReg
r,LocalReg
c]   [CmmExpr
x,CmmExpr
y]          = Width
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddSubRetCarry Width
w 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  LocalReg
r LocalReg
c CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_SubIntC Width
w)       [LocalReg
r,LocalReg
c]   [CmmExpr
x,CmmExpr
y]          = Width
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddSubRetCarry Width
w 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  LocalReg
r LocalReg
c CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_Add2 Width
w)          [LocalReg
h,LocalReg
l]   [CmmExpr
x,CmmExpr
y]          = Width
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddWithCarry Width
w LocalReg
h LocalReg
l CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_U_Mul2 Width
w)        [LocalReg
h,LocalReg
l]   [CmmExpr
x,CmmExpr
y]          = Width
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genUnsignedLargeMul Width
w LocalReg
h LocalReg
l CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_S_Mul2 Width
w)        [LocalReg
c,LocalReg
h,LocalReg
l] [CmmExpr
x,CmmExpr
y]          = Width
-> LocalReg
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genSignedLargeMul Width
w LocalReg
c LocalReg
h LocalReg
l CmmExpr
x CmmExpr
y
genSimplePrim Label
_   (MO_S_QuotRem Width
w)     [LocalReg
q,LocalReg
r]   [CmmExpr
x,CmmExpr
y]          = Width
-> Bool
-> LocalReg
-> LocalReg
-> Maybe CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genQuotRem Width
w Bool
True  LocalReg
q LocalReg
r Maybe CmmExpr
forall a. Maybe a
Nothing   CmmExpr
x  CmmExpr
y
genSimplePrim Label
_   (MO_U_QuotRem Width
w)     [LocalReg
q,LocalReg
r]   [CmmExpr
x,CmmExpr
y]          = Width
-> Bool
-> LocalReg
-> LocalReg
-> Maybe CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genQuotRem Width
w Bool
False LocalReg
q LocalReg
r Maybe CmmExpr
forall a. Maybe a
Nothing   CmmExpr
x  CmmExpr
y
genSimplePrim Label
_   (MO_U_QuotRem2 Width
w)    [LocalReg
q,LocalReg
r]   [CmmExpr
hx,CmmExpr
lx,CmmExpr
y]      = Width
-> Bool
-> LocalReg
-> LocalReg
-> Maybe CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genQuotRem Width
w Bool
False LocalReg
q LocalReg
r (CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
Just CmmExpr
hx) CmmExpr
lx CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_F32_Fabs          [LocalReg
dst]   [CmmExpr
src]          = Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genFloatAbs Width
W32 LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_F64_Fabs          [LocalReg
dst]   [CmmExpr
src]          = Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genFloatAbs Width
W64 LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_F32_Sqrt          [LocalReg
dst]   [CmmExpr
src]          = Format -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genFloatSqrt Format
FF32 LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_F64_Sqrt          [LocalReg
dst]   [CmmExpr
src]          = Format -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genFloatSqrt Format
FF64 LocalReg
dst CmmExpr
src
genSimplePrim Label
bid CallishMachOp
MO_F32_Sin           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"sinf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Cos           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"cosf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Tan           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"tanf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Exp           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"expf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_ExpM1         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"expm1f") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Log           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"logf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Log1P         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"log1pf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Asin          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"asinf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Acos          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"acosf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Atan          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"atanf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Sinh          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"sinhf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Cosh          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"coshf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Tanh          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"tanhf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Pwr           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"powf")  [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
bid CallishMachOp
MO_F32_Asinh         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"asinhf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Acosh         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"acoshf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F32_Atanh         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"atanhf") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Sin           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"sin") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Cos           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"cos") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Tan           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"tan") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Exp           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"exp") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_ExpM1         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"expm1") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Log           [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"log") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Log1P         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"log1p") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Asin          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"asin") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Acos          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"acos") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Atan          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"atan") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Sinh          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"sinh") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Cosh          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"cosh") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Tanh          [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"tanh") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Pwr           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"pow")  [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
bid CallishMachOp
MO_F64_Asinh         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"asinh") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Acosh         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"acosh") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_F64_Atanh         [LocalReg
dst]   [CmmExpr
src]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"atanh") [LocalReg
dst] [CmmExpr
src]
genSimplePrim Label
bid CallishMachOp
MO_SuspendThread     [LocalReg
tok]   [CmmExpr
rs,CmmExpr
i]         = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genRTSCCall Label
bid (String -> FastString
fsLit String
"suspendThread") [LocalReg
tok] [CmmExpr
rs,CmmExpr
i]
genSimplePrim Label
bid CallishMachOp
MO_ResumeThread      [LocalReg
rs]    [CmmExpr
tok]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genRTSCCall Label
bid (String -> FastString
fsLit String
"resumeThread") [LocalReg
rs] [CmmExpr
tok]
genSimplePrim Label
_   CallishMachOp
MO_I64_ToI           [LocalReg
dst]   [CmmExpr
src]          = LocalReg -> CmmExpr -> NatM (OrdList Instr)
genInt64ToInt LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_I64_FromI         [LocalReg
dst]   [CmmExpr
src]          = LocalReg -> CmmExpr -> NatM (OrdList Instr)
genIntToInt64 LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_W64_ToW           [LocalReg
dst]   [CmmExpr
src]          = LocalReg -> CmmExpr -> NatM (OrdList Instr)
genWord64ToWord LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_W64_FromW         [LocalReg
dst]   [CmmExpr
src]          = LocalReg -> CmmExpr -> NatM (OrdList Instr)
genWordToWord64 LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_x64_Neg           [LocalReg
dst]   [CmmExpr
src]          = LocalReg -> CmmExpr -> NatM (OrdList Instr)
genNeg64 LocalReg
dst CmmExpr
src
genSimplePrim Label
_   CallishMachOp
MO_x64_Add           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genAdd64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_x64_Sub           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genSub64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
bid CallishMachOp
MO_x64_Mul           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_mul64") [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
bid CallishMachOp
MO_I64_Quot          [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_quotInt64") [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
bid CallishMachOp
MO_I64_Rem           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_remInt64") [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
bid CallishMachOp
MO_W64_Quot          [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_quotWord64") [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
bid CallishMachOp
MO_W64_Rem           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_remWord64") [LocalReg
dst] [CmmExpr
x,CmmExpr
y]
genSimplePrim Label
_   CallishMachOp
MO_x64_And           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genAnd64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_x64_Or            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genOr64  LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_x64_Xor           [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genXor64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_x64_Not           [LocalReg
dst]   [CmmExpr
src]          = LocalReg -> CmmExpr -> NatM (OrdList Instr)
genNot64 LocalReg
dst CmmExpr
src
genSimplePrim Label
bid CallishMachOp
MO_x64_Shl           [LocalReg
dst]   [CmmExpr
x,CmmExpr
n]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_uncheckedShiftL64") [LocalReg
dst] [CmmExpr
x,CmmExpr
n]
genSimplePrim Label
bid CallishMachOp
MO_I64_Shr           [LocalReg
dst]   [CmmExpr
x,CmmExpr
n]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_uncheckedIShiftRA64") [LocalReg
dst] [CmmExpr
x,CmmExpr
n]
genSimplePrim Label
bid CallishMachOp
MO_W64_Shr           [LocalReg
dst]   [CmmExpr
x,CmmExpr
n]          = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (String -> FastString
fsLit String
"hs_uncheckedShiftRL64") [LocalReg
dst] [CmmExpr
x,CmmExpr
n]
genSimplePrim Label
_   CallishMachOp
MO_x64_Eq            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genEq64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_x64_Ne            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genNe64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_I64_Ge            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGeInt64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_I64_Gt            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGtInt64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_I64_Le            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLeInt64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_I64_Lt            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLtInt64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_W64_Ge            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGeWord64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_W64_Gt            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGtWord64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_W64_Le            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLeWord64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
MO_W64_Lt            [LocalReg
dst]   [CmmExpr
x,CmmExpr
y]          = LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLtWord64 LocalReg
dst CmmExpr
x CmmExpr
y
genSimplePrim Label
_   CallishMachOp
op                   [LocalReg]
dst     [CmmExpr]
args           = do
  Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
  String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genSimplePrim: unhandled primop" ((SDoc, [LocalReg], [SDoc]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CallishMachOp -> SDoc
pprCallishMachOp CallishMachOp
op, [LocalReg]
dst, (CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform) [CmmExpr]
args))

{-
Note [Evaluate C-call arguments before placing in destination registers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When producing code for C calls we must take care when placing arguments
in their final registers. Specifically, we must ensure that temporary register
usage due to evaluation of one argument does not clobber a register in which we
already placed a previous argument (e.g. as the code generation logic for
MO_Shl can clobber %rcx due to x86 instruction limitations).

This is precisely what happened in #18527. Consider this C--:

    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));

Here we are calling the C function `doSomething` with three arguments, the last
involving a non-trivial expression involving MO_Shl. In this case the NCG could
naively generate the following assembly (where $tmp denotes some temporary
register and $argN denotes the register for argument N, as dictated by the
platform's calling convention):

    mov _s2hp, $arg1   # place first argument
    mov _s2hq, $arg2   # place second argument

    # Compute 1 << _s2hz
    mov _s2hz, %rcx
    shl %cl, $tmp

    # Compute (_s2hw | (1 << _s2hz))
    mov _s2hw, $arg3
    or $tmp, $arg3

    # Perform the call
    call func

This code is outright broken on Windows which assigns $arg1 to %rcx. This means
that the evaluation of the last argument clobbers the first argument.

To avoid this we use a rather awful hack: when producing code for a C call with
at least one non-trivial argument, we first evaluate all of the arguments into
local registers before moving them into their final calling-convention-defined
homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an
expression which might contain a MachOp since these are the only cases which
might clobber registers. Furthermore, we use a conservative approximation of
this condition (only looking at the top-level of CmmExprs) to avoid spending
too much effort trying to decide whether we want to take the fast path.

Note that this hack *also* applies to calls to out-of-line PrimTargets (which
are lowered via a C call), which will ultimately end up in
genForeignCall{32,64}.
-}

-- | See Note [Evaluate C-call arguments before placing in destination registers]
evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
evalArgs :: Label -> [CmmExpr] -> NatM (OrdList Instr, [CmmExpr])
evalArgs Label
bid [CmmExpr]
actuals
  | (CmmExpr -> Bool) -> [CmmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CmmExpr -> Bool
mightContainMachOp [CmmExpr]
actuals = do
      [(OrdList Instr, CmmExpr)]
regs_blks <- (CmmExpr -> NatM (OrdList Instr, CmmExpr))
-> [CmmExpr] -> NatM [(OrdList Instr, CmmExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmExpr -> NatM (OrdList Instr, CmmExpr)
evalArg [CmmExpr]
actuals
      (OrdList Instr, [CmmExpr]) -> NatM (OrdList Instr, [CmmExpr])
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList Instr] -> OrdList Instr
forall a. [OrdList a] -> OrdList a
concatOL ([OrdList Instr] -> OrdList Instr)
-> [OrdList Instr] -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ ((OrdList Instr, CmmExpr) -> OrdList Instr)
-> [(OrdList Instr, CmmExpr)] -> [OrdList Instr]
forall a b. (a -> b) -> [a] -> [b]
map (OrdList Instr, CmmExpr) -> OrdList Instr
forall a b. (a, b) -> a
fst [(OrdList Instr, CmmExpr)]
regs_blks, ((OrdList Instr, CmmExpr) -> CmmExpr)
-> [(OrdList Instr, CmmExpr)] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (OrdList Instr, CmmExpr) -> CmmExpr
forall a b. (a, b) -> b
snd [(OrdList Instr, CmmExpr)]
regs_blks)
  | Bool
otherwise = (OrdList Instr, [CmmExpr]) -> NatM (OrdList Instr, [CmmExpr])
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, [CmmExpr]
actuals)
  where
    mightContainMachOp :: CmmExpr -> Bool
mightContainMachOp (CmmReg CmmReg
_)      = Bool
False
    mightContainMachOp (CmmRegOff CmmReg
_ Int
_) = Bool
False
    mightContainMachOp (CmmLit CmmLit
_)      = Bool
False
    mightContainMachOp CmmExpr
_               = Bool
True

    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)
    evalArg :: CmmExpr -> NatM (OrdList Instr, CmmExpr)
evalArg CmmExpr
actual = do
        Platform
platform <- NatM Platform
getPlatform
        LocalReg
lreg <- CmmType -> NatM LocalReg
newLocalReg (CmmType -> NatM LocalReg) -> CmmType -> NatM LocalReg
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
actual
        (OrdList Instr
instrs, Maybe Label
bid1) <- Label -> CmmNode O O -> NatM (OrdList Instr, Maybe Label)
forall (e :: Extensibility) (x :: Extensibility).
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid (CmmNode O O -> NatM (OrdList Instr, Maybe Label))
-> CmmNode O O -> NatM (OrdList Instr, Maybe Label)
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (LocalReg -> CmmReg
CmmLocal LocalReg
lreg) CmmExpr
actual
        -- The above assignment shouldn't change the current block
        Bool -> NatM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Maybe Label -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Label
bid1)
        (OrdList Instr, CmmExpr) -> NatM (OrdList Instr, CmmExpr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ LocalReg -> CmmReg
CmmLocal LocalReg
lreg)

    newLocalReg :: CmmType -> NatM LocalReg
    newLocalReg :: CmmType -> NatM LocalReg
newLocalReg CmmType
ty = Unique -> CmmType -> LocalReg
LocalReg (Unique -> CmmType -> LocalReg)
-> NatM Unique -> NatM (CmmType -> LocalReg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM NatM (CmmType -> LocalReg) -> NatM CmmType -> NatM LocalReg
forall a b. NatM (a -> b) -> NatM a -> NatM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CmmType -> NatM CmmType
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CmmType
ty

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


-- | Generate C call to the given function in ghc-prim
genPrimCCall
  :: BlockId
  -> FastString
  -> [CmmFormal]
  -> [CmmActual]
  -> NatM InstrBlock
genPrimCCall :: Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid FastString
lbl_txt [LocalReg]
dsts [CmmExpr]
args = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel
  let lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId FastString
lbl_txt
  CmmExpr
addr <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
CallReference CLabel
lbl
  let conv :: ForeignConvention
conv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [] [] CmmReturnInfo
CmmMayReturn
  Label
-> CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall Label
bid CmmExpr
addr ForeignConvention
conv [LocalReg]
dsts [CmmExpr]
args

-- | Generate C call to the given function in libc
genLibCCall
  :: BlockId
  -> FastString
  -> [CmmFormal]
  -> [CmmActual]
  -> NatM InstrBlock
genLibCCall :: Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid FastString
lbl_txt [LocalReg]
dsts [CmmExpr]
args = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  -- 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
  let lbl :: CLabel
lbl = FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
lbl_txt Maybe Int
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
  CmmExpr
addr <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
CallReference CLabel
lbl
  let conv :: ForeignConvention
conv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [] [] CmmReturnInfo
CmmMayReturn
  Label
-> CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall Label
bid CmmExpr
addr ForeignConvention
conv [LocalReg]
dsts [CmmExpr]
args

-- | Generate C call to the given function in the RTS
genRTSCCall
  :: BlockId
  -> FastString
  -> [CmmFormal]
  -> [CmmActual]
  -> NatM InstrBlock
genRTSCCall :: Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genRTSCCall Label
bid FastString
lbl_txt [LocalReg]
dsts [CmmExpr]
args = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  -- Assume we can call these functions directly, and that they're not in a dynamic library.
  let lbl :: CLabel
lbl = FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
lbl_txt Maybe Int
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
  CmmExpr
addr <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
CallReference CLabel
lbl
  let conv :: ForeignConvention
conv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [] [] CmmReturnInfo
CmmMayReturn
  Label
-> CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall Label
bid CmmExpr
addr ForeignConvention
conv [LocalReg]
dsts [CmmExpr]
args

-- | Generate a real C call to the given address with the given convention
genCCall
  :: BlockId
  -> CmmExpr
  -> ForeignConvention
  -> [CmmFormal]
  -> [CmmActual]
  -> NatM InstrBlock
genCCall :: Label
-> CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall Label
bid CmmExpr
addr ForeignConvention
conv [LocalReg]
dest_regs [CmmExpr]
args = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  (OrdList Instr
instrs0, [CmmExpr]
args') <- Label -> [CmmExpr] -> NatM (OrdList Instr, [CmmExpr])
evalArgs Label
bid [CmmExpr]
args
  OrdList Instr
instrs1 <- if Bool
is32Bit
    then CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall32 CmmExpr
addr ForeignConvention
conv [LocalReg]
dest_regs [CmmExpr]
args'
    else CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall64 CmmExpr
addr ForeignConvention
conv [LocalReg]
dest_regs [CmmExpr]
args'
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs0 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
instrs1)

genCCall32 :: CmmExpr           -- ^ address of the function to call
           -> ForeignConvention -- ^ calling convention
           -> [CmmFormal]       -- ^ where to put the result
           -> [CmmActual]       -- ^ arguments (of mixed type)
           -> NatM InstrBlock
genCCall32 :: CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall32 CmmExpr
addr ForeignConvention
conv [LocalReg]
dest_regs [CmmExpr]
args = do
        NCGConfig
config <- NatM NCGConfig
getConfig
        let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
            prom_args :: [CmmExpr]
prom_args = (CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Width -> CmmExpr -> CmmExpr
maybePromoteCArg Platform
platform Width
W32) [CmmExpr]
args

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

            roundTo :: a -> a -> a
roundTo a
a 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
== a
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 :: CmmActual {-current argument-}
                            -> NatM InstrBlock  -- code

            push_arg :: CmmExpr -> NatM (OrdList Instr)
push_arg  CmmExpr
arg -- we don't need the hints on x86
              | CmmType -> Bool
isWord64 CmmType
arg_ty = do
                RegCode64 OrdList Instr
code Reg
r_hi Reg
r_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
arg
                Int
delta <- NatM Int
getDeltaNat
                Int -> NatM ()
setDeltaNat (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)
                OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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), Int -> Instr
DELTA (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4),
                                     Format -> Operand -> Instr
PUSH Format
II32 (Reg -> Operand
OpReg Reg
r_lo), Int -> Instr
DELTA (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8),
                                     Int -> Instr
DELTA (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
8)]
                    )

              | CmmType -> Bool
isFloatType CmmType
arg_ty = do
                (Reg
reg, OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg
                Int
delta <- NatM Int
getDeltaNat
                Int -> NatM ()
setDeltaNat (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
size)
                OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 (Int -> Imm
ImmInt Int
size)) (Reg -> Operand
OpReg Reg
esp),
                                      Int -> Instr
DELTA (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
size),
                                      let addr :: AddrMode
addr = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
esp)
                                                                EAIndex
EAIndexNone
                                                                (Int -> Imm
ImmInt Int
0)
                                          format :: Format
format = Width -> Format
floatFormat (CmmType -> Width
typeWidth CmmType
arg_ty)
                                      in

                                      -- assume SSE2
                                       Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
reg) (AddrMode -> Operand
OpAddr 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.
                Bool -> NatM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert ((CmmType -> Width
typeWidth CmmType
arg_ty) Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32)
                (Operand
operand, OrdList Instr
code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
arg
                Int
delta <- NatM Int
getDeltaNat
                Int -> NatM ()
setDeltaNat (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
size)
                OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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`
                        Int -> Instr
DELTA (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
size))

              where
                 arg_ty :: CmmType
arg_ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
arg
                 size :: Int
size = CmmType -> Int
arg_size_bytes CmmType
arg_ty -- Byte size

        let
            -- Align stack to 16n for calls, assuming a starting stack
            -- alignment of 16n - word_size on procedure entry. Which we
            -- maintiain. See Note [Stack Alignment on X86] in rts/StgCRun.c.
            sizes :: [Int]
sizes               = (CmmExpr -> Int) -> [CmmExpr] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (CmmType -> Int
arg_size_bytes (CmmType -> Int) -> (CmmExpr -> CmmType) -> CmmExpr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) ([CmmExpr] -> [CmmExpr]
forall a. [a] -> [a]
reverse [CmmExpr]
args)
            raw_arg_size :: Int
raw_arg_size        = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
sizes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Platform -> Int
platformWordSizeInBytes Platform
platform
            arg_pad_size :: Int
arg_pad_size        = (Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
raw_arg_size) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
raw_arg_size
            tot_arg_size :: Int
tot_arg_size        = Int
raw_arg_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
arg_pad_size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Platform -> Int
platformWordSizeInBytes Platform
platform


        Int
delta0 <- NatM Int
getDeltaNat
        Int -> NatM ()
setDeltaNat (Int
delta0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
arg_pad_size)

        [OrdList Instr]
push_codes <- (CmmExpr -> NatM (OrdList Instr))
-> [CmmExpr] -> NatM [OrdList Instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmExpr -> NatM (OrdList Instr)
push_arg ([CmmExpr] -> [CmmExpr]
forall a. [a] -> [a]
reverse [CmmExpr]
prom_args)
        Int
delta <- NatM Int
getDeltaNat
        Bool -> NatM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Int
delta Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
delta0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tot_arg_size)

        -- deal with static vs dynamic call targets
        (OrdList Instr
callinsns,ForeignConvention
cconv) <-
          case CmmExpr
addr of
            CmmLit (CmmLabel CLabel
lbl)
               -> -- ToDo: stdcall arg sizes
                  (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall a. a -> NatM a
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
            CmmExpr
_
               -> do { (Reg
dyn_r, OrdList Instr
dyn_c) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
addr
                     ; Bool -> NatM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (CmmType -> Bool
isWord32 (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
addr))
                     ; (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall a. a -> NatM a
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) }
        let push_code :: OrdList Instr
push_code
                | Int
arg_pad_size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Operand -> Instr
SUB Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
arg_pad_size)) (Reg -> Operand
OpReg Reg
esp),
                        Int -> Instr
DELTA (Int
delta0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 :: Int
pop_size
               | ForeignConvention CCallConv
StdCallConv [ForeignHint]
_ [ForeignHint]
_ CmmReturnInfo
_ <- ForeignConvention
cconv = Int
arg_pad_size
               | Bool
otherwise = Int
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 Int
pop_sizeInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then [] else
                       [Format -> Operand -> Operand -> Instr
ADD Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
pop_size)) (Reg -> Operand
OpReg Reg
esp)])
                      [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
                      [Int -> Instr
DELTA Int
delta0]
                   )
        Int -> NatM ()
setDeltaNat Int
delta0

        let
            -- assign the results, if necessary
            assign_code :: [LocalReg] -> OrdList Instr
assign_code []     = OrdList Instr
forall a. OrdList a
nilOL
            assign_code [LocalReg
dest]
              | CmmType -> Bool
isFloatType CmmType
ty =
                  -- we assume SSE2
                  let tmp_amode :: AddrMode
tmp_amode = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
esp)
                                                       EAIndex
EAIndexNone
                                                       (Int -> Imm
ImmInt Int
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 (Int -> Imm
ImmInt Int
b)) (Reg -> Operand
OpReg Reg
esp),
                                   Int -> Instr
DELTA (Int
delta0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
b),
                                   Format -> AddrMode -> Instr
X87Store Format
fmt  AddrMode
tmp_amode,
                                   -- X87Store only supported for the CDECL ABI
                                   -- NB: This code will need to be
                                   -- revisited once GHC does more work around
                                   -- SIGFPE f
                                   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 (Int -> Imm
ImmInt Int
b)) (Reg -> Operand
OpReg Reg
esp),
                                   Int -> Instr
DELTA Int
delta0]
              | 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 = LocalReg -> CmmType
localRegType LocalReg
dest
                    w :: Width
w  = CmmType -> Width
typeWidth CmmType
ty
                    b :: Int
b  = Width -> Int
widthInBytes Width
w
                    r_dest_hi :: Reg
r_dest_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dest
                    r_dest :: Reg
r_dest    = LocalReg -> Reg
getLocalRegReg LocalReg
dest
            assign_code [LocalReg]
many = String -> SDoc -> OrdList Instr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genForeignCall.assign_code - too many return values:" ([LocalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocalReg]
many)

        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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`
                [LocalReg] -> OrdList Instr
assign_code [LocalReg]
dest_regs)

genCCall64 :: CmmExpr           -- ^ address of function to call
           -> ForeignConvention -- ^ calling convention
           -> [CmmFormal]       -- ^ where to put the result
           -> [CmmActual]       -- ^ arguments (of mixed type)
           -> NatM InstrBlock
genCCall64 :: CmmExpr
-> ForeignConvention
-> [LocalReg]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall64 CmmExpr
addr ForeignConvention
conv [LocalReg]
dest_regs [CmmExpr]
args = do
    Platform
platform <- NatM Platform
getPlatform
    -- load up the register arguments
    let prom_args :: [CmmExpr]
prom_args = (CmmExpr -> CmmExpr) -> [CmmExpr] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> Width -> CmmExpr -> CmmExpr
maybePromoteCArg Platform
platform Width
W32) [CmmExpr]
args

    let 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 :: [CmmExpr]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmExpr]
args [] [] OrdList Instr
code OrdList Instr
acode     =
            ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmExpr]
args, [], [], OrdList Instr
code, OrdList Instr
acode)

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

        load_args (CmmExpr
arg : [CmmExpr]
rest) [Reg]
aregs [Reg]
fregs OrdList Instr
code OrdList Instr
acode
            | CmmType -> Bool
isFloatType CmmType
arg_rep = case [Reg]
fregs of
                 []     -> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg
                 (Reg
r:[Reg]
rs) -> do
                    (OrdList Instr
code',OrdList Instr
acode') <- Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg Reg
r
                    [CmmExpr]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmExpr]
rest [Reg]
aregs [Reg]
rs OrdList Instr
code' OrdList Instr
acode'
            | Bool
otherwise           = case [Reg]
aregs of
                 []     -> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg
                 (Reg
r:[Reg]
rs) -> do
                    (OrdList Instr
code',OrdList Instr
acode') <- Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg Reg
r
                    [CmmExpr]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmExpr]
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 ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg = do
                 ([CmmExpr]
args',[Reg]
ars,[Reg]
frs,OrdList Instr
code',OrdList Instr
acode')
                     <- [CmmExpr]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmExpr]
rest [Reg]
aregs [Reg]
fregs OrdList Instr
code OrdList Instr
acode
                 ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr
argCmmExpr -> [CmmExpr] -> [CmmExpr]
forall a. a -> [a] -> [a]
:[CmmExpr]
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 Reg
r
                -- "operand" args can be directly assigned into r
                | Platform -> CmmExpr -> Bool
isOperand Platform
platform CmmExpr
arg = do
                    Reg -> OrdList Instr
arg_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg
                    (OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall a. a -> NatM a
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
                | (CmmExpr -> Bool) -> [CmmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Platform -> CmmExpr -> Bool
isOperand Platform
platform) [CmmExpr]
rest = do
                    Reg -> OrdList Instr
arg_code   <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg
                    (OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall a. a -> NatM a
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 <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code',OrdList Instr
acode')

              arg_rep :: CmmType
arg_rep = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
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 :: [CmmExpr]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmExpr]
args [Reg]
usedInt [Reg]
usedFP [] OrdList Instr
code
            = ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmExpr]
args, [Reg]
usedInt, [Reg]
usedFP, OrdList Instr
code, OrdList Instr
forall a. OrdList a
nilOL)
            -- no more regs to use
        load_args_win [] [Reg]
usedInt [Reg]
usedFP [(Reg, Reg)]
_ OrdList Instr
code
            = ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall a. a -> NatM a
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 (CmmExpr
arg : [CmmExpr]
rest) [Reg]
usedInt [Reg]
usedFP
                      ((Reg
ireg, Reg
freg) : [(Reg, Reg)]
regs) OrdList Instr
code
            | CmmType -> Bool
isFloatType CmmType
arg_rep = do
                 Reg -> OrdList Instr
arg_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg
                 [CmmExpr]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmExpr]
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 <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg
                 [CmmExpr]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmExpr]
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 = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
arg

        arg_size :: Int
arg_size = Int
8 -- always, at the mo

        push_args :: [CmmExpr] -> OrdList Instr -> NatM (OrdList Instr)
push_args [] OrdList Instr
code = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
        push_args (CmmExpr
arg:[CmmExpr]
rest) OrdList Instr
code
           | CmmType -> Bool
isFloatType CmmType
arg_rep = do
             (Reg
arg_reg, OrdList Instr
arg_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg
             Int
delta <- NatM Int
getDeltaNat
             Int -> NatM ()
setDeltaNat (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 (Platform -> Width
wordWidth Platform
platform)) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
arg_size)) (Reg -> Operand
OpReg Reg
rsp),
                            Int -> Instr
DELTA (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
arg_size),
                            Format -> Operand -> Operand -> Instr
MOV (Width -> Format
floatFormat Width
width) (Reg -> Operand
OpReg Reg
arg_reg) (AddrMode -> Operand
OpAddr (Platform -> Int -> AddrMode
spRel Platform
platform Int
0))]
             [CmmExpr] -> OrdList Instr -> NatM (OrdList Instr)
push_args [CmmExpr]
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.
             Bool -> NatM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Width
width Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W64)
             (Operand
arg_op, OrdList Instr
arg_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
arg
             Int
delta <- NatM Int
getDeltaNat
             Int -> NatM ()
setDeltaNat (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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,
                                    Int -> Instr
DELTA (Int
deltaInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
arg_size)]
             [CmmExpr] -> OrdList Instr -> NatM (OrdList Instr)
push_args [CmmExpr]
rest OrdList Instr
code'
            where
              arg_rep :: CmmType
arg_rep = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
arg
              width :: Width
width = CmmType -> Width
typeWidth CmmType
arg_rep

        leaveStackSpace :: Int -> NatM (OrdList Instr)
leaveStackSpace Int
n = do
             Int
delta <- NatM Int
getDeltaNat
             Int -> NatM ()
setDeltaNat (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
arg_size)
             OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 (Int -> Imm
ImmInt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Platform -> Int
platformWordSizeInBytes Platform
platform))) (Reg -> Operand
OpReg Reg
rsp),
                         Int -> Instr
DELTA (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
arg_size)]

    ([CmmExpr]
stack_args, [Reg]
int_regs_used, [Reg]
fp_regs_used, OrdList Instr
load_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 [CmmExpr]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmExpr]
prom_args [] [] (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform) OrdList Instr
forall a. OrdList a
nilOL
        else do
           ([CmmExpr]
stack_args, [Reg]
aregs, [Reg]
fregs, OrdList Instr
load_args_code, OrdList Instr
assign_args_code)
               <- [CmmExpr]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmExpr]
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 t a
rs [a]
as = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
dropTail (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
rs) [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)
           ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmExpr], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmExpr]
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 :: Int
sse_regs = [Reg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
fp_regs_used
        arg_stack_slots :: Int
arg_stack_slots = if Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32
                          then [CmmExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmExpr]
stack_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Reg, Reg)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform)
                          else [CmmExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmExpr]
stack_args
        tot_arg_size :: Int
tot_arg_size = Int
arg_size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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 [Stack Alignment on X86] in rts/StgCRun.c
    let word_size :: Int
word_size = Platform -> Int
platformWordSizeInBytes Platform
platform
    (Int
real_size, OrdList Instr
adjust_rsp) <-
        if (Int
tot_arg_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
word_size) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
16 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
            then (Int, OrdList Instr) -> NatM (Int, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
tot_arg_size, OrdList Instr
forall a. OrdList a
nilOL)
            else do -- we need to adjust...
                Int
delta <- NatM Int
getDeltaNat
                Int -> NatM ()
setDeltaNat (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
word_size)
                (Int, OrdList Instr) -> NatM (Int, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
tot_arg_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
word_size, [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                Format -> Operand -> Operand -> Instr
SUB Format
II64 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
word_size)) (Reg -> Operand
OpReg Reg
rsp),
                                Int -> Instr
DELTA (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
word_size) ])

    -- push the stack args, right to left
    OrdList Instr
push_code <- [CmmExpr] -> OrdList Instr -> NatM (OrdList Instr)
push_args ([CmmExpr] -> [CmmExpr]
forall a. [a] -> [a]
reverse [CmmExpr]
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 Int -> NatM (OrdList Instr)
leaveStackSpace ([(Reg, Reg)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform))
                else OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
    Int
delta <- NatM Int
getDeltaNat

    -- deal with static vs dynamic call targets
    (OrdList Instr
callinsns,ForeignConvention
_cconv) <- case CmmExpr
addr of
      CmmLit (CmmLabel CLabel
lbl) ->
        -- ToDo: stdcall arg sizes
        (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall a. a -> NatM a
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 (CLabel -> Imm
ImmCLbl CLabel
lbl)) [Reg]
arg_regs), ForeignConvention
conv)
      CmmExpr
_ -> do
        (Reg
dyn_r, OrdList Instr
dyn_c) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
addr
        (OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall a. a -> NatM a
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)

    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 :: Int -> OrdList Instr
assign_eax Int
n = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
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 Int
real_sizeInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then [] else
                   [Format -> Operand -> Operand -> Instr
ADD (Width -> Format
intFormat (Platform -> Width
platformWordWidth Platform
platform)) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
real_size)) (Reg -> Operand
OpReg Reg
esp)])
                  [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++
                  [Int -> Instr
DELTA (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
real_size)]
               )
    Int -> NatM ()
setDeltaNat (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
real_size)

    let
        -- assign the results, if necessary
        assign_code :: [LocalReg] -> OrdList Instr
assign_code []     = OrdList Instr
forall a. OrdList a
nilOL
        assign_code [LocalReg
dest] =
          case CmmType -> Width
typeWidth CmmType
rep of
                Width
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))
                Width
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))
                Width
_ -> 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 = LocalReg -> CmmType
localRegType LocalReg
dest
                r_dest :: Reg
r_dest = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
dest)
        assign_code [LocalReg]
_many = String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"genForeignCall.assign_code many"

    OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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`
            Int -> OrdList Instr
assign_eax Int
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`
            [LocalReg] -> OrdList Instr
assign_code [LocalReg]
dest_regs)


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

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

{-
Note [Sub-word subtlety during jump-table indexing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Offset the index by the start index of the jump table.
It's important that we do this *before* the widening below. To see
why, consider a switch with a sub-word, signed discriminant such as:

    switch [-5...+2] x::I16 {
        case -5: ...
        ...
        case +2: ...
    }

Consider what happens if we offset *after* widening in the case that
x=-4:

                                         // x == -4 == 0xfffc::I16
    indexWidened = UU_Conv(x);           // == 0xfffc::I64
    indexExpr    = indexWidened - (-5);  // == 0x10000::I64

This index is clearly nonsense given that the jump table only has
eight entries.

By contrast, if we widen *after* we offset then we get the correct
index (1),

                                         // x == -4 == 0xfffc::I16
    indexOffset  = x - (-5);             // == 1::I16
    indexExpr    = UU_Conv(indexOffset); // == 1::I64

See #21186.
-}

genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock

genSwitch :: CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch CmmExpr
expr SwitchTargets
targets = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
      expr_w :: Width
expr_w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
expr
      indexExpr0 :: CmmExpr
indexExpr0 = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
expr Int
offset
      -- We widen to a native-width register because we cannot use arbitrary sizes
      -- in x86 addressing modes.
      -- See Note [Sub-word subtlety during jump-table indexing].
      indexExpr :: CmmExpr
indexExpr = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp
        (Width -> Width -> MachOp
MO_UU_Conv Width
expr_w (Platform -> Width
platformWordWidth Platform
platform))
        [CmmExpr
indexExpr0]
  if NCGConfig -> Bool
ncgPIC NCGConfig
config
  then do
        (Reg
reg,OrdList Instr
e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
indexExpr
           -- getNonClobberedReg because it needs to survive across t_code
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        let is32bit :: Bool
is32bit = Platform -> Bool
target32Bit Platform
platform
            os :: OS
os = Platform -> OS
platformOS Platform
platform
            -- 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.
              OS
OSDarwin | Bool -> Bool
not Bool
is32bit -> SectionType -> CLabel -> Section
Section SectionType
Text CLabel
lbl
              OS
_ -> SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl
        CmmExpr
dynRef <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
DataReference CLabel
lbl
        (Reg
tableReg,OrdList Instr
t_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (CmmExpr -> NatM (Reg, OrdList Instr))
-> CmmExpr -> NatM (Reg, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmExpr
dynRef
        let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
tableReg)
                                       (Reg -> Int -> EAIndex
EAIndex Reg
reg (Platform -> Int
platformWordSizeInBytes Platform
platform)) (Int -> Imm
ImmInt Int
0))

        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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
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 (Platform -> Width
platformWordWidth Platform
platform)) 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 do
        (Reg
reg,OrdList Instr
e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        let is32bit :: Bool
is32bit = Platform -> Bool
target32Bit Platform
platform
        if Bool
is32bit
          then let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex EABase
EABaseNone (Reg -> Int -> EAIndex
EAIndex Reg
reg (Platform -> Int
platformWordSizeInBytes Platform
platform)) (CLabel -> Imm
ImmCLbl CLabel
lbl))
                   jmp_code :: Instr
jmp_code = Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL Operand
op [Maybe JumpDest]
ids (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) CLabel
lbl
               in OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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
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
unitOL Instr
jmp_code
          else do
            -- See Note [%rip-relative addressing on x86-64].
            Reg
tableReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (Platform -> Width
platformWordWidth Platform
platform))
            Reg
targetReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (Platform -> Width
platformWordWidth Platform
platform))
            let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
tableReg) (Reg -> Int -> EAIndex
EAIndex Reg
reg (Platform -> Int
platformWordSizeInBytes Platform
platform)) (Int -> Imm
ImmInt Int
0))
                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
                    [ Format -> Operand -> Operand -> Instr
LEA (Bool -> Format
archWordFormat Bool
is32bit) (AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex EABase
EABaseRip EAIndex
EAIndexNone (CLabel -> Imm
ImmCLbl CLabel
lbl))) (Reg -> Operand
OpReg Reg
tableReg)
                    , Format -> Operand -> Operand -> Instr
MOV (Bool -> Format
archWordFormat Bool
is32bit) Operand
op (Reg -> Operand
OpReg Reg
targetReg)
                    , Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL (Reg -> Operand
OpReg Reg
targetReg) [Maybe JumpDest]
ids (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) CLabel
lbl
                    ]
            OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
  where
    (Int
offset, [Maybe Label]
blockIds) = SwitchTargets -> (Int, [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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> JumpDest
DestBlockId) [Maybe Label]
blockIds

generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
generateJumpTableForInstr :: NCGConfig
-> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
generateJumpTableForInstr NCGConfig
config (JMP_TBL Operand
_ [Maybe JumpDest]
ids Section
section CLabel
lbl)
    = let getBlockId :: JumpDest -> Label
getBlockId (DestBlockId Label
id) = Label
id
          getBlockId JumpDest
_ = String -> Label
forall a. HasCallStack => String -> a
panic String
"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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JumpDest -> Label
getBlockId) [Maybe JumpDest]
ids
      in NatCmmDecl (Alignment, RawCmmStatics) Instr
-> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
forall a. a -> Maybe a
Just (NCGConfig
-> [Maybe Label]
-> Section
-> CLabel
-> NatCmmDecl (Alignment, RawCmmStatics) Instr
forall h g.
NCGConfig
-> [Maybe Label]
-> Section
-> CLabel
-> GenCmmDecl (Alignment, RawCmmStatics) h g
createJumpTable NCGConfig
config [Maybe Label]
blockIds Section
section CLabel
lbl)
generateJumpTableForInstr NCGConfig
_ Instr
_ = Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
forall a. Maybe a
Nothing

createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel
                -> GenCmmDecl (Alignment, RawCmmStatics) h g
createJumpTable :: forall h g.
NCGConfig
-> [Maybe Label]
-> Section
-> CLabel
-> GenCmmDecl (Alignment, RawCmmStatics) h g
createJumpTable NCGConfig
config [Maybe Label]
ids Section
section CLabel
lbl
    = let jumpTable :: [CmmStatic]
jumpTable
            | NCGConfig -> Bool
ncgPIC NCGConfig
config =
                  let ww :: Width
ww = NCGConfig -> Width
ncgWordWidth NCGConfig
config
                      jumpTableEntryRel :: Maybe Label -> CmmStatic
jumpTableEntryRel Maybe Label
Nothing
                          = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 Width
ww)
                      jumpTableEntryRel (Just Label
blockid)
                          = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
blockLabel CLabel
lbl Int
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 (NCGConfig -> Maybe Label -> CmmStatic
jumpTableEntry NCGConfig
config) [Maybe Label]
ids
      in Section
-> (Alignment, RawCmmStatics)
-> GenCmmDecl (Alignment, RawCmmStatics) h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
section (Int -> Alignment
mkAlignment Int
1, CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmStatic]
jumpTable)

extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints :: [Instr] -> [UnwindPoint]
extractUnwindPoints [Instr]
instrs =
    [ CLabel -> Map GlobalReg (Maybe UnwindExpr) -> UnwindPoint
UnwindPoint CLabel
lbl Map GlobalReg (Maybe UnwindExpr)
unwinds | UNWIND CLabel
lbl 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 -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
cond CmmExpr
x CmmExpr
y = do
  CondCode Bool
_ Cond
cond OrdList Instr
cond_code <- Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond CmmExpr
x CmmExpr
y
  Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II8
  let
        code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 prediction system
-- and plays better with the uOP cache.

condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Bool
is32Bit Cond
cond CmmExpr
x CmmExpr
y = NatM Register
condFltReg_sse2
 where


  condFltReg_sse2 :: NatM Register
condFltReg_sse2 = do
    CondCode Bool
_ Cond
cond OrdList Instr
cond_code <- Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
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 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
                Cond
NE  -> Reg -> OrdList Instr
or_unordered Reg
dst
                Cond
GU  -> Reg -> OrdList Instr
plain_test   Reg
dst
                Cond
GEU -> Reg -> OrdList Instr
plain_test   Reg
dst
                -- Use ASSERT so we don't break releases if these creep in.
                Cond
LTT -> Bool -> SDoc -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should have been turned into >") (OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$
                       Reg -> OrdList Instr
and_ordered  Reg
dst
                Cond
LE  -> Bool -> SDoc -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr Bool
False (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Should have been turned into >=") (OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$
                       Reg -> OrdList Instr
and_ordered  Reg
dst
                Cond
_   -> Reg -> OrdList Instr
and_ordered  Reg
dst)

        plain_test :: Reg -> OrdList Instr
plain_test 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 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 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 a. a -> NatM a
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)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
m CmmExpr
a CmmExpr
b
    = do Platform
platform <- NatM Platform
getPlatform
         Platform
-> Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode' Platform
platform Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
m CmmExpr
a CmmExpr
b

trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)
             -> Maybe (Operand -> Operand -> Instr)
             -> CmmExpr -> CmmExpr -> NatM Register
trivialCode' :: Platform
-> Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode' Platform
platform Width
width Operand -> Operand -> Instr
_ (Just Operand -> Operand -> Instr
revinstr) (CmmLit CmmLit
lit_a) CmmExpr
b
  | Platform -> CmmLit -> Bool
is32BitLit Platform
platform CmmLit
lit_a = do
  Reg -> OrdList Instr
b_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
b
  let
       code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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' Platform
_ Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
_ CmmExpr
a CmmExpr
b
  = Format
-> (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
genTrivialCode (Width -> Format
intFormat Width
width) Operand -> Operand -> Instr
instr CmmExpr
a CmmExpr
b

-- This is re-used for floating pt instructions too.
genTrivialCode :: Format -> (Operand -> Operand -> Instr)
               -> CmmExpr -> CmmExpr -> NatM Register
genTrivialCode :: Format
-> (Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
genTrivialCode Format
rep Operand -> Operand -> Instr
instr CmmExpr
a CmmExpr
b = do
  (Operand
b_op, OrdList Instr
b_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getNonClobberedOperand CmmExpr
b
  Reg -> OrdList Instr
a_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
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 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 a. a -> NatM a
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 regClashesWithOp :: Reg -> Operand -> Bool
`regClashesWithOp` OpReg Reg
reg2   = Reg
reg Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
reg2
Reg
reg `regClashesWithOp` OpAddr 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)
Reg
_   `regClashesWithOp` Operand
_            = Bool
False

-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@,
-- with 3 operands (FMA3 instruction set).
genFMA3Code :: Width
            -> FMASign
            -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register
genFMA3Code :: Width -> FMASign -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register
genFMA3Code Width
w FMASign
signs CmmExpr
x CmmExpr
y CmmExpr
z = do

  -- For the FMA instruction, we want to compute x * y + z
  --
  -- There are three possible instructions we could emit:
  --
  --   - fmadd213 z y x, result in x, z can be a memory address
  --   - fmadd132 x z y, result in y, x can be a memory address
  --   - fmadd231 y x z, result in z, y can be a memory address
  --
  -- This suggests two possible optimisations:
  --
  --   - OPTIMISATION 1
  --     If one argument is an address, use the instruction that allows
  --     a memory address in that position.
  --
  --   - OPTIMISATION 2
  --     If one argument is in a fixed register, use the instruction that puts
  --     the result in that same register.
  --
  -- Currently we follow neither of these optimisations,
  -- opting to always use fmadd213 for simplicity.
  let rep :: Format
rep = Width -> Format
floatFormat Width
w
  (Reg
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
y
  (Reg
z_reg, OrdList Instr
z_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmExpr
z
  Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
x
  Reg
y_tmp <- Format -> NatM Reg
getNewRegNat Format
rep
  Reg
z_tmp <- Format -> NatM Reg
getNewRegNat Format
rep
  let
     fma213 :: Operand -> Reg -> Reg -> Instr
fma213 = Format
-> FMASign -> FMAPermutation -> Operand -> Reg -> Reg -> Instr
FMA3 Format
rep FMASign
signs FMAPermutation
FMA213
     code :: Reg -> OrdList Instr
code Reg
dst
         | Reg
dst Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
y_reg
         , Reg
dst Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
z_reg
         = OrdList Instr
y_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 (Reg -> Operand
OpReg Reg
y_reg) (Reg -> Operand
OpReg Reg
y_tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
           OrdList Instr
z_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 (Reg -> Operand
OpReg Reg
z_reg) (Reg -> Operand
OpReg Reg
z_tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
           Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
           Operand -> Reg -> Reg -> Instr
fma213 (Reg -> Operand
OpReg Reg
z_tmp) Reg
y_tmp Reg
dst
        | Reg
dst Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
y_reg
        = OrdList Instr
y_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 (Reg -> Operand
OpReg Reg
y_reg) (Reg -> Operand
OpReg Reg
z_tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          OrdList Instr
z_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
          Operand -> Reg -> Reg -> Instr
fma213 (Reg -> Operand
OpReg Reg
z_reg) Reg
y_tmp Reg
dst
        | Reg
dst Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
z_reg
        = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          OrdList Instr
z_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 (Reg -> Operand
OpReg Reg
z_reg) (Reg -> Operand
OpReg Reg
z_tmp)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
          Operand -> Reg -> Reg -> Instr
fma213 (Reg -> Operand
OpReg Reg
z_tmp) Reg
y_reg Reg
dst
        | Bool
otherwise
        = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          OrdList Instr
z_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
          Operand -> Reg -> Reg -> Instr
fma213 (Reg -> Operand
OpReg Reg
z_reg) Reg
y_reg Reg
dst
  Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
rep Reg -> OrdList Instr
code)

-----------

trivialUCode :: Format -> (Operand -> Instr)
             -> CmmExpr -> NatM Register
trivialUCode :: Format -> (Operand -> Instr) -> CmmExpr -> NatM Register
trivialUCode Format
rep Operand -> Instr
instr CmmExpr
x = do
  Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
x
  let
     code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
rep Reg -> OrdList Instr
code)

-----------


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


--------------------------------------------------------------------------------
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
from Width
to CmmExpr
x =  NatM Register
coerce_sse2
 where

   coerce_sse2 :: NatM Register
coerce_sse2 = do
     (Operand
x_op, OrdList Instr
x_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
x  -- ToDo: could be a safe operand
     let
           opc :: Format -> Operand -> Reg -> Instr
opc  = case Width
to of Width
W32 -> Format -> Operand -> Reg -> Instr
CVTSI2SS; Width
W64 -> Format -> Operand -> Reg -> Instr
CVTSI2SD
                             Width
n -> String -> Format -> Operand -> Reg -> Instr
forall a. HasCallStack => String -> a
panic (String -> Format -> Operand -> Reg -> Instr)
-> String -> Format -> Operand -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
")"
           code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 -> CmmExpr -> NatM Register
coerceFP2Int Width
from Width
to CmmExpr
x =  NatM Register
coerceFP2Int_sse2
 where
   coerceFP2Int_sse2 :: NatM Register
coerceFP2Int_sse2 = do
     (Operand
x_op, OrdList Instr
x_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getOperand CmmExpr
x  -- ToDo: could be a safe operand
     let
           opc :: Format -> Operand -> Reg -> Instr
opc  = case Width
from of Width
W32 -> Format -> Operand -> Reg -> Instr
CVTTSS2SIQ; Width
W64 -> Format -> Operand -> Reg -> Instr
CVTTSD2SIQ;
                               Width
n -> String -> Format -> Operand -> Reg -> Instr
forall a. HasCallStack => String -> a
panic (String -> Format -> Operand -> Reg -> Instr)
-> String -> Format -> Operand -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
")"
           code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 -> CmmExpr -> NatM Register
coerceFP2FP Width
to CmmExpr
x = do
  (Reg
x_reg, OrdList Instr
x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
  let
        opc :: Reg -> Reg -> Instr
opc  = case Width
to of Width
W32 -> Reg -> Reg -> Instr
CVTSD2SS; Width
W64 -> Reg -> Reg -> Instr
CVTSS2SD;
                                     Width
n -> String -> Reg -> Reg -> Instr
forall a. HasCallStack => String -> a
panic (String -> Reg -> Reg -> Instr) -> String -> Reg -> Reg -> Instr
forall a b. (a -> b) -> a -> b
$ String
"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]
++ String
")"
        code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any ( Width -> Format
floatFormat Width
to) Reg -> OrdList Instr
code)

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

sse2NegCode :: Width -> CmmExpr -> NatM Register
sse2NegCode :: Width -> CmmExpr -> NatM Register
sse2NegCode Width
w CmmExpr
x = do
  let fmt :: Format
fmt = Width -> Format
floatFormat Width
w
  Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
x
  -- This is how gcc does it, so it can't be that bad:
  let
    const :: CmmLit
const = case Format
fmt of
      Format
FF32 -> Integer -> Width -> CmmLit
CmmInt Integer
0x80000000 Width
W32
      Format
FF64 -> Integer -> Width -> CmmLit
CmmInt Integer
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

      where
        wrongFmt :: a -> a
wrongFmt a
x = String -> a
forall a. HasCallStack => String -> a
panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"sse2NegCode: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
  Amode AddrMode
amode OrdList Instr
amode_code <- Alignment -> CmmLit -> NatM Amode
memConstant (Int -> Alignment
mkAlignment (Int -> Alignment) -> Int -> Alignment
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBytes Width
w) CmmLit
const
  Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
  let
    code :: Reg -> OrdList Instr
code 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 a. a -> NatM a
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 :: CmmExpr -> Bool
isVecExpr (CmmMachOp (MO_V_Insert {}) [CmmExpr]
_)   = Bool
True
isVecExpr (CmmMachOp (MO_V_Extract {}) [CmmExpr]
_)  = Bool
True
isVecExpr (CmmMachOp (MO_V_Add {}) [CmmExpr]
_)      = Bool
True
isVecExpr (CmmMachOp (MO_V_Sub {}) [CmmExpr]
_)      = Bool
True
isVecExpr (CmmMachOp (MO_V_Mul {}) [CmmExpr]
_)      = Bool
True
isVecExpr (CmmMachOp (MO_VS_Quot {}) [CmmExpr]
_)    = Bool
True
isVecExpr (CmmMachOp (MO_VS_Rem {}) [CmmExpr]
_)     = Bool
True
isVecExpr (CmmMachOp (MO_VS_Neg {}) [CmmExpr]
_)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Insert {}) [CmmExpr]
_)  = Bool
True
isVecExpr (CmmMachOp (MO_VF_Extract {}) [CmmExpr]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Add {}) [CmmExpr]
_)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Sub {}) [CmmExpr]
_)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Mul {}) [CmmExpr]
_)     = Bool
True
isVecExpr (CmmMachOp (MO_VF_Quot {}) [CmmExpr]
_)    = Bool
True
isVecExpr (CmmMachOp (MO_VF_Neg {}) [CmmExpr]
_)     = Bool
True
isVecExpr (CmmMachOp MachOp
_ [CmmExpr
e])                = CmmExpr -> Bool
isVecExpr CmmExpr
e
isVecExpr CmmExpr
_                                = Bool
False

needLlvm :: NatM a
needLlvm :: forall a. NatM a
needLlvm =
    String -> NatM a
forall a. HasCallStack => String -> a
sorry (String -> NatM a) -> String -> NatM a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"The native code generator does not support vector"
                    ,String
"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 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 :: forall a.
Maybe CFG
-> LabelMap a -> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invertCondBranches Maybe CFG
Nothing LabelMap a
_       [NatBasicBlock Instr]
bs = [NatBasicBlock Instr]
bs
invertCondBranches (Just CFG
cfg) LabelMap a
keep [NatBasicBlock Instr]
bs =
    [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invert [NatBasicBlock Instr]
bs
  where
    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
invert (BasicBlock Label
lbl1 [Instr]
ins:b2 :: NatBasicBlock Instr
b2@(BasicBlock Label
lbl2 [Instr]
_):[NatBasicBlock Instr]
bs)
      | --pprTrace "Block" (ppr lbl1) True,
        Just (Instr
jmp1,Instr
jmp2) <- [Instr] -> Maybe (Instr, Instr)
forall a. [a] -> Maybe (a, a)
last2 [Instr]
ins
      , JXX Cond
cond1 Label
target1 <- Instr
jmp1
      , Label
target1 Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
lbl2
      --, pprTrace "CutChance" (ppr b1) True
      , JXX Cond
ALWAYS 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 EdgeInfo
edgeInfo1 <- Label -> Label -> CFG -> Maybe EdgeInfo
getEdgeInfo Label
lbl1 Label
target1 CFG
cfg
      , Just 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 {trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmNode O C
cmmCondBranch} <- EdgeInfo -> TransitionSource
transitionSource EdgeInfo
edgeInfo1

      --Int comparisons are invertable
      , CmmCondBranch (CmmMachOp MachOp
op [CmmExpr]
_args) Label
_ Label
_ Maybe Bool
_ <- CmmNode O C
cmmCondBranch
      , Just Width
_ <- MachOp -> Maybe Width
maybeIntComparison MachOp
op
      , Just 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 a. 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
            (Int -> [Instr] -> [Instr]
forall a. Int -> [a] -> [a]
dropTail Int
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 (NatBasicBlock Instr
b:[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 [] = []

genAtomicRMW
  :: BlockId
  -> Width
  -> AtomicMachOp
  -> LocalReg
  -> CmmExpr
  -> CmmExpr
  -> NatM (InstrBlock, Maybe BlockId)
genAtomicRMW :: Label
-> Width
-> AtomicMachOp
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr, Maybe Label)
genAtomicRMW Label
bid Width
width AtomicMachOp
amop LocalReg
dst CmmExpr
addr CmmExpr
n = do
    Amode AddrMode
amode OrdList Instr
addr_code <-
        if AtomicMachOp
amop AtomicMachOp -> [AtomicMachOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AtomicMachOp
AMO_Add, AtomicMachOp
AMO_Sub]
        then CmmExpr -> NatM Amode
getAmode CmmExpr
addr
        else CmmExpr -> NatM Amode
getSimpleAmode CmmExpr
addr  -- See genForeignCall for MO_Cmpxchg
    Reg
arg <- Format -> NatM Reg
getNewRegNat Format
format
    Reg -> OrdList Instr
arg_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
n
    Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig

    let dst_r :: Reg
dst_r    = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
dst)
    (OrdList Instr
code, 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 a. a -> NatM a
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 Reg
dst_r Reg
arg 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.
        AtomicMachOp
AMO_Add  -> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a. a -> NatM a
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)
        AtomicMachOp
AMO_Sub  -> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a. a -> NatM a
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.
        AtomicMachOp
AMO_And  -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ Operand
src 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)
        AtomicMachOp
AMO_Nand -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ Operand
src 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
                                                    ])
        AtomicMachOp
AMO_Or   -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ Operand
src 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)
        AtomicMachOp
AMO_Xor  -> (Operand -> Operand -> OrdList Instr)
-> NatM (OrdList Instr, Label)
cmpxchg_code (\ Operand
src 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 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'.
            Label -> Label -> NatM ()
addImmediateSuccessorNat Label
bid Label
lbl1
            Label -> Label -> NatM ()
addImmediateSuccessorNat Label
lbl1 Label
lbl2
            (CFG -> CFG) -> NatM ()
updateCfgNat (Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
lbl1 Label
lbl1 EdgeWeight
0)

            (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a. a -> NatM a
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

-- | Count trailing zeroes
genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)
genCtz :: Label
-> Width
-> LocalReg
-> CmmExpr
-> NatM (OrdList Instr, Maybe Label)
genCtz Label
bid Width
width LocalReg
dst CmmExpr
src = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  if Bool
is32Bit Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
    then Label -> LocalReg -> CmmExpr -> NatM (OrdList Instr, Maybe Label)
genCtz64_32 Label
bid LocalReg
dst CmmExpr
src
    else (,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
<$> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genCtzGeneric Width
width LocalReg
dst CmmExpr
src

-- | Count trailing zeroes
--
-- 64-bit width on 32-bit architecture
genCtz64_32
  :: BlockId
  -> LocalReg
  -> CmmExpr
  -> NatM (InstrBlock, Maybe BlockId)
genCtz64_32 :: Label -> LocalReg -> CmmExpr -> NatM (OrdList Instr, Maybe Label)
genCtz64_32 Label
bid LocalReg
dst CmmExpr
src = do
  RegCode64 OrdList Instr
vcode Reg
rhi Reg
rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
src
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  Label
lbl1 <- NatM Label
getBlockIdNat
  Label
lbl2 <- NatM Label
getBlockIdNat
  Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
II64

  -- New CFG Edges:
  --  bid -> lbl2
  --  bid -> lbl1 -> lbl2
  --  We also changes edges originating at bid to start at lbl2 instead.
  Weights
weights <- NatM Weights
getCfgWeights
  (CFG -> CFG) -> NatM ()
updateCfgNat (Label -> Label -> EdgeWeight -> CFG -> CFG
addWeightEdge Label
bid Label
lbl1 EdgeWeight
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 EdgeWeight
110 (CFG -> CFG) -> (CFG -> CFG) -> CFG -> CFG
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                Weights -> Label -> Label -> CFG -> CFG
addImmediateSuccessor Weights
weights 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 (Int -> Imm
ImmInt Int
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 (Int -> Imm
ImmInt Int
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, Label -> Maybe Label
forall a. a -> Maybe a
Just Label
lbl2)

-- | Count trailing zeroes
--
-- Generic case (width <= word size)
genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genCtzGeneric Width
width LocalReg
dst CmmExpr
src = do
  Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  NCGConfig
config <- NatM NCGConfig
getConfig
  let bw :: Int
bw = Width -> Int
widthInBits Width
width
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  if NCGConfig -> Maybe BmiVersion
ncgBmiVersion NCGConfig
config Maybe BmiVersion -> Maybe BmiVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= BmiVersion -> Maybe BmiVersion
forall a. a -> Maybe a
Just BmiVersion
BMI2
  then do
      Reg
src_r <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
width)
      let instrs :: OrdList Instr
instrs = 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 -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ case Width
width of
              Width
W8 -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                  [ Format -> Operand -> Operand -> Instr
OR    Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
0xFFFFFF00)) (Reg -> Operand
OpReg Reg
src_r)
                  , Format -> Operand -> Reg -> Instr
TZCNT Format
II32 (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r
                  ]
              Width
W16 -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                  [ Format -> Operand -> Reg -> Instr
TZCNT  Format
II16 (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r
                  , Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r)
                  ]
              Width
_ -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Reg -> Instr
TZCNT (Width -> Format
intFormat Width
width) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r
      OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
instrs
  else do
      -- 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 (Int -> Imm
ImmInt Int
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 -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
instrs



-- | Copy memory
--
-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf
-- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.
genMemCpy
  :: BlockId
  -> Int
  -> CmmExpr
  -> CmmExpr
  -> CmmExpr
  -> NatM InstrBlock
genMemCpy :: Label
-> Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genMemCpy Label
bid Int
align CmmExpr
dst CmmExpr
src CmmExpr
arg_n = do

  let libc_memcpy :: NatM (OrdList Instr)
libc_memcpy = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"memcpy") [] [CmmExpr
dst,CmmExpr
src,CmmExpr
arg_n]

  case CmmExpr
arg_n of
    CmmLit (CmmInt Integer
n Width
_) -> do
      -- try to inline it
      Maybe (OrdList Instr)
mcode <- Int
-> CmmExpr -> CmmExpr -> Integer -> NatM (Maybe (OrdList Instr))
genMemCpyInlineMaybe Int
align CmmExpr
dst CmmExpr
src Integer
n
      -- if it didn't inline, call the C function
      case Maybe (OrdList Instr)
mcode of
        Maybe (OrdList Instr)
Nothing -> NatM (OrdList Instr)
libc_memcpy
        Just OrdList Instr
c  -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
c

    -- not a literal size argument: call the C function
    CmmExpr
_ -> NatM (OrdList Instr)
libc_memcpy



genMemCpyInlineMaybe
  :: Int
  -> CmmExpr
  -> CmmExpr
  -> Integer
  -> NatM (Maybe InstrBlock)
genMemCpyInlineMaybe :: Int
-> CmmExpr -> CmmExpr -> Integer -> NatM (Maybe (OrdList Instr))
genMemCpyInlineMaybe Int
align CmmExpr
dst CmmExpr
src Integer
n = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  let
    platform :: Platform
platform     = NCGConfig -> Platform
ncgPlatform NCGConfig
config
    maxAlignment :: Alignment
maxAlignment = Platform -> Alignment
wordAlignment Platform
platform
                   -- only machine word wide MOVs are supported
    effectiveAlignment :: Alignment
effectiveAlignment = Alignment -> Alignment -> Alignment
forall a. Ord a => a -> a -> a
min (Int -> Alignment
alignmentOf Int
align) Alignment
maxAlignment
    format :: Format
format = Width -> Format
intFormat (Width -> Format) -> (Int -> Width) -> Int -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Width
widthFromBytes (Int -> Format) -> Int -> Format
forall a b. (a -> b) -> a -> b
$ Alignment -> Int
alignmentBytes Alignment
effectiveAlignment


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

  -- The number of instructions we will generate (approx). We need 2
  -- instructions per move.
  let insns :: Integer
insns = Integer
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
- Integer
1) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
sizeBytes)

      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst Reg
src Reg
tmp 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
>= Integer
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
- Integer
4)
          | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
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
- Integer
2)
          | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
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
- Integer
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))

  if Integer
insns Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Word -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NCGConfig -> Word
ncgInlineThresholdMemcpy NCGConfig
config)
    then Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (OrdList Instr)
forall a. Maybe a
Nothing
    else do
      Reg -> OrdList Instr
code_dst <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
dst
      Reg
dst_r <- Format -> NatM Reg
getNewRegNat Format
format
      Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
      Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
      Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
      Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr)))
-> Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Maybe (OrdList Instr)
forall a. a -> Maybe a
Just (OrdList Instr -> Maybe (OrdList Instr))
-> OrdList Instr -> Maybe (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)

-- | Set memory to the given byte
--
-- Unroll memset calls if the number of bytes to copy isn't too large (cf
-- ncgInlineThresholdMemset).  Otherwise, call C's memset.
genMemSet
  :: BlockId
  -> Int
  -> CmmExpr
  -> CmmExpr
  -> CmmExpr
  -> NatM InstrBlock
genMemSet :: Label
-> Int -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genMemSet Label
bid Int
align CmmExpr
dst CmmExpr
arg_c CmmExpr
arg_n = do

  let libc_memset :: NatM (OrdList Instr)
libc_memset = Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"memset") [] [CmmExpr
dst,CmmExpr
arg_c,CmmExpr
arg_n]

  case (CmmExpr
arg_c,CmmExpr
arg_n) of
    (CmmLit (CmmInt Integer
c Width
_), CmmLit (CmmInt Integer
n Width
_)) -> do
      -- try to inline it
      Maybe (OrdList Instr)
mcode <- Int
-> CmmExpr -> Integer -> Integer -> NatM (Maybe (OrdList Instr))
genMemSetInlineMaybe Int
align CmmExpr
dst Integer
c Integer
n
      -- if it didn't inline, call the C function
      case Maybe (OrdList Instr)
mcode of
        Maybe (OrdList Instr)
Nothing -> NatM (OrdList Instr)
libc_memset
        Just OrdList Instr
c  -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
c

    -- not literal size arguments: call the C function
    (CmmExpr, CmmExpr)
_ -> NatM (OrdList Instr)
libc_memset

genMemSetInlineMaybe
  :: Int
  -> CmmExpr
  -> Integer
  -> Integer
  -> NatM (Maybe InstrBlock)
genMemSetInlineMaybe :: Int
-> CmmExpr -> Integer -> Integer -> NatM (Maybe (OrdList Instr))
genMemSetInlineMaybe Int
align CmmExpr
dst Integer
c Integer
n = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  let
    platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
    maxAlignment :: Alignment
maxAlignment = Platform -> Alignment
wordAlignment Platform
platform -- only machine word wide MOVs are supported
    effectiveAlignment :: Alignment
effectiveAlignment = Alignment -> Alignment -> Alignment
forall a. Ord a => a -> a -> a
min (Int -> Alignment
alignmentOf Int
align) Alignment
maxAlignment
    format :: Format
format = Width -> Format
intFormat (Width -> Format) -> (Int -> Width) -> Int -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Width
widthFromBytes (Int -> Format) -> Int -> Format
forall a b. (a -> b) -> a -> b
$ Alignment -> Int
alignmentBytes Alignment
effectiveAlignment
    c2 :: Integer
c2 = Integer
c Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
c
    c4 :: Integer
c4 = Integer
c2 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
16 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
c2
    c8 :: Integer
c8 = Integer
c4 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
32 Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
c4

    -- 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
- Integer
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 = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Int
formatInBytes Format
format)

    -- Depending on size returns the widest MOV instruction and its
    -- width.
    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)
    gen4 :: AddrMode -> Integer -> (OrdList Instr, Integer)
gen4 AddrMode
addr Integer
size
        | Integer
size Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
4 =
            (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
addr)), Integer
4)
        | Integer
size Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
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
addr)), Integer
2)
        | Integer
size Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
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
addr)), Integer
1)
        | Bool
otherwise = (OrdList Instr
forall a. OrdList a
nilOL, Integer
0)

    -- Generates a 64-bit wide MOV instruction from REG to MEM.
    gen8 :: AddrMode -> Reg -> InstrBlock
    gen8 :: AddrMode -> Reg -> OrdList Instr
gen8 AddrMode
addr Reg
reg8byte =
      Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
reg8byte) (AddrMode -> Operand
OpAddr AddrMode
addr))

    -- Unrolls memset when the widest MOV is <= 4 bytes.
    go4 :: Reg -> Integer -> InstrBlock
    go4 :: Reg -> Integer -> OrdList Instr
go4 Reg
dst Integer
left =
      if Integer
left Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 then OrdList Instr
forall a. OrdList a
nilOL
      else OrdList Instr
curMov OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> Integer -> OrdList Instr
go4 Reg
dst (Integer
left Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
curWidth)
      where
        possibleWidth :: Integer
possibleWidth = [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Integer
left, Integer
sizeBytes]
        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
left))
        (OrdList Instr
curMov, Integer
curWidth) = AddrMode -> Integer -> (OrdList Instr, Integer)
gen4 AddrMode
dst_addr Integer
possibleWidth

    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg
    -- argument). Falls back to go4 when all 8 byte moves are
    -- exhausted.
    go8 :: Reg -> Reg -> Integer -> InstrBlock
    go8 :: Reg -> Reg -> Integer -> OrdList Instr
go8 Reg
dst Reg
reg8byte Integer
left =
      if Integer
possibleWidth Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
8 then
        let curMov :: OrdList Instr
curMov = AddrMode -> Reg -> OrdList Instr
gen8 AddrMode
dst_addr Reg
reg8byte
        in  OrdList Instr
curMov OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> Reg -> Integer -> OrdList Instr
go8 Reg
dst Reg
reg8byte (Integer
left Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
8)
      else Reg -> Integer -> OrdList Instr
go4 Reg
dst Integer
left
      where
        possibleWidth :: Integer
possibleWidth = [Integer] -> Integer
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Integer
left, Integer
sizeBytes]
        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
left))

  if Integer -> Word
forall a. Num a => Integer -> a
fromInteger Integer
insns Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> NCGConfig -> Word
ncgInlineThresholdMemset NCGConfig
config
    then Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (OrdList Instr)
forall a. Maybe a
Nothing
    else do
        Reg -> OrdList Instr
code_dst <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
dst
        Reg
dst_r <- Format -> NatM Reg
getNewRegNat Format
format
        if Format
format Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
== Format
II64 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
8
          then do
            Reg -> OrdList Instr
code_imm8byte <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
c8 Width
W64))
            Reg
imm8byte_r <- Format -> NatM Reg
getNewRegNat Format
II64
            Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr)))
-> Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Maybe (OrdList Instr)
forall a. a -> Maybe a
Just (OrdList Instr -> Maybe (OrdList Instr))
-> OrdList Instr -> Maybe (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_imm8byte Reg
imm8byte_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                              Reg -> Reg -> Integer -> OrdList Instr
go8 Reg
dst_r Reg
imm8byte_r (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n)
          else
            Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr)))
-> Maybe (OrdList Instr) -> NatM (Maybe (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Maybe (OrdList Instr)
forall a. a -> Maybe a
Just (OrdList Instr -> Maybe (OrdList Instr))
-> OrdList Instr -> Maybe (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
go4 Reg
dst_r (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n)


genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
genMemMove :: forall p.
Label -> p -> CmmExpr -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genMemMove Label
bid p
_align CmmExpr
dst CmmExpr
src CmmExpr
n = do
  -- TODO: generate inline assembly when under a given treshold (similarly to
  -- memcpy and memset)
  Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"memmove") [] [CmmExpr
dst,CmmExpr
src,CmmExpr
n]

genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
genMemCmp :: forall p.
Label
-> p
-> LocalReg
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genMemCmp Label
bid p
_align LocalReg
res CmmExpr
dst CmmExpr
src CmmExpr
n = do
  -- TODO: generate inline assembly when under a given treshold (similarly to
  -- memcpy and memset)
  Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genLibCCall Label
bid (String -> FastString
fsLit String
"memcmp") [LocalReg
res] [CmmExpr
dst,CmmExpr
src,CmmExpr
n]

genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)
genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)
genPrefetchData Int
n CmmExpr
src = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  let
    format :: Format
format = Bool -> Format
archWordFormat Bool
is32Bit
    -- need to know what register width for pointers!
    genPrefetch :: CmmExpr -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmExpr
inRegSrc Operand -> Instr
prefetchCTor = do
      Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
inRegSrc
      Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
      OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 (Int -> Imm
ImmInt Int
0))))  ))
        -- prefetch always takes an address

  -- the c / llvm prefetch convention is 0, 1, 2, and 3
  -- the x86 corresponding names are : NTA, 2 , 1, and 0
  case Int
n of
      Int
0 -> CmmExpr -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmExpr
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
      Int
1 -> CmmExpr -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmExpr
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
      Int
2 -> CmmExpr -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmExpr
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
      Int
3 -> CmmExpr -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmExpr
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
      Int
l -> String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genPrefetchData: unexpected prefetch level" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
l)

genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genByteSwap Width
width LocalReg
dst CmmExpr
src = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  let format :: Format
format = Width -> Format
intFormat Width
width
  case Width
width of
      Width
W64 | Bool
is32Bit -> do
        let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
        RegCode64 OrdList Instr
vcode Reg
rhi Reg
rlo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
src
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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_hi),
                        Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rhi) (Reg -> Operand
OpReg Reg
dst_lo),
                        Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_hi,
                        Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_lo ]
      Width
W16 -> do
        let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
        Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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
$ Int -> Imm
ImmInt Int
16) (Reg -> Operand
OpReg Reg
dst_r))
      Width
_   -> do
        let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
        Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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)

genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
genBitRev :: Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genBitRev Label
bid Width
width LocalReg
dst CmmExpr
src = do
  -- Here the C implementation (hs_bitrevN) is used as there is no x86
  -- instruction to reverse a word's bit order.
  Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
bRevLabel Width
width) [LocalReg
dst] [CmmExpr
src]

genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock
genPopCnt :: Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genPopCnt Label
bid Width
width LocalReg
dst CmmExpr
src = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  let
    platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
    format :: Format
format = Width -> Format
intFormat Width
width

  NatM Bool
sse4_2Enabled NatM Bool -> (Bool -> NatM (OrdList Instr)) -> NatM (OrdList Instr)
forall a b. NatM a -> (a -> NatM b) -> NatM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

    Bool
True -> do
      Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
      Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
      let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
dst)
      OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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)

    Bool
False ->
      -- generate C call to hs_popcntN in ghc-prim
      -- TODO: we could directly generate the assembly to index popcount_tab
      -- here instead of doing it by calling a C function
      Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
popCntLabel Width
width) [LocalReg
dst] [CmmExpr
src]


genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genPdep :: Label
-> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPdep Label
bid Width
width LocalReg
dst CmmExpr
src CmmExpr
mask = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  let
    platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
    format :: Format
format = Width -> Format
intFormat Width
width

  if NCGConfig -> Maybe BmiVersion
ncgBmiVersion NCGConfig
config Maybe BmiVersion -> Maybe BmiVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= BmiVersion -> Maybe BmiVersion
forall a. a -> Maybe a
Just BmiVersion
BMI2
    then do
      Reg -> OrdList Instr
code_src  <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
      Reg -> OrdList Instr
code_mask <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
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 -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
dst)
      OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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`
          -- PDEP only supports > 32 bit args
          ( 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
              [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                [ Format -> Operand -> Operand -> Instr
MOVZxL Format
format (Reg -> Operand
OpReg Reg
src_r ) (Reg -> Operand
OpReg Reg
src_r )
                , Format -> Operand -> Operand -> Instr
MOVZxL Format
format (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
mask_r)
                , Format -> Operand -> Operand -> Reg -> Instr
PDEP   Format
II32 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r ) Reg
dst_r
                , Format -> Operand -> Operand -> Instr
MOVZxL Format
format (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r) -- Truncate to op width
                ]
            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)
          )
    else
      -- generate C call to hs_pdepN in ghc-prim
      Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
pdepLabel Width
width) [LocalReg
dst] [CmmExpr
src,CmmExpr
mask]


genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genPext :: Label
-> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPext Label
bid Width
width LocalReg
dst CmmExpr
src CmmExpr
mask = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  if NCGConfig -> Maybe BmiVersion
ncgBmiVersion NCGConfig
config Maybe BmiVersion -> Maybe BmiVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= BmiVersion -> Maybe BmiVersion
forall a. a -> Maybe a
Just BmiVersion
BMI2
    then do
      let format :: Format
format   = Width -> Format
intFormat Width
width
      let dst_r :: Reg
dst_r    = LocalReg -> Reg
getLocalRegReg LocalReg
dst
      Reg -> OrdList Instr
code_src  <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
      Reg -> OrdList Instr
code_mask <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
mask
      Reg
src_r     <- Format -> NatM Reg
getNewRegNat Format
format
      Reg
mask_r    <- Format -> NatM Reg
getNewRegNat Format
format
      OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 then
               -- The PEXT instruction doesn't take a r/m8 or 16
              [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                [ Format -> Operand -> Operand -> Instr
MOVZxL Format
format (Reg -> Operand
OpReg Reg
src_r ) (Reg -> Operand
OpReg Reg
src_r )
                , Format -> Operand -> Operand -> Instr
MOVZxL Format
format (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
mask_r)
                , Format -> Operand -> Operand -> Reg -> Instr
PEXT   Format
II32 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r ) Reg
dst_r
                , Format -> Operand -> Operand -> Instr
MOVZxL Format
format (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r) -- Truncate to op width
                ]
            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)
          )
    else
      -- generate C call to hs_pextN in ghc-prim
      Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
pextLabel Width
width) [LocalReg
dst] [CmmExpr
src,CmmExpr
mask]

genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
genClz :: Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genClz Label
bid Width
width LocalReg
dst CmmExpr
src = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  NCGConfig
config <- NatM NCGConfig
getConfig
  if Bool
is32Bit Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64

    then
      -- Fallback to `hs_clz64` on i386
      Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
clzLabel Width
width) [LocalReg
dst] [CmmExpr
src]

    else do
      Reg -> OrdList Instr
code_src <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
      let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
      if NCGConfig -> Maybe BmiVersion
ncgBmiVersion NCGConfig
config Maybe BmiVersion -> Maybe BmiVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= BmiVersion -> Maybe BmiVersion
forall a. a -> Maybe a
Just BmiVersion
BMI2
        then do
          Reg
src_r <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
width)
          OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 -> 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 -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ case Width
width of
            Width
W8 -> [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) -- zero-extend to 32 bit
                , Format -> Operand -> Reg -> Instr
LZCNT  Format
II32 (Reg -> Operand
OpReg Reg
src_r)       Reg
dst_r         -- lzcnt with extra 24 zeros
                , Format -> Operand -> Operand -> Instr
SUB    Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
24)) (Reg -> Operand
OpReg Reg
dst_r) -- compensate for extra zeros
                ]
            Width
W16 -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                [ Format -> Operand -> Reg -> Instr
LZCNT  Format
II16 (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r
                , Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r) -- zero-extend from 16 bit
                ]
            Width
_ -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Reg -> Instr
LZCNT (Width -> Format
intFormat Width
width) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)
        else do
          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
          let bw :: Int
bw = Width -> Int
widthInBits Width
width
          Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
          Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
          OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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 (Int -> Imm
ImmInt (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
bwInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 (Int -> Imm
ImmInt (Int
bwInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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

genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
genWordToFloat :: Label -> Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genWordToFloat Label
bid Width
width LocalReg
dst CmmExpr
src =
  -- TODO: generate assembly instead
  Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
word2FloatLabel Width
width) [LocalReg
dst] [CmmExpr
src]

genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock
genAtomicRead :: Width
-> MemoryOrdering -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genAtomicRead Width
width MemoryOrdering
_mord LocalReg
dst CmmExpr
addr = do
  Reg -> OrdList Instr
load_code <- (Operand -> Operand -> Instr)
-> CmmExpr -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV (Width -> Format
intFormat Width
width)) CmmExpr
addr
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
load_code (LocalReg -> Reg
getLocalRegReg LocalReg
dst))

genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock
genAtomicWrite :: Width
-> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genAtomicWrite Width
width MemoryOrdering
mord CmmExpr
addr CmmExpr
val = do
  OrdList Instr
code <- Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmExpr
addr CmmExpr
val
  let needs_fence :: Bool
needs_fence = case MemoryOrdering
mord of
        MemoryOrdering
MemOrderSeqCst  -> Bool
True
        MemoryOrdering
MemOrderRelease -> Bool
False
        MemoryOrdering
MemOrderAcquire -> String -> SDoc -> Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genAtomicWrite: acquire ordering on write" SDoc
forall doc. IsOutput doc => doc
empty
        MemoryOrdering
MemOrderRelaxed -> Bool
False
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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
needs_fence then OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
MFENCE else OrdList Instr
code

genCmpXchg
  :: BlockId
  -> Width
  -> LocalReg
  -> CmmExpr
  -> CmmExpr
  -> CmmExpr
  -> NatM InstrBlock
genCmpXchg :: Label
-> Width
-> LocalReg
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genCmpXchg Label
bid Width
width LocalReg
dst CmmExpr
addr CmmExpr
old CmmExpr
new = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform
  -- 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.
  if Bool -> Bool
not (Bool
is32Bit Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64)
    then do
      let format :: Format
format = Width -> Format
intFormat Width
width
      Amode AddrMode
amode OrdList Instr
addr_code <- CmmExpr -> NatM Amode
getSimpleAmode CmmExpr
addr
      Reg
newval <- Format -> NatM Reg
getNewRegNat Format
format
      Reg -> OrdList Instr
newval_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
new
      Reg
oldval <- Format -> NatM Reg
getNewRegNat Format
format
      Reg -> OrdList Instr
oldval_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
old
      Platform
platform <- NatM Platform
getPlatform
      let dst_r :: Reg
dst_r    = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
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 a. a -> NatM a
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
    else
      -- generate C call to hs_cmpxchgN in ghc-prim
      Label
-> FastString -> [LocalReg] -> [CmmExpr] -> NatM (OrdList Instr)
genPrimCCall Label
bid (Width -> FastString
cmpxchgLabel Width
width) [LocalReg
dst] [CmmExpr
addr,CmmExpr
old,CmmExpr
new]
      -- TODO: implement cmpxchg8b instruction

genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genXchg Width
width LocalReg
dst CmmExpr
addr CmmExpr
value = do
  Bool
is32Bit <- NatM Bool
is32BitPlatform

  Bool -> NatM () -> NatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
is32Bit Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64) (NatM () -> NatM ()) -> NatM () -> NatM ()
forall a b. (a -> b) -> a -> b
$
    String -> NatM ()
forall a. HasCallStack => String -> a
panic String
"genXchg: 64bit atomic exchange not supported on 32bit platforms"

  Amode AddrMode
amode OrdList Instr
addr_code <- CmmExpr -> NatM Amode
getSimpleAmode CmmExpr
addr
  (Reg
newval, OrdList Instr
newval_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
value
  let format :: Format
format   = Width -> Format
intFormat Width
width
  let dst_r :: Reg
dst_r    = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  -- Copy the value into the target register, perform the exchange.
  let code :: OrdList Instr
code     = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                 [ Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
newval) (Reg -> Operand
OpReg Reg
dst_r)
                  -- On X86 xchg implies a lock prefix if we use a memory argument.
                  -- so this is atomic.
                 , Format -> Operand -> Reg -> Instr
XCHG Format
format (AddrMode -> Operand
OpAddr AddrMode
amode) Reg
dst_r
                 ]
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
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` OrdList Instr
newval_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code


genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genFloatAbs Width
width LocalReg
dst CmmExpr
src = do
  let
    format :: Format
format = Width -> Format
floatFormat Width
width
    const :: CmmLit
const = case Width
width of
      Width
W32 -> Integer -> Width -> CmmLit
CmmInt Integer
0x7fffffff Width
W32
      Width
W64 -> Integer -> Width -> CmmLit
CmmInt Integer
0x7fffffffffffffff Width
W64
      Width
_   -> String -> SDoc -> CmmLit
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genFloatAbs: invalid width" (Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
width)
  Reg -> OrdList Instr
src_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  Amode AddrMode
amode OrdList Instr
amode_code <- Alignment -> CmmLit -> NatM Amode
memConstant (Int -> Alignment
mkAlignment (Int -> Alignment) -> Int -> Alignment
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBytes Width
width) CmmLit
const
  Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
format
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
src_code Reg
dst_r 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
format (AddrMode -> Operand
OpAddr AddrMode
amode) (Reg -> Operand
OpReg Reg
tmp)
           , Format -> Operand -> Operand -> Instr
AND Format
format (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst_r)
           ]


genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock
genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM (OrdList Instr)
genFloatSqrt Format
format LocalReg
dst CmmExpr
src = do
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  Reg -> OrdList Instr
src_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
src_code Reg
dst_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Reg -> Instr
SQRT Format
format (Reg -> Operand
OpReg Reg
dst_r) Reg
dst_r


genAddSubRetCarry
  :: Width
  -> (Format -> Operand -> Operand -> Instr)
  -> (Format -> Maybe (Operand -> Operand -> Instr))
  -> Cond
  -> LocalReg
  -> LocalReg
  -> CmmExpr
  -> CmmExpr
  -> NatM InstrBlock
genAddSubRetCarry :: Width
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddSubRetCarry Width
width Format -> Operand -> Operand -> Instr
instr Format -> Maybe (Operand -> Operand -> Instr)
mrevinstr Cond
cond LocalReg
res_r LocalReg
res_c CmmExpr
arg_x CmmExpr
arg_y = do
  Platform
platform <- NCGConfig -> Platform
ncgPlatform (NCGConfig -> Platform) -> NatM NCGConfig -> NatM Platform
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM NCGConfig
getConfig
  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)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
width (Format -> Operand -> Operand -> Instr
instr Format
format)
                        (Format -> Maybe (Operand -> Operand -> Instr)
mrevinstr Format
format) CmmExpr
arg_x CmmExpr
arg_y
  Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
II8
  let reg_c :: Reg
reg_c = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
res_c)
      reg_r :: Reg
reg_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform  (LocalReg -> CmmReg
CmmLocal LocalReg
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code


genAddWithCarry
  :: Width
  -> LocalReg
  -> LocalReg
  -> CmmExpr
  -> CmmExpr
  -> NatM InstrBlock
genAddWithCarry :: Width
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genAddWithCarry Width
width LocalReg
res_h LocalReg
res_l CmmExpr
arg_x CmmExpr
arg_y = do
  Reg -> OrdList Instr
hCode <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
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)
-> CmmExpr
-> CmmExpr
-> 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)) CmmExpr
arg_x CmmExpr
arg_y
  let reg_l :: Reg
reg_l = LocalReg -> Reg
getLocalRegReg LocalReg
res_l
      reg_h :: Reg
reg_h = LocalReg -> Reg
getLocalRegReg LocalReg
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 Integer
0)) (Reg -> Operand
OpReg Reg
reg_h)
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code


genSignedLargeMul
  :: Width
  -> LocalReg
  -> LocalReg
  -> LocalReg
  -> CmmExpr
  -> CmmExpr
  -> NatM (OrdList Instr)
genSignedLargeMul :: Width
-> LocalReg
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genSignedLargeMul Width
width LocalReg
res_c LocalReg
res_h LocalReg
res_l CmmExpr
arg_x CmmExpr
arg_y = do
  (Operand
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getRegOrMem CmmExpr
arg_y
  Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg_x
  Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
II8
  let format :: Format
format = Width -> Format
intFormat Width
width
      reg_h :: Reg
reg_h = LocalReg -> Reg
getLocalRegReg LocalReg
res_h
      reg_l :: Reg
reg_l = LocalReg -> Reg
getLocalRegReg LocalReg
res_l
      reg_c :: Reg
reg_c = LocalReg -> Reg
getLocalRegReg LocalReg
res_c
      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
IMUL2 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)
                  , Cond -> Operand -> Instr
SETCC Cond
CARRY (Reg -> Operand
OpReg Reg
reg_tmp)
                  , 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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code

genUnsignedLargeMul
  :: Width
  -> LocalReg
  -> LocalReg
  -> CmmExpr
  -> CmmExpr
  -> NatM (OrdList Instr)
genUnsignedLargeMul :: Width
-> LocalReg
-> LocalReg
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genUnsignedLargeMul Width
width LocalReg
res_h LocalReg
res_l CmmExpr
arg_x CmmExpr
arg_y = do
  (Operand
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getRegOrMem CmmExpr
arg_y
  Reg -> OrdList Instr
x_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg_x
  let format :: Format
format = Width -> Format
intFormat Width
width
      reg_h :: Reg
reg_h = LocalReg -> Reg
getLocalRegReg LocalReg
res_h
      reg_l :: Reg
reg_l = LocalReg -> Reg
getLocalRegReg LocalReg
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 a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code


genQuotRem
  :: Width
  -> Bool
  -> LocalReg
  -> LocalReg
  -> Maybe CmmExpr
  -> CmmExpr
  -> CmmExpr
  -> NatM InstrBlock
genQuotRem :: Width
-> Bool
-> LocalReg
-> LocalReg
-> Maybe CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genQuotRem Width
width Bool
signed LocalReg
res_q LocalReg
res_r Maybe CmmExpr
m_arg_x_high CmmExpr
arg_x_low CmmExpr
arg_y = do
  case Width
width of
    Width
W8 -> do
      -- See Note [DIV/IDIV for bytes]
      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 :: CmmExpr
arg_x_low_16 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
widen [CmmExpr
arg_x_low]
          arg_y_16 :: CmmExpr
arg_y_16 = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
widen [CmmExpr
arg_y]
          m_arg_x_high_16 :: Maybe CmmExpr
m_arg_x_high_16 = (\CmmExpr
p -> MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
widen [CmmExpr
p]) (CmmExpr -> CmmExpr) -> Maybe CmmExpr -> Maybe CmmExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CmmExpr
m_arg_x_high
      Width
-> Bool
-> LocalReg
-> LocalReg
-> Maybe CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM (OrdList Instr)
genQuotRem Width
W16 Bool
signed LocalReg
res_q LocalReg
res_r Maybe CmmExpr
m_arg_x_high_16 CmmExpr
arg_x_low_16 CmmExpr
arg_y_16

    Width
_ -> do
      let format :: Format
format = Width -> Format
intFormat Width
width
          reg_q :: Reg
reg_q = LocalReg -> Reg
getLocalRegReg LocalReg
res_q
          reg_r :: Reg
reg_r = LocalReg -> Reg
getLocalRegReg LocalReg
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
      (Operand
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Operand, OrdList Instr)
getRegOrMem CmmExpr
arg_y
      Reg -> OrdList Instr
x_low_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg_x_low
      Reg -> OrdList Instr
x_high_code <- case Maybe CmmExpr
m_arg_x_high of
                     Just CmmExpr
arg_x_high ->
                         CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
arg_x_high
                     Maybe CmmExpr
Nothing ->
                         (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall a. a -> NatM a
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 a. a -> NatM a
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)]


----------------------------------------------------------------------------
-- The following functions implement certain 64-bit MachOps inline for 32-bit
-- architectures. On 64-bit architectures, those MachOps aren't supported and
-- calling these functions for a 64-bit target platform is considered an error
-- (hence the use of `expect32BitPlatform`).
--
-- On 64-bit platforms, generic MachOps should be used instead of these 64-bit
-- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection
-- is done by StgToCmm.

genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock
genInt64ToInt :: LocalReg -> CmmExpr -> NatM (OrdList Instr)
genInt64ToInt LocalReg
dst CmmExpr
src = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genInt64ToInt")
  RegCode64 OrdList Instr
code Reg
_src_hi Reg
src_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
src
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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` Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
src_lo) (Reg -> Operand
OpReg Reg
dst_r)

genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock
genWord64ToWord :: LocalReg -> CmmExpr -> NatM (OrdList Instr)
genWord64ToWord LocalReg
dst CmmExpr
src = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genWord64ToWord")
  RegCode64 OrdList Instr
code Reg
_src_hi Reg
src_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
src
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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` Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
src_lo) (Reg -> Operand
OpReg Reg
dst_r)

genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock
genIntToInt64 :: LocalReg -> CmmExpr -> NatM (OrdList Instr)
genIntToInt64 LocalReg
dst CmmExpr
src = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genIntToInt64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  Reg -> OrdList Instr
src_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
src_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 -> Instr
CLTD Format
II32 -- sign extend EAX in EDX:EAX
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rax) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock
genWordToWord64 :: LocalReg -> CmmExpr -> NatM (OrdList Instr)
genWordToWord64 LocalReg
dst CmmExpr
src = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genWordToWord64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  Reg -> OrdList Instr
src_code <- CmmExpr -> NatM (Reg -> OrdList Instr)
getAnyReg CmmExpr
src
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
src_code Reg
dst_lo
          OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
dst_hi) (Reg -> Operand
OpReg Reg
dst_hi)

genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock
genNeg64 :: LocalReg -> CmmExpr -> NatM (OrdList Instr)
genNeg64 LocalReg
dst CmmExpr
src = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genNeg64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
code Reg
src_hi Reg
src_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
src
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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
MOV  Format
II32 (Reg -> Operand
OpReg Reg
src_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV  Format
II32 (Reg -> Operand
OpReg Reg
src_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Instr
NEGI Format
II32 (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
ADC  Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Instr
NEGI Format
II32 (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genAdd64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genAdd64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV  Format
II32 (Reg -> Operand
OpReg Reg
x_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Operand -> Instr
ADD  Format
II32 (Reg -> Operand
OpReg Reg
y_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
ADC  Format
II32 (Reg -> Operand
OpReg Reg
y_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genSub64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genSub64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV  Format
II32 (Reg -> Operand
OpReg Reg
x_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Operand -> Instr
SUB  Format
II32 (Reg -> Operand
OpReg Reg
y_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
SBB  Format
II32 (Reg -> Operand
OpReg Reg
y_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genAnd64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genAnd64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
x_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Operand -> Instr
AND Format
II32 (Reg -> Operand
OpReg Reg
y_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
AND Format
II32 (Reg -> Operand
OpReg Reg
y_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genOr64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genOr64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
x_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Operand -> Instr
OR  Format
II32 (Reg -> Operand
OpReg Reg
y_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
OR  Format
II32 (Reg -> Operand
OpReg Reg
y_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genXor64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genXor64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
x_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
y_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
y_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock
genNot64 :: LocalReg -> CmmExpr -> NatM (OrdList Instr)
genNot64 LocalReg
dst CmmExpr
src = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genNot64")
  let Reg64 Reg
dst_hi Reg
dst_lo = HasDebugCallStack => LocalReg -> Reg64
LocalReg -> Reg64
localReg64 LocalReg
dst
  RegCode64 OrdList Instr
src_code Reg
src_hi Reg
src_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
src
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
src_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
II32 (Reg -> Operand
OpReg Reg
src_lo) (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
src_hi) (Reg -> Operand
OpReg Reg
dst_hi)
          , Format -> Operand -> Instr
NOT Format
II32 (Reg -> Operand
OpReg Reg
dst_lo)
          , Format -> Operand -> Instr
NOT Format
II32 (Reg -> Operand
OpReg Reg
dst_hi)
          ]

genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genEq64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genEq64")
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  Reg64 Reg
tmp_hi Reg
tmp_lo <- NatM Reg64
getNewReg64
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo)   (Reg -> Operand
OpReg Reg
tmp_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
x_hi)   (Reg -> Operand
OpReg Reg
tmp_hi)
          , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
y_lo)   (Reg -> Operand
OpReg Reg
tmp_lo)
          , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
y_hi)   (Reg -> Operand
OpReg Reg
tmp_hi)
          , Format -> Operand -> Operand -> Instr
OR  Format
II32 (Reg -> Operand
OpReg Reg
tmp_lo) (Reg -> Operand
OpReg Reg
tmp_hi)
          , Cond -> Operand -> Instr
SETCC Cond
EQQ (Reg -> Operand
OpReg Reg
dst_r)
          , Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r)
          ]

genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genNe64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genNe64")
  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  Reg64 Reg
tmp_hi Reg
tmp_lo <- NatM Reg64
getNewReg64
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_lo)   (Reg -> Operand
OpReg Reg
tmp_lo)
          , Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
x_hi)   (Reg -> Operand
OpReg Reg
tmp_hi)
          , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
y_lo)   (Reg -> Operand
OpReg Reg
tmp_lo)
          , Format -> Operand -> Operand -> Instr
XOR Format
II32 (Reg -> Operand
OpReg Reg
y_hi)   (Reg -> Operand
OpReg Reg
tmp_hi)
          , Format -> Operand -> Operand -> Instr
OR  Format
II32 (Reg -> Operand
OpReg Reg
tmp_lo) (Reg -> Operand
OpReg Reg
tmp_hi)
          , Cond -> Operand -> Instr
SETCC Cond
NE (Reg -> Operand
OpReg Reg
dst_r)
          , Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r)
          ]

genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGtWord64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genGtWord64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
LU LocalReg
dst CmmExpr
y CmmExpr
x

genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLtWord64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genLtWord64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
LU LocalReg
dst CmmExpr
x CmmExpr
y

genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGeWord64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genGeWord64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
GEU LocalReg
dst CmmExpr
x CmmExpr
y

genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLeWord64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genLeWord64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
GEU LocalReg
dst CmmExpr
y CmmExpr
x

genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGtInt64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genGtInt64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
LTT LocalReg
dst CmmExpr
y CmmExpr
x

genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLtInt64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genLtInt64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
LTT LocalReg
dst CmmExpr
x CmmExpr
y

genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genGeInt64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genGeInt64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
GE LocalReg
dst CmmExpr
x CmmExpr
y

genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genLeInt64 LocalReg
dst CmmExpr
x CmmExpr
y = do
  SDoc -> NatM ()
expect32BitPlatform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"genLeInt64")
  Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
GE LocalReg
dst CmmExpr
y CmmExpr
x

genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
genPred64 Cond
cond LocalReg
dst CmmExpr
x CmmExpr
y = do
  -- we can only rely on CF/SF/OF flags!
  -- Not on ZF, which doesn't take into account the lower parts.
  Bool -> NatM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Cond
cond Cond -> [Cond] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Cond
LU,Cond
GEU,Cond
LTT,Cond
GE])

  let dst_r :: Reg
dst_r = LocalReg -> Reg
getLocalRegReg LocalReg
dst
  RegCode64 OrdList Instr
x_code Reg
x_hi Reg
x_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  RegCode64 OrdList Instr
y_code Reg
y_hi Reg
y_lo <- HasDebugCallStack => CmmExpr -> NatM (RegCode64 (OrdList Instr))
CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
  -- Basically we perform a subtraction with borrow.
  -- As we don't need to result, we can use CMP instead of SUB for the low part
  -- (it sets the borrow flag just like SUB does)
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ 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 -> 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
x_hi) (Reg -> Operand
OpReg Reg
dst_r)
          , Format -> Operand -> Operand -> Instr
CMP Format
II32 (Reg -> Operand
OpReg Reg
y_lo) (Reg -> Operand
OpReg Reg
x_lo)
          , Format -> Operand -> Operand -> Instr
SBB Format
II32 (Reg -> Operand
OpReg Reg
y_hi) (Reg -> Operand
OpReg Reg
dst_r)
          , Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
dst_r)
          , Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r)
          ]