{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__ <= 808
{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
#endif
module X86.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
extractUnwindPoints,
invertCondBranches,
InstrBlock
)
where
#include "HsVersions.h"
import GhcPrelude
import X86.Instr
import X86.Cond
import X86.Regs
import X86.Ppr ( )
import X86.RegInfo
import GHC.Platform.Regs
import CPrim
import Debug ( DebugBlock(..), UnwindPoint(..), UnwindTable
, UnwindExpr(UwReg), toUnwindExpr )
import Instruction
import PIC
import NCGMonad ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat
, getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat
, getPicBaseMaybeNat, getDebugBlock, getFileId
, addImmediateSuccessorNat, updateCfgNat)
import CFG
import Format
import Reg
import GHC.Platform
import BasicTypes
import BlockId
import Module ( primUnitId )
import CmmUtils
import CmmSwitch
import Cmm
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label
import CLabel
import CoreSyn ( Tickish(..) )
import SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
import ForeignCall ( CCallConv(..) )
import OrdList
import Outputable
import FastString
import DynFlags
import Util
import UniqSupply ( getUniqueM )
import Control.Monad
import Data.Bits
import Data.Foldable (fold)
import Data.Int
import Data.Maybe
import Data.Word
import qualified Data.Map as M
is32BitPlatform :: NatM Bool
is32BitPlatform :: NatM Bool
is32BitPlatform = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> NatM Bool) -> Bool -> NatM Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
sse2Enabled :: NatM Bool
sse2Enabled :: NatM Bool
sse2Enabled = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
case Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
Arch
ArchX86_64 -> Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Arch
ArchX86 -> Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Arch
_ -> String -> NatM Bool
forall a. String -> a
panic String
"trying to generate x86/x86_64 on the wrong platform"
sse4_2Enabled :: NatM Bool
sse4_2Enabled :: NatM Bool
sse4_2Enabled = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> NatM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Bool
isSse4_2Enabled DynFlags
dflags)
cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
cmmTopCodeGen (CmmProc LabelMap CmmStatics
info CLabel
lab [GlobalReg]
live CmmGraph
graph) = do
let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
([[NatBasicBlock Instr]]
nat_blocks,[[NatCmmDecl (Alignment, CmmStatics) Instr]]
statics) <- (CmmBlock
-> NatM
([NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr]))
-> [CmmBlock]
-> NatM
([[NatBasicBlock Instr]],
[[NatCmmDecl (Alignment, CmmStatics) Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CmmBlock
-> NatM
([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
basicBlockCodeGen [CmmBlock]
blocks
Maybe Reg
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let proc :: NatCmmDecl (Alignment, CmmStatics) Instr
proc = LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lab [GlobalReg]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock Instr]] -> [NatBasicBlock Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
nat_blocks)
tops :: [NatCmmDecl (Alignment, CmmStatics) Instr]
tops = NatCmmDecl (Alignment, CmmStatics) Instr
proc NatCmmDecl (Alignment, CmmStatics) Instr
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl (Alignment, CmmStatics) Instr]]
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl (Alignment, CmmStatics) Instr]]
statics
os :: OS
os = Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
case Maybe Reg
picBaseMb of
Just Reg
picBase -> Arch
-> OS
-> Reg
-> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
initializePicBase_x86 Arch
ArchX86 OS
os Reg
picBase [NatCmmDecl (Alignment, CmmStatics) Instr]
tops
Maybe Reg
Nothing -> [NatCmmDecl (Alignment, CmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl (Alignment, CmmStatics) Instr]
tops
cmmTopCodeGen (CmmData Section
sec CmmStatics
dat) = do
[NatCmmDecl (Alignment, CmmStatics) Instr]
-> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Section
-> (Alignment, CmmStatics)
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (Int -> Alignment
mkAlignment Int
1, CmmStatics
dat)]
verifyBasicBlock :: [Instr] -> ()
verifyBasicBlock :: [Instr] -> ()
verifyBasicBlock [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
NEWBLOCK {} -> Bool -> [Instr] -> ()
go Bool
False [Instr]
instr
CALL {} | Bool
atEnd -> Instr -> ()
faultyBlockWith Instr
i
| Bool -> Bool
not Bool
atEnd -> Bool -> [Instr] -> ()
go Bool
atEnd [Instr]
instr
Instr
_ | Bool -> Bool
not Bool
atEnd -> Bool -> [Instr] -> ()
go (Instr -> Bool
forall instr. Instruction instr => instr -> Bool
isJumpishInstr Instr
i) [Instr]
instr
| Bool
otherwise -> if Instr -> Bool
forall instr. Instruction instr => instr -> Bool
isJumpishInstr Instr
i
then Bool -> [Instr] -> ()
go Bool
True [Instr]
instr
else Instr -> ()
faultyBlockWith Instr
i
faultyBlockWith :: Instr -> ()
faultyBlockWith Instr
i
= String -> SDoc -> ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Non control flow instructions after end of basic block."
(Instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr Instr
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in:" SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((Instr -> SDoc) -> [Instr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Instr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Instr]
instrs))
basicBlockCodeGen
:: CmmBlock
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl (Alignment, CmmStatics) Instr])
basicBlockCodeGen :: CmmBlock
-> NatM
([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
basicBlockCodeGen 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 (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
Maybe DebugBlock
dbg <- Label -> NatM (Maybe DebugBlock)
getDebugBlock (CmmBlock -> 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 String
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 (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 String
name
Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
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
() -> NatM ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> NatM ()) -> () -> NatM ()
forall a b. (a -> b) -> a -> b
$! [Instr] -> ()
verifyBasicBlock (OrdList Instr -> [Instr]
forall a. OrdList a -> [a]
fromOL OrdList Instr
instrs)
OrdList Instr
instrs' <- OrdList (OrdList Instr) -> OrdList Instr
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (OrdList (OrdList Instr) -> OrdList Instr)
-> NatM (OrdList (OrdList Instr)) -> NatM (OrdList Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList (OrdList Instr))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Instr -> NatM (OrdList Instr)
addSpUnwindings OrdList Instr
instrs
let
([Instr]
top,[NatBasicBlock Instr]
other_blocks,[NatCmmDecl (Alignment, CmmStatics) Instr]
statics) = (Instr
-> ([Instr], [NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr])
-> ([Instr], [NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr]))
-> ([Instr], [NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr])
-> OrdList Instr
-> ([Instr], [NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr])
-> ([Instr], [NatBasicBlock Instr],
[NatCmmDecl (Alignment, CmmStatics) Instr])
forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr],
[GenCmmDecl (Alignment, CmmStatics) h g])
-> ([Instr], [NatBasicBlock Instr],
[GenCmmDecl (Alignment, CmmStatics) h g])
mkBlocks ([],[],[]) OrdList Instr
instrs'
mkBlocks :: Instr
-> ([Instr], [NatBasicBlock Instr],
[GenCmmDecl (Alignment, CmmStatics) h g])
-> ([Instr], [NatBasicBlock Instr],
[GenCmmDecl (Alignment, CmmStatics) h g])
mkBlocks (NEWBLOCK Label
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl (Alignment, CmmStatics) h g]
statics)
= ([], Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
mkBlocks (LDATA Section
sec (Alignment, CmmStatics)
dat) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl (Alignment, CmmStatics) h g]
statics)
= ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section
-> (Alignment, CmmStatics)
-> GenCmmDecl (Alignment, CmmStatics) h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec (Alignment, CmmStatics)
datGenCmmDecl (Alignment, CmmStatics) h g
-> [GenCmmDecl (Alignment, CmmStatics) h g]
-> [GenCmmDecl (Alignment, CmmStatics) h g]
forall a. a -> [a] -> [a]
:[GenCmmDecl (Alignment, CmmStatics) h g]
statics)
mkBlocks Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl (Alignment, CmmStatics) h g]
statics)
= (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl (Alignment, CmmStatics) h g]
statics)
([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
-> NatM
([NatBasicBlock Instr], [NatCmmDecl (Alignment, CmmStatics) Instr])
forall (m :: * -> *) a. Monad m => a -> m a
return (Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
top NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
other_blocks, [NatCmmDecl (Alignment, CmmStatics) Instr]
statics)
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings :: Instr -> NatM (OrdList Instr)
addSpUnwindings instr :: Instr
instr@(DELTA Int
d) = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if DynFlags -> Int
debugLevel DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1
then do CLabel
lbl <- Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel (Unique -> CLabel) -> NatM Unique -> NatM CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
let unwind :: Map GlobalReg (Maybe UnwindExpr)
unwind = GlobalReg -> Maybe UnwindExpr -> Map GlobalReg (Maybe UnwindExpr)
forall k a. k -> a -> Map k a
M.singleton GlobalReg
MachSp (UnwindExpr -> Maybe UnwindExpr
forall a. a -> Maybe a
Just (UnwindExpr -> Maybe UnwindExpr) -> UnwindExpr -> Maybe UnwindExpr
forall a b. (a -> b) -> a -> b
$ GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
MachSp (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 (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr
instr, CLabel -> Map GlobalReg (Maybe UnwindExpr) -> Instr
UNWIND CLabel
lbl Map GlobalReg (Maybe UnwindExpr)
unwind ]
else OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
instr)
addSpUnwindings Instr
instr = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
instr
stmtsToInstrs :: BlockId
-> [CmmNode O O]
-> NatM (InstrBlock, BlockId)
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 (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
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')
stmtToInstrs :: BlockId
-> CmmNode e x
-> NatM (InstrBlock, Maybe BlockId)
stmtToInstrs :: Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid CmmNode e x
stmt = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool
is32Bit <- NatM Bool
is32BitPlatform
case CmmNode e x
stmt of
CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
result_regs [CmmActual]
args
-> DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
result_regs [CmmActual]
args Label
bid
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 (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FastString -> Instr
COMMENT FastString
s))
CmmTick {} -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
CmmUnwind [(GlobalReg, Maybe CmmActual)]
regs -> do
let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
to_unwind_entry :: (GlobalReg, Maybe CmmActual) -> Map GlobalReg (Maybe UnwindExpr)
to_unwind_entry (GlobalReg
reg, Maybe CmmActual
expr) = GlobalReg -> Maybe UnwindExpr -> Map GlobalReg (Maybe UnwindExpr)
forall k a. k -> a -> Map k a
M.singleton GlobalReg
reg ((CmmActual -> UnwindExpr) -> Maybe CmmActual -> Maybe UnwindExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CmmActual -> UnwindExpr
toUnwindExpr Maybe CmmActual
expr)
case ((GlobalReg, Maybe CmmActual) -> Map GlobalReg (Maybe UnwindExpr))
-> [(GlobalReg, Maybe CmmActual)]
-> Map GlobalReg (Maybe UnwindExpr)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (GlobalReg, Maybe CmmActual) -> Map GlobalReg (Maybe UnwindExpr)
to_unwind_entry [(GlobalReg, Maybe CmmActual)]
regs of
Map GlobalReg (Maybe UnwindExpr)
tbl | Map GlobalReg (Maybe UnwindExpr) -> Bool
forall k a. Map k a -> Bool
M.null Map GlobalReg (Maybe UnwindExpr)
tbl -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
| Bool
otherwise -> do
CLabel
lbl <- Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel (Unique -> CLabel) -> NatM Unique -> NatM CLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NatM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> Map GlobalReg (Maybe UnwindExpr) -> Instr
UNWIND CLabel
lbl Map GlobalReg (Maybe UnwindExpr)
tbl
CmmAssign CmmReg
reg CmmActual
src
| CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmActual
src
| Bool
is32Bit Bool -> Bool -> Bool
&& CmmType -> Bool
isWord64 CmmType
ty -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_I64Code CmmReg
reg CmmActual
src
| Bool
otherwise -> Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_IntCode Format
format CmmReg
reg CmmActual
src
where ty :: CmmType
ty = DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty
CmmStore CmmActual
addr CmmActual
src
| CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmActual
addr CmmActual
src
| Bool
is32Bit Bool -> Bool -> Bool
&& CmmType -> Bool
isWord64 CmmType
ty -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_I64Code CmmActual
addr CmmActual
src
| Bool
otherwise -> Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_IntCode Format
format CmmActual
addr CmmActual
src
where ty :: CmmType
ty = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
src
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty
CmmBranch Label
id -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Label -> OrdList Instr
genBranch Label
id
CmmCondBranch CmmActual
arg Label
true Label
false Maybe Bool
_ -> Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch Label
bid Label
true Label
false CmmActual
arg
CmmSwitch CmmActual
arg SwitchTargets
ids -> do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
DynFlags -> CmmActual -> SwitchTargets -> NatM (OrdList Instr)
genSwitch DynFlags
dflags CmmActual
arg SwitchTargets
ids
CmmCall { cml_target :: CmmNode O C -> CmmActual
cml_target = CmmActual
arg
, cml_args_regs :: CmmNode O C -> [GlobalReg]
cml_args_regs = [GlobalReg]
gregs } -> do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmActual -> [Reg] -> NatM (OrdList Instr)
genJump CmmActual
arg (DynFlags -> [GlobalReg] -> [Reg]
jumpRegs DynFlags
dflags [GlobalReg]
gregs)
CmmNode e x
_ ->
String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"stmtToInstrs: statement should have been cps'd away"
jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
jumpRegs DynFlags
dflags [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 ]
where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
type InstrBlock
= OrdList Instr
data CondCode
= CondCode Bool Cond InstrBlock
data ChildCode64
= ChildCode64
InstrBlock
Reg
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
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg Platform
_ (CmmLocal (LocalReg Unique
u CmmType
pk))
=
let fmt :: Format
fmt = CmmType -> Format
cmmTypeFormat CmmType
pk in
VirtualReg -> Reg
RegVirtual (Unique -> Format -> VirtualReg
mkVirtualReg Unique
u Format
fmt)
getRegisterReg Platform
platform (CmmGlobal GlobalReg
mid)
= case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
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
$ GlobalReg -> CmmReg
CmmGlobal GlobalReg
mid)
data Amode
= Amode AddrMode InstrBlock
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
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry :: DynFlags -> Maybe Label -> CmmStatic
jumpTableEntry DynFlags
dflags Maybe Label
Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (DynFlags -> Width
wordWidth DynFlags
dflags))
jumpTableEntry DynFlags
_ (Just Label
blockid) = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CmmLit
CmmLabel CLabel
blockLabel)
where blockLabel :: CLabel
blockLabel = Label -> CLabel
blockLbl Label
blockid
mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr
mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmActual
mangleIndexTree DynFlags
dflags CmmReg
reg Int
off
= MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmActual
CmmReg CmmReg
reg, CmmLit -> CmmActual
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 (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg)
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg :: CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr = do
Register
r <- CmmActual -> NatM Register
getRegister CmmActual
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, OrdList Instr
code)
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_I64Code CmmActual
addrTree CmmActual
valueTree = do
Amode AddrMode
addr OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
addrTree
ChildCode64 OrdList Instr
vcode Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
valueTree
let
rhi :: Reg
rhi = Reg -> Reg
getHiVRegFromLo Reg
rlo
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 (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
vcode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code :: CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_I64Code (CmmLocal (LocalReg Unique
u_dst CmmType
_)) CmmActual
valueTree = do
ChildCode64 OrdList Instr
vcode Reg
r_src_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
valueTree
let
r_dst_lo :: Reg
r_dst_lo = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
u_dst Format
II32
r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
r_src_hi :: Reg
r_src_hi = Reg -> Reg
getHiVRegFromLo Reg
r_src_lo
mov_lo :: Instr
mov_lo = Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r_src_lo) (Reg -> Operand
OpReg Reg
r_dst_lo)
mov_hi :: Instr
mov_hi = Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r_src_hi) (Reg -> Operand
OpReg Reg
r_dst_hi)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (
OrdList Instr
vcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi
)
assignReg_I64Code CmmReg
_ CmmActual
_
= String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"assignReg_I64Code(i386): invalid lvalue"
iselExpr64 :: CmmExpr -> NatM ChildCode64
iselExpr64 :: CmmActual -> NatM ChildCode64
iselExpr64 (CmmLit (CmmInt Integer
i Width
_)) = do
(Reg
rlo,Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
let
r :: Integer
r = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word32)
q :: Integer
q = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> 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)
]
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)
iselExpr64 (CmmLoad CmmActual
addrTree CmmType
ty) | CmmType -> Bool
isWord64 CmmType
ty = do
Amode AddrMode
addr OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
addrTree
(Reg
rlo,Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
let
mov_lo :: Instr
mov_lo = Format -> Operand -> Operand -> Instr
MOV Format
II32 (AddrMode -> Operand
OpAddr AddrMode
addr) (Reg -> Operand
OpReg Reg
rlo)
mov_hi :: Instr
mov_hi = Format -> Operand -> Operand -> Instr
MOV Format
II32 (AddrMode -> Operand
OpAddr (Maybe AddrMode -> AddrMode
forall a. HasCallStack => Maybe a -> a
fromJust (AddrMode -> Int -> Maybe AddrMode
addrOffset AddrMode
addr Int
4))) (Reg -> Operand
OpReg Reg
rhi)
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (
OrdList Instr -> Reg -> ChildCode64
ChildCode64 (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
Reg
rlo
)
iselExpr64 (CmmReg (CmmLocal (LocalReg Unique
vu CmmType
ty))) | CmmType -> Bool
isWord64 CmmType
ty
= ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
forall a. OrdList a
nilOL (VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
vu Format
II32))
iselExpr64 (CmmMachOp (MO_Add Width
_) [CmmActual
e1, CmmLit (CmmInt Integer
i Width
_)]) = do
ChildCode64 OrdList Instr
code1 Reg
r1lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
(Reg
rlo,Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
let
r :: Integer
r = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word32)
q :: Integer
q = Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word32)
r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
code :: OrdList Instr
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1lo) (Reg -> Operand
OpReg Reg
rlo),
Format -> Operand -> Operand -> Instr
ADD Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
r)) (Reg -> Operand
OpReg Reg
rlo),
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1hi) (Reg -> Operand
OpReg Reg
rhi),
Format -> Operand -> Operand -> Instr
ADC Format
II32 (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
q)) (Reg -> Operand
OpReg Reg
rhi) ]
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)
iselExpr64 (CmmMachOp (MO_Add Width
_) [CmmActual
e1,CmmActual
e2]) = do
ChildCode64 OrdList Instr
code1 Reg
r1lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
ChildCode64 OrdList Instr
code2 Reg
r2lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e2
(Reg
rlo,Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
let
r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
r2hi :: Reg
r2hi = Reg -> Reg
getHiVRegFromLo Reg
r2lo
code :: OrdList Instr
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1lo) (Reg -> Operand
OpReg Reg
rlo),
Format -> Operand -> Operand -> Instr
ADD Format
II32 (Reg -> Operand
OpReg Reg
r2lo) (Reg -> Operand
OpReg Reg
rlo),
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1hi) (Reg -> Operand
OpReg Reg
rhi),
Format -> Operand -> Operand -> Instr
ADC Format
II32 (Reg -> Operand
OpReg Reg
r2hi) (Reg -> Operand
OpReg Reg
rhi) ]
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)
iselExpr64 (CmmMachOp (MO_Sub Width
_) [CmmActual
e1,CmmActual
e2]) = do
ChildCode64 OrdList Instr
code1 Reg
r1lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
ChildCode64 OrdList Instr
code2 Reg
r2lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e2
(Reg
rlo,Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
let
r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
r2hi :: Reg
r2hi = Reg -> Reg
getHiVRegFromLo Reg
r2lo
code :: OrdList Instr
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1lo) (Reg -> Operand
OpReg Reg
rlo),
Format -> Operand -> Operand -> Instr
SUB Format
II32 (Reg -> Operand
OpReg Reg
r2lo) (Reg -> Operand
OpReg Reg
rlo),
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r1hi) (Reg -> Operand
OpReg Reg
rhi),
Format -> Operand -> Operand -> Instr
SBB Format
II32 (Reg -> Operand
OpReg Reg
r2hi) (Reg -> Operand
OpReg Reg
rhi) ]
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> ChildCode64
ChildCode64 OrdList Instr
code Reg
rlo)
iselExpr64 (CmmMachOp (MO_UU_Conv Width
_ Width
W64) [CmmActual
expr]) = do
Reg -> OrdList Instr
fn <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr
Reg
r_dst_lo <- Format -> NatM Reg
getNewRegNat Format
II32
let r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
code :: OrdList Instr
code = Reg -> OrdList Instr
fn Reg
r_dst_lo
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (
OrdList Instr -> Reg -> ChildCode64
ChildCode64 (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) (Reg -> Operand
OpReg Reg
r_dst_hi))
Reg
r_dst_lo
)
iselExpr64 (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmActual
expr]) = do
Reg -> OrdList Instr
fn <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr
Reg
r_dst_lo <- Format -> NatM Reg
getNewRegNat Format
II32
let r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
code :: OrdList Instr
code = Reg -> OrdList Instr
fn Reg
r_dst_lo
ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (
OrdList Instr -> Reg -> ChildCode64
ChildCode64 (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
r_dst_lo) (Reg -> Operand
OpReg Reg
eax) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Instr
CLTD Format
II32 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
r_dst_lo) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
r_dst_hi))
Reg
r_dst_lo
)
iselExpr64 CmmActual
expr
= String -> SDoc -> NatM ChildCode64
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"iselExpr64(i386)" (CmmActual -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmActual
expr)
getRegister :: CmmExpr -> NatM Register
getRegister :: CmmActual -> NatM Register
getRegister CmmActual
e = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool
is32Bit <- NatM Bool
is32BitPlatform
DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit CmmActual
e
getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register
getRegister' :: DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit (CmmReg CmmReg
reg)
= case CmmReg
reg of
CmmGlobal GlobalReg
PicBaseReg
| Bool
is32Bit ->
do Reg
reg' <- Format -> NatM Reg
getPicBaseNat (Bool -> Format
archWordFormat Bool
is32Bit)
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed (Bool -> Format
archWordFormat Bool
is32Bit) Reg
reg' OrdList Instr
forall a. OrdList a
nilOL)
CmmReg
_ ->
do
let
fmt :: Format
fmt = CmmType -> Format
cmmTypeFormat (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg)
format :: Format
format = Format
fmt
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format
(Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg)
OrdList Instr
forall a. OrdList a
nilOL)
getRegister' DynFlags
dflags Bool
is32Bit (CmmRegOff CmmReg
r Int
n)
= DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit (CmmActual -> NatM Register) -> CmmActual -> NatM Register
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmReg -> Int -> CmmActual
mangleIndexTree DynFlags
dflags CmmReg
r Int
n
getRegister' DynFlags
dflags Bool
is32Bit (CmmMachOp (MO_AlignmentCheck Int
align Width
_) [CmmActual
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
<$> DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit CmmActual
e
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W64 Width
W32)
[CmmMachOp (MO_U_Shr Width
W64) [CmmActual
x,CmmLit (CmmInt Integer
32 Width
_)]])
| Bool
is32Bit = do
ChildCode64 OrdList Instr
code Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
rlo) OrdList Instr
code
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W64 Width
W32)
[CmmMachOp (MO_U_Shr Width
W64) [CmmActual
x,CmmLit (CmmInt Integer
32 Width
_)]])
| Bool
is32Bit = do
ChildCode64 OrdList Instr
code Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
rlo) OrdList Instr
code
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W64 Width
W32) [CmmActual
x])
| Bool
is32Bit = do
ChildCode64 OrdList Instr
code Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 Reg
rlo OrdList Instr
code
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W64 Width
W32) [CmmActual
x])
| Bool
is32Bit = do
ChildCode64 OrdList Instr
code Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
x
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 Reg
rlo OrdList Instr
code
getRegister' DynFlags
_ 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))
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
| Bool
otherwise = do
Amode 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
getRegister' DynFlags
_ Bool
_ (CmmMachOp (MO_UU_Conv Width
W8 Width
W32) [CmmLoad CmmActual
addr CmmType
_]) = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
_ (CmmMachOp (MO_SS_Conv Width
W8 Width
W32) [CmmLoad CmmActual
addr CmmType
_]) = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II8) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
_ (CmmMachOp (MO_UU_Conv Width
W16 Width
W32) [CmmLoad CmmActual
addr CmmType
_]) = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
_ (CmmMachOp (MO_SS_Conv Width
W16 Width
W32) [CmmLoad CmmActual
addr CmmType
_]) = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II16) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W8 Width
W64) [CmmLoad CmmActual
addr CmmType
_])
| Bool -> Bool
not Bool
is32Bit = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W8 Width
W64) [CmmLoad CmmActual
addr CmmType
_])
| Bool -> Bool
not Bool
is32Bit = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II8) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W16 Width
W64) [CmmLoad CmmActual
addr CmmType
_])
| Bool -> Bool
not Bool
is32Bit = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W16 Width
W64) [CmmLoad CmmActual
addr CmmType
_])
| Bool -> Bool
not Bool
is32Bit = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II16) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_UU_Conv Width
W32 Width
W64) [CmmLoad CmmActual
addr CmmType
_])
| Bool -> Bool
not Bool
is32Bit = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
II32) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmLoad CmmActual
addr CmmType
_])
| Bool -> Bool
not Bool
is32Bit = do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOVSxL Format
II32) CmmActual
addr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp (MO_Add Width
W64) [CmmReg (CmmGlobal GlobalReg
PicBaseReg),
CmmLit CmmLit
displacement])
| Bool -> Bool
not Bool
is32Bit = do
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 (\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' DynFlags
dflags Bool
is32Bit (CmmMachOp MachOp
mop [CmmActual
x]) = do
case MachOp
mop of
MO_F_Neg Width
w -> Width -> CmmActual -> NatM Register
sse2NegCode Width
w CmmActual
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)
MO_UU_Conv Width
W32 Width
W8 -> Width -> CmmActual -> NatM Register
toI8Reg Width
W32 CmmActual
x
MO_SS_Conv Width
W32 Width
W8 -> Width -> CmmActual -> NatM Register
toI8Reg Width
W32 CmmActual
x
MO_XX_Conv Width
W32 Width
W8 -> Width -> CmmActual -> NatM Register
toI8Reg Width
W32 CmmActual
x
MO_UU_Conv Width
W16 Width
W8 -> Width -> CmmActual -> NatM Register
toI8Reg Width
W16 CmmActual
x
MO_SS_Conv Width
W16 Width
W8 -> Width -> CmmActual -> NatM Register
toI8Reg Width
W16 CmmActual
x
MO_XX_Conv Width
W16 Width
W8 -> Width -> CmmActual -> NatM Register
toI8Reg Width
W16 CmmActual
x
MO_UU_Conv Width
W32 Width
W16 -> Width -> CmmActual -> NatM Register
toI16Reg Width
W32 CmmActual
x
MO_SS_Conv Width
W32 Width
W16 -> Width -> CmmActual -> NatM Register
toI16Reg Width
W32 CmmActual
x
MO_XX_Conv Width
W32 Width
W16 -> Width -> CmmActual -> NatM Register
toI16Reg Width
W32 CmmActual
x
MO_UU_Conv Width
W64 Width
W32 | Bool -> Bool
not Bool
is32Bit -> Format -> CmmActual -> NatM Register
conversionNop Format
II64 CmmActual
x
MO_SS_Conv Width
W64 Width
W32 | Bool -> Bool
not Bool
is32Bit -> Format -> CmmActual -> NatM Register
conversionNop Format
II64 CmmActual
x
MO_XX_Conv Width
W64 Width
W32 | Bool -> Bool
not Bool
is32Bit -> Format -> CmmActual -> NatM Register
conversionNop Format
II64 CmmActual
x
MO_UU_Conv Width
W64 Width
W16 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI16Reg Width
W64 CmmActual
x
MO_SS_Conv Width
W64 Width
W16 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI16Reg Width
W64 CmmActual
x
MO_XX_Conv Width
W64 Width
W16 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI16Reg Width
W64 CmmActual
x
MO_UU_Conv Width
W64 Width
W8 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI8Reg Width
W64 CmmActual
x
MO_SS_Conv Width
W64 Width
W8 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI8Reg Width
W64 CmmActual
x
MO_XX_Conv Width
W64 Width
W8 | Bool -> Bool
not Bool
is32Bit -> Width -> CmmActual -> NatM Register
toI8Reg Width
W64 CmmActual
x
MO_UU_Conv Width
rep1 Width
rep2 | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 -> Format -> CmmActual -> NatM Register
conversionNop (Width -> Format
intFormat Width
rep1) CmmActual
x
MO_SS_Conv Width
rep1 Width
rep2 | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 -> Format -> CmmActual -> NatM Register
conversionNop (Width -> Format
intFormat Width
rep1) CmmActual
x
MO_XX_Conv Width
rep1 Width
rep2 | Width
rep1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
rep2 -> Format -> CmmActual -> NatM Register
conversionNop (Width -> Format
intFormat Width
rep1) CmmActual
x
MO_UU_Conv Width
W8 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
MO_UU_Conv Width
W16 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
MO_UU_Conv Width
W8 Width
W16 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
MO_SS_Conv Width
W8 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
MO_SS_Conv Width
W16 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
MO_SS_Conv Width
W8 Width
W16 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
MO_XX_Conv Width
W8 Width
W32
| Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
| Bool
otherwise -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W32 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
MO_XX_Conv Width
W8 Width
W16
| Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
| Bool
otherwise -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W16 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
MO_XX_Conv Width
W16 Width
W32 -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W32 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
MO_UU_Conv Width
W8 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
MO_UU_Conv Width
W16 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
MO_UU_Conv Width
W32 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOVZxL CmmActual
x
MO_SS_Conv Width
W8 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
MO_SS_Conv Width
W16 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
MO_SS_Conv Width
W32 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOVSxL CmmActual
x
MO_XX_Conv Width
W8 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W8 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
MO_XX_Conv Width
W16 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W16 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
MO_XX_Conv Width
W32 Width
W64 | Bool -> Bool
not Bool
is32Bit -> Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
W32 Width
W64 Format -> Operand -> Operand -> Instr
MOV CmmActual
x
MO_FF_Conv Width
W32 Width
W64 -> Width -> CmmActual -> NatM Register
coerceFP2FP Width
W64 CmmActual
x
MO_FF_Conv Width
W64 Width
W32 -> Width -> CmmActual -> NatM Register
coerceFP2FP Width
W32 CmmActual
x
MO_FS_Conv Width
from Width
to -> Width -> Width -> CmmActual -> NatM Register
coerceFP2Int Width
from Width
to CmmActual
x
MO_SF_Conv Width
from Width
to -> Width -> Width -> CmmActual -> NatM Register
coerceInt2FP Width
from Width
to CmmActual
x
MO_V_Insert {} -> NatM Register
forall a. NatM a
needLlvm
MO_V_Extract {} -> NatM Register
forall a. NatM a
needLlvm
MO_V_Add {} -> NatM Register
forall a. NatM a
needLlvm
MO_V_Sub {} -> NatM Register
forall a. NatM a
needLlvm
MO_V_Mul {} -> NatM Register
forall a. NatM a
needLlvm
MO_VS_Quot {} -> NatM Register
forall a. NatM a
needLlvm
MO_VS_Rem {} -> NatM Register
forall a. NatM a
needLlvm
MO_VS_Neg {} -> NatM Register
forall a. NatM a
needLlvm
MO_VU_Quot {} -> NatM Register
forall a. NatM a
needLlvm
MO_VU_Rem {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Insert {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Extract {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Add {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Sub {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Mul {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Quot {} -> NatM Register
forall a. NatM a
needLlvm
MO_VF_Neg {} -> NatM Register
forall a. NatM a
needLlvm
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) -> CmmActual -> NatM Register
trivialUCode Format
format (Format -> Operand -> Instr
instr Format
format) CmmActual
x
integerExtend :: Width -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr -> NatM Register
integerExtend :: Width
-> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> NatM Register
integerExtend Width
from Width
to Format -> Operand -> Operand -> Instr
instr CmmActual
expr = do
(Reg
reg,OrdList Instr
e_code) <- if Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then CmmActual -> NatM (Reg, OrdList Instr)
getByteReg CmmActual
expr
else CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
let
code :: Reg -> OrdList Instr
code Reg
dst =
OrdList Instr
e_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
instr (Width -> Format
intFormat Width
from) (Reg -> Operand
OpReg Reg
reg) (Reg -> Operand
OpReg Reg
dst)
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> OrdList Instr
code)
toI8Reg :: Width -> CmmExpr -> NatM Register
toI8Reg :: Width -> CmmActual -> NatM Register
toI8Reg Width
new_rep CmmActual
expr
= do Reg -> OrdList Instr
codefn <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
new_rep) Reg -> OrdList Instr
codefn)
toI16Reg :: Width -> CmmActual -> NatM Register
toI16Reg = Width -> CmmActual -> NatM Register
toI8Reg
conversionNop :: Format -> CmmExpr -> NatM Register
conversionNop :: Format -> CmmActual -> NatM Register
conversionNop Format
new_format CmmActual
expr
= do Register
e_code <- DynFlags -> Bool -> CmmActual -> NatM Register
getRegister' DynFlags
dflags Bool
is32Bit CmmActual
expr
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> Format -> Register
swizzleRegisterRep Register
e_code Format
new_format)
getRegister' DynFlags
_ Bool
is32Bit (CmmMachOp MachOp
mop [CmmActual
x, CmmActual
y]) = do
case MachOp
mop of
MO_F_Eq Width
_ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
EQQ CmmActual
x CmmActual
y
MO_F_Ne Width
_ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
NE CmmActual
x CmmActual
y
MO_F_Gt Width
_ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GTT CmmActual
x CmmActual
y
MO_F_Ge Width
_ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GE CmmActual
x CmmActual
y
MO_F_Lt Width
_ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GTT CmmActual
y CmmActual
x
MO_F_Le Width
_ -> Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
GE CmmActual
y CmmActual
x
MO_Eq Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
EQQ CmmActual
x CmmActual
y
MO_Ne Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
NE CmmActual
x CmmActual
y
MO_S_Gt Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GTT CmmActual
x CmmActual
y
MO_S_Ge Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GE CmmActual
x CmmActual
y
MO_S_Lt Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LTT CmmActual
x CmmActual
y
MO_S_Le Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LE CmmActual
x CmmActual
y
MO_U_Gt Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GU CmmActual
x CmmActual
y
MO_U_Ge Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
GEU CmmActual
x CmmActual
y
MO_U_Lt Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LU CmmActual
x CmmActual
y
MO_U_Le Width
_ -> Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
LEU CmmActual
x CmmActual
y
MO_F_Add Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
ADD CmmActual
x CmmActual
y
MO_F_Sub Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
SUB CmmActual
x CmmActual
y
MO_F_Quot Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
FDIV CmmActual
x CmmActual
y
MO_F_Mul Width
w -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
w Format -> Operand -> Operand -> Instr
MUL CmmActual
x CmmActual
y
MO_Add Width
rep -> Width -> CmmActual -> CmmActual -> NatM Register
add_code Width
rep CmmActual
x CmmActual
y
MO_Sub Width
rep -> Width -> CmmActual -> CmmActual -> NatM Register
sub_code Width
rep CmmActual
x CmmActual
y
MO_S_Quot Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
True Bool
True CmmActual
x CmmActual
y
MO_S_Rem Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
True Bool
False CmmActual
x CmmActual
y
MO_U_Quot Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
False Bool
True CmmActual
x CmmActual
y
MO_U_Rem Width
rep -> Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
rep Bool
False Bool
False CmmActual
x CmmActual
y
MO_S_MulMayOflo Width
rep -> Width -> CmmActual -> CmmActual -> NatM Register
imulMayOflo Width
rep CmmActual
x CmmActual
y
MO_Mul Width
W8 -> CmmActual -> CmmActual -> NatM Register
imulW8 CmmActual
x CmmActual
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
MO_Shl Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SHL CmmActual
x CmmActual
y
MO_U_Shr Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SHR CmmActual
x CmmActual
y
MO_S_Shr Width
rep -> Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
rep Format -> Operand -> Operand -> Instr
SAR CmmActual
x CmmActual
y
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)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width Operand -> Operand -> Instr
op ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just Operand -> Operand -> Instr
op) CmmActual
x CmmActual
y
where op :: Operand -> Operand -> Instr
op = Format -> Operand -> Operand -> Instr
instr (Width -> Format
intFormat Width
width)
imulW8 :: CmmExpr -> CmmExpr -> NatM Register
imulW8 :: CmmActual -> CmmActual -> NatM Register
imulW8 CmmActual
arg_a CmmActual
arg_b = do
(Reg
a_reg, OrdList Instr
a_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
arg_a
Reg -> OrdList Instr
b_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_b
let code :: OrdList Instr
code = OrdList Instr
a_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
b_code Reg
eax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Instr
IMUL2 Format
format (Reg -> Operand
OpReg Reg
a_reg) ]
format :: Format
format = Width -> Format
intFormat Width
W8
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
eax OrdList Instr
code)
imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo :: Width -> CmmActual -> CmmActual -> NatM Register
imulMayOflo Width
rep CmmActual
a CmmActual
b = do
(Reg
a_reg, OrdList Instr
a_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
a
Reg -> OrdList Instr
b_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
b
let
shift_amt :: Int
shift_amt = case Width
rep of
Width
W32 -> Int
31
Width
W64 -> Int
63
Width
_ -> String -> Int
forall a. String -> a
panic String
"shift_amt"
format :: Format
format = Width -> Format
intFormat Width
rep
code :: OrdList Instr
code = OrdList Instr
a_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
b_code Reg
eax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Operand -> Instr
IMUL2 Format
format (Reg -> Operand
OpReg Reg
a_reg),
Format -> Operand -> Operand -> Instr
SAR Format
format (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift_amt)) (Reg -> Operand
OpReg Reg
eax),
Format -> Operand -> Operand -> Instr
SUB Format
format (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
eax)
]
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
eax OrdList Instr
code)
shift_code :: Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shift_code :: Width
-> (Format -> Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
shift_code Width
width Format -> Operand -> Operand -> Instr
instr CmmActual
x (CmmLit CmmLit
lit) = do
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
let
format :: Format
format = Width -> Format
intFormat Width
width
code :: Reg -> OrdList Instr
code Reg
dst
= Reg -> OrdList Instr
x_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
instr Format
format (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit)) (Reg -> Operand
OpReg Reg
dst)
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
shift_code Width
width Format -> Operand -> Operand -> Instr
instr CmmActual
x CmmActual
y = do
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
let format :: Format
format = Width -> Format
intFormat Width
width
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
format
Reg -> OrdList Instr
y_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
y
let
code :: OrdList Instr
code = Reg -> OrdList Instr
x_code Reg
tmp OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
y_code Reg
ecx OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
instr Format
format (Reg -> Operand
OpReg Reg
ecx) (Reg -> Operand
OpReg Reg
tmp)
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
tmp OrdList Instr
code)
add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
add_code :: Width -> CmmActual -> CmmActual -> NatM Register
add_code Width
rep CmmActual
x (CmmLit (CmmInt Integer
y Width
_))
| Integer -> Bool
is32BitInteger Integer
y = Width -> CmmActual -> Integer -> NatM Register
add_int Width
rep CmmActual
x Integer
y
add_code Width
rep CmmActual
x CmmActual
y = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
rep (Format -> Operand -> Operand -> Instr
ADD Format
format) ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just (Format -> Operand -> Operand -> Instr
ADD Format
format)) CmmActual
x CmmActual
y
where format :: Format
format = Width -> Format
intFormat Width
rep
sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
sub_code :: Width -> CmmActual -> CmmActual -> NatM Register
sub_code Width
rep CmmActual
x (CmmLit (CmmInt Integer
y Width
_))
| Integer -> Bool
is32BitInteger (-Integer
y) = Width -> CmmActual -> Integer -> NatM Register
add_int Width
rep CmmActual
x (-Integer
y)
sub_code Width
rep CmmActual
x CmmActual
y = Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
rep (Format -> Operand -> Operand -> Instr
SUB (Width -> Format
intFormat Width
rep)) Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing CmmActual
x CmmActual
y
add_int :: Width -> CmmActual -> Integer -> NatM Register
add_int Width
width CmmActual
x Integer
y = do
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
div_code :: Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code Width
W8 Bool
signed Bool
quotient CmmActual
x CmmActual
y = do
let widen :: MachOp
widen | Bool
signed = Width -> Width -> MachOp
MO_SS_Conv Width
W8 Width
W16
| Bool
otherwise = Width -> Width -> MachOp
MO_UU_Conv Width
W8 Width
W16
Width -> Bool -> Bool -> CmmActual -> CmmActual -> NatM Register
div_code
Width
W16
Bool
signed
Bool
quotient
(MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
x])
(MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
y])
div_code Width
width Bool
signed Bool
quotient CmmActual
x CmmActual
y = do
(Operand
y_op, OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
y
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
let
format :: Format
format = Width -> Format
intFormat Width
width
widen :: Instr
widen | Bool
signed = Format -> Instr
CLTD Format
format
| Bool
otherwise = Format -> Operand -> Operand -> Instr
XOR Format
format (Reg -> Operand
OpReg Reg
edx) (Reg -> Operand
OpReg Reg
edx)
instr :: Format -> Operand -> Instr
instr | Bool
signed = Format -> Operand -> Instr
IDIV
| Bool
otherwise = Format -> Operand -> Instr
DIV
code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
x_code Reg
eax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Instr
widen, Format -> Operand -> Instr
instr Format
format Operand
y_op]
result :: Reg
result | Bool
quotient = Reg
eax
| Bool
otherwise = Reg
edx
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
result OrdList Instr
code)
getRegister' DynFlags
_ Bool
_ (CmmLoad CmmActual
mem CmmType
pk)
| CmmType -> Bool
isFloatType CmmType
pk
= do
Amode AddrMode
addr OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
Width -> AddrMode -> OrdList Instr -> NatM Register
loadFloatAmode (CmmType -> Width
typeWidth CmmType
pk) AddrMode
addr OrdList Instr
mem_code
getRegister' DynFlags
_ Bool
is32Bit (CmmLoad CmmActual
mem CmmType
pk)
| Bool
is32Bit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk)
= do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode Operand -> Operand -> Instr
instr CmmActual
mem
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
where
width :: Width
width = CmmType -> Width
typeWidth CmmType
pk
format :: Format
format = Width -> Format
intFormat Width
width
instr :: Operand -> Operand -> Instr
instr = case Width
width of
Width
W8 -> Format -> Operand -> Operand -> Instr
MOVZxL Format
II8
Width
_other -> Format -> Operand -> Operand -> Instr
MOV Format
format
getRegister' DynFlags
_ Bool
is32Bit (CmmLoad CmmActual
mem CmmType
pk)
| Bool -> Bool
not Bool
is32Bit
= do
Reg -> OrdList Instr
code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
format) CmmActual
mem
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
where format :: Format
format = Width -> Format
intFormat (Width -> Format) -> Width -> Format
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
pk
getRegister' DynFlags
_ Bool
is32Bit (CmmLit (CmmInt Integer
0 Width
width))
= let
format :: Format
format = Width -> Format
intFormat Width
width
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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
getRegister' DynFlags
dflags Bool
is32Bit (CmmLit CmmLit
lit)
| Bool -> Bool
not Bool
is32Bit, CmmType -> Bool
isWord64 (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit), Bool -> Bool
not (CmmLit -> Bool
isBigLit CmmLit
lit)
= let
imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
code :: Reg -> OrdList Instr
code Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
II32 (Imm -> Operand
OpImm Imm
imm) (Reg -> Operand
OpReg Reg
dst))
in
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II64 Reg -> OrdList Instr
code)
where
isBigLit :: CmmLit -> Bool
isBigLit (CmmInt 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
getRegister' DynFlags
dflags Bool
_ (CmmLit CmmLit
lit)
= do let format :: Format
format = CmmType -> Format
cmmTypeFormat (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit)
imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
code :: Reg -> OrdList Instr
code Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOV Format
format (Imm -> Operand
OpImm Imm
imm) (Reg -> Operand
OpReg Reg
dst))
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
getRegister' DynFlags
_ Bool
_ CmmActual
other
| CmmActual -> Bool
isVecExpr CmmActual
other = NatM Register
forall a. NatM a
needLlvm
| Bool
otherwise = String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(x86)" (CmmActual -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmActual
other)
intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
-> NatM (Reg -> InstrBlock)
intLoadCode :: (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode Operand -> Operand -> Instr
instr CmmActual
mem = do
Amode AddrMode
src OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
(Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (\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))
getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg :: CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
expr = do
Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
Register -> NatM (Reg -> OrdList Instr)
anyReg Register
r
anyReg :: Register -> NatM (Reg -> InstrBlock)
anyReg :: Register -> NatM (Reg -> OrdList Instr)
anyReg (Any Format
_ Reg -> OrdList Instr
code) = (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return Reg -> OrdList Instr
code
anyReg (Fixed Format
rep Reg
reg OrdList Instr
fcode) = (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
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)
getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
getByteReg :: CmmActual -> NatM (Reg, OrdList Instr)
getByteReg CmmActual
expr = do
Bool
is32Bit <- NatM Bool
is32BitPlatform
if Bool
is32Bit
then do Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
case Register
r of
Any Format
rep Reg -> OrdList Instr
code -> do
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
(Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
Fixed Format
rep Reg
reg OrdList Instr
code
| Reg -> Bool
isVirtualReg Reg
reg -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg,OrdList Instr
code)
| Bool
otherwise -> do
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
(Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
rep Reg
reg Reg
tmp)
else CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg :: CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
expr = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Register
r <- CmmActual -> NatM Register
getRegister CmmActual
expr
case Register
r of
Any Format
rep Reg -> OrdList Instr
code -> do
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
(Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> OrdList Instr
code Reg
tmp)
Fixed Format
rep Reg
reg OrdList Instr
code
| Reg
reg Reg -> [Reg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Platform -> [Reg]
instrClobberedRegs (DynFlags -> Platform
targetPlatform DynFlags
dflags)
-> do
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
(Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
rep Reg
reg Reg
tmp)
| Bool
otherwise ->
(Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, OrdList Instr
code)
reg2reg :: Format -> Reg -> Reg -> Instr
reg2reg :: Format -> Reg -> Reg -> Instr
reg2reg Format
format Reg
src Reg
dst = Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
src) (Reg -> Operand
OpReg Reg
dst)
getAmode :: CmmExpr -> NatM Amode
getAmode :: CmmActual -> NatM Amode
getAmode CmmActual
e = do Bool
is32Bit <- NatM Bool
is32BitPlatform
Bool -> CmmActual -> NatM Amode
getAmode' Bool
is32Bit CmmActual
e
getAmode' :: Bool -> CmmExpr -> NatM Amode
getAmode' :: Bool -> CmmActual -> NatM Amode
getAmode' Bool
_ (CmmRegOff CmmReg
r Int
n) = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmActual -> NatM Amode
getAmode (CmmActual -> NatM Amode) -> CmmActual -> NatM Amode
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmReg -> Int -> CmmActual
mangleIndexTree DynFlags
dflags CmmReg
r Int
n
getAmode' Bool
is32Bit (CmmMachOp (MO_Add Width
W64) [CmmReg (CmmGlobal GlobalReg
PicBaseReg),
CmmLit CmmLit
displacement])
| Bool -> Bool
not Bool
is32Bit
= Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Imm -> AddrMode
ripRel (CmmLit -> Imm
litToImm CmmLit
displacement)) OrdList Instr
forall a. OrdList a
nilOL
getAmode' Bool
is32Bit (CmmMachOp (MO_Sub Width
_rep) [CmmActual
x, CmmLit lit :: CmmLit
lit@(CmmInt Integer
i Width
_)])
| Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
= do (Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
let off :: Imm
off = Int -> Imm
ImmInt (-(Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i))
Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
x_reg) EAIndex
EAIndexNone Imm
off) OrdList Instr
x_code)
getAmode' Bool
is32Bit (CmmMachOp (MO_Add Width
_rep) [CmmActual
x, CmmLit CmmLit
lit])
| Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
= do (Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
let off :: Imm
off = CmmLit -> Imm
litToImm CmmLit
lit
Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
x_reg) EAIndex
EAIndexNone Imm
off) OrdList Instr
x_code)
getAmode' Bool
is32Bit (CmmMachOp (MO_Add Width
rep) [a :: CmmActual
a@(CmmMachOp (MO_Shl Width
_) [CmmActual]
_),
b :: CmmActual
b@(CmmLit CmmLit
_)])
= Bool -> CmmActual -> NatM Amode
getAmode' Bool
is32Bit (MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> MachOp
MO_Add Width
rep) [CmmActual
b,CmmActual
a])
getAmode' Bool
_ (CmmMachOp (MO_Add Width
_) [CmmRegOff CmmReg
x Int
offset,
CmmMachOp (MO_Shl Width
_)
[CmmActual
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
= CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode (CmmReg -> CmmActual
CmmReg CmmReg
x) CmmActual
y Integer
shift (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset)
getAmode' Bool
_ (CmmMachOp (MO_Add Width
_) [CmmActual
x, CmmMachOp (MO_Shl Width
_)
[CmmActual
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
= CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
x CmmActual
y Integer
shift Integer
0
getAmode' Bool
_ (CmmMachOp (MO_Add Width
_)
[CmmActual
x, CmmMachOp (MO_Add Width
_)
[CmmMachOp (MO_Shl Width
_) [CmmActual
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
= CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
x CmmActual
y Integer
shift Integer
offset
getAmode' Bool
_ (CmmMachOp (MO_Add Width
_) [CmmActual
x,CmmActual
y])
= CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
x CmmActual
y Integer
0 Integer
0
getAmode' Bool
is32Bit (CmmLit CmmLit
lit) | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
= Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Imm -> Int -> AddrMode
ImmAddr (CmmLit -> Imm
litToImm CmmLit
lit) Int
0) OrdList Instr
forall a. OrdList a
nilOL)
getAmode' Bool
_ CmmActual
expr = do
(Reg
reg,OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
reg) EAIndex
EAIndexNone (Int -> Imm
ImmInt Int
0)) OrdList Instr
code)
getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode
getSimpleAmode :: DynFlags -> Bool -> CmmActual -> NatM Amode
getSimpleAmode DynFlags
dflags Bool
is32Bit CmmActual
addr
| Bool
is32Bit = do
Reg -> OrdList Instr
addr_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
addr
Reg
addr_r <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags))
let amode :: AddrMode
amode = EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
addr_r) EAIndex
EAIndexNone (Int -> Imm
ImmInt Int
0)
Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$! AddrMode -> OrdList Instr -> Amode
Amode AddrMode
amode (Reg -> OrdList Instr
addr_code Reg
addr_r)
| Bool
otherwise = CmmActual -> NatM Amode
getAmode CmmActual
addr
x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
x86_complex_amode :: CmmActual -> CmmActual -> Integer -> Integer -> NatM Amode
x86_complex_amode CmmActual
base CmmActual
index Integer
shift Integer
offset
= do (Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
base
(Reg
y_reg, OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
index
let
code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
y_code
base :: 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. 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 (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)
getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
getNonClobberedOperand :: CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand (CmmLit CmmLit
lit) = do
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 (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
addr, OrdList Instr
code)
else do
Bool
is32Bit <- NatM Bool
is32BitPlatform
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit))
then (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit), OrdList Instr
forall a. OrdList a
nilOL)
else CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic (CmmLit -> CmmActual
CmmLit CmmLit
lit)
getNonClobberedOperand (CmmLoad CmmActual
mem CmmType
pk) = do
Bool
is32Bit <- NatM Bool
is32BitPlatform
if (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
then do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
Amode AddrMode
src OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
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 (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 (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
src, OrdList Instr
forall a. OrdList a
nilOL)
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src', OrdList Instr
mem_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
save_code)
else do
CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic (CmmActual -> CmmType -> CmmActual
CmmLoad CmmActual
mem CmmType
pk)
getNonClobberedOperand CmmActual
e = CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic CmmActual
e
getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
getNonClobberedOperand_generic :: CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand_generic CmmActual
e = do
(Reg
reg, OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
e
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)
amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
amodeCouldBeClobbered Platform
platform 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 :: CmmExpr -> NatM (Operand, InstrBlock)
getOperand :: CmmActual -> 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 (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
addr, OrdList Instr
code)
else do
Bool
is32Bit <- NatM Bool
is32BitPlatform
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit))
then (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit), OrdList Instr
forall a. OrdList a
nilOL)
else CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic (CmmLit -> CmmActual
CmmLit CmmLit
lit)
getOperand (CmmLoad CmmActual
mem CmmType
pk) = do
Bool
is32Bit <- NatM Bool
is32BitPlatform
Bool
use_sse2 <- NatM Bool
sse2Enabled
if (Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
pk) Bool -> Bool -> Bool
|| Bool
use_sse2) Bool -> Bool -> Bool
&& (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
then do
Amode AddrMode
src OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src, OrdList Instr
mem_code)
else
CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic (CmmActual -> CmmType -> CmmActual
CmmLoad CmmActual
mem CmmType
pk)
getOperand CmmActual
e = CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic CmmActual
e
getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
getOperand_generic :: CmmActual -> NatM (Operand, OrdList Instr)
getOperand_generic CmmActual
e = do
(Reg
reg, OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
e
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)
isOperand :: Bool -> CmmExpr -> Bool
isOperand :: Bool -> CmmActual -> Bool
isOperand Bool
_ (CmmLoad CmmActual
_ CmmType
_) = Bool
True
isOperand Bool
is32Bit (CmmLit CmmLit
lit) = Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
Bool -> Bool -> Bool
|| CmmLit -> Bool
isSuitableFloatingPointLit CmmLit
lit
isOperand Bool
_ CmmActual
_ = Bool
False
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 =
ASSERT(not $ isFloatFormat fmt)
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
TEST Format
fmt (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ 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
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(AddrMode
addr, OrdList Instr
addr_code) <- if Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
then do CmmActual
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference
DynFlags
dflags
ReferenceKind
DataReference
CLabel
lbl
Amode AddrMode
addr OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
dynRef
(AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
addr, OrdList Instr
addr_code)
else (AddrMode, OrdList Instr) -> NatM (AddrMode, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> AddrMode
ripRel (CLabel -> Imm
ImmCLbl CLabel
lbl), OrdList Instr
forall a. OrdList a
nilOL)
let code :: OrdList Instr
code =
Section -> (Alignment, CmmStatics) -> Instr
LDATA Section
rosection (Alignment
align, CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit CmmLit
lit])
Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList Instr
addr_code
Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode AddrMode
addr OrdList Instr
code)
loadFloatAmode :: 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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
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 :: CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem e :: CmmActual
e@(CmmLoad CmmActual
mem CmmType
pk) = do
Bool
is32Bit <- NatM Bool
is32BitPlatform
Bool
use_sse2 <- NatM Bool
sse2Enabled
if (Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
pk) Bool -> Bool -> Bool
|| Bool
use_sse2) Bool -> Bool -> Bool
&& (if Bool
is32Bit then Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) else Bool
True)
then do
Amode AddrMode
src OrdList Instr
mem_code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> Operand
OpAddr AddrMode
src, OrdList Instr
mem_code)
else do
(Reg
reg, OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
e
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)
getRegOrMem CmmActual
e = do
(Reg
reg, OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
e
(Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Operand
OpReg Reg
reg, OrdList Instr
code)
is32BitLit :: Bool -> CmmLit -> Bool
is32BitLit :: Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit (CmmInt Integer
i Width
W64)
| Bool -> Bool
not Bool
is32Bit
=
Integer -> Bool
is32BitInteger Integer
i
is32BitLit Bool
_ CmmLit
_ = Bool
True
getCondCode :: CmmExpr -> NatM CondCode
getCondCode :: CmmActual -> NatM CondCode
getCondCode (CmmMachOp MachOp
mop [CmmActual
x, CmmActual
y])
=
case MachOp
mop of
MO_F_Eq Width
W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
EQQ CmmActual
x CmmActual
y
MO_F_Ne Width
W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
NE CmmActual
x CmmActual
y
MO_F_Gt Width
W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
x CmmActual
y
MO_F_Ge Width
W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE CmmActual
x CmmActual
y
MO_F_Lt Width
W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
y CmmActual
x
MO_F_Le Width
W32 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE CmmActual
y CmmActual
x
MO_F_Eq Width
W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
EQQ CmmActual
x CmmActual
y
MO_F_Ne Width
W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
NE CmmActual
x CmmActual
y
MO_F_Gt Width
W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
x CmmActual
y
MO_F_Ge Width
W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE CmmActual
x CmmActual
y
MO_F_Lt Width
W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GTT CmmActual
y CmmActual
x
MO_F_Le Width
W64 -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
GE CmmActual
y CmmActual
x
MachOp
_ -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode (MachOp -> Cond
machOpToCond MachOp
mop) CmmActual
x CmmActual
y
getCondCode CmmActual
other = String -> SDoc -> NatM CondCode
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getCondCode(2)(x86,x86_64)" (CmmActual -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmActual
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)
condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode :: Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode Cond
cond CmmActual
x CmmActual
y = do Bool
is32Bit <- NatM Bool
is32BitPlatform
Bool -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode' Bool
is32Bit Cond
cond CmmActual
x CmmActual
y
condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' :: Bool -> Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode' Bool
is32Bit Cond
cond (CmmLoad CmmActual
x CmmType
pk) (CmmLit CmmLit
lit)
| Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit = do
Amode AddrMode
x_addr OrdList Instr
x_code <- CmmActual -> NatM Amode
getAmode CmmActual
x
let
imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat CmmType
pk) (Imm -> Operand
OpImm Imm
imm) (AddrMode -> Operand
OpAddr AddrMode
x_addr)
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)
condIntCode' Bool
is32Bit Cond
cond (CmmMachOp (MO_And Width
_) [CmmActual
x,CmmActual
o2]) (CmmLit (CmmInt Integer
0 Width
pk))
| (CmmLit lit :: CmmLit
lit@(CmmInt Integer
mask Width
_)) <- CmmActual
o2, Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
= do
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
let
code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
TEST (Width -> Format
intFormat Width
pk) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
mask)) (Reg -> Operand
OpReg Reg
x_reg)
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)
condIntCode' Bool
_ Cond
cond CmmActual
x (CmmLit (CmmInt Integer
0 Width
pk)) = do
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
let
code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
TEST (Width -> Format
intFormat Width
pk) (Reg -> Operand
OpReg Reg
x_reg) (Reg -> Operand
OpReg Reg
x_reg)
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)
condIntCode' Bool
is32Bit Cond
cond CmmActual
x CmmActual
y
| Bool -> CmmActual -> Bool
isOperand Bool
is32Bit CmmActual
y = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
x
(Operand
y_op, OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
y
let
code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
y_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
x)) Operand
y_op (Reg -> Operand
OpReg Reg
x_reg)
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)
| Bool -> CmmActual -> Bool
isOperand Bool
is32Bit CmmActual
x
, Just Cond
revcond <- Cond -> Maybe Cond
maybeFlipCond Cond
cond = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Reg
y_reg, OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
y
(Operand
x_op, OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
x
let
code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
x)) Operand
x_op (Reg -> Operand
OpReg Reg
y_reg)
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
revcond OrdList Instr
code)
condIntCode' Bool
_ Cond
cond CmmActual
x CmmActual
y = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Reg
y_reg, OrdList Instr
y_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
y
(Operand
x_op, OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
x
let
code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
x_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
CMP (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
x)) (Reg -> Operand
OpReg Reg
y_reg) Operand
x_op
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode :: Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
cond CmmActual
x CmmActual
y
= NatM CondCode
condFltCode_sse2
where
condFltCode_sse2 :: NatM CondCode
condFltCode_sse2 = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
x
(Operand
y_op, OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
y
let
code :: OrdList Instr
code = OrdList Instr
x_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
y_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
CMP (Width -> Format
floatFormat (Width -> Format) -> Width -> Format
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmActual -> Width
cmmExprWidth DynFlags
dflags CmmActual
x) Operand
y_op (Reg -> Operand
OpReg Reg
x_reg)
CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
True (Cond -> Cond
condToUnsigned Cond
cond) OrdList Instr
code)
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
assignMem_IntCode :: Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_IntCode Format
pk CmmActual
addr (CmmMachOp MachOp
op [CmmLoad CmmActual
addr2 CmmType
_,
CmmLit (CmmInt Integer
i Width
_)])
| CmmActual
addr CmmActual -> CmmActual -> Bool
forall a. Eq a => a -> a -> Bool
== CmmActual
addr2, Format
pk Format -> Format -> Bool
forall a. Eq a => a -> a -> Bool
/= Format
II64 Bool -> Bool -> Bool
|| Integer -> Bool
is32BitInteger Integer
i,
Just Format -> Operand -> Operand -> Instr
instr <- MachOp -> Maybe (Format -> Operand -> Operand -> Instr)
check MachOp
op
= do Amode AddrMode
amode OrdList Instr
code_addr <- CmmActual -> NatM Amode
getAmode CmmActual
addr
let code :: OrdList Instr
code = OrdList Instr
code_addr OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
instr Format
pk (Imm -> Operand
OpImm (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 (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
assignMem_IntCode Format
pk CmmActual
addr CmmActual
src = do
Bool
is32Bit <- NatM Bool
is32BitPlatform
Amode AddrMode
addr OrdList Instr
code_addr <- CmmActual -> NatM Amode
getAmode CmmActual
addr
(OrdList Instr
code_src, Operand
op_src) <- Bool -> CmmActual -> NatM (OrdList Instr, Operand)
get_op_RI Bool
is32Bit CmmActual
src
let
code :: OrdList Instr
code = OrdList Instr
code_src OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code_addr OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOV Format
pk Operand
op_src (AddrMode -> Operand
OpAddr AddrMode
addr)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
where
get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)
get_op_RI :: Bool -> CmmActual -> NatM (OrdList Instr, Operand)
get_op_RI Bool
is32Bit (CmmLit CmmLit
lit) | Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit
= (OrdList Instr, Operand) -> NatM (OrdList Instr, Operand)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit))
get_op_RI Bool
_ CmmActual
op
= do (Reg
reg,OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
op
(OrdList Instr, Operand) -> NatM (OrdList Instr, Operand)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, Reg -> Operand
OpReg Reg
reg)
assignReg_IntCode :: Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_IntCode Format
pk CmmReg
reg (CmmLoad CmmActual
src CmmType
_) = do
Reg -> OrdList Instr
load_code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV Format
pk) CmmActual
src
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
load_code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg))
assignReg_IntCode Format
_ CmmReg
reg CmmActual
src = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
Reg -> OrdList Instr
code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg))
assignMem_FltCode :: Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_FltCode Format
pk CmmActual
addr CmmActual
src = do
(Reg
src_reg, OrdList Instr
src_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg CmmActual
src
Amode AddrMode
addr OrdList Instr
addr_code <- CmmActual -> NatM Amode
getAmode CmmActual
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 (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
assignReg_FltCode :: Format -> CmmReg -> CmmActual -> NatM (OrdList Instr)
assignReg_FltCode Format
_ CmmReg
reg CmmActual
src = do
Reg -> OrdList Instr
src_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
src_code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg))
genJump :: CmmExpr -> [Reg] -> NatM InstrBlock
genJump :: CmmActual -> [Reg] -> NatM (OrdList Instr)
genJump (CmmLoad CmmActual
mem CmmType
_) [Reg]
regs = do
Amode AddrMode
target OrdList Instr
code <- CmmActual -> NatM Amode
getAmode CmmActual
mem
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> [Reg] -> Instr
JMP (AddrMode -> Operand
OpAddr AddrMode
target) [Reg]
regs)
genJump (CmmLit CmmLit
lit) [Reg]
regs = do
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Operand -> [Reg] -> Instr
JMP (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit)) [Reg]
regs))
genJump CmmActual
expr [Reg]
regs = do
(Reg
reg,OrdList Instr
code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> [Reg] -> Instr
JMP (Reg -> Operand
OpReg Reg
reg) [Reg]
regs)
genBranch :: BlockId -> InstrBlock
genBranch :: Label -> OrdList Instr
genBranch = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL ([Instr] -> OrdList Instr)
-> (Label -> [Instr]) -> Label -> OrdList Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> [Instr]
forall instr. Instruction instr => Label -> [instr]
mkJumpInstr
genCondBranch
:: BlockId
-> BlockId
-> BlockId
-> CmmExpr
-> NatM InstrBlock
genCondBranch :: Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch Label
bid Label
id Label
false CmmActual
expr = do
Bool
is32Bit <- NatM Bool
is32BitPlatform
Bool
-> Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch' Bool
is32Bit Label
bid Label
id Label
false CmmActual
expr
genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
-> NatM InstrBlock
genCondBranch' :: Bool
-> Label -> Label -> Label -> CmmActual -> NatM (OrdList Instr)
genCondBranch' Bool
is32Bit Label
_bid Label
true Label
false (CmmMachOp MachOp
mop [CmmActual
e1,CmmActual
e2])
| Bool
is32Bit, Just Width
W64 <- MachOp -> Maybe Width
maybeIntComparison MachOp
mop = do
ChildCode64 OrdList Instr
code1 Reg
r1_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e1
ChildCode64 OrdList Instr
code2 Reg
r2_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
e2
let r1_hi :: Reg
r1_hi = Reg -> Reg
getHiVRegFromLo Reg
r1_lo
r2_hi :: Reg
r2_hi = Reg -> Reg
getHiVRegFromLo Reg
r2_lo
cond :: Cond
cond = MachOp -> Cond
machOpToCond MachOp
mop
Just Cond
cond' = Cond -> Maybe Cond
maybeFlipCond Cond
cond
let code :: OrdList Instr
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Operand -> Operand -> Instr
CMP Format
II32 (Reg -> Operand
OpReg Reg
r2_hi) (Reg -> Operand
OpReg Reg
r1_hi),
Cond -> Label -> Instr
JXX Cond
cond Label
true,
Cond -> Label -> Instr
JXX Cond
cond' Label
false,
Format -> Operand -> Operand -> Instr
CMP Format
II32 (Reg -> Operand
OpReg Reg
r2_lo) (Reg -> Operand
OpReg Reg
r1_lo),
Cond -> Label -> Instr
JXX Cond
cond Label
true] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Label -> OrdList Instr
genBranch Label
false
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
genCondBranch' Bool
_ Label
bid Label
id Label
false CmmActual
bool = do
CondCode Bool
is_float Cond
cond OrdList Instr
cond_code <- CmmActual -> NatM CondCode
getCondCode CmmActual
bool
Bool
use_sse2 <- NatM Bool
sse2Enabled
if Bool -> Bool
not Bool
is_float Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
use_sse2
then
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
cond_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Cond -> Label -> Instr
JXX Cond
cond Label
id OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Label -> OrdList Instr
genBranch Label
false)
else do
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
Cond
LTT ->
ASSERT2(False, ppr "Should have been turned into >")
OrdList Instr
and_ordered
Cond
LE ->
ASSERT2(False, ppr "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 (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)
genCCall
:: DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> BlockId
-> NatM (InstrBlock, Maybe BlockId)
genCCall :: DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall DynFlags
dflags Bool
is32Bit (PrimTarget (MO_AtomicRMW Width
width AtomicMachOp
amop))
[CmmFormal
dst] [CmmActual
addr, CmmActual
n] Label
bid = do
Amode AddrMode
amode OrdList Instr
addr_code <-
if AtomicMachOp
amop AtomicMachOp -> [AtomicMachOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AtomicMachOp
AMO_Add, AtomicMachOp
AMO_Sub]
then CmmActual -> NatM Amode
getAmode CmmActual
addr
else DynFlags -> Bool -> CmmActual -> NatM Amode
getSimpleAmode DynFlags
dflags Bool
is32Bit CmmActual
addr
Reg
arg <- Format -> NatM Reg
getNewRegNat Format
format
Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
n
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
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 (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
op_code :: Reg
-> Reg
-> AddrMode
-> NatM (OrdList Instr,BlockId)
op_code :: Reg -> Reg -> AddrMode -> NatM (OrdList Instr, Label)
op_code Reg
dst_r Reg
arg AddrMode
amode = case AtomicMachOp
amop of
AtomicMachOp
AMO_Add -> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList Instr, Label) -> NatM (OrdList Instr, Label))
-> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a b. (a -> b) -> a -> b
$ ([Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
XADD Format
format (Reg -> Operand
OpReg Reg
arg) (AddrMode -> Operand
OpAddr AddrMode
amode))
, Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
arg) (Reg -> Operand
OpReg Reg
dst_r)
], Label
bid)
AtomicMachOp
AMO_Sub -> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList Instr, Label) -> NatM (OrdList Instr, Label))
-> (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
forall a b. (a -> b) -> a -> b
$ ([Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Instr
NEGI Format
format (Reg -> Operand
OpReg Reg
arg)
, Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
XADD Format
format (Reg -> Operand
OpReg Reg
arg) (AddrMode -> Operand
OpAddr AddrMode
amode))
, Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
arg) (Reg -> Operand
OpReg Reg
dst_r)
], Label
bid)
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
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
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 (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
, 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
, Cond -> Label -> Instr
JXX Cond
ALWAYS Label
lbl2
, Label -> Instr
NEWBLOCK Label
lbl2
],
Label
lbl2)
format :: Format
format = Width -> Format
intFormat Width
width
genCCall DynFlags
dflags Bool
is32Bit (PrimTarget (MO_Ctz Width
width)) [CmmFormal
dst] [CmmActual
src] Label
bid
| Bool
is32Bit, Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = do
ChildCode64 OrdList Instr
vcode Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
src
let rhi :: Reg
rhi = Reg -> Reg
getHiVRegFromLo Reg
rlo
dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
Label
lbl1 <- NatM Label
getBlockIdNat
Label
lbl2 <- NatM Label
getBlockIdNat
let format :: Format
format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then Format
II16 else Width -> Format
intFormat Width
width
Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
(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
.
Label -> Label -> CFG -> CFG
addImmediateSuccessor Label
bid Label
lbl2)
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 (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, Label -> Maybe Label
forall a. a -> Maybe a
Just Label
lbl2)
| Bool
otherwise = do
Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
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, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, Maybe Label
forall a. Maybe a
Nothing)
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
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
])
(OrdList Instr, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs, Maybe Label
forall a. Maybe a
Nothing)
where
bw :: Int
bw = Width -> Int
widthInBits Width
width
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
genCCall DynFlags
dflags Bool
bits ForeignTarget
mop [CmmFormal]
dst [CmmActual]
args Label
bid = do
OrdList Instr
instr <- DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
bits ForeignTarget
mop [CmmFormal]
dst [CmmActual]
args Label
bid
(OrdList Instr, Maybe Label) -> NatM (OrdList Instr, Maybe Label)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instr, Maybe Label
forall a. Maybe a
Nothing)
genCCall'
:: DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> BlockId
-> NatM InstrBlock
genCCall' :: DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
_ (PrimTarget (MO_Memcpy Int
align)) [CmmFormal]
_
[CmmActual
dst, CmmActual
src, CmmLit (CmmInt Integer
n Width
_)] Label
_
| Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
insns Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
maxInlineMemcpyInsns DynFlags
dflags = do
Reg -> OrdList Instr
code_dst <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
dst
Reg
dst_r <- Format -> NatM Reg
getNewRegNat Format
format
Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_dst Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> Reg -> Reg -> Integer -> OrdList Instr
go Reg
dst_r Reg
src_r Reg
tmp_r (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n)
where
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)
maxAlignment :: Alignment
maxAlignment = DynFlags -> Alignment
wordAlignment DynFlags
dflags
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
sizeBytes :: Integer
sizeBytes :: Integer
sizeBytes = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Int
formatInBytes Format
format)
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)
| Integer
i 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 (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))
genCCall' DynFlags
dflags Bool
_ (PrimTarget (MO_Memset Int
align)) [CmmFormal]
_
[CmmActual
dst,
CmmLit (CmmInt Integer
c Width
_),
CmmLit (CmmInt Integer
n Width
_)]
Label
_
| Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
insns Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= DynFlags -> Int
maxInlineMemsetInsns DynFlags
dflags = do
Reg -> OrdList Instr
code_dst <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
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 <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg (CmmLit -> CmmActual
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
c8 Width
W64))
Reg
imm8byte_r <- Format -> NatM Reg
getNewRegNat Format
II64
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_dst Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
code_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
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_dst Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> Integer -> OrdList Instr
go4 Reg
dst_r (Integer -> Integer
forall a. Num a => Integer -> a
fromInteger Integer
n)
where
maxAlignment :: Alignment
maxAlignment = DynFlags -> Alignment
wordAlignment DynFlags
dflags
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
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
sizeBytes :: Integer
sizeBytes :: Integer
sizeBytes = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Format -> Int
formatInBytes Format
format)
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)
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))
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 (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
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 (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))
genCCall' DynFlags
_ Bool
_ (PrimTarget CallishMachOp
MO_ReadBarrier) [CmmFormal]
_ [CmmActual]
_ Label
_ = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
genCCall' DynFlags
_ Bool
_ (PrimTarget CallishMachOp
MO_WriteBarrier) [CmmFormal]
_ [CmmActual]
_ Label
_ = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
genCCall' DynFlags
_ Bool
_ (PrimTarget CallishMachOp
MO_Touch) [CmmFormal]
_ [CmmActual]
_ Label
_ = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
genCCall' DynFlags
_ Bool
is32bit (PrimTarget (MO_Prefetch_Data Int
n )) [CmmFormal]
_ [CmmActual
src] Label
_ =
case Int
n of
Int
0 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
NTA Format
format
Int
1 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
Lvl2 Format
format
Int
2 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
Lvl1 Format
format
Int
3 -> CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
src ((Operand -> Instr) -> NatM (OrdList Instr))
-> (Operand -> Instr) -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ PrefetchVariant -> Format -> Operand -> Instr
PREFETCH PrefetchVariant
Lvl0 Format
format
Int
l -> String -> NatM (OrdList Instr)
forall a. String -> a
panic (String -> NatM (OrdList Instr)) -> String -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ String
"unexpected prefetch level in genCCall MO_Prefetch_Data: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
l)
where
format :: Format
format = Bool -> Format
archWordFormat Bool
is32bit
genPrefetch :: CmmActual -> (Operand -> Instr) -> NatM (OrdList Instr)
genPrefetch CmmActual
inRegSrc Operand -> Instr
prefetchCTor =
do
Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
inRegSrc
Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Operand -> Instr
prefetchCTor (AddrMode -> Operand
OpAddr
((EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
src_r ) EAIndex
EAIndexNone (Int -> Imm
ImmInt Int
0)))) ))
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_BSwap Width
width)) [CmmFormal
dst] [CmmActual
src] Label
_ = do
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
case Width
width of
Width
W64 | Bool
is32Bit -> do
ChildCode64 OrdList Instr
vcode Reg
rlo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
src
let dst_rhi :: Reg
dst_rhi = Reg -> Reg
getHiVRegFromLo Reg
dst_r
rhi :: Reg
rhi = Reg -> Reg
getHiVRegFromLo Reg
rlo
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
vcode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rlo) (Reg -> Operand
OpReg Reg
dst_rhi),
Format -> Operand -> Operand -> Instr
MOV Format
II32 (Reg -> Operand
OpReg Reg
rhi) (Reg -> Operand
OpReg Reg
dst_r),
Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_rhi,
Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_r ]
Width
W16 -> do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Instr
BSWAP Format
II32 Reg
dst_r) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
SHR Format
II32 (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
16) (Reg -> Operand
OpReg Reg
dst_r))
Width
_ -> do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
dst_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Instr
BSWAP Format
format Reg
dst_r)
where
format :: Format
format = Width -> Format
intFormat Width
width
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_PopCnt Width
width)) dest_regs :: [CmmFormal]
dest_regs@[CmmFormal
dst]
args :: [CmmActual]
args@[CmmActual
src] Label
bid = do
Bool
sse4_2 <- NatM Bool
sse4_2Enabled
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
if Bool
sse4_2
then do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then
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
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r))
else OrdList Instr
forall a. OrdList a
nilOL)
else do
CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
ReferenceKind
CallReference CLabel
lbl
let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
[ForeignHint
NoHint] [ForeignHint
NoHint]
CmmReturnInfo
CmmMayReturn)
DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
where
format :: Format
format = Width -> Format
intFormat Width
width
lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
popCntLabel Width
width))
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_Pdep Width
width)) dest_regs :: [CmmFormal]
dest_regs@[CmmFormal
dst]
args :: [CmmActual]
args@[CmmActual
src, CmmActual
mask] Label
bid = do
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
then do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
Reg -> OrdList Instr
code_mask <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
mask
Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
Reg
mask_r <- Format -> NatM Reg
getNewRegNat Format
format
let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
code_mask Reg
mask_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
src_r ) (Reg -> Operand
OpReg Reg
src_r )) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
mask_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PDEP Format
II16 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r ) Reg
dst_r)
else
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PDEP Format
format (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 then
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r))
else OrdList Instr
forall a. OrdList a
nilOL)
else do
CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
ReferenceKind
CallReference CLabel
lbl
let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
[ForeignHint
NoHint] [ForeignHint
NoHint]
CmmReturnInfo
CmmMayReturn)
DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
where
format :: Format
format = Width -> Format
intFormat Width
width
lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
pdepLabel Width
width))
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_Pext Width
width)) dest_regs :: [CmmFormal]
dest_regs@[CmmFormal
dst]
args :: [CmmActual]
args@[CmmActual
src, CmmActual
mask] Label
bid = do
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
then do Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
Reg -> OrdList Instr
code_mask <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
mask
Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
Reg
mask_r <- Format -> NatM Reg
getNewRegNat Format
format
let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_src Reg
src_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
code_mask Reg
mask_r OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 then
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
src_r ) (Reg -> Operand
OpReg Reg
src_r )) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
mask_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PEXT Format
II16 (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)
else
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Reg -> Instr
PEXT Format
format (Reg -> Operand
OpReg Reg
mask_r) (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
(if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 then
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Operand -> Operand -> Instr
MOVZxL Format
II16 (Reg -> Operand
OpReg Reg
dst_r) (Reg -> Operand
OpReg Reg
dst_r))
else OrdList Instr
forall a. OrdList a
nilOL)
else do
CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
ReferenceKind
CallReference CLabel
lbl
let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
[ForeignHint
NoHint] [ForeignHint
NoHint]
CmmReturnInfo
CmmMayReturn)
DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
where
format :: Format
format = Width -> Format
intFormat Width
width
lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
pextLabel Width
width))
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_Clz Width
width)) dest_regs :: [CmmFormal]
dest_regs@[CmmFormal
dst] args :: [CmmActual]
args@[CmmActual
src] Label
bid
| Bool
is32Bit Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = do
CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
CallReference CLabel
lbl
let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
[ForeignHint
NoHint] [ForeignHint
NoHint]
CmmReturnInfo
CmmMayReturn)
DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
| Bool
otherwise = do
Reg -> OrdList Instr
code_src <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
src
let dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
then do
Reg
src_r <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
width)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> 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)
, Format -> Operand -> Reg -> Instr
LZCNT Format
II32 (Reg -> Operand
OpReg Reg
src_r) Reg
dst_r
, Format -> Operand -> Operand -> Instr
SUB Format
II32 (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
24)) (Reg -> Operand
OpReg Reg
dst_r)
]
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)
]
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
Reg
src_r <- Format -> NatM Reg
getNewRegNat Format
format
Reg
tmp_r <- Format -> NatM Reg
getNewRegNat Format
format
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code_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)
])
where
bw :: Int
bw = Width -> Int
widthInBits Width
width
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
clzLabel Width
width))
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_UF_Conv Width
width)) [CmmFormal]
dest_regs [CmmActual]
args Label
bid = do
CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags
ReferenceKind
CallReference CLabel
lbl
let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr (CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv
[ForeignHint
NoHint] [ForeignHint
NoHint]
CmmReturnInfo
CmmMayReturn)
DynFlags
-> Bool
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> Label
-> NatM (OrdList Instr)
genCCall' DynFlags
dflags Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid
where
lbl :: CLabel
lbl = UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
primUnitId (String -> FastString
fsLit (Width -> String
word2FloatLabel Width
width))
genCCall' DynFlags
dflags Bool
_ (PrimTarget (MO_AtomicRead Width
width)) [CmmFormal
dst] [CmmActual
addr] Label
_ = do
Reg -> OrdList Instr
load_code <- (Operand -> Operand -> Instr)
-> CmmActual -> NatM (Reg -> OrdList Instr)
intLoadCode (Format -> Operand -> Operand -> Instr
MOV (Width -> Format
intFormat Width
width)) CmmActual
addr
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
load_code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)))
genCCall' DynFlags
_ Bool
_ (PrimTarget (MO_AtomicWrite Width
width)) [] [CmmActual
addr, CmmActual
val] Label
_ = do
OrdList Instr
code <- Format -> CmmActual -> CmmActual -> NatM (OrdList Instr)
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmActual
addr CmmActual
val
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
MFENCE
genCCall' DynFlags
dflags Bool
is32Bit (PrimTarget (MO_Cmpxchg Width
width)) [CmmFormal
dst] [CmmActual
addr, CmmActual
old, CmmActual
new] Label
_ = do
Amode AddrMode
amode OrdList Instr
addr_code <- DynFlags -> Bool -> CmmActual -> NatM Amode
getSimpleAmode DynFlags
dflags Bool
is32Bit CmmActual
addr
Reg
newval <- Format -> NatM Reg
getNewRegNat Format
format
Reg -> OrdList Instr
newval_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
new
Reg
oldval <- Format -> NatM Reg
getNewRegNat Format
format
Reg -> OrdList Instr
oldval_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
old
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
dst_r :: Reg
dst_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
code :: OrdList Instr
code = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
oldval) (Reg -> Operand
OpReg Reg
eax)
, Instr -> Instr
LOCK (Format -> Operand -> Operand -> Instr
CMPXCHG Format
format (Reg -> Operand
OpReg Reg
newval) (AddrMode -> Operand
OpAddr AddrMode
amode))
, Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
eax) (Reg -> Operand
OpReg Reg
dst_r)
]
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
addr_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
newval_code Reg
newval OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
oldval_code Reg
oldval
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code
where
format :: Format
format = Width -> Format
intFormat Width
width
genCCall' DynFlags
_ Bool
is32Bit ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args Label
bid = do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
case (ForeignTarget
target, [CmmFormal]
dest_regs) of
(PrimTarget CallishMachOp
op, []) ->
Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
op Maybe CmmFormal
forall a. Maybe a
Nothing [CmmActual]
args
(PrimTarget CallishMachOp
op, [CmmFormal
r]) -> case CallishMachOp
op of
CallishMachOp
MO_F32_Fabs -> case [CmmActual]
args of
[CmmActual
x] -> Width -> CmmActual -> NatM (OrdList Instr)
sse2FabsCode Width
W32 CmmActual
x
[CmmActual]
_ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments for fabs"
CallishMachOp
MO_F64_Fabs -> case [CmmActual]
args of
[CmmActual
x] -> Width -> CmmActual -> NatM (OrdList Instr)
sse2FabsCode Width
W64 CmmActual
x
[CmmActual]
_ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments for fabs"
CallishMachOp
MO_F32_Sqrt -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineSSE2Op (\Format
fmt Reg
r -> Format -> Operand -> Reg -> Instr
SQRT Format
fmt (Reg -> Operand
OpReg Reg
r)) Format
FF32 [CmmActual]
args
CallishMachOp
MO_F64_Sqrt -> (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineSSE2Op (\Format
fmt Reg
r -> Format -> Operand -> Reg -> Instr
SQRT Format
fmt (Reg -> Operand
OpReg Reg
r)) Format
FF64 [CmmActual]
args
CallishMachOp
_other_op -> Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
op (CmmFormal -> Maybe CmmFormal
forall a. a -> Maybe a
Just CmmFormal
r) [CmmActual]
args
where
actuallyInlineSSE2Op :: (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineSSE2Op = (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp'
actuallyInlineFloatOp' :: (Format -> Reg -> Reg -> Instr)
-> Format -> [CmmActual] -> NatM (OrdList Instr)
actuallyInlineFloatOp' Format -> Reg -> Reg -> Instr
instr Format
format [CmmActual
x]
= do Register
res <- Format -> (Reg -> Reg -> Instr) -> CmmActual -> NatM Register
trivialUFCode Format
format (Format -> Reg -> Reg -> Instr
instr Format
format) CmmActual
x
Reg -> OrdList Instr
any <- Register -> NatM (Reg -> OrdList Instr)
anyReg Register
res
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> OrdList Instr
any (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
r)))
actuallyInlineFloatOp' Format -> Reg -> Reg -> Instr
_ Format
_ [CmmActual]
args
= String -> NatM (OrdList Instr)
forall a. String -> a
panic (String -> NatM (OrdList Instr)) -> String -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ String
"genCCall.actuallyInlineFloatOp': bad number of arguments! ("
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmActual] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmActual]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock
sse2FabsCode :: Width -> CmmActual -> NatM (OrdList Instr)
sse2FabsCode Width
w CmmActual
x = do
let fmt :: Format
fmt = Width -> Format
floatFormat Width
w
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
let
const :: CmmLit
const | Format
FF32 <- Format
fmt = Integer -> Width -> CmmLit
CmmInt Integer
0x7fffffff Width
W32
| Bool
otherwise = Integer -> Width -> CmmLit
CmmInt Integer
0x7fffffffffffffff Width
W64
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
AND Format
fmt (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
]
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Reg -> OrdList Instr
code (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
r))
(PrimTarget (MO_S_QuotRem Width
width), [CmmFormal]
_) -> Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp1 Platform
platform Bool
True Width
width [CmmFormal]
dest_regs [CmmActual]
args
(PrimTarget (MO_U_QuotRem Width
width), [CmmFormal]
_) -> Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp1 Platform
platform Bool
False Width
width [CmmFormal]
dest_regs [CmmActual]
args
(PrimTarget (MO_U_QuotRem2 Width
width), [CmmFormal]
_) -> Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp2 Platform
platform Bool
False Width
width [CmmFormal]
dest_regs [CmmActual]
args
(PrimTarget (MO_Add2 Width
width), [CmmFormal
res_h, CmmFormal
res_l]) ->
case [CmmActual]
args of
[CmmActual
arg_x, CmmActual
arg_y] ->
do Reg -> OrdList Instr
hCode <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg (CmmLit -> CmmActual
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)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width (Format -> Operand -> Operand -> Instr
ADD_CC Format
format)
((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just (Format -> Operand -> Operand -> Instr
ADD_CC Format
format)) CmmActual
arg_x CmmActual
arg_y
let reg_l :: Reg
reg_l = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_l)
reg_h :: Reg
reg_h = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_h)
code :: OrdList Instr
code = Reg -> OrdList Instr
hCode Reg
reg_h OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
lCode Reg
reg_l OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
ADC Format
format (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
0)) (Reg -> Operand
OpReg Reg
reg_h)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
[CmmActual]
_ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments/results for add2"
(PrimTarget (MO_AddWordC Width
width), [CmmFormal
res_r, CmmFormal
res_c]) ->
Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
ADD_CC (Maybe (Operand -> Operand -> Instr)
-> Format -> Maybe (Operand -> Operand -> Instr)
forall a b. a -> b -> a
const Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing) Cond
CARRY Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
(PrimTarget (MO_SubWordC Width
width), [CmmFormal
res_r, CmmFormal
res_c]) ->
Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
SUB_CC (Maybe (Operand -> Operand -> Instr)
-> Format -> Maybe (Operand -> Operand -> Instr)
forall a b. a -> b -> a
const Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing) Cond
CARRY Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
(PrimTarget (MO_AddIntC Width
width), [CmmFormal
res_r, CmmFormal
res_c]) ->
Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
ADD_CC ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
forall a. a -> Maybe a
Just ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr))
-> (Format -> Operand -> Operand -> Instr)
-> Format
-> Maybe (Operand -> Operand -> Instr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Operand -> Operand -> Instr
ADD_CC) Cond
OFLO Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
(PrimTarget (MO_SubIntC Width
width), [CmmFormal
res_r, CmmFormal
res_c]) ->
Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
SUB_CC (Maybe (Operand -> Operand -> Instr)
-> Format -> Maybe (Operand -> Operand -> Instr)
forall a b. a -> b -> a
const Maybe (Operand -> Operand -> Instr)
forall a. Maybe a
Nothing) Cond
OFLO Width
width CmmFormal
res_r CmmFormal
res_c [CmmActual]
args
(PrimTarget (MO_U_Mul2 Width
width), [CmmFormal
res_h, CmmFormal
res_l]) ->
case [CmmActual]
args of
[CmmActual
arg_x, CmmActual
arg_y] ->
do (Operand
y_reg, OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
arg_y
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_x
let format :: Format
format = Width -> Format
intFormat Width
width
reg_h :: Reg
reg_h = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_h)
reg_l :: Reg
reg_l = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_l)
code :: OrdList Instr
code = OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
x_code Reg
rax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Instr
MUL2 Format
format Operand
y_reg,
Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
reg_h),
Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rax) (Reg -> Operand
OpReg Reg
reg_l)]
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
[CmmActual]
_ -> String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments/results for mul2"
(ForeignTarget, [CmmFormal])
_ -> if Bool
is32Bit
then DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall32' DynFlags
dflags ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args
else DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall64' DynFlags
dflags ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args
where divOp1 :: Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp1 Platform
platform Bool
signed Width
width [CmmFormal]
results [CmmActual
arg_x, CmmActual
arg_y]
= Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp Platform
platform Bool
signed Width
width [CmmFormal]
results Maybe CmmActual
forall a. Maybe a
Nothing CmmActual
arg_x CmmActual
arg_y
divOp1 Platform
_ Bool
_ Width
_ [CmmFormal]
_ [CmmActual]
_
= String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments for divOp1"
divOp2 :: Platform
-> Bool
-> Width
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
divOp2 Platform
platform Bool
signed Width
width [CmmFormal]
results [CmmActual
arg_x_high, CmmActual
arg_x_low, CmmActual
arg_y]
= Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp Platform
platform Bool
signed Width
width [CmmFormal]
results (CmmActual -> Maybe CmmActual
forall a. a -> Maybe a
Just CmmActual
arg_x_high) CmmActual
arg_x_low CmmActual
arg_y
divOp2 Platform
_ Bool
_ Width
_ [CmmFormal]
_ [CmmActual]
_
= String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments for divOp2"
divOp :: Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp Platform
platform Bool
signed Width
W8 [CmmFormal
res_q, CmmFormal
res_r] Maybe CmmActual
m_arg_x_high CmmActual
arg_x_low CmmActual
arg_y =
let widen :: MachOp
widen | Bool
signed = Width -> Width -> MachOp
MO_SS_Conv Width
W8 Width
W16
| Bool
otherwise = Width -> Width -> MachOp
MO_UU_Conv Width
W8 Width
W16
arg_x_low_16 :: CmmActual
arg_x_low_16 = MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
arg_x_low]
arg_y_16 :: CmmActual
arg_y_16 = MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
arg_y]
m_arg_x_high_16 :: Maybe CmmActual
m_arg_x_high_16 = (\CmmActual
p -> MachOp -> [CmmActual] -> CmmActual
CmmMachOp MachOp
widen [CmmActual
p]) (CmmActual -> CmmActual) -> Maybe CmmActual -> Maybe CmmActual
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CmmActual
m_arg_x_high
in Platform
-> Bool
-> Width
-> [CmmFormal]
-> Maybe CmmActual
-> CmmActual
-> CmmActual
-> NatM (OrdList Instr)
divOp
Platform
platform Bool
signed Width
W16 [CmmFormal
res_q, CmmFormal
res_r]
Maybe CmmActual
m_arg_x_high_16 CmmActual
arg_x_low_16 CmmActual
arg_y_16
divOp Platform
platform Bool
signed Width
width [CmmFormal
res_q, CmmFormal
res_r]
Maybe CmmActual
m_arg_x_high CmmActual
arg_x_low CmmActual
arg_y
= do let format :: Format
format = Width -> Format
intFormat Width
width
reg_q :: Reg
reg_q = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_q)
reg_r :: Reg
reg_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_r)
widen :: Instr
widen | Bool
signed = Format -> Instr
CLTD Format
format
| Bool
otherwise = Format -> Operand -> Operand -> Instr
XOR Format
format (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
rdx)
instr :: Format -> Operand -> Instr
instr | Bool
signed = Format -> Operand -> Instr
IDIV
| Bool
otherwise = Format -> Operand -> Instr
DIV
(Operand
y_reg, OrdList Instr
y_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getRegOrMem CmmActual
arg_y
Reg -> OrdList Instr
x_low_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_x_low
Reg -> OrdList Instr
x_high_code <- case Maybe CmmActual
m_arg_x_high of
Just CmmActual
arg_x_high ->
CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg_x_high
Maybe CmmActual
Nothing ->
(Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr))
-> (Reg -> OrdList Instr) -> NatM (Reg -> OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Reg -> OrdList Instr
forall a b. a -> b -> a
const (OrdList Instr -> Reg -> OrdList Instr)
-> OrdList Instr -> Reg -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
widen
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
x_low_code Reg
rax OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
x_high_code Reg
rdx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Instr
instr Format
format Operand
y_reg,
Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rax) (Reg -> Operand
OpReg Reg
reg_q),
Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
rdx) (Reg -> Operand
OpReg Reg
reg_r)]
divOp Platform
_ Bool
_ Width
_ [CmmFormal]
_ Maybe CmmActual
_ CmmActual
_ CmmActual
_
= String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of results for divOp"
addSubIntC :: Platform
-> (Format -> Operand -> Operand -> Instr)
-> (Format -> Maybe (Operand -> Operand -> Instr))
-> Cond
-> Width
-> CmmFormal
-> CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
addSubIntC Platform
platform Format -> Operand -> Operand -> Instr
instr Format -> Maybe (Operand -> Operand -> Instr)
mrevinstr Cond
cond Width
width
CmmFormal
res_r CmmFormal
res_c [CmmActual
arg_x, CmmActual
arg_y]
= do let format :: Format
format = Width -> Format
intFormat Width
width
Reg -> OrdList Instr
rCode <- Register -> NatM (Reg -> OrdList Instr)
anyReg (Register -> NatM (Reg -> OrdList Instr))
-> NatM Register -> NatM (Reg -> OrdList Instr)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width (Format -> Operand -> Operand -> Instr
instr Format
format)
(Format -> Maybe (Operand -> Operand -> Instr)
mrevinstr Format
format) CmmActual
arg_x CmmActual
arg_y
Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
II8
let reg_c :: Reg
reg_c = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_c)
reg_r :: Reg
reg_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_r)
code :: OrdList Instr
code = Reg -> OrdList Instr
rCode Reg
reg_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
reg_tmp) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
reg_tmp) (Reg -> Operand
OpReg Reg
reg_c)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
addSubIntC Platform
_ Format -> Operand -> Operand -> Instr
_ Format -> Maybe (Operand -> Operand -> Instr)
_ Cond
_ Width
_ CmmFormal
_ CmmFormal
_ [CmmActual]
_
= String -> NatM (OrdList Instr)
forall a. String -> a
panic String
"genCCall: Wrong number of arguments/results for addSubIntC"
genCCall32' :: DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall32' :: DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall32' DynFlags
dflags ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args = do
let
prom_args :: [CmmActual]
prom_args = (CmmActual -> CmmActual) -> [CmmActual] -> [CmmActual]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Width -> CmmActual -> CmmActual
maybePromoteCArg DynFlags
dflags Width
W32) [CmmActual]
args
sizes :: [Int]
sizes = (CmmActual -> Int) -> [CmmActual] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (CmmType -> Int
arg_size_bytes (CmmType -> Int) -> (CmmActual -> CmmType) -> CmmActual -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags) ([CmmActual] -> [CmmActual]
forall a. [a] -> [a]
reverse [CmmActual]
args)
raw_arg_size :: Int
raw_arg_size = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
sizes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
wORD_SIZE DynFlags
dflags
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
- DynFlags -> Int
wORD_SIZE DynFlags
dflags
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 <- (CmmActual -> NatM (OrdList Instr))
-> [CmmActual] -> NatM [OrdList Instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmActual -> NatM (OrdList Instr)
push_arg ([CmmActual] -> [CmmActual]
forall a. [a] -> [a]
reverse [CmmActual]
prom_args)
Int
delta <- NatM Int
getDeltaNat
MASSERT(delta == delta0 - tot_arg_size)
(OrdList Instr
callinsns,ForeignConvention
cconv) <-
case ForeignTarget
target of
ForeignTarget (CmmLit (CmmLabel CLabel
lbl)) ForeignConvention
conv
->
(OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Either Imm Reg -> [Reg] -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left Imm
fn_imm) []), ForeignConvention
conv)
where fn_imm :: Imm
fn_imm = CLabel -> Imm
ImmCLbl CLabel
lbl
ForeignTarget CmmActual
expr ForeignConvention
conv
-> do { (Reg
dyn_r, OrdList Instr
dyn_c) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
; ASSERT( isWord32 (cmmExprType dflags expr) )
(OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
dyn_c OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Either Imm Reg -> [Reg] -> Instr
CALL (Reg -> Either Imm Reg
forall a b. b -> Either a b
Right Reg
dyn_r) [], ForeignConvention
conv) }
PrimTarget CallishMachOp
_
-> String -> NatM (OrdList Instr, ForeignConvention)
forall a. String -> a
panic (String -> NatM (OrdList Instr, ForeignConvention))
-> String -> NatM (OrdList Instr, ForeignConvention)
forall a b. (a -> b) -> a -> b
$ String
"genCCall: Can't handle PrimTarget call type here, error "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"probably because too many return values."
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
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
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let
assign_code :: [CmmFormal] -> OrdList Instr
assign_code [] = OrdList Instr
forall a. OrdList a
nilOL
assign_code [CmmFormal
dest]
| CmmType -> Bool
isFloatType CmmType
ty =
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,
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 = CmmFormal -> CmmType
localRegType CmmFormal
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 = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
assign_code [CmmFormal]
many = String -> SDoc -> OrdList Instr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCCall.assign_code - too many return values:" ([CmmFormal] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmFormal]
many)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
push_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
call OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[CmmFormal] -> OrdList Instr
assign_code [CmmFormal]
dest_regs)
where
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 (DynFlags -> Width
wordWidth DynFlags
dflags))
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
-> NatM InstrBlock
push_arg :: CmmActual -> NatM (OrdList Instr)
push_arg CmmActual
arg
| CmmType -> Bool
isWord64 CmmType
arg_ty = do
ChildCode64 OrdList Instr
code Reg
r_lo <- CmmActual -> NatM ChildCode64
iselExpr64 CmmActual
arg
Int
delta <- NatM Int
getDeltaNat
Int -> NatM ()
setDeltaNat (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)
let r_hi :: Reg
r_hi = Reg -> Reg
getHiVRegFromLo Reg
r_lo
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Operand -> Instr
PUSH Format
II32 (Reg -> Operand
OpReg Reg
r_hi), 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) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
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 (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
Format -> Operand -> Operand -> Instr
MOV Format
format (Reg -> Operand
OpReg Reg
reg) (AddrMode -> Operand
OpAddr AddrMode
addr)
]
)
| Bool
otherwise = do
ASSERT((typeWidth arg_ty) <= W32) return ()
(Operand
operand, OrdList Instr
code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
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 (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 = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
size :: Int
size = CmmType -> Int
arg_size_bytes CmmType
arg_ty
genCCall64' :: DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall64' :: DynFlags
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM (OrdList Instr)
genCCall64' DynFlags
dflags ForeignTarget
target [CmmFormal]
dest_regs [CmmActual]
args = do
let prom_args :: [CmmActual]
prom_args = (CmmActual -> CmmActual) -> [CmmActual] -> [CmmActual]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags -> Width -> CmmActual -> CmmActual
maybePromoteCArg DynFlags
dflags Width
W32) [CmmActual]
args
([CmmActual]
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 [CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
prom_args [] [] (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform) OrdList Instr
forall a. OrdList a
nilOL
else do
([CmmActual]
stack_args, [Reg]
aregs, [Reg]
fregs, OrdList Instr
load_args_code, OrdList Instr
assign_args_code)
<- [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
prom_args (Platform -> [Reg]
allIntArgRegs Platform
platform)
(Platform -> [Reg]
allFPArgRegs Platform
platform)
OrdList Instr
forall a. OrdList a
nilOL OrdList Instr
forall a. OrdList a
nilOL
let used_regs :: t a -> [a] -> [a]
used_regs t a
rs [a]
as = [a] -> [a]
forall a. [a] -> [a]
reverse (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
rs) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
as))
fregs_used :: [Reg]
fregs_used = [Reg] -> [Reg] -> [Reg]
forall (t :: * -> *) a a. Foldable t => t a -> [a] -> [a]
used_regs [Reg]
fregs (Platform -> [Reg]
allFPArgRegs Platform
platform)
aregs_used :: [Reg]
aregs_used = [Reg] -> [Reg] -> [Reg]
forall (t :: * -> *) a a. Foldable t => t a -> [a] -> [a]
used_regs [Reg]
aregs (Platform -> [Reg]
allIntArgRegs Platform
platform)
([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmActual]
stack_args, [Reg]
aregs_used, [Reg]
fregs_used, OrdList Instr
load_args_code
, OrdList Instr
assign_args_code)
let
arg_regs_used :: [Reg]
arg_regs_used = [Reg]
int_regs_used [Reg] -> [Reg] -> [Reg]
forall a. [a] -> [a] -> [a]
++ [Reg]
fp_regs_used
arg_regs :: [Reg]
arg_regs = [Reg
eax] [Reg] -> [Reg] -> [Reg]
forall a. [a] -> [a] -> [a]
++ [Reg]
arg_regs_used
sse_regs :: Int
sse_regs = [Reg] -> 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 [CmmActual] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmActual]
stack_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(Reg, Reg)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform)
else [CmmActual] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmActual]
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
(Int
real_size, OrdList Instr
adjust_rsp) <-
if (Int
tot_arg_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
wORD_SIZE DynFlags
dflags) 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 (m :: * -> *) a. Monad m => a -> m a
return (Int
tot_arg_size, OrdList Instr
forall a. OrdList a
nilOL)
else do
Int
delta <- NatM Int
getDeltaNat
Int -> NatM ()
setDeltaNat (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
wORD_SIZE DynFlags
dflags)
(Int, OrdList Instr) -> NatM (Int, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
tot_arg_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
wORD_SIZE DynFlags
dflags, [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Operand -> Operand -> Instr
SUB Format
II64 (Imm -> Operand
OpImm (Int -> Imm
ImmInt (DynFlags -> Int
wORD_SIZE DynFlags
dflags))) (Reg -> Operand
OpReg Reg
rsp),
Int -> Instr
DELTA (Int
delta Int -> Int -> Int
forall a. Num a => a -> a -> a
- DynFlags -> Int
wORD_SIZE DynFlags
dflags) ])
OrdList Instr
push_code <- [CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args ([CmmActual] -> [CmmActual]
forall a. [a] -> [a]
reverse [CmmActual]
stack_args) OrdList Instr
forall a. OrdList a
nilOL
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 (t :: * -> *) a. Foldable t => t a -> Int
length (Platform -> [(Reg, Reg)]
allArgRegs Platform
platform))
else OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
Int
delta <- NatM Int
getDeltaNat
(OrdList Instr
callinsns,ForeignConvention
_cconv) <-
case ForeignTarget
target of
ForeignTarget (CmmLit (CmmLabel CLabel
lbl)) ForeignConvention
conv
->
(OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Either Imm Reg -> [Reg] -> Instr
CALL (Imm -> Either Imm Reg
forall a b. a -> Either a b
Left Imm
fn_imm) [Reg]
arg_regs), ForeignConvention
conv)
where fn_imm :: Imm
fn_imm = CLabel -> Imm
ImmCLbl CLabel
lbl
ForeignTarget CmmActual
expr ForeignConvention
conv
-> do (Reg
dyn_r, OrdList Instr
dyn_c) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
expr
(OrdList Instr, ForeignConvention)
-> NatM (OrdList Instr, ForeignConvention)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
dyn_c OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Either Imm Reg -> [Reg] -> Instr
CALL (Reg -> Either Imm Reg
forall a b. b -> Either a b
Right Reg
dyn_r) [Reg]
arg_regs, ForeignConvention
conv)
PrimTarget CallishMachOp
_
-> String -> NatM (OrdList Instr, ForeignConvention)
forall a. String -> a
panic (String -> NatM (OrdList Instr, ForeignConvention))
-> String -> NatM (OrdList Instr, ForeignConvention)
forall a b. (a -> b) -> a -> b
$ String
"genCCall: Can't handle PrimTarget call type here, error "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"probably because too many return values."
let
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 (
(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 (DynFlags -> Width
wordWidth DynFlags
dflags)) (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_code :: [CmmFormal] -> OrdList Instr
assign_code [] = OrdList Instr
forall a. OrdList a
nilOL
assign_code [CmmFormal
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 = CmmFormal -> CmmType
localRegType CmmFormal
dest
r_dest :: Reg
r_dest = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
assign_code [CmmFormal]
_many = String -> OrdList Instr
forall a. String -> a
panic String
"genCCall.assign_code many"
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
adjust_rsp OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
push_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
load_args_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
assign_args_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
lss_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
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`
[CmmFormal] -> OrdList Instr
assign_code [CmmFormal]
dest_regs)
where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
arg_size :: Int
arg_size = Int
8
load_args :: [CmmExpr]
-> [Reg]
-> [Reg]
-> InstrBlock
-> InstrBlock
-> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
load_args :: [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
args [] [] OrdList Instr
code OrdList Instr
acode =
([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmActual]
args, [], [], OrdList Instr
code, OrdList Instr
acode)
load_args [] [Reg]
aregs [Reg]
fregs OrdList Instr
code OrdList Instr
acode =
([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Reg]
aregs, [Reg]
fregs, OrdList Instr
code, OrdList Instr
acode)
load_args (CmmActual
arg : [CmmActual]
rest) [Reg]
aregs [Reg]
fregs OrdList Instr
code OrdList Instr
acode
| CmmType -> Bool
isFloatType CmmType
arg_rep = case [Reg]
fregs of
[] -> NatM ([CmmActual], [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
[CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
rest [Reg]
aregs [Reg]
rs OrdList Instr
code' OrdList Instr
acode'
| Bool
otherwise = case [Reg]
aregs of
[] -> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg
(Reg
r:[Reg]
rs) -> do
(OrdList Instr
code',OrdList Instr
acode') <- Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg Reg
r
[CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
rest [Reg]
rs [Reg]
fregs OrdList Instr
code' OrdList Instr
acode'
where
push_this_arg :: NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
push_this_arg = do
([CmmActual]
args',[Reg]
ars,[Reg]
frs,OrdList Instr
code',OrdList Instr
acode')
<- [CmmActual]
-> [Reg]
-> [Reg]
-> OrdList Instr
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args [CmmActual]
rest [Reg]
aregs [Reg]
fregs OrdList Instr
code OrdList Instr
acode
([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmActual
argCmmActual -> [CmmActual] -> [CmmActual]
forall a. a -> [a] -> [a]
:[CmmActual]
args', [Reg]
ars, [Reg]
frs, OrdList Instr
code', OrdList Instr
acode')
reg_this_arg :: Reg -> NatM (OrdList Instr, OrdList Instr)
reg_this_arg Reg
r
| Bool -> CmmActual -> Bool
isOperand Bool
False CmmActual
arg = do
Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
(OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, (OrdList Instr
acode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
r))
| (CmmActual -> Bool) -> [CmmActual] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> CmmActual -> Bool
isOperand Bool
False) [CmmActual]
rest = do
Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
(OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
r,OrdList Instr
acode)
| Bool
otherwise = do
Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
arg_fmt
let
code' :: OrdList Instr
code' = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
tmp
acode' :: OrdList Instr
acode' = OrdList Instr
acode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Instr
reg2reg Format
arg_fmt Reg
tmp Reg
r
(OrdList Instr, OrdList Instr)
-> NatM (OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code',OrdList Instr
acode')
arg_rep :: CmmType
arg_rep = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
arg_fmt :: Format
arg_fmt = CmmType -> Format
cmmTypeFormat CmmType
arg_rep
load_args_win :: [CmmExpr]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> InstrBlock
-> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
load_args_win :: [CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
args [Reg]
usedInt [Reg]
usedFP [] OrdList Instr
code
= ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmActual]
args, [Reg]
usedInt, [Reg]
usedFP, OrdList Instr
code, OrdList Instr
forall a. OrdList a
nilOL)
load_args_win [] [Reg]
usedInt [Reg]
usedFP [(Reg, Reg)]
_ OrdList Instr
code
= ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Reg]
usedInt, [Reg]
usedFP, OrdList Instr
code, OrdList Instr
forall a. OrdList a
nilOL)
load_args_win (CmmActual
arg : [CmmActual]
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 <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
[CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
rest (Reg
ireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
usedInt) (Reg
freg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
usedFP) [(Reg, Reg)]
regs
(OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
Reg -> OrdList Instr
arg_code Reg
freg OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Operand -> Operand -> Instr
MOV Format
II64 (Reg -> Operand
OpReg Reg
freg) (Reg -> Operand
OpReg Reg
ireg))
| Bool
otherwise = do
Reg -> OrdList Instr
arg_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
arg
[CmmActual]
-> [Reg]
-> [Reg]
-> [(Reg, Reg)]
-> OrdList Instr
-> NatM ([CmmActual], [Reg], [Reg], OrdList Instr, OrdList Instr)
load_args_win [CmmActual]
rest (Reg
ireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
usedInt) [Reg]
usedFP [(Reg, Reg)]
regs
(OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
arg_code Reg
ireg)
where
arg_rep :: CmmType
arg_rep = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
push_args :: [CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args [] OrdList Instr
code = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
push_args (CmmActual
arg:[CmmActual]
rest) OrdList Instr
code
| CmmType -> Bool
isFloatType CmmType
arg_rep = do
(Reg
arg_reg, OrdList Instr
arg_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
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 (DynFlags -> Width
wordWidth DynFlags
dflags)) (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 (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags Int
0))]
[CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args [CmmActual]
rest OrdList Instr
code'
| Bool
otherwise = do
ASSERT(width <= W64) return ()
(Operand
arg_op, OrdList Instr
arg_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
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)]
[CmmActual] -> OrdList Instr -> NatM (OrdList Instr)
push_args [CmmActual]
rest OrdList Instr
code'
where
arg_rep :: CmmType
arg_rep = DynFlags -> CmmActual -> CmmType
cmmExprType DynFlags
dflags CmmActual
arg
width :: Width
width = CmmType -> Width
typeWidth CmmType
arg_rep
leaveStackSpace :: 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 (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
* DynFlags -> Int
wORD_SIZE DynFlags
dflags))) (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)]
maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr
maybePromoteCArg :: DynFlags -> Width -> CmmActual -> CmmActual
maybePromoteCArg DynFlags
dflags Width
wto CmmActual
arg
| Width
wfrom Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
wto = MachOp -> [CmmActual] -> CmmActual
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv Width
wfrom Width
wto) [CmmActual
arg]
| Bool
otherwise = CmmActual
arg
where
wfrom :: Width
wfrom = DynFlags -> CmmActual -> Width
cmmExprWidth DynFlags
dflags CmmActual
arg
outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]
-> NatM InstrBlock
outOfLineCmmOp :: Label
-> CallishMachOp
-> Maybe CmmFormal
-> [CmmActual]
-> NatM (OrdList Instr)
outOfLineCmmOp Label
bid CallishMachOp
mop Maybe CmmFormal
res [CmmActual]
args
= do
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmActual
targetExpr <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
CallReference CLabel
lbl
let target :: ForeignTarget
target = CmmActual -> ForeignConvention -> ForeignTarget
ForeignTarget CmmActual
targetExpr
(CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [] [] CmmReturnInfo
CmmMayReturn)
(OrdList Instr
instrs, Maybe Label
_) <- 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 (ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmNode O O
CmmUnsafeForeignCall ForeignTarget
target ([Maybe CmmFormal] -> [CmmFormal]
forall a. [Maybe a] -> [a]
catMaybes [Maybe CmmFormal
res]) [CmmActual]
args)
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
instrs
where
lbl :: CLabel
lbl = FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
fn Maybe Int
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
fn :: FastString
fn = case CallishMachOp
mop of
CallishMachOp
MO_F32_Sqrt -> String -> FastString
fsLit String
"sqrtf"
CallishMachOp
MO_F32_Fabs -> String -> FastString
fsLit String
"fabsf"
CallishMachOp
MO_F32_Sin -> String -> FastString
fsLit String
"sinf"
CallishMachOp
MO_F32_Cos -> String -> FastString
fsLit String
"cosf"
CallishMachOp
MO_F32_Tan -> String -> FastString
fsLit String
"tanf"
CallishMachOp
MO_F32_Exp -> String -> FastString
fsLit String
"expf"
CallishMachOp
MO_F32_ExpM1 -> String -> FastString
fsLit String
"expm1f"
CallishMachOp
MO_F32_Log -> String -> FastString
fsLit String
"logf"
CallishMachOp
MO_F32_Log1P -> String -> FastString
fsLit String
"log1pf"
CallishMachOp
MO_F32_Asin -> String -> FastString
fsLit String
"asinf"
CallishMachOp
MO_F32_Acos -> String -> FastString
fsLit String
"acosf"
CallishMachOp
MO_F32_Atan -> String -> FastString
fsLit String
"atanf"
CallishMachOp
MO_F32_Sinh -> String -> FastString
fsLit String
"sinhf"
CallishMachOp
MO_F32_Cosh -> String -> FastString
fsLit String
"coshf"
CallishMachOp
MO_F32_Tanh -> String -> FastString
fsLit String
"tanhf"
CallishMachOp
MO_F32_Pwr -> String -> FastString
fsLit String
"powf"
CallishMachOp
MO_F32_Asinh -> String -> FastString
fsLit String
"asinhf"
CallishMachOp
MO_F32_Acosh -> String -> FastString
fsLit String
"acoshf"
CallishMachOp
MO_F32_Atanh -> String -> FastString
fsLit String
"atanhf"
CallishMachOp
MO_F64_Sqrt -> String -> FastString
fsLit String
"sqrt"
CallishMachOp
MO_F64_Fabs -> String -> FastString
fsLit String
"fabs"
CallishMachOp
MO_F64_Sin -> String -> FastString
fsLit String
"sin"
CallishMachOp
MO_F64_Cos -> String -> FastString
fsLit String
"cos"
CallishMachOp
MO_F64_Tan -> String -> FastString
fsLit String
"tan"
CallishMachOp
MO_F64_Exp -> String -> FastString
fsLit String
"exp"
CallishMachOp
MO_F64_ExpM1 -> String -> FastString
fsLit String
"expm1"
CallishMachOp
MO_F64_Log -> String -> FastString
fsLit String
"log"
CallishMachOp
MO_F64_Log1P -> String -> FastString
fsLit String
"log1p"
CallishMachOp
MO_F64_Asin -> String -> FastString
fsLit String
"asin"
CallishMachOp
MO_F64_Acos -> String -> FastString
fsLit String
"acos"
CallishMachOp
MO_F64_Atan -> String -> FastString
fsLit String
"atan"
CallishMachOp
MO_F64_Sinh -> String -> FastString
fsLit String
"sinh"
CallishMachOp
MO_F64_Cosh -> String -> FastString
fsLit String
"cosh"
CallishMachOp
MO_F64_Tanh -> String -> FastString
fsLit String
"tanh"
CallishMachOp
MO_F64_Pwr -> String -> FastString
fsLit String
"pow"
CallishMachOp
MO_F64_Asinh -> String -> FastString
fsLit String
"asinh"
CallishMachOp
MO_F64_Acosh -> String -> FastString
fsLit String
"acosh"
CallishMachOp
MO_F64_Atanh -> String -> FastString
fsLit String
"atanh"
MO_Memcpy Int
_ -> String -> FastString
fsLit String
"memcpy"
MO_Memset Int
_ -> String -> FastString
fsLit String
"memset"
MO_Memmove Int
_ -> String -> FastString
fsLit String
"memmove"
MO_Memcmp Int
_ -> String -> FastString
fsLit String
"memcmp"
MO_PopCnt Width
_ -> String -> FastString
fsLit String
"popcnt"
MO_BSwap Width
_ -> String -> FastString
fsLit String
"bswap"
MO_BRev Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
bRevLabel Width
w
MO_Clz Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
clzLabel Width
w
MO_Ctz Width
_ -> FastString
unsupported
MO_Pdep Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pdepLabel Width
w
MO_Pext Width
w -> String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pextLabel Width
w
MO_AtomicRMW Width
_ AtomicMachOp
_ -> String -> FastString
fsLit String
"atomicrmw"
MO_AtomicRead Width
_ -> String -> FastString
fsLit String
"atomicread"
MO_AtomicWrite Width
_ -> String -> FastString
fsLit String
"atomicwrite"
MO_Cmpxchg Width
_ -> String -> FastString
fsLit String
"cmpxchg"
MO_UF_Conv Width
_ -> FastString
unsupported
MO_S_QuotRem {} -> FastString
unsupported
MO_U_QuotRem {} -> FastString
unsupported
MO_U_QuotRem2 {} -> FastString
unsupported
MO_Add2 {} -> FastString
unsupported
MO_AddIntC {} -> FastString
unsupported
MO_SubIntC {} -> FastString
unsupported
MO_AddWordC {} -> FastString
unsupported
MO_SubWordC {} -> FastString
unsupported
MO_U_Mul2 {} -> FastString
unsupported
CallishMachOp
MO_ReadBarrier -> FastString
unsupported
CallishMachOp
MO_WriteBarrier -> FastString
unsupported
CallishMachOp
MO_Touch -> FastString
unsupported
(MO_Prefetch_Data Int
_ ) -> FastString
unsupported
unsupported :: FastString
unsupported = String -> FastString
forall a. String -> a
panic (String
"outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported here")
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: DynFlags -> CmmActual -> SwitchTargets -> NatM (OrdList Instr)
genSwitch DynFlags
dflags CmmActual
expr SwitchTargets
targets
| DynFlags -> Bool
positionIndependent DynFlags
dflags
= do
(Reg
reg,OrdList Instr
e_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getNonClobberedReg (DynFlags -> CmmActual -> Int -> CmmActual
cmmOffset DynFlags
dflags CmmActual
expr Int
offset)
CLabel
lbl <- NatM CLabel
getNewLabelNat
DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let is32bit :: Bool
is32bit = Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
os :: OS
os = Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
rosection :: Section
rosection = case OS
os of
OS
OSDarwin | Bool -> Bool
not Bool
is32bit -> SectionType -> CLabel -> Section
Section SectionType
Text CLabel
lbl
OS
_ -> SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl
CmmActual
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmActual
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmActual
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
(Reg
tableReg,OrdList Instr
t_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg (CmmActual -> NatM (Reg, OrdList Instr))
-> CmmActual -> NatM (Reg, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmActual
dynRef
let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex (Reg -> EABase
EABaseReg Reg
tableReg)
(Reg -> Int -> EAIndex
EAIndex Reg
reg (DynFlags -> Int
wORD_SIZE DynFlags
dflags)) (Int -> Imm
ImmInt Int
0))
Reg
offsetReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags))
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ if Bool
is32bit Bool -> Bool -> Bool
|| OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin
then OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Operand -> Operand -> Instr
ADD (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags)) Operand
op (Reg -> Operand
OpReg Reg
tableReg),
Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL (Reg -> Operand
OpReg Reg
tableReg) [Maybe JumpDest]
ids Section
rosection CLabel
lbl
]
else
OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Operand -> Operand -> Instr
MOVSxL Format
II32 Operand
op (Reg -> Operand
OpReg Reg
offsetReg),
Format -> Operand -> Operand -> Instr
ADD (Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags))
(Reg -> Operand
OpReg Reg
offsetReg)
(Reg -> Operand
OpReg Reg
tableReg),
Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL (Reg -> Operand
OpReg Reg
tableReg) [Maybe JumpDest]
ids Section
rosection CLabel
lbl
]
| Bool
otherwise
= do
(Reg
reg,OrdList Instr
e_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg (DynFlags -> CmmActual -> Int -> CmmActual
cmmOffset DynFlags
dflags CmmActual
expr Int
offset)
CLabel
lbl <- NatM CLabel
getNewLabelNat
let op :: Operand
op = AddrMode -> Operand
OpAddr (EABase -> EAIndex -> Imm -> AddrMode
AddrBaseIndex EABase
EABaseNone (Reg -> Int -> EAIndex
EAIndex Reg
reg (DynFlags -> Int
wORD_SIZE DynFlags
dflags)) (CLabel -> Imm
ImmCLbl CLabel
lbl))
code :: OrdList Instr
code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Operand -> [Maybe JumpDest] -> Section -> CLabel -> Instr
JMP_TBL Operand
op [Maybe JumpDest]
ids (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) CLabel
lbl
]
OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
code
where
(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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Label -> JumpDest
DestBlockId) [Maybe Label]
blockIds
generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
generateJumpTableForInstr :: DynFlags
-> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
generateJumpTableForInstr DynFlags
dflags (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. 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JumpDest -> Label
getBlockId) [Maybe JumpDest]
ids
in NatCmmDecl (Alignment, CmmStatics) Instr
-> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
forall a. a -> Maybe a
Just (DynFlags
-> [Maybe Label]
-> Section
-> CLabel
-> NatCmmDecl (Alignment, CmmStatics) Instr
forall h g.
DynFlags
-> [Maybe Label]
-> Section
-> CLabel
-> GenCmmDecl (Alignment, CmmStatics) h g
createJumpTable DynFlags
dflags [Maybe Label]
blockIds Section
section CLabel
lbl)
generateJumpTableForInstr DynFlags
_ Instr
_ = Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
forall a. Maybe a
Nothing
createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel
-> GenCmmDecl (Alignment, CmmStatics) h g
createJumpTable :: DynFlags
-> [Maybe Label]
-> Section
-> CLabel
-> GenCmmDecl (Alignment, CmmStatics) h g
createJumpTable DynFlags
dflags [Maybe Label]
ids Section
section CLabel
lbl
= let jumpTable :: [CmmStatic]
jumpTable
| DynFlags -> Bool
positionIndependent DynFlags
dflags =
let ww :: Width
ww = DynFlags -> Width
wordWidth DynFlags
dflags
jumpTableEntryRel :: Maybe Label -> CmmStatic
jumpTableEntryRel 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 (DynFlags -> Maybe Label -> CmmStatic
jumpTableEntry DynFlags
dflags) [Maybe Label]
ids
in Section
-> (Alignment, CmmStatics)
-> GenCmmDecl (Alignment, CmmStatics) h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
section (Int -> Alignment
mkAlignment Int
1, CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmStatic]
jumpTable)
extractUnwindPoints :: [Instr] -> [UnwindPoint]
[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 :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg :: Cond -> CmmActual -> CmmActual -> NatM Register
condIntReg Cond
cond CmmActual
x CmmActual
y = do
CondCode Bool
_ Cond
cond OrdList Instr
cond_code <- Cond -> CmmActual -> CmmActual -> NatM CondCode
condIntCode Cond
cond CmmActual
x CmmActual
y
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II8
let
code :: Reg -> OrdList Instr
code Reg
dst = OrdList Instr
cond_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Cond -> Operand -> Instr
SETCC Cond
cond (Reg -> Operand
OpReg Reg
tmp),
Format -> Operand -> Operand -> Instr
MOVZxL Format
II8 (Reg -> Operand
OpReg Reg
tmp) (Reg -> Operand
OpReg Reg
dst)
]
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg :: Bool -> Cond -> CmmActual -> CmmActual -> NatM Register
condFltReg Bool
is32Bit Cond
cond CmmActual
x CmmActual
y = NatM Register
condFltReg_sse2
where
condFltReg_sse2 :: NatM Register
condFltReg_sse2 = do
CondCode Bool
_ Cond
cond OrdList Instr
cond_code <- Cond -> CmmActual -> CmmActual -> NatM CondCode
condFltCode Cond
cond CmmActual
x CmmActual
y
Reg
tmp1 <- Format -> NatM Reg
getNewRegNat (Bool -> Format
archWordFormat Bool
is32Bit)
Reg
tmp2 <- Format -> NatM Reg
getNewRegNat (Bool -> Format
archWordFormat Bool
is32Bit)
let
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
Cond
LTT -> ASSERT2(False, ppr "Should have been turned into >")
Reg -> OrdList Instr
and_ordered Reg
dst
Cond
LE -> ASSERT2(False, ppr "Should have been turned into >=")
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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
trivialCode :: Width -> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCode :: Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
m CmmActual
a CmmActual
b
= do Bool
is32Bit <- NatM Bool
is32BitPlatform
Bool
-> Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode' Bool
is32Bit Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
m CmmActual
a CmmActual
b
trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCode' :: Bool
-> Width
-> (Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
trivialCode' Bool
is32Bit Width
width Operand -> Operand -> Instr
_ (Just Operand -> Operand -> Instr
revinstr) (CmmLit CmmLit
lit_a) CmmActual
b
| Bool -> CmmLit -> Bool
is32BitLit Bool
is32Bit CmmLit
lit_a = do
Reg -> OrdList Instr
b_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
b
let
code :: Reg -> OrdList Instr
code Reg
dst
= Reg -> OrdList Instr
b_code Reg
dst OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Operand -> Operand -> Instr
revinstr (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit_a)) (Reg -> Operand
OpReg Reg
dst)
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
width) Reg -> OrdList Instr
code)
trivialCode' Bool
_ Width
width Operand -> Operand -> Instr
instr Maybe (Operand -> Operand -> Instr)
_ CmmActual
a CmmActual
b
= Format
-> (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
genTrivialCode (Width -> Format
intFormat Width
width) Operand -> Operand -> Instr
instr CmmActual
a CmmActual
b
genTrivialCode :: Format -> (Operand -> Operand -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
genTrivialCode :: Format
-> (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
genTrivialCode Format
rep Operand -> Operand -> Instr
instr CmmActual
a CmmActual
b = do
(Operand
b_op, OrdList Instr
b_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getNonClobberedOperand CmmActual
b
Reg -> OrdList Instr
a_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
a
Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
let
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 (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
trivialUCode :: Format -> (Operand -> Instr)
-> CmmExpr -> NatM Register
trivialUCode :: Format -> (Operand -> Instr) -> CmmActual -> NatM Register
trivialUCode Format
rep Operand -> Instr
instr CmmActual
x = do
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
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 (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)
-> CmmActual
-> CmmActual
-> NatM Register
trivialFCode_sse2 Width
pk Format -> Operand -> Operand -> Instr
instr CmmActual
x CmmActual
y
= Format
-> (Operand -> Operand -> Instr)
-> CmmActual
-> CmmActual
-> NatM Register
genTrivialCode Format
format (Format -> Operand -> Operand -> Instr
instr Format
format) CmmActual
x CmmActual
y
where format :: Format
format = Width -> Format
floatFormat Width
pk
trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmActual -> NatM Register
trivialUFCode Format
format Reg -> Reg -> Instr
instr CmmActual
x = do
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
x
let
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
instr Reg
x_reg Reg
dst
Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
code)
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP :: Width -> Width -> CmmActual -> NatM Register
coerceInt2FP Width
from Width
to CmmActual
x = NatM Register
coerce_sse2
where
coerce_sse2 :: NatM Register
coerce_sse2 = do
(Operand
x_op, OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
x
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. 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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) Reg -> OrdList Instr
code)
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int :: Width -> Width -> CmmActual -> NatM Register
coerceFP2Int Width
from Width
to CmmActual
x = NatM Register
coerceFP2Int_sse2
where
coerceFP2Int_sse2 :: NatM Register
coerceFP2Int_sse2 = do
(Operand
x_op, OrdList Instr
x_code) <- CmmActual -> NatM (Operand, OrdList Instr)
getOperand CmmActual
x
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. 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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> OrdList Instr
code)
coerceFP2FP :: Width -> CmmExpr -> NatM Register
coerceFP2FP :: Width -> CmmActual -> NatM Register
coerceFP2FP Width
to CmmActual
x = do
(Reg
x_reg, OrdList Instr
x_code) <- CmmActual -> NatM (Reg, OrdList Instr)
getSomeReg CmmActual
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. 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 (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 -> CmmActual -> NatM Register
sse2NegCode Width
w CmmActual
x = do
let fmt :: Format
fmt = Width -> Format
floatFormat Width
w
Reg -> OrdList Instr
x_code <- CmmActual -> NatM (Reg -> OrdList Instr)
getAnyReg CmmActual
x
let
const :: CmmLit
const = 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. 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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt Reg -> OrdList Instr
code)
isVecExpr :: CmmExpr -> Bool
isVecExpr :: CmmActual -> Bool
isVecExpr (CmmMachOp (MO_V_Insert {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_V_Extract {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_V_Add {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_V_Sub {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_V_Mul {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VS_Quot {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VS_Rem {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VS_Neg {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Insert {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Extract {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Add {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Sub {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Mul {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Quot {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp (MO_VF_Neg {}) [CmmActual]
_) = Bool
True
isVecExpr (CmmMachOp MachOp
_ [CmmActual
e]) = CmmActual -> Bool
isVecExpr CmmActual
e
isVecExpr CmmActual
_ = Bool
False
needLlvm :: NatM a
needLlvm :: NatM a
needLlvm =
String -> NatM a
forall a. String -> a
sorry (String -> NatM a) -> String -> NatM a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"The native code generator does not support vector"
,String
"instructions. Please use -fllvm."]
invertCondBranches :: Maybe CFG
-> LabelMap a
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
invertCondBranches :: 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 ins :: [Instr]
ins@(Instr
_:Instr
_:[Instr]
_xs)):b2 :: NatBasicBlock Instr
b2@(BasicBlock Label
lbl2 [Instr]
_):[NatBasicBlock Instr]
bs)
|
(Instr
jmp1,Instr
jmp2) <- [Instr] -> (Instr, Instr)
forall a. [a] -> (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
, JXX Cond
ALWAYS Label
target2 <- Instr
jmp2
, 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
, 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
, CmmCondBranch (CmmMachOp MachOp
op [CmmActual]
_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
= let jumps :: [Instr]
jumps =
case () of
()
_ | Bool -> Bool
not (KeyOf LabelMap -> LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
Label
target1 LabelMap a
keep)
-> [Cond -> Label -> Instr
JXX Cond
invCond Label
target2]
| 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]
| Bool
otherwise
-> [Instr
jmp1, Instr
jmp2]
in
(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 [] = []