{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs, MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Regs ( activeStgRegs )
import GHC.Llvm
import GHC.Llvm.Types
import GHC.CmmToLlvm.Base
import GHC.CmmToLlvm.Config
import GHC.CmmToLlvm.Regs
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Types.ForeignCall
import GHC.Types.Unique.DSM
import GHC.Types.Unique
import GHC.Utils.Outputable
import qualified GHC.Utils.Panic as Panic
import GHC.Utils.Misc
import Control.Applicative (Alternative((<|>)))
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Control.Monad
import qualified Data.Semigroup as Semigroup
import Data.List ( nub )
import Data.Maybe ( catMaybes, isJust )
type Atomic = Maybe MemoryOrdering
type LlvmStatements = OrdList LlvmStatement
data Signage = Signed | Unsigned deriving (Signage -> Signage -> Bool
(Signage -> Signage -> Bool)
-> (Signage -> Signage -> Bool) -> Eq Signage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Signage -> Signage -> Bool
== :: Signage -> Signage -> Bool
$c/= :: Signage -> Signage -> Bool
/= :: Signage -> Signage -> Bool
Eq, Int -> Signage -> ShowS
[Signage] -> ShowS
Signage -> String
(Int -> Signage -> ShowS)
-> (Signage -> String) -> ([Signage] -> ShowS) -> Show Signage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Signage -> ShowS
showsPrec :: Int -> Signage -> ShowS
$cshow :: Signage -> String
show :: Signage -> String
$cshowList :: [Signage] -> ShowS
showList :: [Signage] -> ShowS
Show)
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc (CmmProc LabelMap RawCmmStatics
infos CLabel
lbl [GlobalRegUse]
live CmmGraph
graph) = do
let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough CmmGraph
graph
(lmblocks, lmdata) <- [GlobalRegUse]
-> [CmmBlock] -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen [GlobalRegUse]
live [CmmBlock]
blocks
let info = BlockId -> LabelMap RawCmmStatics -> Maybe RawCmmStatics
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup (CmmGraph -> BlockId
forall (s :: * -> *) (n :: Extensibility -> Extensibility -> *).
GenGenCmmGraph s n -> BlockId
g_entry CmmGraph
graph) LabelMap RawCmmStatics
infos
proc = Maybe RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> ListGraph LlvmStatement
-> LlvmCmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc Maybe RawCmmStatics
info CLabel
lbl [GlobalRegUse]
live ([LlvmBasicBlock] -> ListGraph LlvmStatement
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph [LlvmBasicBlock]
lmblocks)
return (proc:lmdata)
genLlvmProc RawCmmDecl
_ = String -> LlvmM [LlvmCmmDecl]
forall a. HasCallStack => String -> a
panic String
"genLlvmProc: case that shouldn't reach here!"
newtype UnreachableBlockId = UnreachableBlockId BlockId
basicBlocksCodeGen :: LiveGlobalRegUses -> [CmmBlock]
-> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen :: [GlobalRegUse]
-> [CmmBlock] -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen [GlobalRegUse]
_ [] = String -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic String
"no entry block!"
basicBlocksCodeGen [GlobalRegUse]
live [CmmBlock]
cmmBlocks
= do
bid <- LlvmM BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
(prologue, prologueTops) <- funPrologue live cmmBlocks
let entryBlock = BlockId -> [LlvmStatement] -> LlvmBasicBlock
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
bid (LlvmStatements -> [LlvmStatement]
forall a. OrdList a -> [a]
fromOL LlvmStatements
prologue)
ubid@(UnreachableBlockId ubid') <- UnreachableBlockId <$> newBlockId
let ubblock = BlockId -> [LlvmStatement] -> LlvmBasicBlock
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
ubid' [LlvmStatement
Unreachable]
(blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks
return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)
basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
basicBlockCodeGen :: UnreachableBlockId
-> CmmBlock -> LlvmM (LlvmBasicBlock, [LlvmCmmDecl])
basicBlockCodeGen UnreachableBlockId
ubid 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 :: BlockId
id = CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
(mid_instrs, top) <- UnreachableBlockId
-> [CmmNode O O] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (e :: Extensibility) (x :: Extensibility).
UnreachableBlockId
-> [CmmNode e x] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtsToInstrs UnreachableBlockId
ubid ([CmmNode O O] -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> [CmmNode O O] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
(tail_instrs, top') <- stmtToInstrs ubid tail
let instrs = LlvmStatements -> [LlvmStatement]
forall a. OrdList a -> [a]
fromOL (LlvmStatements
mid_instrs LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
tail_instrs)
return (BasicBlock id instrs, top' ++ top)
type StmtData = (LlvmStatements, [LlvmCmmDecl])
stmtsToInstrs :: UnreachableBlockId -> [CmmNode e x] -> LlvmM StmtData
stmtsToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
UnreachableBlockId
-> [CmmNode e x] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtsToInstrs UnreachableBlockId
ubid [CmmNode e x]
stmts
= do (instrss, topss) <- ([(LlvmStatements, [LlvmCmmDecl])]
-> ([LlvmStatements], [[LlvmCmmDecl]]))
-> LlvmM [(LlvmStatements, [LlvmCmmDecl])]
-> LlvmM ([LlvmStatements], [[LlvmCmmDecl]])
forall a b. (a -> b) -> LlvmM a -> LlvmM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(LlvmStatements, [LlvmCmmDecl])]
-> ([LlvmStatements], [[LlvmCmmDecl]])
forall a b. [(a, b)] -> ([a], [b])
unzip (LlvmM [(LlvmStatements, [LlvmCmmDecl])]
-> LlvmM ([LlvmStatements], [[LlvmCmmDecl]]))
-> LlvmM [(LlvmStatements, [LlvmCmmDecl])]
-> LlvmM ([LlvmStatements], [[LlvmCmmDecl]])
forall a b. (a -> b) -> a -> b
$ (CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> [CmmNode e x] -> LlvmM [(LlvmStatements, [LlvmCmmDecl])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (UnreachableBlockId
-> CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (e :: Extensibility) (x :: Extensibility).
UnreachableBlockId
-> CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtToInstrs UnreachableBlockId
ubid) [CmmNode e x]
stmts
return (concatOL instrss, concat topss)
stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData
stmtToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
UnreachableBlockId
-> CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtToInstrs UnreachableBlockId
ubid CmmNode e x
stmt = case CmmNode e x
stmt of
CmmComment LMString
_ -> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])
CmmTick CmmTickish
_ -> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])
CmmUnwind {} -> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])
CmmAssign CmmReg
reg CmmExpr
src -> CmmReg -> CmmExpr -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genAssign CmmReg
reg CmmExpr
src
CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
align
-> CmmExpr
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore CmmExpr
addr CmmExpr
src AlignmentSpec
align
CmmBranch BlockId
id -> BlockId -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genBranch BlockId
id
CmmCondBranch CmmExpr
arg BlockId
true BlockId
false Maybe Bool
likely
-> CmmExpr
-> BlockId
-> BlockId
-> Maybe Bool
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCondBranch CmmExpr
arg BlockId
true BlockId
false Maybe Bool
likely
CmmSwitch CmmExpr
arg SwitchTargets
ids -> UnreachableBlockId
-> CmmExpr
-> SwitchTargets
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genSwitch UnreachableBlockId
ubid CmmExpr
arg SwitchTargets
ids
CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
res [CmmExpr]
args
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCall ForeignTarget
target [CmmFormal]
res [CmmExpr]
args
CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg,
cml_args_regs :: CmmNode O C -> [GlobalRegUse]
cml_args_regs = [GlobalRegUse]
live } -> CmmExpr -> [GlobalRegUse] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genJump CmmExpr
arg [GlobalRegUse]
live
CmmNode e x
_ -> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic String
"Llvm.CodeGen.stmtToInstrs"
getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 LMString
fname fty :: LlvmType
fty@(LMFunction LlvmFunctionDecl
funSig) = do
let fv :: LlvmVar
fv = LMString
-> LlvmType
-> LlvmLinkageType
-> LMSection
-> LMAlign
-> LMConst
-> LlvmVar
LMGlobalVar LMString
fname LlvmType
fty (LlvmFunctionDecl -> LlvmLinkageType
funcLinkage LlvmFunctionDecl
funSig) LMSection
forall a. Maybe a
Nothing LMAlign
forall a. Maybe a
Nothing LMConst
Constant
fn <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
fname
tops <- case fn of
Just LlvmType
_ ->
[LlvmCmmDecl] -> LlvmM [LlvmCmmDecl]
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Maybe LlvmType
Nothing -> do
LMString -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
fname LlvmType
fty
un <- LlvmM Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM
let lbl = Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel Unique
un
return [CmmData (Section Data lbl) [([],[fty])]]
return (fv, nilOL, tops)
getInstrinct2 LMString
_ LlvmType
_ = String -> LlvmM ExprData
forall a. HasCallStack => String -> a
error String
"getInstrinct2: Non-function type!"
getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct LMString
fname LlvmType
retTy [LlvmType]
parTys =
let funSig :: LlvmFunctionDecl
funSig = LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [LlvmParameter]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
fname LlvmLinkageType
ExternallyVisible LlvmCallConvention
CC_Ccc LlvmType
retTy
LlvmParameterListType
FixedArgs ([LlvmType] -> [LlvmParameter]
tysToParams [LlvmType]
parTys) LMAlign
forall a. Maybe a
Nothing
fty :: LlvmType
fty = LlvmFunctionDecl -> LlvmType
LMFunction LlvmFunctionDecl
funSig
in LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 LMString
fname LlvmType
fty
genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
genCall :: ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCall (PrimTarget CallishMachOp
MO_AcquireFence) [CmmFormal]
_ [CmmExpr]
_ = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$
LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ Bool -> LlvmSyncOrdering -> LlvmStatement
Fence Bool
False LlvmSyncOrdering
SyncAcquire
genCall (PrimTarget CallishMachOp
MO_ReleaseFence) [CmmFormal]
_ [CmmExpr]
_ = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$
LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ Bool -> LlvmSyncOrdering -> LlvmStatement
Fence Bool
False LlvmSyncOrdering
SyncRelease
genCall (PrimTarget CallishMachOp
MO_SeqCstFence) [CmmFormal]
_ [CmmExpr]
_ = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$
LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ Bool -> LlvmSyncOrdering -> LlvmStatement
Fence Bool
False LlvmSyncOrdering
SyncSeqCst
genCall (PrimTarget CallishMachOp
MO_Touch) [CmmFormal]
_ [CmmExpr]
_ =
(LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])
genCall (PrimTarget (MO_UF_Conv Width
w)) [CmmFormal
dst] [CmmExpr
e] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
dstV <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
let ty = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
dst
width = Width -> LlvmType
widthToLlvmFloat Width
w
castV <- lift $ mkLocalVar ty
ve <- exprToVarW e
statement $ Assignment castV $ Cast LM_Uitofp ve width
statement $ Store castV dstV Nothing []
genCall (PrimTarget (MO_UF_Conv Width
_)) [CmmFormal
_] [CmmExpr]
args =
String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic (String -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ String
"genCall: Too many arguments to MO_UF_Conv. " String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
"Can only handle 1, given" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmExpr]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
genCall t :: ForeignTarget
t@(PrimTarget (MO_Prefetch_Data Int
localityInt)) [] [CmmExpr]
args
| Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
localityInt Bool -> Bool -> Bool
&& Int
localityInt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3 = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
let argTy :: [LlvmType]
argTy = [LlvmType
i8Ptr, LlvmType
i32, LlvmType
i32, LlvmType
i32]
funTy :: LMString -> LlvmType
funTy = \LMString
name -> LlvmFunctionDecl -> LlvmType
LMFunction (LlvmFunctionDecl -> LlvmType) -> LlvmFunctionDecl -> LlvmType
forall a b. (a -> b) -> a -> b
$ LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [LlvmParameter]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
name LlvmLinkageType
ExternallyVisible
LlvmCallConvention
CC_Ccc LlvmType
LMVoid LlvmParameterListType
FixedArgs ([LlvmType] -> [LlvmParameter]
tysToParams [LlvmType]
argTy) LMAlign
forall a. Maybe a
Nothing
let ([ForeignHint]
_, [ForeignHint]
arg_hints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
t
let args_hints' :: [(CmmExpr, ForeignHint)]
args_hints' = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints
argVars <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT LlvmAccum LlvmM [LlvmVar]
arg_varsW [(CmmExpr, ForeignHint)]
args_hints' ([], LlvmStatements
forall a. OrdList a
nilOL, [])
fptr <- liftExprData $ getFunPtr funTy t
argVars' <- castVarsW Signed $ zip argVars argTy
let argSuffix = [LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32 Integer
0, LlvmType -> Int -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32 Int
localityInt, LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32 Integer
1]
statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
| Bool
otherwise = String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic (String -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ String
"prefetch locality level integer must be between 0 and 3, given: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int -> String
forall a. Show a => a -> String
show Int
localityInt)
genCall t :: ForeignTarget
t@(PrimTarget (MO_PopCnt Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall t :: ForeignTarget
t@(PrimTarget (MO_Pdep Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast2 Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall t :: ForeignTarget
t@(PrimTarget (MO_Pext Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast2 Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall t :: ForeignTarget
t@(PrimTarget (MO_Clz Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall t :: ForeignTarget
t@(PrimTarget (MO_Ctz Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall t :: ForeignTarget
t@(PrimTarget (MO_BSwap Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall t :: ForeignTarget
t@(PrimTarget (MO_BRev Width
w)) [CmmFormal]
dsts [CmmExpr]
args =
Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args
genCall (PrimTarget (MO_AtomicRMW Width
width AtomicMachOp
amop)) [CmmFormal
dst] [CmmExpr
addr, CmmExpr
n] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
addrVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
addr
nVar <- exprToVarW n
let targetTy = Width -> LlvmType
widthToLlvmInt Width
width
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar (LlvmType -> LlvmType
pLift LlvmType
targetTy)
ptrVar <- doExprW (pLift targetTy) ptrExpr
dstVar <- getCmmRegW (CmmLocal dst)
let op = case AtomicMachOp
amop of
AtomicMachOp
AMO_Add -> LlvmAtomicOp
LAO_Add
AtomicMachOp
AMO_Sub -> LlvmAtomicOp
LAO_Sub
AtomicMachOp
AMO_And -> LlvmAtomicOp
LAO_And
AtomicMachOp
AMO_Nand -> LlvmAtomicOp
LAO_Nand
AtomicMachOp
AMO_Or -> LlvmAtomicOp
LAO_Or
AtomicMachOp
AMO_Xor -> LlvmAtomicOp
LAO_Xor
retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
statement $ Store retVar dstVar Nothing []
genCall (PrimTarget (MO_AtomicRead Width
_ MemoryOrdering
mem_ord)) [CmmFormal
dst] [CmmExpr
addr] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
dstV <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned
statement $ Store v1 dstV Nothing []
genCall (PrimTarget (MO_Cmpxchg Width
_width))
[CmmFormal
dst] [CmmExpr
addr, CmmExpr
old, CmmExpr
new] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
addrVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
addr
oldVar <- exprToVarW old
newVar <- exprToVarW new
let targetTy = LlvmVar -> LlvmType
getVarType LlvmVar
oldVar
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar (LlvmType -> LlvmType
pLift LlvmType
targetTy)
ptrVar <- doExprW (pLift targetTy) ptrExpr
dstVar <- getCmmRegW (CmmLocal dst)
retVar <- doExprW (LMStructU [targetTy,i1])
$ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
retVar' <- doExprW targetTy $ ExtractV retVar 0
statement $ Store retVar' dstVar Nothing []
genCall (PrimTarget (MO_Xchg Width
_width)) [CmmFormal
dst] [CmmExpr
addr, CmmExpr
val] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
dstV <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst) :: WriterT LlvmAccum LlvmM LlvmVar
addrVar <- exprToVarW addr
valVar <- exprToVarW val
let ptrTy = LlvmType -> LlvmType
pLift (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
valVar
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar LlvmType
ptrTy
ptrVar <- doExprW ptrTy ptrExpr
resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)
statement $ Store resVar dstV Nothing []
genCall (PrimTarget (MO_AtomicWrite Width
_width MemoryOrdering
mem_ord)) [] [CmmExpr
addr, CmmExpr
val] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
addrVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
addr
valVar <- exprToVarW val
let ptrTy = LlvmType -> LlvmType
pLift (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
valVar
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar LlvmType
ptrTy
ptrVar <- doExprW ptrTy ptrExpr
let ordering = MemoryOrdering -> LlvmSyncOrdering
convertMemoryOrdering MemoryOrdering
mem_ord
statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar ordering
genCall t :: ForeignTarget
t@(PrimTarget CallishMachOp
op) [] [CmmExpr]
args
| Just Int
align <- CallishMachOp -> LMAlign
machOpMemcpyishAlign CallishMachOp
op
= do
platform <- LlvmM Platform
getPlatform
runStmtsDecls $ do
let isVolTy = [LlvmType
i1]
isVolVal = [LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i1 Integer
0]
argTy | MO_Memset Int
_ <- CallishMachOp
op = [LlvmType
i8Ptr, LlvmType
i8, Platform -> LlvmType
llvmWord Platform
platform, LlvmType
i32] [LlvmType] -> [LlvmType] -> [LlvmType]
forall a. [a] -> [a] -> [a]
++ [LlvmType]
isVolTy
| Bool
otherwise = [LlvmType
i8Ptr, LlvmType
i8Ptr, Platform -> LlvmType
llvmWord Platform
platform, LlvmType
i32] [LlvmType] -> [LlvmType] -> [LlvmType]
forall a. [a] -> [a] -> [a]
++ [LlvmType]
isVolTy
funTy = \LMString
name -> LlvmFunctionDecl -> LlvmType
LMFunction (LlvmFunctionDecl -> LlvmType) -> LlvmFunctionDecl -> LlvmType
forall a b. (a -> b) -> a -> b
$ LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [LlvmParameter]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
name LlvmLinkageType
ExternallyVisible
LlvmCallConvention
CC_Ccc LlvmType
LMVoid LlvmParameterListType
FixedArgs ([LlvmType] -> [LlvmParameter]
tysToParams [LlvmType]
argTy) LMAlign
forall a. Maybe a
Nothing
let (_, arg_hints) = foreignTargetHints t
let args_hints = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints
argVars <- arg_varsW args_hints ([], nilOL, [])
fptr <- getFunPtrW funTy t
argVars' <- castVarsW Signed $ zip argVars argTy
let alignVal = LlvmType -> Int -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32 Int
align
arguments = [LlvmVar]
argVars' [LlvmVar] -> [LlvmVar] -> [LlvmVar]
forall a. [a] -> [a] -> [a]
++ (LlvmVar
alignValLlvmVar -> [LlvmVar] -> [LlvmVar]
forall a. a -> [a] -> [a]
:[LlvmVar]
isVolVal)
statement $ Expr $ Call StdCall fptr arguments []
genCall (PrimTarget (MO_U_Mul2 Width
w)) [CmmFormal
dstH, CmmFormal
dstL] [CmmExpr
lhs, CmmExpr
rhs] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
bitWidth :: Int
bitWidth = Width -> Int
widthInBits Width
w
width2x :: LlvmType
width2x = Int -> LlvmType
LMInt (Int
bitWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
lhsVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
lhs
rhsVar <- exprToVarW rhs
lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x
rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x
retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
retL <- doExprW width $ Cast LM_Trunc retV width
let widthLlvmLit = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bitWidth) LlvmType
width
retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
retH <- doExprW width $ Cast LM_Trunc retShifted width
dstRegL <- getCmmRegW (CmmLocal dstL)
dstRegH <- getCmmRegW (CmmLocal dstH)
statement $ Store retL dstRegL Nothing []
statement $ Store retH dstRegH Nothing []
genCall (PrimTarget (MO_S_Mul2 Width
w)) [CmmFormal
dstC, CmmFormal
dstH, CmmFormal
dstL] [CmmExpr
lhs, CmmExpr
rhs] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
bitWidth :: Int
bitWidth = Width -> Int
widthInBits Width
w
width2x :: LlvmType
width2x = Int -> LlvmType
LMInt (Int
bitWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
lhsVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
lhs
rhsVar <- exprToVarW rhs
lhsExt <- doExprW width2x $ Cast LM_Sext lhsVar width2x
rhsExt <- doExprW width2x $ Cast LM_Sext rhsVar width2x
retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
retL <- doExprW width $ Cast LM_Trunc retV width
let widthLlvmLit = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bitWidth) LlvmType
width
retShifted <- doExprW width2x $ LlvmOp LM_MO_AShr retV widthLlvmLit
retH <- doExprW width $ Cast LM_Trunc retShifted width
let widthLlvmLitm1 = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bitWidth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) LlvmType
width
retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1
retC1 <- doExprW i1 $ Compare LM_CMP_Ne retH retH'
retC <- doExprW width $ Cast LM_Zext retC1 width
dstRegL <- getCmmRegW (CmmLocal dstL)
dstRegH <- getCmmRegW (CmmLocal dstH)
dstRegC <- getCmmRegW (CmmLocal dstC)
statement $ Store retL dstRegL Nothing []
statement $ Store retH dstRegH Nothing []
statement $ Store retC dstRegC Nothing []
genCall (PrimTarget (MO_U_QuotRem2 Width
w))
[CmmFormal
dstQ, CmmFormal
dstR] [CmmExpr
lhsH, CmmExpr
lhsL, CmmExpr
rhs] = WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls (WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> WriterT LlvmAccum LlvmM ()
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ do
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
bitWidth :: Int
bitWidth = Width -> Int
widthInBits Width
w
width2x :: LlvmType
width2x = Int -> LlvmType
LMInt (Int
bitWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)
let zeroExtend :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
zeroExtend CmmExpr
expr = do
var <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
expr
doExprW width2x $ Cast LM_Zext var width2x
lhsExtH <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
zeroExtend CmmExpr
lhsH
lhsExtL <- zeroExtend lhsL
rhsExt <- zeroExtend rhs
let widthLlvmLit = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bitWidth) LlvmType
width
lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit
lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL
retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt
retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt
let narrow LlvmVar
var = LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Trunc LlvmVar
var LlvmType
width
retDiv <- narrow retExtDiv
retRem <- narrow retExtRem
dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)
dstRegR <- lift $ getCmmReg (CmmLocal dstR)
statement $ Store retDiv dstRegQ Nothing []
statement $ Store retRem dstRegR Nothing []
genCall t :: ForeignTarget
t@(PrimTarget (MO_AddIntC Width
w)) [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs] =
ForeignTarget
-> Width
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallWithOverflow ForeignTarget
t Width
w [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs]
genCall t :: ForeignTarget
t@(PrimTarget (MO_SubIntC Width
w)) [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs] =
ForeignTarget
-> Width
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallWithOverflow ForeignTarget
t Width
w [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs]
genCall t :: ForeignTarget
t@(PrimTarget (MO_Add2 Width
w)) [CmmFormal
dstO, CmmFormal
dstV] [CmmExpr
lhs, CmmExpr
rhs] =
ForeignTarget
-> Width
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallWithOverflow ForeignTarget
t Width
w [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs]
genCall t :: ForeignTarget
t@(PrimTarget (MO_AddWordC Width
w)) [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs] =
ForeignTarget
-> Width
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallWithOverflow ForeignTarget
t Width
w [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs]
genCall t :: ForeignTarget
t@(PrimTarget (MO_SubWordC Width
w)) [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs] =
ForeignTarget
-> Width
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallWithOverflow ForeignTarget
t Width
w [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs]
genCall ForeignTarget
target [CmmFormal]
res [CmmExpr]
args = do
platform <- LlvmM Platform
getPlatform
runStmtsDecls $ do
let lmconv = case ForeignTarget
target of
ForeignTarget CmmExpr
_ (ForeignConvention CCallConv
conv [ForeignHint]
_ [ForeignHint]
_ CmmReturnInfo
_) ->
case CCallConv
conv of
CCallConv
StdCallConv -> String -> LlvmCallConvention
forall a. HasCallStack => String -> a
panic String
"GHC.CmmToLlvm.CodeGen.genCall: StdCallConv"
CCallConv
CCallConv -> LlvmCallConvention
CC_Ccc
CCallConv
CApiConv -> LlvmCallConvention
CC_Ccc
CCallConv
PrimCallConv -> String -> LlvmCallConvention
forall a. HasCallStack => String -> a
panic String
"GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv"
CCallConv
JavaScriptCallConv -> String -> LlvmCallConvention
forall a. HasCallStack => String -> a
panic String
"GHC.CmmToLlvm.CodeGen.genCall: JavaScriptCallConv"
PrimTarget CallishMachOp
_ -> LlvmCallConvention
CC_Ccc
let arg_type (CmmExpr
_, ForeignHint
AddrHint) = (LlvmType
i8Ptr, [])
arg_type (CmmExpr
expr, ForeignHint
hint) =
case CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr of
ty :: LlvmType
ty@(LMInt Int
n) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
64 Bool -> Bool -> Bool
&& LlvmCallConvention
lmconv LlvmCallConvention -> LlvmCallConvention -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmCallConvention
CC_Ccc Bool -> Bool -> Bool
&& Platform -> Bool
platformCConvNeedsExtension Platform
platform
-> (LlvmType
ty, if ForeignHint
hint ForeignHint -> ForeignHint -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignHint
SignedHint then [LlvmParamAttr
SignExt] else [LlvmParamAttr
ZeroExt])
LlvmType
ty -> (LlvmType
ty, [])
let ret_type [] = LlvmType
LMVoid
ret_type [(CmmFormal
_, ForeignHint
AddrHint)] = LlvmType
i8Ptr
ret_type [(CmmFormal
reg, ForeignHint
_)] = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
reg
ret_type [(CmmFormal, ForeignHint)]
t = String -> LlvmType
forall a. HasCallStack => String -> a
panic (String -> LlvmType) -> String -> LlvmType
forall a b. (a -> b) -> a -> b
$ String
"genCall: Too many return values! Can only handle"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" 0 or 1, given " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(CmmFormal, ForeignHint)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CmmFormal, ForeignHint)]
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
let fnAttrs | Bool
never_returns = LlvmFuncAttr
NoReturn LlvmFuncAttr -> [LlvmFuncAttr] -> [LlvmFuncAttr]
forall a. a -> [a] -> [a]
: [LlvmFuncAttr]
llvmStdFunAttrs
| Bool
otherwise = [LlvmFuncAttr]
llvmStdFunAttrs
never_returns = case ForeignTarget
target of
ForeignTarget CmmExpr
_ (ForeignConvention CCallConv
_ [ForeignHint]
_ [ForeignHint]
_ CmmReturnInfo
CmmNeverReturns) -> Bool
True
ForeignTarget
_ -> Bool
False
let (res_hints, arg_hints) = foreignTargetHints target
let args_hints = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints
let ress_hints = [CmmFormal] -> [ForeignHint] -> [(CmmFormal, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmFormal]
res [ForeignHint]
res_hints
let ccTy = LlvmCallType
StdCall
let retTy = [(CmmFormal, ForeignHint)] -> LlvmType
ret_type [(CmmFormal, ForeignHint)]
ress_hints
let argTy = ((CmmExpr, ForeignHint) -> LlvmParameter)
-> [(CmmExpr, ForeignHint)] -> [LlvmParameter]
forall a b. (a -> b) -> [a] -> [b]
map (CmmExpr, ForeignHint) -> LlvmParameter
arg_type [(CmmExpr, ForeignHint)]
args_hints
let funTy = \LMString
name -> LlvmFunctionDecl -> LlvmType
LMFunction (LlvmFunctionDecl -> LlvmType) -> LlvmFunctionDecl -> LlvmType
forall a b. (a -> b) -> a -> b
$ LMString
-> LlvmLinkageType
-> LlvmCallConvention
-> LlvmType
-> LlvmParameterListType
-> [LlvmParameter]
-> LMAlign
-> LlvmFunctionDecl
LlvmFunctionDecl LMString
name LlvmLinkageType
ExternallyVisible
LlvmCallConvention
lmconv LlvmType
retTy LlvmParameterListType
FixedArgs [LlvmParameter]
argTy (Platform -> LMAlign
llvmFunAlign Platform
platform)
argVars <- arg_varsW args_hints ([], nilOL, [])
fptr <- getFunPtrW funTy target
let doReturn | LlvmCallType
ccTy LlvmCallType -> LlvmCallType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmCallType
TailCall = LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ Maybe LlvmVar -> LlvmStatement
Return Maybe LlvmVar
forall a. Maybe a
Nothing
| Bool
never_returns = LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmStatement
Unreachable
| Bool
otherwise = () -> WriterT LlvmAccum LlvmM ()
forall a. a -> WriterT LlvmAccum LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case retTy of
LlvmType
LMVoid ->
LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmExpression -> LlvmStatement
Expr (LlvmExpression -> LlvmStatement)
-> LlvmExpression -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
ccTy LlvmVar
fptr [LlvmVar]
argVars [LlvmFuncAttr]
fnAttrs
LlvmType
_ -> do
v1 <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
retTy (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
ccTy LlvmVar
fptr [LlvmVar]
argVars [LlvmFuncAttr]
fnAttrs
let ret_reg [a
reg] = a
reg
ret_reg [a]
t = String -> a
forall a. HasCallStack => String -> a
panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"genCall: Bad number of registers! Can only handle"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" 1, given " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
let creg = [CmmFormal] -> CmmFormal
forall {a}. [a] -> a
ret_reg [CmmFormal]
res
vreg <- getCmmRegW (CmmLocal creg)
if retTy == pLower (getVarType vreg)
then do
statement $ Store v1 vreg Nothing []
doReturn
else do
let ty = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
vreg
let op = case LlvmType
ty of
LlvmType
vt | LlvmType -> Bool
isPointer LlvmType
vt -> LlvmCastOp
LM_Bitcast
| LlvmType -> Bool
isInt LlvmType
vt -> LlvmCastOp
LM_Ptrtoint
| Bool
otherwise ->
String -> LlvmCastOp
forall a. HasCallStack => String -> a
panic (String -> LlvmCastOp) -> String -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ String
"genCall: CmmReg bad match for"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" returned type!"
v2 <- doExprW ty $ Cast op v1 ty
statement $ Store v2 vreg Nothing []
doReturn
genCallWithOverflow
:: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
genCallWithOverflow :: ForeignTarget
-> Width
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallWithOverflow t :: ForeignTarget
t@(PrimTarget CallishMachOp
op) Width
w [CmmFormal
dstV, CmmFormal
dstO] [CmmExpr
lhs, CmmExpr
rhs] = do
let valid :: Bool
valid = CallishMachOp
op CallishMachOp -> [CallishMachOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ Width -> CallishMachOp
MO_Add2 Width
w
, Width -> CallishMachOp
MO_AddIntC Width
w
, Width -> CallishMachOp
MO_SubIntC Width
w
, Width -> CallishMachOp
MO_AddWordC Width
w
, Width -> CallishMachOp
MO_SubWordC Width
w
]
Bool -> LlvmM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
Panic.massert Bool
valid
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
(value, overflowBit, (stmts, top)) <-
ForeignTarget
-> Width
-> (CmmExpr, CmmExpr)
-> (LlvmType, LlvmType)
-> LlvmM (LlvmVar, LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
genCallExtract ForeignTarget
t Width
w (CmmExpr
lhs, CmmExpr
rhs) (LlvmType
width, LlvmType
i1)
(overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
dstRegV <- getCmmReg (CmmLocal dstV)
dstRegO <- getCmmReg (CmmLocal dstO)
let storeV = LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
value LlvmVar
dstRegV LMAlign
forall a. Maybe a
Nothing []
storeO = LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
overflow LlvmVar
dstRegO LMAlign
forall a. Maybe a
Nothing []
return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
genCallWithOverflow ForeignTarget
_ Width
_ [CmmFormal]
_ [CmmExpr]
_ =
String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic String
"genCallExtract: wrong ForeignTarget or number of arguments"
genCallExtract
:: ForeignTarget
-> Width
-> (CmmActual, CmmActual)
-> (LlvmType, LlvmType)
-> LlvmM (LlvmVar, LlvmVar, StmtData)
target :: ForeignTarget
target@(PrimTarget CallishMachOp
op) Width
w (CmmExpr
argA, CmmExpr
argB) (LlvmType
llvmTypeA, LlvmType
llvmTypeB) = do
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
argTy :: [LlvmType]
argTy = [LlvmType
width, LlvmType
width]
retTy :: LlvmType
retTy = [LlvmType] -> LlvmType
LMStructU [LlvmType
llvmTypeA, LlvmType
llvmTypeB]
let args_hints :: [(CmmExpr, ForeignHint)]
args_hints = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr
argA, CmmExpr
argB] (([ForeignHint], [ForeignHint]) -> [ForeignHint]
forall a b. (a, b) -> b
snd (([ForeignHint], [ForeignHint]) -> [ForeignHint])
-> ([ForeignHint], [ForeignHint]) -> [ForeignHint]
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target)
(argsV1, args1, top1) <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
args_hints ([], LlvmStatements
forall a. OrdList a
nilOL, [])
(argsV2, args2) <- castVars Signed $ zip argsV1 argTy
fname <- cmmPrimOpFunctions op
(fptr, _, top2) <- getInstrinct fname retTy argTy
(retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []
(res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)
(res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)
let stmts = LlvmStatements
args1 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
args2 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
call LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
ext1 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
ext2
tops = [LlvmCmmDecl]
top1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top2
return (res1, res2, (stmts, tops))
genCallExtract ForeignTarget
_ Width
_ (CmmExpr, CmmExpr)
_ (LlvmType, LlvmType)
_ =
String -> LlvmM (LlvmVar, LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
forall a. HasCallStack => String -> a
panic String
"genCallExtract: unsupported ForeignTarget"
genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
-> LlvmM StmtData
genCallSimpleCast :: Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w t :: ForeignTarget
t@(PrimTarget CallishMachOp
op) [CmmFormal
dst] [CmmExpr]
args = do
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
dstTy :: LlvmType
dstTy = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
dst
fname <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
op
(fptr, _, top3) <- getInstrinct fname width [width]
dstV <- getCmmReg (CmmLocal dst)
let (_, arg_hints) = foreignTargetHints t
let args_hints = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints
(argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
(argsV', stmts4) <- castVars Signed $ zip argsV [width]
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
(retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
let retV' = String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic String
"genCallSimpleCast" [LlvmVar]
retVs'
let s2 = LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
retV' LlvmVar
dstV LMAlign
forall a. Maybe a
Nothing []
let stmts = LlvmStatements
stmts2 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts4 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL`
LlvmStatement
s1 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts5 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s2
return (stmts, top2 ++ top3)
genCallSimpleCast Width
_ ForeignTarget
_ [CmmFormal]
dsts [CmmExpr]
_ =
String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic (String
"genCallSimpleCast: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmFormal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmFormal]
dsts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" dsts")
genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
-> LlvmM StmtData
genCallSimpleCast2 :: Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast2 Width
w t :: ForeignTarget
t@(PrimTarget CallishMachOp
op) [CmmFormal
dst] [CmmExpr]
args = do
let width :: LlvmType
width = Width -> LlvmType
widthToLlvmInt Width
w
dstTy :: LlvmType
dstTy = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
dst
fname <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
op
(fptr, _, top3) <- getInstrinct fname width (const width <$> args)
dstV <- getCmmReg (CmmLocal dst)
let (_, arg_hints) = foreignTargetHints t
let args_hints = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints
(argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
(argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV)
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
(retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
let retV' = String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic String
"genCallSimpleCast2" [LlvmVar]
retVs'
let s2 = LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
retV' LlvmVar
dstV LMAlign
forall a. Maybe a
Nothing []
let stmts = LlvmStatements
stmts2 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts4 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL`
LlvmStatement
s1 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts5 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s2
return (stmts, top2 ++ top3)
genCallSimpleCast2 Width
_ ForeignTarget
_ [CmmFormal]
dsts [CmmExpr]
_ =
String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> a
panic (String
"genCallSimpleCast2: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmFormal] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmFormal]
dsts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" dsts")
getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
-> WriterT LlvmAccum LlvmM LlvmVar
getFunPtrW :: (LMString -> LlvmType)
-> ForeignTarget -> WriterT LlvmAccum LlvmM LlvmVar
getFunPtrW LMString -> LlvmType
funTy ForeignTarget
targ = LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
liftExprData (LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ (LMString -> LlvmType) -> ForeignTarget -> LlvmM ExprData
getFunPtr LMString -> LlvmType
funTy ForeignTarget
targ
getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
-> LlvmM ExprData
getFunPtr :: (LMString -> LlvmType) -> ForeignTarget -> LlvmM ExprData
getFunPtr LMString -> LlvmType
funTy ForeignTarget
targ = case ForeignTarget
targ of
ForeignTarget (CmmLit (CmmLabel CLabel
lbl)) ForeignConvention
_ -> do
name <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
lbl
getHsFunc' name (funTy name)
ForeignTarget CmmExpr
expr ForeignConvention
_ -> do
(v1, stmts, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
expr
let fty = LMString -> LlvmType
funTy (LMString -> LlvmType) -> LMString -> LlvmType
forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit String
"dynamic"
cast = case LlvmVar -> LlvmType
getVarType LlvmVar
v1 of
LlvmType
ty | LlvmType -> Bool
isPointer LlvmType
ty -> LlvmCastOp
LM_Bitcast
LlvmType
ty | LlvmType -> Bool
isInt LlvmType
ty -> LlvmCastOp
LM_Inttoptr
LlvmType
ty -> String -> SDoc -> LlvmCastOp
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCall: Expr is of bad type for function" (SDoc -> LlvmCastOp) -> SDoc -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" call! " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
lparen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
rparen
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (v2, stmts `snocOL` s1, top)
PrimTarget CallishMachOp
mop -> do
name <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
mop
let fty = LMString -> LlvmType
funTy LMString
name
getInstrinct2 name fty
arg_varsW :: [(CmmActual, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT LlvmAccum LlvmM [LlvmVar]
arg_varsW :: [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT LlvmAccum LlvmM [LlvmVar]
arg_varsW [(CmmExpr, ForeignHint)]
xs ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
ys = do
(vars, stmts, decls) <- LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT
LlvmAccum LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => m a -> WriterT LlvmAccum m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT
LlvmAccum LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]))
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT
LlvmAccum LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
xs ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
ys
tell $ LlvmAccum stmts decls
return vars
arg_vars :: [(CmmActual, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars :: [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [] ([LlvmVar]
vars, LlvmStatements
stmts, [LlvmCmmDecl]
tops)
= ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LlvmVar]
vars, LlvmStatements
stmts, [LlvmCmmDecl]
tops)
arg_vars ((CmmExpr
e, ForeignHint
AddrHint):[(CmmExpr, ForeignHint)]
rest) ([LlvmVar]
vars, LlvmStatements
stmts, [LlvmCmmDecl]
tops)
= do (v1, stmts', top') <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
e
let op = case LlvmVar -> LlvmType
getVarType LlvmVar
v1 of
LlvmType
ty | LlvmType -> Bool
isPointer LlvmType
ty -> LlvmCastOp
LM_Bitcast
LlvmType
ty | LlvmType -> Bool
isInt LlvmType
ty -> LlvmCastOp
LM_Inttoptr
LlvmType
a -> String -> SDoc -> LlvmCastOp
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCall: Can't cast llvmType to i8*! " (SDoc -> LlvmCastOp) -> SDoc -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$
SDoc
forall doc. IsLine doc => doc
lparen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
a SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
rparen
(v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
tops ++ top')
arg_vars ((CmmExpr
e, ForeignHint
_):[(CmmExpr, ForeignHint)]
rest) ([LlvmVar]
vars, LlvmStatements
stmts, [LlvmCmmDecl]
tops)
= do (v1, stmts', top') <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
e
arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
castVarsW :: Signage
-> [(LlvmVar, LlvmType)]
-> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW :: Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
signage [(LlvmVar, LlvmType)]
vars = do
(vars, stmts) <- LlvmM ([LlvmVar], LlvmStatements)
-> WriterT LlvmAccum LlvmM ([LlvmVar], LlvmStatements)
forall (m :: * -> *) a. Monad m => m a -> WriterT LlvmAccum m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM ([LlvmVar], LlvmStatements)
-> WriterT LlvmAccum LlvmM ([LlvmVar], LlvmStatements))
-> LlvmM ([LlvmVar], LlvmStatements)
-> WriterT LlvmAccum LlvmM ([LlvmVar], LlvmStatements)
forall a b. (a -> b) -> a -> b
$ Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars Signage
signage [(LlvmVar, LlvmType)]
vars
tell $ LlvmAccum stmts mempty
return vars
castVars :: Signage -> [(LlvmVar, LlvmType)]
-> LlvmM ([LlvmVar], LlvmStatements)
castVars :: Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars Signage
signage [(LlvmVar, LlvmType)]
vars = do
done <- ((LlvmVar, LlvmType) -> LlvmM (LlvmVar, LlvmStatement))
-> [(LlvmVar, LlvmType)] -> LlvmM [(LlvmVar, LlvmStatement)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement))
-> (LlvmVar, LlvmType) -> LlvmM (LlvmVar, LlvmStatement)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
castVar Signage
signage)) [(LlvmVar, LlvmType)]
vars
let (vars', stmts) = unzip done
return (vars', toOL stmts)
castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
castVar Signage
signage LlvmVar
v LlvmType
t | LlvmVar -> LlvmType
getVarType LlvmVar
v LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmType
t
= (LlvmVar, LlvmStatement) -> LlvmM (LlvmVar, LlvmStatement)
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v, LlvmStatement
Nop)
| Bool
otherwise
= do platform <- LlvmM Platform
getPlatform
let op = case (LlvmVar -> LlvmType
getVarType LlvmVar
v, LlvmType
t) of
(LMInt Int
n, LMInt Int
m)
-> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m then LlvmCastOp
extend else LlvmCastOp
LM_Trunc
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isFloat LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isFloat LlvmType
t
-> if Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform LlvmType
vt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform LlvmType
t
then LlvmCastOp
LM_Fpext else LlvmCastOp
LM_Fptrunc
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isInt LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isFloat LlvmType
t -> LlvmCastOp
LM_Sitofp
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isFloat LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isInt LlvmType
t -> LlvmCastOp
LM_Fptosi
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isInt LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isPointer LlvmType
t -> LlvmCastOp
LM_Inttoptr
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isPointer LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isInt LlvmType
t -> LlvmCastOp
LM_Ptrtoint
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isPointer LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isPointer LlvmType
t -> LlvmCastOp
LM_Bitcast
(LlvmType
vt, LlvmType
_) | LlvmType -> Bool
isVector LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isVector LlvmType
t -> LlvmCastOp
LM_Bitcast
(LlvmType
vt, LlvmType
_) -> String -> SDoc -> LlvmCastOp
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"castVars: Can't cast this type " (SDoc -> LlvmCastOp) -> SDoc -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$
SDoc
forall doc. IsLine doc => doc
lparen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
vt SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
rparen
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" to " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc
forall doc. IsLine doc => doc
lparen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
rparen
doExpr t $ Cast op v t
where extend :: LlvmCastOp
extend = case Signage
signage of
Signage
Signed -> LlvmCastOp
LM_Sext
Signage
Unsigned -> LlvmCastOp
LM_Zext
cmmPrimOpRetValSignage :: CallishMachOp -> Signage
cmmPrimOpRetValSignage :: CallishMachOp -> Signage
cmmPrimOpRetValSignage CallishMachOp
mop = case CallishMachOp
mop of
MO_Pdep Width
_ -> Signage
Unsigned
MO_Pext Width
_ -> Signage
Unsigned
CallishMachOp
_ -> Signage
Signed
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
mop = do
cfg <- LlvmM LlvmCgConfig
getConfig
platform <- getPlatform
let !isBmi2Enabled = LlvmCgConfig -> Maybe BmiVersion
llvmCgBmiVersion LlvmCgConfig
cfg Maybe BmiVersion -> Maybe BmiVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= BmiVersion -> Maybe BmiVersion
forall a. a -> Maybe a
Just BmiVersion
BMI2
!is32bit = Platform -> PlatformWordSize
platformWordSize Platform
platform PlatformWordSize -> PlatformWordSize -> Bool
forall a. Eq a => a -> a -> Bool
== PlatformWordSize
PW4
unsupported = String -> LMString
forall a. HasCallStack => String -> a
panic (String
"cmmPrimOpFunctions: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" not supported here")
dontReach64 = String -> LMString
forall a. HasCallStack => String -> a
panic (String
"cmmPrimOpFunctions: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" should be not be encountered because the regular primop for this 64-bit operation is used instead.")
return $ case mop of
CallishMachOp
MO_F32_Exp -> String -> LMString
fsLit String
"expf"
CallishMachOp
MO_F32_ExpM1 -> String -> LMString
fsLit String
"expm1f"
CallishMachOp
MO_F32_Log -> String -> LMString
fsLit String
"logf"
CallishMachOp
MO_F32_Log1P -> String -> LMString
fsLit String
"log1pf"
CallishMachOp
MO_F32_Sqrt -> String -> LMString
fsLit String
"llvm.sqrt.f32"
CallishMachOp
MO_F32_Fabs -> String -> LMString
fsLit String
"llvm.fabs.f32"
CallishMachOp
MO_F32_Pwr -> String -> LMString
fsLit String
"llvm.pow.f32"
CallishMachOp
MO_F32_Sin -> String -> LMString
fsLit String
"llvm.sin.f32"
CallishMachOp
MO_F32_Cos -> String -> LMString
fsLit String
"llvm.cos.f32"
CallishMachOp
MO_F32_Tan -> String -> LMString
fsLit String
"tanf"
CallishMachOp
MO_F32_Asin -> String -> LMString
fsLit String
"asinf"
CallishMachOp
MO_F32_Acos -> String -> LMString
fsLit String
"acosf"
CallishMachOp
MO_F32_Atan -> String -> LMString
fsLit String
"atanf"
CallishMachOp
MO_F32_Sinh -> String -> LMString
fsLit String
"sinhf"
CallishMachOp
MO_F32_Cosh -> String -> LMString
fsLit String
"coshf"
CallishMachOp
MO_F32_Tanh -> String -> LMString
fsLit String
"tanhf"
CallishMachOp
MO_F32_Asinh -> String -> LMString
fsLit String
"asinhf"
CallishMachOp
MO_F32_Acosh -> String -> LMString
fsLit String
"acoshf"
CallishMachOp
MO_F32_Atanh -> String -> LMString
fsLit String
"atanhf"
CallishMachOp
MO_F64_Exp -> String -> LMString
fsLit String
"exp"
CallishMachOp
MO_F64_ExpM1 -> String -> LMString
fsLit String
"expm1"
CallishMachOp
MO_F64_Log -> String -> LMString
fsLit String
"log"
CallishMachOp
MO_F64_Log1P -> String -> LMString
fsLit String
"log1p"
CallishMachOp
MO_F64_Sqrt -> String -> LMString
fsLit String
"llvm.sqrt.f64"
CallishMachOp
MO_F64_Fabs -> String -> LMString
fsLit String
"llvm.fabs.f64"
CallishMachOp
MO_F64_Pwr -> String -> LMString
fsLit String
"llvm.pow.f64"
CallishMachOp
MO_F64_Sin -> String -> LMString
fsLit String
"llvm.sin.f64"
CallishMachOp
MO_F64_Cos -> String -> LMString
fsLit String
"llvm.cos.f64"
CallishMachOp
MO_F64_Tan -> String -> LMString
fsLit String
"tan"
CallishMachOp
MO_F64_Asin -> String -> LMString
fsLit String
"asin"
CallishMachOp
MO_F64_Acos -> String -> LMString
fsLit String
"acos"
CallishMachOp
MO_F64_Atan -> String -> LMString
fsLit String
"atan"
CallishMachOp
MO_F64_Sinh -> String -> LMString
fsLit String
"sinh"
CallishMachOp
MO_F64_Cosh -> String -> LMString
fsLit String
"cosh"
CallishMachOp
MO_F64_Tanh -> String -> LMString
fsLit String
"tanh"
CallishMachOp
MO_F64_Asinh -> String -> LMString
fsLit String
"asinh"
CallishMachOp
MO_F64_Acosh -> String -> LMString
fsLit String
"acosh"
CallishMachOp
MO_F64_Atanh -> String -> LMString
fsLit String
"atanh"
MO_Memcpy Int
_
| Bool
is32bit -> String -> LMString
fsLit String
"llvm.memcpy.p0i8.p0i8.i32"
| Bool
otherwise -> String -> LMString
fsLit String
"llvm.memcpy.p0i8.p0i8.i64"
MO_Memmove Int
_
| Bool
is32bit -> String -> LMString
fsLit String
"llvm.memmove.p0i8.p0i8.i32"
| Bool
otherwise -> String -> LMString
fsLit String
"llvm.memmove.p0i8.p0i8.i64"
MO_Memset Int
_
| Bool
is32bit -> String -> LMString
fsLit String
"llvm.memset.p0i8.i32"
| Bool
otherwise -> String -> LMString
fsLit String
"llvm.memset.p0i8.i64"
MO_Memcmp Int
_ -> String -> LMString
fsLit String
"memcmp"
CallishMachOp
MO_SuspendThread -> String -> LMString
fsLit String
"suspendThread"
CallishMachOp
MO_ResumeThread -> String -> LMString
fsLit String
"resumeThread"
MO_PopCnt Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.ctpop.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.ctpop.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.ctpop.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.ctpop.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.ctpop.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.ctpop.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.ctpop.i512"
MO_BSwap Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.bswap.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.bswap.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.bswap.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.bswap.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.bswap.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.bswap.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.bswap.i512"
MO_BRev Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.bitreverse.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.bitreverse.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.bitreverse.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.bitreverse.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.bitreverse.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.bitreverse.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.bitreverse.i512"
MO_Clz Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.ctlz.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.ctlz.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.ctlz.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.ctlz.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.ctlz.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.ctlz.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.ctlz.i512"
MO_Ctz Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.cttz.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.cttz.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.cttz.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.cttz.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.cttz.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.cttz.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.cttz.i512"
MO_Pdep Width
w
| Bool
isBmi2Enabled -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.8"
Width
W16 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.16"
Width
W32 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.32"
Width
W64 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.64"
Width
W128 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.128"
Width
W256 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.256"
Width
W512 -> String -> LMString
fsLit String
"llvm.x86.bmi.pdep.512"
| Bool
otherwise -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"hs_pdep8"
Width
W16 -> String -> LMString
fsLit String
"hs_pdep16"
Width
W32 -> String -> LMString
fsLit String
"hs_pdep32"
Width
W64 -> String -> LMString
fsLit String
"hs_pdep64"
Width
W128 -> String -> LMString
fsLit String
"hs_pdep128"
Width
W256 -> String -> LMString
fsLit String
"hs_pdep256"
Width
W512 -> String -> LMString
fsLit String
"hs_pdep512"
MO_Pext Width
w
| Bool
isBmi2Enabled -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.8"
Width
W16 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.16"
Width
W32 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.32"
Width
W64 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.64"
Width
W128 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.128"
Width
W256 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.256"
Width
W512 -> String -> LMString
fsLit String
"llvm.x86.bmi.pext.512"
| Bool
otherwise -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"hs_pext8"
Width
W16 -> String -> LMString
fsLit String
"hs_pext16"
Width
W32 -> String -> LMString
fsLit String
"hs_pext32"
Width
W64 -> String -> LMString
fsLit String
"hs_pext64"
Width
W128 -> String -> LMString
fsLit String
"hs_pext128"
Width
W256 -> String -> LMString
fsLit String
"hs_pext256"
Width
W512 -> String -> LMString
fsLit String
"hs_pext512"
MO_AddIntC Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.sadd.with.overflow.i512"
MO_SubIntC Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.ssub.with.overflow.i512"
MO_Add2 Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i512"
MO_AddWordC Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.uadd.with.overflow.i512"
MO_SubWordC Width
w -> case Width
w of
Width
W8 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i8"
Width
W16 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i16"
Width
W32 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i32"
Width
W64 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i64"
Width
W128 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i128"
Width
W256 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i256"
Width
W512 -> String -> LMString
fsLit String
"llvm.usub.with.overflow.i512"
MO_Prefetch_Data Int
_ -> String -> LMString
fsLit String
"llvm.prefetch"
MO_S_Mul2 {} -> LMString
unsupported
MO_S_QuotRem {} -> LMString
unsupported
MO_U_QuotRem {} -> LMString
unsupported
MO_U_QuotRem2 {} -> LMString
unsupported
MO_U_Mul2 {} -> LMString
unsupported
CallishMachOp
MO_ReleaseFence -> LMString
unsupported
CallishMachOp
MO_AcquireFence -> LMString
unsupported
CallishMachOp
MO_SeqCstFence -> LMString
unsupported
CallishMachOp
MO_Touch -> LMString
unsupported
MO_UF_Conv Width
_ -> LMString
unsupported
MO_AtomicRead Width
_ MemoryOrdering
_ -> LMString
unsupported
MO_AtomicRMW Width
_ AtomicMachOp
_ -> LMString
unsupported
MO_AtomicWrite Width
_ MemoryOrdering
_ -> LMString
unsupported
MO_Cmpxchg Width
_ -> LMString
unsupported
MO_Xchg Width
_ -> LMString
unsupported
CallishMachOp
MO_I64_ToI -> LMString
dontReach64
CallishMachOp
MO_I64_FromI -> LMString
dontReach64
CallishMachOp
MO_W64_ToW -> LMString
dontReach64
CallishMachOp
MO_W64_FromW -> LMString
dontReach64
CallishMachOp
MO_x64_Neg -> LMString
dontReach64
CallishMachOp
MO_x64_Add -> LMString
dontReach64
CallishMachOp
MO_x64_Sub -> LMString
dontReach64
CallishMachOp
MO_x64_Mul -> LMString
dontReach64
CallishMachOp
MO_I64_Quot -> LMString
dontReach64
CallishMachOp
MO_I64_Rem -> LMString
dontReach64
CallishMachOp
MO_W64_Quot -> LMString
dontReach64
CallishMachOp
MO_W64_Rem -> LMString
dontReach64
CallishMachOp
MO_x64_And -> LMString
dontReach64
CallishMachOp
MO_x64_Or -> LMString
dontReach64
CallishMachOp
MO_x64_Xor -> LMString
dontReach64
CallishMachOp
MO_x64_Not -> LMString
dontReach64
CallishMachOp
MO_x64_Shl -> LMString
dontReach64
CallishMachOp
MO_I64_Shr -> LMString
dontReach64
CallishMachOp
MO_W64_Shr -> LMString
dontReach64
CallishMachOp
MO_x64_Eq -> LMString
dontReach64
CallishMachOp
MO_x64_Ne -> LMString
dontReach64
CallishMachOp
MO_I64_Ge -> LMString
dontReach64
CallishMachOp
MO_I64_Gt -> LMString
dontReach64
CallishMachOp
MO_I64_Le -> LMString
dontReach64
CallishMachOp
MO_I64_Lt -> LMString
dontReach64
CallishMachOp
MO_W64_Ge -> LMString
dontReach64
CallishMachOp
MO_W64_Gt -> LMString
dontReach64
CallishMachOp
MO_W64_Le -> LMString
dontReach64
CallishMachOp
MO_W64_Lt -> LMString
dontReach64
genJump :: CmmExpr -> LiveGlobalRegUses -> LlvmM StmtData
genJump :: CmmExpr -> [GlobalRegUse] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genJump (CmmLit (CmmLabel CLabel
lbl)) [GlobalRegUse]
live = do
(vf, stmts, top) <- [GlobalRegUse] -> CLabel -> LlvmM ExprData
getHsFunc [GlobalRegUse]
live CLabel
lbl
(stgRegs, stgStmts) <- funEpilogue live
let s1 = LlvmExpression -> LlvmStatement
Expr (LlvmExpression -> LlvmStatement)
-> LlvmExpression -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
TailCall LlvmVar
vf [LlvmVar]
stgRegs [LlvmFuncAttr]
llvmStdFunAttrs
let s2 = Maybe LlvmVar -> LlvmStatement
Return Maybe LlvmVar
forall a. Maybe a
Nothing
return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
genJump CmmExpr
expr [GlobalRegUse]
live = do
fty <- [GlobalRegUse] -> LlvmM LlvmType
llvmFunTy [GlobalRegUse]
live
(vf, stmts, top) <- exprToVar expr
let cast = case LlvmVar -> LlvmType
getVarType LlvmVar
vf of
LlvmType
ty | LlvmType -> Bool
isPointer LlvmType
ty -> LlvmCastOp
LM_Bitcast
LlvmType
ty | LlvmType -> Bool
isInt LlvmType
ty -> LlvmCastOp
LM_Inttoptr
LlvmType
ty -> String -> SDoc -> LlvmCastOp
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genJump: Expr is of bad type for function call! "
(SDoc -> LlvmCastOp) -> SDoc -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ SDoc
forall doc. IsLine doc => doc
lparen SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
rparen
(v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
(stgRegs, stgStmts) <- funEpilogue live
let s2 = LlvmExpression -> LlvmStatement
Expr (LlvmExpression -> LlvmStatement)
-> LlvmExpression -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
TailCall LlvmVar
v1 [LlvmVar]
stgRegs [LlvmFuncAttr]
llvmStdFunAttrs
let s3 = Maybe LlvmVar -> LlvmStatement
Return Maybe LlvmVar
forall a. Maybe a
Nothing
return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
top)
genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
genAssign :: CmmReg -> CmmExpr -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genAssign CmmReg
reg CmmExpr
val = do
vreg <- CmmReg -> LlvmM LlvmVar
getCmmReg CmmReg
reg
(vval, stmts2, top2) <- exprToVar val
let stmts = LlvmStatements
stmts2
let ty = (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType)
-> (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType) LlvmVar
vreg
platform <- getPlatform
case ty of
LMPointer LlvmType
_ | LlvmVar -> LlvmType
getVarType LlvmVar
vval LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> LlvmType
llvmWord Platform
platform -> do
(v, s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
vval LlvmType
ty
let s2 = LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
v LlvmVar
vreg LMAlign
forall a. Maybe a
Nothing []
return (stmts `snocOL` s1 `snocOL` s2, top2)
LMVector Int
_ LlvmType
_ -> do
(v, s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Bitcast LlvmVar
vval LlvmType
ty
let s2 = LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
v LlvmVar
vreg AlignmentSpec
NaturallyAligned []
return (stmts `snocOL` s1 `snocOL` s2, top2)
LlvmType
_ -> do
let s1 :: LlvmStatement
s1 = LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
vval LlvmVar
vreg LMAlign
forall a. Maybe a
Nothing []
(LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top2)
genStore :: CmmExpr -> CmmExpr -> AlignmentSpec -> LlvmM StmtData
genStore :: CmmExpr
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore addr :: CmmExpr
addr@(CmmReg (CmmGlobal GlobalRegUse
r)) CmmExpr
val AlignmentSpec
alignment
= CmmExpr
-> GlobalRegUse
-> Int
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalRegUse
r Int
0 CmmExpr
val AlignmentSpec
alignment
genStore addr :: CmmExpr
addr@(CmmRegOff (CmmGlobal GlobalRegUse
r) Int
n) CmmExpr
val AlignmentSpec
alignment
= CmmExpr
-> GlobalRegUse
-> Int
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalRegUse
r Int
n CmmExpr
val AlignmentSpec
alignment
genStore addr :: CmmExpr
addr@(CmmMachOp (MO_Add Width
_) [
(CmmReg (CmmGlobal GlobalRegUse
r)),
(CmmLit (CmmInt Integer
n Width
_))])
CmmExpr
val AlignmentSpec
alignment
= CmmExpr
-> GlobalRegUse
-> Int
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalRegUse
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) CmmExpr
val AlignmentSpec
alignment
genStore addr :: CmmExpr
addr@(CmmMachOp (MO_Sub Width
_) [
(CmmReg (CmmGlobal GlobalRegUse
r)),
(CmmLit (CmmInt Integer
n Width
_))])
CmmExpr
val AlignmentSpec
alignment
= CmmExpr
-> GlobalRegUse
-> Int
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalRegUse
r (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) CmmExpr
val AlignmentSpec
alignment
genStore CmmExpr
addr CmmExpr
val AlignmentSpec
alignment
= Unique -> LlvmM [MetaAnnot]
getTBAAMeta Unique
topN LlvmM [MetaAnnot]
-> ([MetaAnnot] -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CmmExpr
-> CmmExpr
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_slow CmmExpr
addr CmmExpr
val AlignmentSpec
alignment
genStore_fast :: CmmExpr -> GlobalRegUse -> Int -> CmmExpr -> AlignmentSpec
-> LlvmM StmtData
genStore_fast :: CmmExpr
-> GlobalRegUse
-> Int
-> CmmExpr
-> AlignmentSpec
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalRegUse
r Int
n CmmExpr
val AlignmentSpec
alignment
= do platform <- LlvmM Platform
getPlatform
(gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
meta <- getTBAARegMeta (globalRegUse_reg r)
let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8)
case isPointer grt && rem == 0 of
Bool
True -> do
(vval, stmts, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
val
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
case pLower grt == getVarType vval of
Bool
True -> do
let s3 :: LlvmStatement
s3 = LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
vval LlvmVar
ptr AlignmentSpec
alignment [MetaAnnot]
meta
(LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
s1 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s2
LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s3, [LlvmCmmDecl]
top)
Bool
False -> do
let ty :: LlvmType
ty = (LlvmType -> LlvmType
pLift (LlvmType -> LlvmType)
-> (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType) LlvmVar
vval
(ptr', s3) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Bitcast LlvmVar
ptr LlvmType
ty
let s4 = LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
vval LlvmVar
ptr' AlignmentSpec
alignment [MetaAnnot]
meta
return (stmts `appOL` s1 `snocOL` s2
`snocOL` s3 `snocOL` s4, top)
Bool
False -> CmmExpr
-> CmmExpr
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_slow CmmExpr
addr CmmExpr
val AlignmentSpec
alignment [MetaAnnot]
meta
genStore_slow :: CmmExpr -> CmmExpr -> AlignmentSpec -> [MetaAnnot] -> LlvmM StmtData
genStore_slow :: CmmExpr
-> CmmExpr
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_slow CmmExpr
addr CmmExpr
val AlignmentSpec
alignment [MetaAnnot]
meta = do
(vaddr, stmts1, top1) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
addr
(vval, stmts2, top2) <- exprToVar val
let stmts = LlvmStatements
stmts1 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts2
platform <- getPlatform
cfg <- getConfig
case getVarType vaddr of
LMPointer ty :: LlvmType
ty@(LMPointer LlvmType
_) | LlvmVar -> LlvmType
getVarType LlvmVar
vval LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> LlvmType
llvmWord Platform
platform -> do
(v, s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
vval LlvmType
ty
let s2 = LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
v LlvmVar
vaddr AlignmentSpec
alignment [MetaAnnot]
meta
return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
LMPointer LlvmType
_ -> do
let s1 :: LlvmStatement
s1 = LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
vval LlvmVar
vaddr AlignmentSpec
alignment [MetaAnnot]
meta
(LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top2)
i :: LlvmType
i@(LMInt Int
_) | LlvmType
i LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> LlvmType
llvmWord Platform
platform -> do
let vty :: LlvmType
vty = LlvmType -> LlvmType
pLift (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
vval
(vptr, s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
vty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
vaddr LlvmType
vty
let s2 = LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
vval LlvmVar
vptr AlignmentSpec
alignment [MetaAnnot]
meta
return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
LlvmType
other ->
String -> SDoc -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genStore: ptr not right type!"
(Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
addr SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Size of Ptr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Platform -> Int
llvmPtrBits Platform
platform) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Size of var:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform LlvmType
other) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Var:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> LlvmCgConfig -> LlvmVar -> SDoc
forall doc. IsLine doc => LlvmCgConfig -> LlvmVar -> doc
ppVar LlvmCgConfig
cfg LlvmVar
vaddr)
mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement
mkStore LlvmVar
vval LlvmVar
vptr AlignmentSpec
alignment [MetaAnnot]
metas =
LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
vval LlvmVar
vptr LMAlign
align [MetaAnnot]
metas
where
ty :: LlvmType
ty = LlvmType -> LlvmType
pLower (LlvmVar -> LlvmType
getVarType LlvmVar
vptr)
align :: LMAlign
align = case AlignmentSpec
alignment of
AlignmentSpec
_ | LlvmType -> Bool
isVector LlvmType
ty -> Int -> LMAlign
forall a. a -> Maybe a
Just Int
1
AlignmentSpec
Unaligned -> Int -> LMAlign
forall a. a -> Maybe a
Just Int
1
AlignmentSpec
NaturallyAligned -> LMAlign
forall a. Maybe a
Nothing
genBranch :: BlockId -> LlvmM StmtData
genBranch :: BlockId -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genBranch BlockId
id =
let label :: LlvmVar
label = BlockId -> LlvmVar
blockIdToLlvm BlockId
id
in (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL (LlvmStatement -> LlvmStatements)
-> LlvmStatement -> LlvmStatements
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmStatement
Branch LlvmVar
label, [])
genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData
genCondBranch :: CmmExpr
-> BlockId
-> BlockId
-> Maybe Bool
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCondBranch CmmExpr
cond BlockId
idT BlockId
idF Maybe Bool
likely = do
let labelT :: LlvmVar
labelT = BlockId -> LlvmVar
blockIdToLlvm BlockId
idT
let labelF :: LlvmVar
labelF = BlockId -> LlvmVar
blockIdToLlvm BlockId
idF
(vc, stmts1, top1) <- EOption -> CmmExpr -> LlvmM ExprData
exprToVarOpt EOption
i1Option CmmExpr
cond
if getVarType vc == i1
then do
(vc', (stmts2, top2)) <- case likely of
Just Bool
b -> Integer
-> LlvmType
-> LlvmVar
-> LlvmM (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
genExpectLit (if Bool
b then Integer
1 else Integer
0) LlvmType
i1 LlvmVar
vc
Maybe Bool
_ -> (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
-> LlvmM (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
forall a. a -> LlvmM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LlvmVar
vc, (LlvmStatements
forall a. OrdList a
nilOL, []))
let s1 = LlvmVar -> LlvmVar -> LlvmVar -> LlvmStatement
BranchIf LlvmVar
vc' LlvmVar
labelT LlvmVar
labelF
return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
else do
cfg <- getConfig
pprPanic "genCondBranch: Cond expr not bool! " $
lparen <> ppVar cfg vc <> rparen
genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
genExpectLit :: Integer
-> LlvmType
-> LlvmVar
-> LlvmM (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
genExpectLit Integer
expLit LlvmType
expTy LlvmVar
var = do
cfg <- LlvmM LlvmCgConfig
getConfig
let
lit = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit Integer
expLit LlvmType
expTy
llvmExpectName
| LlvmType -> Bool
isInt LlvmType
expTy = String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ String
"llvm.expect." String -> ShowS
forall a. [a] -> [a] -> [a]
++ SDocContext -> SDoc -> String
showSDocOneLine (LlvmCgConfig -> SDocContext
llvmCgContext LlvmCgConfig
cfg) (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
expTy)
| Bool
otherwise = String -> LMString
forall a. HasCallStack => String -> a
panic String
"genExpectedLit: Type not an int!"
(llvmExpect, stmts, top) <-
getInstrinct llvmExpectName expTy [expTy, expTy]
(var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []
return (var', (stmts `snocOL` call, top))
genSwitch :: UnreachableBlockId -> CmmExpr -> SwitchTargets -> LlvmM StmtData
genSwitch :: UnreachableBlockId
-> CmmExpr
-> SwitchTargets
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genSwitch (UnreachableBlockId BlockId
ubid) CmmExpr
cond SwitchTargets
ids = do
(vc, stmts, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
cond
let ty = LlvmVar -> LlvmType
getVarType LlvmVar
vc
let labels = [ (LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
ty Integer
ix, BlockId -> LlvmVar
blockIdToLlvm BlockId
b)
| (Integer
ix, BlockId
b) <- SwitchTargets -> [(Integer, BlockId)]
switchTargetsCases SwitchTargets
ids ]
let defLbl | Just BlockId
l <- SwitchTargets -> Maybe BlockId
switchTargetsDefault SwitchTargets
ids = BlockId -> LlvmVar
blockIdToLlvm BlockId
l
| Bool
otherwise = BlockId -> LlvmVar
blockIdToLlvm BlockId
ubid
let s1 = LlvmVar -> LlvmVar -> [(LlvmVar, LlvmVar)] -> LlvmStatement
Switch LlvmVar
vc LlvmVar
defLbl [(LlvmVar, LlvmVar)]
labels
return $ (stmts `snocOL` s1, top)
type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
newtype EOption = EOption { EOption -> Bool
i1Expected :: Bool }
i1Option :: EOption
i1Option :: EOption
i1Option = Bool -> EOption
EOption Bool
True
wordOption :: EOption
wordOption :: EOption
wordOption = Bool -> EOption
EOption Bool
False
exprToVar :: CmmExpr -> LlvmM ExprData
exprToVar :: CmmExpr -> LlvmM ExprData
exprToVar = EOption -> CmmExpr -> LlvmM ExprData
exprToVarOpt EOption
wordOption
exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
exprToVarOpt EOption
opt CmmExpr
e = case CmmExpr
e of
CmmLit CmmLit
lit
-> EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt CmmLit
lit
CmmLoad CmmExpr
e' CmmType
ty AlignmentSpec
align
-> Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
genLoad Atomic
forall a. Maybe a
Nothing CmmExpr
e' CmmType
ty AlignmentSpec
align
CmmReg CmmReg
r -> do
(v1, ty, s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal CmmReg
r
case isPointer ty of
Bool
True -> do
platform <- LlvmM Platform
getPlatform
(v2, s2) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint v1 (llvmWord platform)
return (v2, s1 `snocOL` s2, [])
Bool
False -> ExprData -> LlvmM ExprData
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatements
s1, [])
CmmMachOp MachOp
op [CmmExpr]
exprs
-> EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp EOption
opt MachOp
op [CmmExpr]
exprs
CmmRegOff CmmReg
r Int
i
-> CmmExpr -> LlvmM ExprData
exprToVar (CmmExpr -> LlvmM ExprData) -> CmmExpr -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ (CmmReg, Int) -> CmmExpr
expandCmmReg (CmmReg
r, Int
i)
CmmStackSlot Area
_ Int
_
-> String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic String
"exprToVar: CmmStackSlot not supported!"
genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp EOption
_ MachOp
op [CmmExpr
x] = case MachOp
op of
MO_Not Width
w ->
let all1 :: LlvmVar
all1 = LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit (Width -> LlvmType
widthToLlvmInt Width
w) (-Integer
1)
in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate (Width -> LlvmType
widthToLlvmInt Width
w) LlvmVar
all1 LlvmMachOp
LM_MO_Xor
MO_S_Neg Width
w ->
let all0 :: LlvmVar
all0 = LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit (Width -> LlvmType
widthToLlvmInt Width
w) Integer
0
in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate (Width -> LlvmType
widthToLlvmInt Width
w) LlvmVar
all0 LlvmMachOp
LM_MO_Sub
MO_F_Neg Width
w ->
let all0 :: LlvmVar
all0 = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Double -> LlvmType -> LlvmLit
LMFloatLit (-Double
0) (Width -> LlvmType
widthToLlvmFloat Width
w)
in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate (Width -> LlvmType
widthToLlvmFloat Width
w) LlvmVar
all0 LlvmMachOp
LM_MO_FSub
MO_SF_Round Width
_ Width
w -> LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv (Width -> LlvmType
widthToLlvmFloat Width
w) LlvmCastOp
LM_Sitofp
MO_FS_Truncate Width
_ Width
w -> LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv (Width -> LlvmType
widthToLlvmInt Width
w) LlvmCastOp
LM_Fptosi
MO_SS_Conv Width
from Width
to
-> Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv Width
from (Width -> LlvmType
widthToLlvmInt Width
to) LlvmCastOp
LM_Trunc LlvmCastOp
LM_Sext
MO_UU_Conv Width
from Width
to
-> Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv Width
from (Width -> LlvmType
widthToLlvmInt Width
to) LlvmCastOp
LM_Trunc LlvmCastOp
LM_Zext
MO_XX_Conv Width
from Width
to
-> Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv Width
from (Width -> LlvmType
widthToLlvmInt Width
to) LlvmCastOp
LM_Trunc LlvmCastOp
LM_Zext
MO_FF_Conv Width
from Width
to
-> Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv Width
from (Width -> LlvmType
widthToLlvmFloat Width
to) LlvmCastOp
LM_Fptrunc LlvmCastOp
LM_Fpext
MO_WF_Bitcast Width
w -> LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv (Width -> LlvmType
widthToLlvmFloat Width
w) LlvmCastOp
LM_Bitcast
MO_FW_Bitcast Width
w -> LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv (Width -> LlvmType
widthToLlvmInt Width
w) LlvmCastOp
LM_Bitcast
MO_VS_Neg Int
len Width
w ->
let ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmInt Width
w
vecty :: LlvmType
vecty = Int -> LlvmType -> LlvmType
LMVector Int
len LlvmType
ty
all0 :: LlvmLit
all0 = Integer -> LlvmType -> LlvmLit
LMIntLit (-Integer
0) LlvmType
ty
all0s :: LlvmVar
all0s = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ [LlvmLit] -> LlvmLit
LMVectorLit (Int -> LlvmLit -> [LlvmLit]
forall a. Int -> a -> [a]
replicate Int
len LlvmLit
all0)
in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negateVec LlvmType
vecty LlvmVar
all0s LlvmMachOp
LM_MO_Sub
MO_VF_Neg Int
len Width
w ->
let ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmFloat Width
w
vecty :: LlvmType
vecty = Int -> LlvmType -> LlvmType
LMVector Int
len LlvmType
ty
all0 :: LlvmLit
all0 = Double -> LlvmType -> LlvmLit
LMFloatLit (-Double
0) LlvmType
ty
all0s :: LlvmVar
all0s = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ [LlvmLit] -> LlvmLit
LMVectorLit (Int -> LlvmLit -> [LlvmLit]
forall a. Int -> a -> [a]
replicate Int
len LlvmLit
all0)
in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negateVec LlvmType
vecty LlvmVar
all0s LlvmMachOp
LM_MO_FSub
MO_V_Broadcast Int
l Width
w -> Int -> Width -> CmmExpr -> LlvmM ExprData
genBroadcastOp Int
l Width
w CmmExpr
x
MO_VF_Broadcast Int
l Width
w -> Int -> Width -> CmmExpr -> LlvmM ExprData
genBroadcastOp Int
l Width
w CmmExpr
x
MO_RelaxedRead Width
w -> CmmExpr -> LlvmM ExprData
exprToVar (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
x (Width -> CmmType
cmmBits Width
w) AlignmentSpec
NaturallyAligned)
MO_AlignmentCheck Int
_ Width
_ -> String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic String
"-falignment-sanitisation is not supported by -fllvm"
MO_Add Width
_ -> LlvmM ExprData
panicOp
MO_Mul Width
_ -> LlvmM ExprData
panicOp
MO_Sub Width
_ -> LlvmM ExprData
panicOp
MO_S_MulMayOflo Width
_ -> LlvmM ExprData
panicOp
MO_S_Quot Width
_ -> LlvmM ExprData
panicOp
MO_S_Rem Width
_ -> LlvmM ExprData
panicOp
MO_U_Quot Width
_ -> LlvmM ExprData
panicOp
MO_U_Rem Width
_ -> LlvmM ExprData
panicOp
MO_Eq Width
_ -> LlvmM ExprData
panicOp
MO_Ne Width
_ -> LlvmM ExprData
panicOp
MO_S_Ge Width
_ -> LlvmM ExprData
panicOp
MO_S_Gt Width
_ -> LlvmM ExprData
panicOp
MO_S_Le Width
_ -> LlvmM ExprData
panicOp
MO_S_Lt Width
_ -> LlvmM ExprData
panicOp
MO_U_Ge Width
_ -> LlvmM ExprData
panicOp
MO_U_Gt Width
_ -> LlvmM ExprData
panicOp
MO_U_Le Width
_ -> LlvmM ExprData
panicOp
MO_U_Lt Width
_ -> LlvmM ExprData
panicOp
MO_F_Add Width
_ -> LlvmM ExprData
panicOp
MO_F_Sub Width
_ -> LlvmM ExprData
panicOp
MO_F_Mul Width
_ -> LlvmM ExprData
panicOp
MO_F_Quot Width
_ -> LlvmM ExprData
panicOp
MO_F_Min Width
_ -> LlvmM ExprData
panicOp
MO_F_Max Width
_ -> LlvmM ExprData
panicOp
MO_FMA FMASign
_ Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_F_Eq Width
_ -> LlvmM ExprData
panicOp
MO_F_Ne Width
_ -> LlvmM ExprData
panicOp
MO_F_Ge Width
_ -> LlvmM ExprData
panicOp
MO_F_Gt Width
_ -> LlvmM ExprData
panicOp
MO_F_Le Width
_ -> LlvmM ExprData
panicOp
MO_F_Lt Width
_ -> LlvmM ExprData
panicOp
MO_And Width
_ -> LlvmM ExprData
panicOp
MO_Or Width
_ -> LlvmM ExprData
panicOp
MO_Xor Width
_ -> LlvmM ExprData
panicOp
MO_Shl Width
_ -> LlvmM ExprData
panicOp
MO_U_Shr Width
_ -> LlvmM ExprData
panicOp
MO_S_Shr Width
_ -> LlvmM ExprData
panicOp
MO_V_Insert Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_V_Extract Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_V_Add Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_V_Sub Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_V_Mul Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VS_Quot Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VS_Rem Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VS_Min Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VS_Max Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VU_Quot Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VU_Rem Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VU_Min Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VU_Max Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Insert Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Extract Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_V_Shuffle {} -> LlvmM ExprData
panicOp
MO_VF_Shuffle {} -> LlvmM ExprData
panicOp
MO_VF_Add Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Sub Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Mul Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Quot Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Min Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_VF_Max Int
_ Width
_ -> LlvmM ExprData
panicOp
where
negate :: LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate LlvmType
ty LlvmVar
v2 LlvmMachOp
negOp = do
(vx, stmts, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
return (v1, stmts `snocOL` s1, top)
negateVec :: LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negateVec LlvmType
ty LlvmVar
v2 LlvmMachOp
negOp = do
(vx, stmts1, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
(vxs', stmts2) <- castVars Signed [(vx, ty)]
let vx' = String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic String
"genMachOp: negateVec" [LlvmVar]
vxs'
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
fiConv :: LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv LlvmType
ty LlvmCastOp
convOp = do
(vx, stmts, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
(v1, s1) <- doExpr ty $ Cast convOp vx ty
return (v1, stmts `snocOL` s1, top)
sameConv :: Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv Width
from LlvmType
ty LlvmCastOp
reduce LlvmCastOp
expand = do
x'@(vx, stmts, top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
let sameConv' LlvmCastOp
op = do
(v1, s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
op LlvmVar
vx LlvmType
ty
return (v1, stmts `snocOL` s1, top)
platform <- getPlatform
let toWidth = Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform LlvmType
ty
case widthInBits from of
Int
w | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
toWidth -> LlvmCastOp -> LlvmM ExprData
sameConv' LlvmCastOp
expand
Int
w | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
toWidth -> LlvmCastOp -> LlvmM ExprData
sameConv' LlvmCastOp
reduce
Int
_w -> ExprData -> LlvmM ExprData
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return ExprData
x'
panicOp :: LlvmM ExprData
panicOp = String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic (String -> LlvmM ExprData) -> String -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ String
"LLVM.CodeGen.genMachOp: non unary op encountered"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"with one argument! (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ MachOp -> String
forall a. Show a => a -> String
show MachOp
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
genMachOp EOption
opt o :: MachOp
o@(MO_Add Width
_) e :: [CmmExpr]
e@[(CmmReg (CmmGlobal GlobalRegUse
r)), (CmmLit (CmmInt Integer
n Width
_))]
= EOption
-> MachOp -> GlobalRegUse -> Int -> [CmmExpr] -> LlvmM ExprData
genMachOp_fast EOption
opt MachOp
o GlobalRegUse
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) [CmmExpr]
e
genMachOp EOption
opt o :: MachOp
o@(MO_Sub Width
_) e :: [CmmExpr]
e@[(CmmReg (CmmGlobal GlobalRegUse
r)), (CmmLit (CmmInt Integer
n Width
_))]
= EOption
-> MachOp -> GlobalRegUse -> Int -> [CmmExpr] -> LlvmM ExprData
genMachOp_fast EOption
opt MachOp
o GlobalRegUse
r (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> (Integer -> Int) -> Integer -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Integer
n) [CmmExpr]
e
genMachOp EOption
opt MachOp
op [CmmExpr]
e = EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow EOption
opt MachOp
op [CmmExpr]
e
genMachOp_fast :: EOption -> MachOp -> GlobalRegUse -> Int -> [CmmExpr]
-> LlvmM ExprData
genMachOp_fast :: EOption
-> MachOp -> GlobalRegUse -> Int -> [CmmExpr] -> LlvmM ExprData
genMachOp_fast EOption
opt MachOp
op GlobalRegUse
r Int
n [CmmExpr]
e
= do (gv, grt, s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal (GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
r)
platform <- getPlatform
let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8)
case isPointer grt && rem == 0 of
Bool
True -> do
(ptr, s2) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
grt (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ Bool -> LlvmVar -> [LlvmVar] -> LlvmExpression
GetElemPtr Bool
True LlvmVar
gv [Int -> LlvmVar
forall a. Integral a => a -> LlvmVar
toI32 Int
ix]
(var, s3) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint ptr (llvmWord platform)
return (var, s1 `snocOL` s2 `snocOL` s3, [])
Bool
False -> EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow EOption
opt MachOp
op [CmmExpr]
e
genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow EOption
_ (MO_V_Extract Int
l Width
w) [CmmExpr
val, CmmExpr
idx] = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
vidx <- exprToVarW idx
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, LMVector l ty)]
doExprW ty $ Extract vval' vidx
where
ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmInt Width
w
genMachOp_slow EOption
_ (MO_VF_Extract Int
l Width
w) [CmmExpr
val, CmmExpr
idx] = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
vidx <- exprToVarW idx
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, LMVector l ty)]
doExprW ty $ Extract vval' vidx
where
ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmFloat Width
w
genMachOp_slow EOption
_ (MO_V_Insert Int
l Width
w) [CmmExpr
val, CmmExpr
elt, CmmExpr
idx] = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
velt <- exprToVarW elt
vidx <- exprToVarW idx
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, ty)]
doExprW ty $ Insert vval' velt vidx
where
ty :: LlvmType
ty = Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)
genMachOp_slow EOption
_ (MO_VF_Insert Int
l Width
w) [CmmExpr
val, CmmExpr
elt, CmmExpr
idx] = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
velt <- exprToVarW elt
vidx <- exprToVarW idx
vval' <- singletonPanic "genMachOp_slow" <$>
castVarsW Signed [(vval, ty)]
doExprW ty $ Insert vval' velt vidx
where
ty :: LlvmType
ty = Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)
genMachOp_slow EOption
opt MachOp
op [CmmExpr
x, CmmExpr
y] = case MachOp
op of
MO_Eq Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Eq
MO_Ne Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ne
MO_S_Gt Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Sgt
MO_S_Ge Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Sge
MO_S_Lt Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Slt
MO_S_Le Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Sle
MO_U_Gt Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ugt
MO_U_Ge Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Uge
MO_U_Lt Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ult
MO_U_Le Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ule
MO_Add Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Add
MO_Sub Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Sub
MO_Mul Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Mul
MO_S_MulMayOflo Width
w -> Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
isSMulOK Width
w CmmExpr
x CmmExpr
y
MO_S_Quot Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_SDiv
MO_S_Rem Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_SRem
MO_U_Quot Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_UDiv
MO_U_Rem Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_URem
MO_F_Eq Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Feq
MO_F_Ne Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fne
MO_F_Gt Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fgt
MO_F_Ge Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fge
MO_F_Lt Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Flt
MO_F_Le Width
_ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fle
MO_F_Add Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FAdd
MO_F_Sub Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FSub
MO_F_Mul Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FMul
MO_F_Quot Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FDiv
MO_FMA FMASign
_ Int
_ Width
_ -> LlvmM ExprData
panicOp
MO_And Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_And
MO_Or Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Or
MO_Xor Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Xor
MO_Shl Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinCastYMach LlvmMachOp
LM_MO_Shl
MO_U_Shr Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinCastYMach LlvmMachOp
LM_MO_LShr
MO_S_Shr Width
_ -> LlvmMachOp -> LlvmM ExprData
genBinCastYMach LlvmMachOp
LM_MO_AShr
MO_V_Add Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_Add
MO_V_Sub Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_Sub
MO_V_Mul Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_Mul
MO_VS_Quot Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_SDiv
MO_VS_Rem Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_SRem
MO_VU_Quot Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_UDiv
MO_VU_Rem Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)) LlvmMachOp
LM_MO_URem
MO_VF_Add Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)) LlvmMachOp
LM_MO_FAdd
MO_VF_Sub Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)) LlvmMachOp
LM_MO_FSub
MO_VF_Mul Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)) LlvmMachOp
LM_MO_FMul
MO_VF_Quot Int
l Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)) LlvmMachOp
LM_MO_FDiv
MO_Not Width
_ -> LlvmM ExprData
panicOp
MO_S_Neg Width
_ -> LlvmM ExprData
panicOp
MO_F_Neg Width
_ -> LlvmM ExprData
panicOp
MO_SF_Round Width
_ Width
_ -> LlvmM ExprData
panicOp
MO_FS_Truncate Width
_ Width
_ -> LlvmM ExprData
panicOp
MO_SS_Conv Width
_ Width
_ -> LlvmM ExprData
panicOp
MO_UU_Conv Width
_ Width
_ -> LlvmM ExprData
panicOp
MO_XX_Conv Width
_ Width
_ -> LlvmM ExprData
panicOp
MO_FF_Conv Width
_ Width
_ -> LlvmM ExprData
panicOp
MO_WF_Bitcast Width
_to -> LlvmM ExprData
panicOp
MO_FW_Bitcast Width
_to -> LlvmM ExprData
panicOp
MO_VS_Neg {} -> LlvmM ExprData
panicOp
MO_VF_Broadcast {} -> LlvmM ExprData
panicOp
MO_V_Broadcast {} -> LlvmM ExprData
panicOp
MO_V_Insert {} -> LlvmM ExprData
panicOp
MO_VF_Insert {} -> LlvmM ExprData
panicOp
MO_V_Shuffle Int
_ Width
_ [Int]
is -> [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData
genShuffleOp [Int]
is CmmExpr
x CmmExpr
y
MO_VF_Shuffle Int
_ Width
_ [Int]
is -> [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData
genShuffleOp [Int]
is CmmExpr
x CmmExpr
y
MO_VF_Neg {} -> LlvmM ExprData
panicOp
MO_F_Min {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"minnum" CmmExpr
x CmmExpr
y
MO_F_Max {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"maxnum" CmmExpr
x CmmExpr
y
MO_VF_Min {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"minnum" CmmExpr
x CmmExpr
y
MO_VF_Max {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"maxnum" CmmExpr
x CmmExpr
y
MO_VU_Min {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"umin" CmmExpr
x CmmExpr
y
MO_VU_Max {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"umax" CmmExpr
x CmmExpr
y
MO_VS_Min {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"smin" CmmExpr
x CmmExpr
y
MO_VS_Max {} -> String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
"smax" CmmExpr
x CmmExpr
y
MO_RelaxedRead {} -> LlvmM ExprData
panicOp
MO_AlignmentCheck {} -> LlvmM ExprData
panicOp
where
binLlvmOp :: (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> Bool -> LlvmM ExprData
binLlvmOp LlvmVar -> LlvmType
ty LlvmVar -> LlvmVar -> LlvmExpression
binOp Bool
allow_y_cast = do
platform <- LlvmM Platform
getPlatform
runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
if | getVarType vx == getVarType vy
-> doExprW (ty vx) $ binOp vx vy
| allow_y_cast
-> do
vy' <- singletonPanic "binLlvmOp cast"<$>
castVarsW Signed [(vy, (ty vx))]
doExprW (ty vx) $ binOp vx vy'
| otherwise
-> pprPanic "binLlvmOp types" (pdoc platform x $$ pdoc platform y)
binCastLlvmOp :: LlvmType
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binCastLlvmOp LlvmType
ty LlvmVar -> LlvmVar -> LlvmExpression
binOp = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
vy <- exprToVarW y
vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
case vxy' of
[LlvmVar
vx',LlvmVar
vy'] -> LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
ty (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmExpression
binOp LlvmVar
vx' LlvmVar
vy'
[LlvmVar]
_ -> String -> WriterT LlvmAccum LlvmM LlvmVar
forall a. HasCallStack => String -> a
panic String
"genMachOp_slow: binCastLlvmOp"
genBinComp :: EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
cmp = do
ed@(v1, stmts, top) <- (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> Bool -> LlvmM ExprData
binLlvmOp (LlvmType -> LlvmVar -> LlvmType
forall a b. a -> b -> a
const LlvmType
i1) (LlvmCmpOp -> LlvmVar -> LlvmVar -> LlvmExpression
Compare LlvmCmpOp
cmp) Bool
False
platform <- getPlatform
if getVarType v1 == i1
then case i1Expected opt of
Bool
True -> ExprData -> LlvmM ExprData
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return ExprData
ed
Bool
False -> do
let w_ :: LlvmType
w_ = Platform -> LlvmType
llvmWord Platform
platform
(v2, s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
w_ (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Zext LlvmVar
v1 LlvmType
w_
return (v2, stmts `snocOL` s1, top)
else
pprPanic "genBinComp: Compare returned type other then i1! "
(ppr $ getVarType v1)
genBinMach :: LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
op = (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> Bool -> LlvmM ExprData
binLlvmOp LlvmVar -> LlvmType
getVarType (LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
op) Bool
False
genBinCastYMach :: LlvmMachOp -> LlvmM ExprData
genBinCastYMach LlvmMachOp
op = (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> Bool -> LlvmM ExprData
binLlvmOp LlvmVar -> LlvmType
getVarType (LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
op) Bool
True
genCastBinMach :: LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach LlvmType
ty LlvmMachOp
op = LlvmType
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binCastLlvmOp LlvmType
ty (LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
op)
genMinMaxOp :: String -> CmmExpr -> CmmExpr -> LlvmM ExprData
genMinMaxOp String
intrin CmmExpr
x CmmExpr
y = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
vy <- exprToVarW y
let tx = LlvmVar -> LlvmType
getVarType LlvmVar
vx
ty = LlvmVar -> LlvmType
getVarType LlvmVar
vy
fname = String
"llvm." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
intrin String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ LlvmType -> String
ppLlvmTypeShort LlvmType
ty
Panic.massertPpr
(tx == ty)
(vcat [ text (fname ++ ": mismatched arg types")
, ppLlvmType tx, ppLlvmType ty ])
fptr <- liftExprData $ getInstrinct (fsLit fname) ty [tx, ty]
doExprW tx $ Call StdCall fptr [vx, vy] [ReadNone, NoUnwind]
isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
isSMulOK Width
_ CmmExpr
x CmmExpr
y = do
platform <- LlvmM Platform
getPlatform
runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
let word = LlvmVar -> LlvmType
getVarType LlvmVar
vx
let word2 = Int -> LlvmType
LMInt (Int -> LlvmType) -> Int -> LlvmType
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform (LlvmVar -> LlvmType
getVarType LlvmVar
vx)
let shift = Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform LlvmType
word
let shift1 = Platform -> Int -> LlvmVar
forall a. Integral a => Platform -> a -> LlvmVar
toIWord Platform
platform (Int
shift Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
let shift2 = Platform -> Int -> LlvmVar
forall a. Integral a => Platform -> a -> LlvmVar
toIWord Platform
platform Int
shift
if isInt word
then do
x1 <- doExprW word2 $ Cast LM_Sext vx word2
y1 <- doExprW word2 $ Cast LM_Sext vy word2
r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
rlow1 <- doExprW word $ Cast LM_Trunc r1 word
rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
else
pprPanic "isSMulOK: Not bit type! " $
lparen <> ppr word <> rparen
panicOp :: LlvmM ExprData
panicOp = String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic (String -> LlvmM ExprData) -> String -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ String
"LLVM.CodeGen.genMachOp_slow: non-binary op encountered "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"with two arguments! (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ MachOp -> String
forall a. Show a => a -> String
show MachOp
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
genMachOp_slow EOption
_opt MachOp
op [CmmExpr
x, CmmExpr
y, CmmExpr
z] = do
let
panicOp :: LlvmM ExprData
panicOp = String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic (String -> LlvmM ExprData) -> String -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ String
"LLVM.CodeGen.genMachOp_slow: non-ternary op encountered "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"with three arguments! (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ MachOp -> String
forall a. Show a => a -> String
show MachOp
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
case MachOp
op of
MO_FMA FMASign
var Int
lg Width
width ->
case FMASign
var of
FMASign
FMAdd -> CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp CmmExpr
x CmmExpr
y CmmExpr
z
FMASign
FMSub -> CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp CmmExpr
x CmmExpr
y (CmmExpr -> CmmExpr
neg CmmExpr
z)
FMASign
FNMAdd -> CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp (CmmExpr -> CmmExpr
neg CmmExpr
x) CmmExpr
y CmmExpr
z
FMASign
FNMSub -> CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp (CmmExpr -> CmmExpr
neg CmmExpr
x) CmmExpr
y (CmmExpr -> CmmExpr
neg CmmExpr
z)
where
neg :: CmmExpr -> CmmExpr
neg CmmExpr
x
| Int
lg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
= MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_F_Neg Width
width) [CmmExpr
x]
| Bool
otherwise
= MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Int -> Width -> MachOp
MO_VF_Neg Int
lg Width
width) [CmmExpr
x]
MachOp
_ -> LlvmM ExprData
panicOp
genMachOp_slow EOption
_ MachOp
_ [CmmExpr]
_ = String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic String
"genMachOp_slow: More than 3 expressions in MachOp!"
genBroadcastOp :: Int -> Width -> CmmExpr -> LlvmM ExprData
genBroadcastOp :: Int -> Width -> CmmExpr -> LlvmM ExprData
genBroadcastOp Int
lg Width
_width CmmExpr
x = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
var_x <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
let tx = LlvmVar -> LlvmType
getVarType LlvmVar
var_x
tv = Int -> LlvmType -> LlvmType
LMVector Int
lg LlvmType
tx
z = if LlvmType -> Bool
isFloat LlvmType
tx
then Double -> LlvmType -> LlvmLit
LMFloatLit Double
0 LlvmType
tx
else Integer -> LlvmType -> LlvmLit
LMIntLit Integer
0 LlvmType
tx
zs = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ [LlvmLit] -> LlvmLit
LMVectorLit ([LlvmLit] -> LlvmLit) -> [LlvmLit] -> LlvmLit
forall a b. (a -> b) -> a -> b
$ Int -> LlvmLit -> [LlvmLit]
forall a. Int -> a -> [a]
replicate Int
lg LlvmLit
z
w <- doExprW tv $ Insert zs var_x (LMLitVar $ LMIntLit 0 (LMInt 32))
doExprW tv $ Shuffle w w (replicate lg 0)
genShuffleOp :: [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData
genShuffleOp :: [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData
genShuffleOp [Int]
is CmmExpr
x CmmExpr
y = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
vy <- exprToVarW y
let tx = LlvmVar -> LlvmType
getVarType LlvmVar
vx
ty = LlvmVar -> LlvmType
getVarType LlvmVar
vy
Panic.massertPpr
(tx == ty)
(vcat [ text "shuffle: mismatched arg types"
, ppLlvmType tx, ppLlvmType ty ])
doExprW tx $ Shuffle vx vy is
genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp CmmExpr
x CmmExpr
y CmmExpr
z = WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData (WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData)
-> WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ do
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
vy <- exprToVarW y
vz <- exprToVarW z
let tx = LlvmVar -> LlvmType
getVarType LlvmVar
vx
ty = LlvmVar -> LlvmType
getVarType LlvmVar
vy
tz = LlvmVar -> LlvmType
getVarType LlvmVar
vz
Panic.massertPpr
(tx == ty && tx == tz)
(vcat [ text "fma: mismatched arg types"
, ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ])
let fname = case LlvmType
tx of
LlvmType
LMFloat -> String -> LMString
fsLit String
"llvm.fma.f32"
LlvmType
LMDouble -> String -> LMString
fsLit String
"llvm.fma.f64"
LMVector Int
4 LlvmType
LMFloat -> String -> LMString
fsLit String
"llvm.fma.v4f32"
LMVector Int
8 LlvmType
LMFloat -> String -> LMString
fsLit String
"llvm.fma.v8f32"
LMVector Int
16 LlvmType
LMFloat -> String -> LMString
fsLit String
"llvm.fma.v16f32"
LMVector Int
2 LlvmType
LMDouble -> String -> LMString
fsLit String
"llvm.fma.v2f64"
LMVector Int
4 LlvmType
LMDouble -> String -> LMString
fsLit String
"llvm.fma.v4f64"
LMVector Int
8 LlvmType
LMDouble -> String -> LMString
fsLit String
"llvm.fma.v8f64"
LlvmType
_ -> String -> SDoc -> LMString
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"CmmToLlvm.genFmaOp: unsupported type" (LlvmType -> SDoc
forall doc. IsLine doc => LlvmType -> doc
ppLlvmType LlvmType
tx)
fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz]
doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind]
genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
genLoad Atomic
atomic e :: CmmExpr
e@(CmmReg (CmmGlobal GlobalRegUse
r)) CmmType
ty AlignmentSpec
align
= Atomic
-> CmmExpr
-> GlobalRegUse
-> Int
-> CmmType
-> AlignmentSpec
-> LlvmM ExprData
genLoad_fast Atomic
atomic CmmExpr
e GlobalRegUse
r Int
0 CmmType
ty AlignmentSpec
align
genLoad Atomic
atomic e :: CmmExpr
e@(CmmRegOff (CmmGlobal GlobalRegUse
r) Int
n) CmmType
ty AlignmentSpec
align
= Atomic
-> CmmExpr
-> GlobalRegUse
-> Int
-> CmmType
-> AlignmentSpec
-> LlvmM ExprData
genLoad_fast Atomic
atomic CmmExpr
e GlobalRegUse
r Int
n CmmType
ty AlignmentSpec
align
genLoad Atomic
atomic e :: CmmExpr
e@(CmmMachOp (MO_Add Width
_) [
(CmmReg (CmmGlobal GlobalRegUse
r)),
(CmmLit (CmmInt Integer
n Width
_))])
CmmType
ty AlignmentSpec
align
= Atomic
-> CmmExpr
-> GlobalRegUse
-> Int
-> CmmType
-> AlignmentSpec
-> LlvmM ExprData
genLoad_fast Atomic
atomic CmmExpr
e GlobalRegUse
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) CmmType
ty AlignmentSpec
align
genLoad Atomic
atomic e :: CmmExpr
e@(CmmMachOp (MO_Sub Width
_) [
(CmmReg (CmmGlobal GlobalRegUse
r)),
(CmmLit (CmmInt Integer
n Width
_))])
CmmType
ty AlignmentSpec
align
= Atomic
-> CmmExpr
-> GlobalRegUse
-> Int
-> CmmType
-> AlignmentSpec
-> LlvmM ExprData
genLoad_fast Atomic
atomic CmmExpr
e GlobalRegUse
r (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) CmmType
ty AlignmentSpec
align
genLoad Atomic
atomic CmmExpr
e CmmType
ty AlignmentSpec
align
= Unique -> LlvmM [MetaAnnot]
getTBAAMeta Unique
topN LlvmM [MetaAnnot]
-> ([MetaAnnot] -> LlvmM ExprData) -> LlvmM ExprData
forall a b. LlvmM a -> (a -> LlvmM b) -> LlvmM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Atomic
-> CmmExpr
-> CmmType
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM ExprData
genLoad_slow Atomic
atomic CmmExpr
e CmmType
ty AlignmentSpec
align
genLoad_fast :: Atomic -> CmmExpr -> GlobalRegUse -> Int -> CmmType
-> AlignmentSpec -> LlvmM ExprData
genLoad_fast :: Atomic
-> CmmExpr
-> GlobalRegUse
-> Int
-> CmmType
-> AlignmentSpec
-> LlvmM ExprData
genLoad_fast Atomic
atomic CmmExpr
e GlobalRegUse
r Int
n CmmType
ty AlignmentSpec
align = do
platform <- LlvmM Platform
getPlatform
(gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
meta <- getTBAARegMeta (globalRegUse_reg r)
let ty' = CmmType -> LlvmType
cmmToLlvmType CmmType
ty
(ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8)
case isPointer grt && rem == 0 of
Bool
True -> do
(ptr, s2) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
grt (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ Bool -> LlvmVar -> [LlvmVar] -> LlvmExpression
GetElemPtr Bool
True LlvmVar
gv [Int -> LlvmVar
forall a. Integral a => a -> LlvmVar
toI32 Int
ix]
case grt == ty' of
Bool
True -> do
(var, s3) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty' ([MetaAnnot] -> LlvmExpression -> LlvmExpression
MExpr [MetaAnnot]
meta (LlvmExpression -> LlvmExpression)
-> LlvmExpression -> LlvmExpression
forall a b. (a -> b) -> a -> b
$ Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression
mkLoad Atomic
atomic LlvmVar
ptr AlignmentSpec
align)
return (var, s1 `snocOL` s2 `snocOL` s3,
[])
Bool
False -> do
let pty :: LlvmType
pty = LlvmType -> LlvmType
pLift LlvmType
ty'
(ptr', s3) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
pty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Bitcast LlvmVar
ptr LlvmType
pty
(var, s4) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr' align)
return (var, s1 `snocOL` s2 `snocOL` s3
`snocOL` s4, [])
Bool
False -> Atomic
-> CmmExpr
-> CmmType
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM ExprData
genLoad_slow Atomic
atomic CmmExpr
e CmmType
ty AlignmentSpec
align [MetaAnnot]
meta
genLoad_slow :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> [MetaAnnot]
-> LlvmM ExprData
genLoad_slow :: Atomic
-> CmmExpr
-> CmmType
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM ExprData
genLoad_slow Atomic
atomic CmmExpr
e CmmType
ty AlignmentSpec
align [MetaAnnot]
meta = do
platform <- LlvmM Platform
getPlatform
cfg <- getConfig
runExprData $ do
iptr <- exprToVarW e
case getVarType iptr of
LMPointer LlvmType
_ ->
LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW (CmmType -> LlvmType
cmmToLlvmType CmmType
ty) ([MetaAnnot] -> LlvmExpression -> LlvmExpression
MExpr [MetaAnnot]
meta (LlvmExpression -> LlvmExpression)
-> LlvmExpression -> LlvmExpression
forall a b. (a -> b) -> a -> b
$ Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression
mkLoad Atomic
atomic LlvmVar
iptr AlignmentSpec
align)
i :: LlvmType
i@(LMInt Int
_) | LlvmType
i LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> LlvmType
llvmWord Platform
platform -> do
let pty :: LlvmType
pty = LlvmType -> LlvmType
LMPointer (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmType -> LlvmType
cmmToLlvmType CmmType
ty
ptr <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
pty (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
iptr LlvmType
pty
doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align)
LlvmType
other -> String -> SDoc -> WriterT LlvmAccum LlvmM LlvmVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"exprToVar: CmmLoad expression is not right type!"
(Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Size of Ptr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Platform -> Int
llvmPtrBits Platform
platform) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Size of var:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Platform -> LlvmType -> Int
llvmWidthInBits Platform
platform LlvmType
other) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Var:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (LlvmCgConfig -> LlvmVar -> SDoc
forall doc. IsLine doc => LlvmCgConfig -> LlvmVar -> doc
ppVar LlvmCgConfig
cfg LlvmVar
iptr))
mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression
mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression
mkLoad Atomic
atomic LlvmVar
vptr AlignmentSpec
alignment
| Just MemoryOrdering
mem_ord <- Atomic
atomic
= LlvmSyncOrdering -> Bool -> LlvmVar -> LlvmExpression
ALoad (MemoryOrdering -> LlvmSyncOrdering
convertMemoryOrdering MemoryOrdering
mem_ord) Bool
False LlvmVar
vptr
| Bool
otherwise = LlvmVar -> LMAlign -> LlvmExpression
Load LlvmVar
vptr LMAlign
align
where
ty :: LlvmType
ty = LlvmType -> LlvmType
pLower (LlvmVar -> LlvmType
getVarType LlvmVar
vptr)
align :: LMAlign
align = case AlignmentSpec
alignment of
AlignmentSpec
_ | LlvmType -> Bool
isVector LlvmType
ty -> Int -> LMAlign
forall a. a -> Maybe a
Just Int
1
AlignmentSpec
Unaligned -> Int -> LMAlign
forall a. a -> Maybe a
Just Int
1
AlignmentSpec
NaturallyAligned -> LMAlign
forall a. Maybe a
Nothing
getCmmReg :: CmmReg -> LlvmM LlvmVar
getCmmReg :: CmmReg -> LlvmM LlvmVar
getCmmReg (CmmLocal (LocalReg Unique
un CmmType
_))
= do exists <- Unique -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup Unique
un
case exists of
Just LlvmType
ety -> LlvmVar -> LlvmM LlvmVar
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> LlvmType -> LlvmVar
LMLocalVar Unique
un (LlvmType -> LlvmVar) -> LlvmType -> LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmType
pLift LlvmType
ety)
Maybe LlvmType
Nothing -> String -> SDoc -> LlvmM LlvmVar
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getCmmReg: Cmm register " (SDoc -> LlvmM LlvmVar) -> SDoc -> LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$
Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
un SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" was not allocated!"
getCmmReg (CmmGlobal ru :: GlobalRegUse
ru@(GlobalRegUse GlobalReg
r CmmType
_))
= do onStack <- GlobalReg -> LlvmM Bool
checkStackReg GlobalReg
r
platform <- getPlatform
if onStack
then return (lmGlobalRegVar platform ru)
else pprPanic "getCmmReg: Cmm register " $
ppr r <> text " not stack-allocated!"
getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal CmmReg
reg =
case CmmReg
reg of
CmmGlobal GlobalRegUse
g -> do
onStack <- GlobalReg -> LlvmM Bool
checkStackReg (GlobalRegUse -> GlobalReg
globalRegUse_reg GlobalRegUse
g)
platform <- getPlatform
if onStack then loadFromStack else do
let r = Platform -> GlobalRegUse -> LlvmVar
lmGlobalRegArg Platform
platform GlobalRegUse
g
return (r, getVarType r, nilOL)
CmmReg
_ -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
loadFromStack
where loadFromStack :: LlvmM (LlvmVar, LlvmType, LlvmStatements)
loadFromStack = do
ptr <- CmmReg -> LlvmM LlvmVar
getCmmReg CmmReg
reg
let ty = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
ptr
(v, s) <- doExpr ty (Load ptr Nothing)
return (v, ty, unitOL s)
allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
allocReg (CmmLocal (LocalReg Unique
un CmmType
ty))
= let ty' :: LlvmType
ty' = CmmType -> LlvmType
cmmToLlvmType CmmType
ty
var :: LlvmVar
var = Unique -> LlvmType -> LlvmVar
LMLocalVar Unique
un (LlvmType -> LlvmType
LMPointer LlvmType
ty')
alc :: LlvmExpression
alc = LlvmType -> Int -> LlvmExpression
Alloca LlvmType
ty' Int
1
in (LlvmVar
var, LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL (LlvmStatement -> LlvmStatements)
-> LlvmStatement -> LlvmStatements
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmExpression -> LlvmStatement
Assignment LlvmVar
var LlvmExpression
alc)
allocReg CmmReg
_ = String -> (LlvmVar, LlvmStatements)
forall a. HasCallStack => String -> a
panic (String -> (LlvmVar, LlvmStatements))
-> String -> (LlvmVar, LlvmStatements)
forall a b. (a -> b) -> a -> b
$ String
"allocReg: Global reg encountered! Global registers should"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" have been handled elsewhere!"
genLit :: EOption -> CmmLit -> LlvmM ExprData
genLit :: EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt (CmmInt Integer
i Width
w)
= let width :: LlvmType
width | EOption -> Bool
i1Expected EOption
opt = LlvmType
i1
| Bool
otherwise = Int -> LlvmType
LMInt (Width -> Int
widthInBits Width
w)
in ExprData -> LlvmM ExprData
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
width Integer
i, LlvmStatements
forall a. OrdList a
nilOL, [])
genLit EOption
_ (CmmFloat Rational
r Width
W32)
= ExprData -> LlvmM ExprData
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Double -> LlvmType -> LlvmLit
LMFloatLit (Float -> Double
widenFp (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r :: Float)) (Width -> LlvmType
widthToLlvmFloat Width
W32),
LlvmStatements
forall a. OrdList a
nilOL, [])
genLit EOption
_ (CmmFloat Rational
r Width
W64)
= ExprData -> LlvmM ExprData
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Double -> LlvmType -> LlvmLit
LMFloatLit (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r :: Double) (Width -> LlvmType
widthToLlvmFloat Width
W64),
LlvmStatements
forall a. OrdList a
nilOL, [])
genLit EOption
_ (CmmFloat Rational
_r Width
_w)
= String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic String
"genLit (CmmLit:CmmFloat), unsupported float lit"
genLit EOption
opt (CmmVec [CmmLit]
ls)
= do llvmLits <- (CmmLit -> LlvmM LlvmLit) -> [CmmLit] -> LlvmM [LlvmLit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmLit -> LlvmM LlvmLit
toLlvmLit [CmmLit]
ls
return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
where
toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit CmmLit
lit = do
(llvmLitVar, _, _) <- EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt CmmLit
lit
case llvmLitVar of
LMLitVar LlvmLit
llvmLit -> LlvmLit -> LlvmM LlvmLit
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return LlvmLit
llvmLit
LlvmVar
_ -> String -> LlvmM LlvmLit
forall a. HasCallStack => String -> a
panic String
"genLit"
genLit EOption
_ cmm :: CmmLit
cmm@(CmmLabel CLabel
l)
= do var <- LMString -> LlvmM LlvmVar
getGlobalPtr (LMString -> LlvmM LlvmVar) -> LlvmM LMString -> LlvmM LlvmVar
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CLabel -> LlvmM LMString
strCLabel_llvm CLabel
l
platform <- getPlatform
let lmty = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
cmm
(v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord platform)
return (v1, unitOL s1, [])
genLit EOption
opt (CmmLabelOff CLabel
label Int
off) = do
platform <- LlvmM Platform
getPlatform
(vlbl, stmts, stat) <- genLit opt (CmmLabel label)
let voff = Platform -> Int -> LlvmVar
forall a. Integral a => Platform -> a -> LlvmVar
toIWord Platform
platform Int
off
(v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
return (v1, stmts `snocOL` s1, stat)
genLit EOption
opt (CmmLabelDiffOff CLabel
l1 CLabel
l2 Int
off Width
w) = do
platform <- LlvmM Platform
getPlatform
(vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
(vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
let voff = Platform -> Int -> LlvmVar
forall a. Integral a => Platform -> a -> LlvmVar
toIWord Platform
platform Int
off
let ty1 = LlvmVar -> LlvmType
getVarType LlvmVar
vl1
let ty2 = LlvmVar -> LlvmType
getVarType LlvmVar
vl2
if (isInt ty1) && (isInt ty2)
&& (llvmWidthInBits platform ty1 == llvmWidthInBits platform ty2)
then do
(v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
(v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
let ty = Width -> LlvmType
widthToLlvmInt Width
w
let stmts = LlvmStatements
stmts1 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts2 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s2
if w /= wordWidth platform
then do
(v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
return (v3, stmts `snocOL` s3, stat1 ++ stat2)
else
return (v2, stmts, stat1 ++ stat2)
else
panic "genLit: CmmLabelDiffOff encountered with different label ty!"
genLit EOption
opt (CmmBlock BlockId
b)
= EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt (CLabel -> CmmLit
CmmLabel (CLabel -> CmmLit) -> CLabel -> CmmLit
forall a b. (a -> b) -> a -> b
$ BlockId -> CLabel
infoTblLbl BlockId
b)
genLit EOption
_ CmmLit
CmmHighStackMark
= String -> LlvmM ExprData
forall a. HasCallStack => String -> a
panic String
"genStaticLit - CmmHighStackMark unsupported!"
convertMemoryOrdering :: MemoryOrdering -> LlvmSyncOrdering
convertMemoryOrdering :: MemoryOrdering -> LlvmSyncOrdering
convertMemoryOrdering MemoryOrdering
MemOrderRelaxed = LlvmSyncOrdering
SyncMonotonic
convertMemoryOrdering MemoryOrdering
MemOrderAcquire = LlvmSyncOrdering
SyncAcquire
convertMemoryOrdering MemoryOrdering
MemOrderRelease = LlvmSyncOrdering
SyncRelease
convertMemoryOrdering MemoryOrdering
MemOrderSeqCst = LlvmSyncOrdering
SyncSeqCst
funPrologue :: LiveGlobalRegUses -> [CmmBlock] -> LlvmM StmtData
funPrologue :: [GlobalRegUse]
-> [CmmBlock] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
funPrologue [GlobalRegUse]
live [CmmBlock]
cmmBlocks = do
platform <- LlvmM Platform
getPlatform
let getAssignedRegs :: CmmNode O O -> [CmmReg]
getAssignedRegs (CmmAssign CmmReg
reg CmmExpr
_) = [CmmReg
reg]
getAssignedRegs (CmmUnsafeForeignCall ForeignTarget
_ [CmmFormal]
rs [CmmExpr]
_) = (CmmFormal -> CmmReg) -> [CmmFormal] -> [CmmReg]
forall a b. (a -> b) -> [a] -> [b]
map CmmFormal -> CmmReg
CmmLocal [CmmFormal]
rs
getAssignedRegs CmmNode O O
_ = []
getRegsBlock (a
_, Block CmmNode O O
body, c
_) = (CmmNode O O -> [CmmReg]) -> [CmmNode O O] -> [CmmReg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmNode O O -> [CmmReg]
getAssignedRegs ([CmmNode O O] -> [CmmReg]) -> [CmmNode O O] -> [CmmReg]
forall a b. (a -> b) -> a -> b
$ Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
body
assignedRegs = [CmmReg] -> [CmmReg]
forall a. Eq a => [a] -> [a]
nub ([CmmReg] -> [CmmReg]) -> [CmmReg] -> [CmmReg]
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> [CmmReg]) -> [CmmBlock] -> [CmmReg]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((CmmNode C O, Block CmmNode O O, CmmNode O C) -> [CmmReg]
forall {a} {c}. (a, Block CmmNode O O, c) -> [CmmReg]
getRegsBlock ((CmmNode C O, Block CmmNode O O, CmmNode O C) -> [CmmReg])
-> (CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C))
-> CmmBlock
-> [CmmReg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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]
cmmBlocks
mbLive GlobalReg
r =
GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r (Platform -> [GlobalRegUse]
alwaysLive Platform
platform) Maybe GlobalRegUse -> Maybe GlobalRegUse -> Maybe GlobalRegUse
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r [GlobalRegUse]
live
platform <- getPlatform
stmtss <- forM assignedRegs $ \CmmReg
reg ->
case CmmReg
reg of
CmmLocal (LocalReg Unique
un CmmType
_) -> do
let (LlvmVar
newv, LlvmStatements
stmts) = CmmReg -> (LlvmVar, LlvmStatements)
allocReg CmmReg
reg
Unique -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
varInsert Unique
un (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
newv)
LlvmStatements -> LlvmM LlvmStatements
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return LlvmStatements
stmts
CmmGlobal ru :: GlobalRegUse
ru@(GlobalRegUse GlobalReg
r CmmType
_) -> do
let reg :: LlvmVar
reg = Platform -> GlobalRegUse -> LlvmVar
lmGlobalRegVar Platform
platform GlobalRegUse
ru
arg :: LlvmVar
arg = Platform -> GlobalRegUse -> LlvmVar
lmGlobalRegArg Platform
platform GlobalRegUse
ru
ty :: LlvmType
ty = (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType)
-> (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType) LlvmVar
reg
trash :: LlvmVar
trash = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmLit
LMUndefLit LlvmType
ty
rval :: LlvmVar
rval = if Maybe GlobalRegUse -> Bool
forall a. Maybe a -> Bool
isJust (GlobalReg -> Maybe GlobalRegUse
mbLive GlobalReg
r) then LlvmVar
arg else LlvmVar
trash
alloc :: LlvmStatement
alloc = LlvmVar -> LlvmExpression -> LlvmStatement
Assignment LlvmVar
reg (LlvmExpression -> LlvmStatement)
-> LlvmExpression -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmType -> Int -> LlvmExpression
Alloca (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
reg) Int
1
GlobalReg -> LlvmM ()
markStackReg GlobalReg
r
LlvmStatements -> LlvmM LlvmStatements
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements -> LlvmM LlvmStatements)
-> LlvmStatements -> LlvmM LlvmStatements
forall a b. (a -> b) -> a -> b
$ [LlvmStatement] -> LlvmStatements
forall a. [a] -> OrdList a
toOL [LlvmStatement
alloc, LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> LlvmStatement
Store LlvmVar
rval LlvmVar
reg LMAlign
forall a. Maybe a
Nothing []]
return (concatOL stmtss `snocOL` jumpToEntry, [])
where
CmmBlock
entryBlk : [CmmBlock]
_ = [CmmBlock]
cmmBlocks
jumpToEntry :: LlvmStatement
jumpToEntry = LlvmVar -> LlvmStatement
Branch (LlvmVar -> LlvmStatement) -> LlvmVar -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ BlockId -> LlvmVar
blockIdToLlvm (CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
entryBlk)
funEpilogue :: LiveGlobalRegUses -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue :: [GlobalRegUse] -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue [GlobalRegUse]
live = do
platform <- LlvmM Platform
getPlatform
let paddingRegs = Platform -> [GlobalRegUse] -> [GlobalRegUse]
padLiveArgs Platform
platform [GlobalRegUse]
live
let loadExpr GlobalRegUse
r = do
(v, _, s) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal (GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
r)
return (Just $ v, s)
loadUndef GlobalRegUse
r = do
let ty :: LlvmType
ty = (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType)
-> (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall a b. (a -> b) -> a -> b
$ Platform -> GlobalRegUse -> LlvmVar
lmGlobalRegVar Platform
platform GlobalRegUse
r)
(Maybe LlvmVar, LlvmStatements)
-> LlvmM (Maybe LlvmVar, LlvmStatements)
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar -> Maybe LlvmVar
forall a. a -> Maybe a
Just (LlvmVar -> Maybe LlvmVar) -> LlvmVar -> Maybe LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmLit
LMUndefLit LlvmType
ty, LlvmStatements
forall a. OrdList a
nilOL)
let allRegs = Platform -> [GlobalReg]
activeStgRegs Platform
platform
loads <- forM allRegs $ \GlobalReg
r -> if
| Just GlobalRegUse
ru <- GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r (Platform -> [GlobalRegUse]
alwaysLive Platform
platform)
-> GlobalRegUse -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadExpr GlobalRegUse
ru
| Just GlobalRegUse
ru <- GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r [GlobalRegUse]
live
-> GlobalRegUse -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadExpr GlobalRegUse
ru
| Bool -> Bool
not (GlobalReg -> Bool
isFPR GlobalReg
r)
-> GlobalRegUse -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadUndef (GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
r (Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
r))
| Just GlobalRegUse
ru <- GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse
lookupRegUse GlobalReg
r [GlobalRegUse]
paddingRegs
-> GlobalRegUse -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadUndef GlobalRegUse
ru
| Bool
otherwise -> (Maybe LlvmVar, LlvmStatements)
-> LlvmM (Maybe LlvmVar, LlvmStatements)
forall a. a -> LlvmM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LlvmVar
forall a. Maybe a
Nothing, LlvmStatements
forall a. OrdList a
nilOL)
let (vars, stmts) = unzip loads
return (catMaybes vars, concatOL stmts)
getHsFunc :: LiveGlobalRegUses -> CLabel -> LlvmM ExprData
getHsFunc :: [GlobalRegUse] -> CLabel -> LlvmM ExprData
getHsFunc [GlobalRegUse]
live CLabel
lbl
= do fty <- [GlobalRegUse] -> LlvmM LlvmType
llvmFunTy [GlobalRegUse]
live
name <- strCLabel_llvm lbl
getHsFunc' name fty
getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
getHsFunc' LMString
name LlvmType
fty
= do fun <- LMString -> LlvmM LlvmVar
getGlobalPtr LMString
name
if getVarType fun == fty
then return (fun, nilOL, [])
else do (v1, s1) <- doExpr (pLift fty)
$ Cast LM_Bitcast fun (pLift fty)
return (v1, unitOL s1, [])
mkLocalVar :: LlvmType -> LlvmM LlvmVar
mkLocalVar :: LlvmType -> LlvmM LlvmVar
mkLocalVar LlvmType
ty = do
un <- LlvmM Unique
forall (m :: * -> *). MonadGetUnique m => m Unique
getUniqueM
return $ LMLocalVar un ty
doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty LlvmExpression
expr = do
v <- LlvmType -> LlvmM LlvmVar
mkLocalVar LlvmType
ty
return (v, Assignment v expr)
expandCmmReg :: (CmmReg, Int) -> CmmExpr
expandCmmReg :: (CmmReg, Int) -> CmmExpr
expandCmmReg (CmmReg
reg, Int
off)
= let width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)
voff :: CmmExpr
voff = CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width
in MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmExpr
voff]
blockIdToLlvm :: BlockId -> LlvmVar
blockIdToLlvm :: BlockId -> LlvmVar
blockIdToLlvm BlockId
bid = Unique -> LlvmType -> LlvmVar
LMLocalVar (BlockId -> Unique
forall a. Uniquable a => a -> Unique
getUnique BlockId
bid) LlvmType
LMLabel
mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
mkIntLit :: forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
ty a
i = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
i) LlvmType
ty
toI32 :: Integral a => a -> LlvmVar
toI32 :: forall a. Integral a => a -> LlvmVar
toI32 = LlvmType -> a -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32
toIWord :: Integral a => Platform -> a -> LlvmVar
toIWord :: forall a. Integral a => Platform -> a -> LlvmVar
toIWord Platform
platform = LlvmType -> a -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit (Platform -> LlvmType
llvmWord Platform
platform)
panic :: HasCallStack => String -> a
panic :: forall a. HasCallStack => String -> a
panic String
s = String -> a
forall a. HasCallStack => String -> a
Panic.panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"GHC.CmmToLlvm.CodeGen." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
pprPanic :: HasCallStack => String -> SDoc -> a
pprPanic :: forall a. HasCallStack => String -> SDoc -> a
pprPanic String
s SDoc
d = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
Panic.pprPanic (String
"GHC.CmmToLlvm.CodeGen." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s) SDoc
d
getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
getTBAAMeta Unique
u = do
mi <- Unique -> LlvmM (Maybe MetaId)
getUniqMeta Unique
u
return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
getTBAARegMeta = Unique -> LlvmM [MetaAnnot]
getTBAAMeta (Unique -> LlvmM [MetaAnnot])
-> (GlobalReg -> Unique) -> GlobalReg -> LlvmM [MetaAnnot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobalReg -> Unique
getTBAA
data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
instance Semigroup LlvmAccum where
LlvmAccum LlvmStatements
stmtsA [LlvmCmmDecl]
declsA <> :: LlvmAccum -> LlvmAccum -> LlvmAccum
<> LlvmAccum LlvmStatements
stmtsB [LlvmCmmDecl]
declsB =
LlvmStatements -> [LlvmCmmDecl] -> LlvmAccum
LlvmAccum (LlvmStatements
stmtsA LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. Semigroup a => a -> a -> a
Semigroup.<> LlvmStatements
stmtsB) ([LlvmCmmDecl]
declsA [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. Semigroup a => a -> a -> a
Semigroup.<> [LlvmCmmDecl]
declsB)
instance Monoid LlvmAccum where
mempty :: LlvmAccum
mempty = LlvmStatements -> [LlvmCmmDecl] -> LlvmAccum
LlvmAccum LlvmStatements
forall a. OrdList a
nilOL []
mappend :: LlvmAccum -> LlvmAccum -> LlvmAccum
mappend = LlvmAccum -> LlvmAccum -> LlvmAccum
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
liftExprData LlvmM ExprData
action = do
(var, stmts, decls) <- LlvmM ExprData -> WriterT LlvmAccum LlvmM ExprData
forall (m :: * -> *) a. Monad m => m a -> WriterT LlvmAccum m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LlvmM ExprData
action
tell $ LlvmAccum stmts decls
return var
statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement LlvmStatement
stmt = LlvmAccum -> WriterT LlvmAccum LlvmM ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (LlvmAccum -> WriterT LlvmAccum LlvmM ())
-> LlvmAccum -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmStatements -> [LlvmCmmDecl] -> LlvmAccum
LlvmAccum (LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL LlvmStatement
stmt) []
doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
a LlvmExpression
b = do
(var, stmt) <- LlvmM (LlvmVar, LlvmStatement)
-> WriterT LlvmAccum LlvmM (LlvmVar, LlvmStatement)
forall (m :: * -> *) a. Monad m => m a -> WriterT LlvmAccum m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM (LlvmVar, LlvmStatement)
-> WriterT LlvmAccum LlvmM (LlvmVar, LlvmStatement))
-> LlvmM (LlvmVar, LlvmStatement)
-> WriterT LlvmAccum LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
a LlvmExpression
b
statement stmt
return var
exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW = LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
liftExprData (LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar)
-> (CmmExpr -> LlvmM ExprData)
-> CmmExpr
-> WriterT LlvmAccum LlvmM LlvmVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> LlvmM ExprData
exprToVar
runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
runExprData WriterT LlvmAccum LlvmM LlvmVar
action = do
(var, LlvmAccum stmts decls) <- WriterT LlvmAccum LlvmM LlvmVar -> LlvmM (LlvmVar, LlvmAccum)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT LlvmAccum LlvmM LlvmVar
action
return (var, stmts, decls)
runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls WriterT LlvmAccum LlvmM ()
action = do
LlvmAccum stmts decls <- WriterT LlvmAccum LlvmM () -> LlvmM LlvmAccum
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT WriterT LlvmAccum LlvmM ()
action
return (stmts, decls)
getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW = LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => m a -> WriterT LlvmAccum m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar)
-> (CmmReg -> LlvmM LlvmVar)
-> CmmReg
-> WriterT LlvmAccum LlvmM LlvmVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmReg -> LlvmM LlvmVar
getCmmReg
genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar
genLoadW :: Atomic
-> CmmExpr
-> CmmType
-> AlignmentSpec
-> WriterT LlvmAccum LlvmM LlvmVar
genLoadW Atomic
atomic CmmExpr
e CmmType
ty AlignmentSpec
alignment = LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
liftExprData (LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
genLoad Atomic
atomic CmmExpr
e CmmType
ty AlignmentSpec
alignment
singletonPanic :: String -> [a] -> a
singletonPanic :: forall a. String -> [a] -> a
singletonPanic String
_ [a
x] = a
x
singletonPanic String
s [a]
_ = String -> a
forall a. HasCallStack => String -> a
panic String
s