{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs, MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Handle conversion of CmmProc to LLVM code.
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)

-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM proc Code generator
--
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!"

-- -----------------------------------------------------------------------------
-- * Block code generation
--

-- | Unreachable basic block
--
-- See Note [Unreachable block as default destination in Switch]
newtype UnreachableBlockId = UnreachableBlockId BlockId

-- | Generate code for a list of blocks that make up a complete
-- procedure. The first block in the list is expected to be the entry
-- point.
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 -- Emit the prologue
       -- N.B. this must be its own block to ensure that the entry block of the
       -- procedure has no predecessors, as required by the LLVM IR. See #17589
       -- and #11649.
       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)

       -- allocate one unreachable basic block that can be used as a default
       -- destination in exhaustive switches.
       --
       -- See Note [Unreachable block as default destination in Switch]
       ubid@(UnreachableBlockId ubid') <- UnreachableBlockId <$> newBlockId
       let ubblock = BlockId -> [LlvmStatement] -> LlvmBasicBlock
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
ubid' [LlvmStatement
Unreachable]

       -- Generate code
       (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) cmmBlocks

       -- Compose
       return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)


-- | Generate code for one block
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)

-- -----------------------------------------------------------------------------
-- * CmmNode code generation
--

-- A statement conversion return data.
--   * LlvmStatements: The compiled LLVM statements.
--   * LlvmCmmDecl: Any global data needed.
type StmtData = (LlvmStatements, [LlvmCmmDecl])


-- | Convert a list of CmmNode's to LlvmStatement's
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)


-- | Convert a CmmStmt to a list of LlvmStatement's
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, []) -- nuke comments
    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

    -- Foreign Call
    CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
res [CmmExpr]
args
        -> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCall ForeignTarget
target [CmmFormal]
res [CmmExpr]
args

    -- Tail call
    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"

-- | Wrapper function to declare an instrinct function by function type
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!"

-- | Declares an instrinct function by return and parameter types
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

-- | Foreign Calls
genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData

-- Barriers need to be handled specially as they are implemented as LLVM
-- intrinsic functions.
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
"."

-- Handle prefetching data
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)

-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
-- and return types
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

-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
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 []

-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands
-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will
-- generate 'mul' on 128-bit operands. Then we only need some plumbing to
-- extract the two 64-bit values out of 128-bit result.
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)
    -- First zero-extend the operands ('mul' instruction requires the operands
    -- and the result to be of the same type). Note that we don't use 'castVars'
    -- because it tries to do LM_Sext.
    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
    -- Do the actual multiplication (note that the result is also 2x width).
    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
    -- Extract the lower bits of the result into retL.
    retL <- doExprW width $ Cast LM_Trunc retV width
    -- Now we unsigned right-shift the higher bits by 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
    -- And extract them into retH.
    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)
    -- First sign-extend the operands ('mul' instruction requires the operands
    -- and the result to be of the same type). Note that we don't use 'castVars'
    -- because it tries to do LM_Sext.
    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
    -- Do the actual multiplication (note that the result is also 2x width).
    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
    -- Extract the lower bits of the result into retL.
    retL <- doExprW width $ Cast LM_Trunc retV width
    -- Now we signed right-shift the higher bits by 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
    -- And extract them into retH.
    retH <- doExprW width $ Cast LM_Trunc retShifted width
    -- Check if the carry is useful by doing a full arithmetic right shift on
    -- retL and comparing the result with retH
    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' -- Compare op returns a 1-bit value (i1)
    retC   <- doExprW width $ Cast LM_Zext retC1 width  -- so we zero-extend it
    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 []

-- MO_U_QuotRem2 is another case we handle by widening the registers to double
-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
-- main difference here is that we need to combine two words into one register
-- and then use both 'udiv' and 'urem' instructions to compute the result.
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)
    -- First zero-extend all parameters to double width.
    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
    -- Now we combine the first two parameters (that represent the high and low
    -- bits of the value). So first left-shift the high bits to their position
    -- and then bit-or them with the low bits.
    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
    -- Finally, we can call 'udiv' and 'urem' to compute the results.
    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt
    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt
    -- And since everything is in 2x width, we need to truncate the results and
    -- then return them.
    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 []

-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
-- which we need to extract the actual values.
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]

-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the
-- return tuple to be the overflow bit and the second element to contain the
-- actual result of the addition. So we still use genCallWithOverflow but swap
-- the return registers.
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]

-- Handle all other foreign calls and prim ops.
genCall ForeignTarget
target [CmmFormal]
res [CmmExpr]
args = do
  platform <- LlvmM Platform
getPlatform
  runStmtsDecls $ do

    -- extract Cmm call convention, and translate to LLVM call convention
    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

    {-
        CC_Ccc of the possibilities here are a worry with the use of a custom
        calling convention for passing STG args. In practice the more
        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.

        The native code generator only handles StdCall and CCallConv.
    -}

    -- parameter types
    let arg_type (CmmExpr
_, ForeignHint
AddrHint) = (LlvmType
i8Ptr, [])
        -- cast pointers to i8*. Llvm equivalent of void*
        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, [])

    -- ret type
    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
"."

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

    -- fun type
    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 -- tail calls should be done through CmmJump
    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 ()


    -- make the actual call
    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
            -- get the return register
            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

-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
-- with overflow bit (i.e., returns a struct containing the actual result of the
-- operation and an overflow bit). This function will also extract the overflow
-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the
-- overflow "bit" as a usual Int# or Word#).
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
    -- So far this was only tested for the following four CallishMachOps.
    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
    -- This will do most of the work of generating the call to the intrinsic and
    -- extracting the values from the struct.
    (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)
    -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects
    -- both to be i<width>)
    (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"

-- | A helper function for genCallWithOverflow that handles generating the call
-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.
genCallExtract
    :: ForeignTarget           -- ^ PrimOp
    -> Width                   -- ^ Width of the operands.
    -> (CmmActual, CmmActual)  -- ^ Actual arguments.
    -> (LlvmType, LlvmType)    -- ^ LLVM types of the returned struct.
    -> LlvmM (LlvmVar, LlvmVar, StmtData)
genCallExtract :: ForeignTarget
-> Width
-> (CmmExpr, CmmExpr)
-> (LlvmType, LlvmType)
-> LlvmM (LlvmVar, LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
genCallExtract 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]

    -- Process the arguments.
    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

    -- Get the function and make the call.
    fname <- cmmPrimOpFunctions op
    (fptr, _, top2) <- getInstrinct fname retTy argTy
    -- We use StdCall for primops. See also the last case of genCall.
    (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []

    -- This will result in a two element struct, we need to use "extractvalue"
    -- to get them out of it.
    (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"

-- Handle simple function call that only need simple type casting, of the form:
--   truncate arg >>= \a -> call(a) >>= zext
--
-- since GHC only really has i32 and i64 types and things like Word8 are backed
-- by an i32 and just present a logical i8 range. So we must handle conversions
-- from i32 to i8 explicitly as LLVM is strict about types.
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")

-- Handle simple function call that only need simple type casting, of the form:
--   truncate arg >>= \a -> call(a) >>= zext
--
-- since GHC only really has i32 and i64 types and things like Word8 are backed
-- by an i32 and just present a logical i8 range. So we must handle conversions
-- from i32 to i8 explicitly as LLVM is strict about types.
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")

-- | Create a function pointer from a target.
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

-- | Create a function pointer from a target.
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

-- | Conversion of call arguments.
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

-- | Conversion of call arguments.
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')


-- | Cast a collection of LLVM variables to specific types.
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

-- | Cast a collection of LLVM variables to specific types.
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)

-- | Cast an LLVM variable to a specific type, panicking if it can't be done.
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

-- | Decide what C function to use to implement a CallishMachOp
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"

    -- In the following ops, it looks like we could factorize the concatenation
    -- of the bit size, and indeed it was like this before, e.g.
    --
    --     MO_PopCnt w -> fsLit $ "llvm.ctpop.i" ++ wbits w
    -- or
    --     MO_Memcpy _ -> fsLit $ "llvm.memcpy."  ++ intrinTy1
    --
    -- however it meant that FastStrings were not built from constant string
    -- literals, hence they weren't matching the "fslit" rewrite rule in
    -- GHC.Data.FastString that computes the string size at compilation time.

    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
    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
    -- appropriate case of genCall.
    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


-- | Tail function calls
genJump :: CmmExpr -> LiveGlobalRegUses -> LlvmM StmtData

-- Call to known function
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)


-- Call to unknown function / address
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)


-- | CmmAssign operation
--
-- We use stack allocated variables for CmmReg. The optimiser will replace
-- these with registers when possible.
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
      -- Some registers are pointer types, so need to cast value to pointer
      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)


-- | CmmStore operation
genStore :: CmmExpr -> CmmExpr -> AlignmentSpec -> LlvmM StmtData

-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
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

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

-- | CmmStore operation
-- This is a special case for storing to a global register pointer
-- offset such as I32[Sp+8].
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]
                -- We might need a different pointer type, so check
                case pLower grt == getVarType vval of
                     -- were fine
                     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)

                     -- cast to pointer type needed
                     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)

            -- If its a bit type then we use the slow method since
            -- we can't avoid casting anyway.
            Bool
False -> CmmExpr
-> CmmExpr
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_slow CmmExpr
addr CmmExpr
val AlignmentSpec
alignment [MetaAnnot]
meta


-- | CmmStore operation
-- Generic case. Uses casts and pointer arithmetic if needed.
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
        -- sometimes we need to cast an int to a pointer before storing
        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
              -- See Note [Alignment of vector-typed values]
              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

-- | Unconditional branch
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, [])


-- | Conditional branch
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
    -- See Note [Literals and branch conditions].
    (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


-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
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))

{- Note [Literals and branch conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is important that whenever we generate branch conditions for
literals like '1', they are properly narrowed to an LLVM expression of
type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
must be certain to return a properly narrowed type. genLit is
responsible for this, in the case of literal integers.

Often, we won't see direct statements like:

    if(1) {
      ...
    } else {
      ...
    }

at this point in the pipeline, because the Glorious Code Generator
will do trivial branch elimination in the sinking pass (among others,)
which will eliminate the expression entirely.

However, it's certainly possible and reasonable for this to occur in
hand-written C-- code. Consider something like:

    #if !defined(SOME_CONDITIONAL)
    #define CHECK_THING(x) 1
    #else
    #define CHECK_THING(x) some_operation((x))
    #endif

    f() {

      if (CHECK_THING(xyz)) {
        ...
      } else {
        ...
      }

    }

In such an instance, CHECK_THING might result in an *expression* in
one case, and a *literal* in the other, depending on what in
particular was #define'd. So we must be sure to properly narrow the
literal in this case to i1 as it won't be eliminated beforehand.

For a real example of this, see ./rts/StgStdThunks.cmm

-}



-- | Switch branch
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
                 -- switch to an unreachable basic block for exhaustive
                 -- switches. See Note [Unreachable block as default destination
                 -- in Switch]

    let s1 = LlvmVar -> LlvmVar -> [(LlvmVar, LlvmVar)] -> LlvmStatement
Switch LlvmVar
vc LlvmVar
defLbl [(LlvmVar, LlvmVar)]
labels
    return $ (stmts `snocOL` s1, top)


-- Note [Unreachable block as default destination in Switch]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- LLVM IR requires a default destination (a block label) for its Switch
-- operation, even if the switch is exhaustive. An LLVM switch is considered
-- exhausitve (e.g. to omit range checks for bit tests [1]) if the default
-- destination is unreachable.
--
-- When we codegen a Cmm function, we always reserve an unreachable basic block
-- that is used as a default destination for exhaustive Cmm switches in
-- genSwitch. See #24717
--
-- [1] https://reviews.llvm.org/D68131



-- -----------------------------------------------------------------------------
-- * CmmExpr code generation
--

-- | An expression conversion return data:
--   * LlvmVar: The var holding the result of the expression
--   * LlvmStatements: Any statements needed to evaluate the expression
--   * LlvmCmmDecl: Any global data needed for this expression
type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])

-- | Values which can be passed to 'exprToVar' to configure its
-- behaviour in certain circumstances.
--
-- Currently just used for determining if a comparison should return
-- a boolean (i1) or a word. See Note [Literals and branch conditions].
newtype EOption = EOption { EOption -> Bool
i1Expected :: Bool }
-- XXX: EOption is an ugly and inefficient solution to this problem.

-- | i1 type expected (condition scrutinee).
i1Option :: EOption
i1Option :: EOption
i1Option = Bool -> EOption
EOption Bool
True

-- | Word type expected (usual).
wordOption :: EOption
wordOption :: EOption
wordOption = Bool -> EOption
EOption Bool
False

-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
-- expression being stored in the returned LlvmVar.
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 in expression is the value, so must load. If you want actual
    -- reg pointer, call getCmmReg directly.
    CmmReg CmmReg
r -> do
        (v1, ty, s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal CmmReg
r
        case isPointer ty of
             Bool
True  -> do
                 -- Cmm wants the value, so pointer types must be cast to ints
                 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!"


-- | Handle CmmMachOp expressions
genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData

-- Unary Machop
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"

    -- Handle unsupported cases explicitly so we get a warning
    -- of missing case when new MachOps added
    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
            -- LLVM doesn't like trying to convert to same width, so
            -- need to check for that as we do get Cmm code doing it.
            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
")"

-- Handle GlobalRegs pointers
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

-- Generic case
genMachOp EOption
opt MachOp
op [CmmExpr]
e = EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow EOption
opt MachOp
op [CmmExpr]
e


-- | Handle CmmMachOp expressions
-- This is a specialised method that handles Global register manipulations like
-- 'Sp - 16', using the getelementptr instruction.
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


-- | Handle CmmMachOp expressions
-- This handles all the cases not handle by the specialised genMachOp_fast.
genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData

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

-- Element insertion
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)

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

    -- Min/max
    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"

        -- Need to use EOption here as Cmm expects word size results from
        -- comparisons while LLVM return i1. Need to extend to llvmWord type
        -- if expected. See Note [Literals and branch conditions].
        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]

        -- Detect if overflow will occur in signed multiply of the two
        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
        -- implementation. Its much longer due to type information/safety.
        -- This should actually compile to only about 3 asm instructions.
        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
        -- LLVM only has the fmadd variant.
        FMASign
FMAdd   -> CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData
genFmaOp CmmExpr
x CmmExpr
y CmmExpr
z
        -- Other fused multiply-add operations are implemented in terms of fmadd
        -- This is sound: it does not lose any precision.
        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

-- More than three expressions, invalid!
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
  -- To broadcast a scalar x as a vector v:
  --   1. insert x at the 0 position of the zero vector
  --   2. shuffle x into all positions
  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

-- | Generate code for a fused multiply-add operation.
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]

-- | Handle CmmLoad expression.
genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData

-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
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

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

-- | Handle CmmLoad expression.
-- This is a special case for loading from a global register pointer
-- offset such as I32[Sp+8].
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]
                -- We might need a different pointer type, so check
                case grt == ty' of
                     -- were fine
                     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,
                                     [])

                     -- cast to pointer type needed
                     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, [])

            -- If its a bit type then we use the slow method since
            -- we can't avoid casting anyway.
            Bool
False -> Atomic
-> CmmExpr
-> CmmType
-> AlignmentSpec
-> [MetaAnnot]
-> LlvmM ExprData
genLoad_slow Atomic
atomic  CmmExpr
e CmmType
ty AlignmentSpec
align [MetaAnnot]
meta

-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
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))

{-
Note [Alignment of vector-typed values]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
On x86, vector types need to be 16-byte aligned for aligned
access, but we have no way of guaranteeing that this is true with GHC
(we would need to modify the layout of the stack and closures, change
the storage manager, etc.). So, we blindly tell LLVM that *any* vector
store or load could be unaligned. In the future we may be able to
guarantee that certain vector access patterns are aligned, in which
case we will need a more granular way of specifying alignment.
-}

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
              -- See Note [Alignment of vector-typed values]
              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

-- | Handle CmmReg expression. This will return a pointer to the stack
-- location of the register. Throws an error if it isn't allocated on
-- the stack.
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!"
           -- This should never happen, as every local variable should
           -- have been assigned a value at some point, triggering
           -- "funPrologue" to allocate it on the stack.

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

-- | Return the value of a given register, as well as its type. Might
-- need to be load from stack.
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)

-- | Allocate a local CmmReg on the stack
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!"


-- | Generate code for a literal
genLit :: EOption -> CmmLit -> LlvmM ExprData
genLit :: EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt (CmmInt Integer
i Width
w)
  -- See Note [Literals and branch conditions].
  = let width :: LlvmType
width | EOption -> Bool
i1Expected EOption
opt = LlvmType
i1
              | Bool
otherwise      = Int -> LlvmType
LMInt (Width -> Int
widthInBits Width
w)
        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt
        --                 , fsLit $ "Width  : " ++ show w
        --                 , fsLit $ "Width' : " ++ show (widthInBits 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!"


-- -----------------------------------------------------------------------------
-- * Misc
--

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

-- | Find CmmRegs that get assigned and allocate them on the stack
--
-- Any register that gets written needs to be allocated on the
-- stack. This avoids having to map a CmmReg to an equivalent SSA form
-- and avoids having to deal with Phi node insertion.  This is also
-- the approach recommended by LLVM developers.
--
-- On the other hand, this is unnecessarily verbose if the register in
-- question is never written. Therefore we skip it where we can to
-- save a few lines in the output and hopefully speed compilation up a
-- bit.
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)

-- | Function epilogue. Load STG variables to use as argument for call.
-- STG Liveness optimisation done here.
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

    -- Set to value or "undef" depending on whether the register is
    -- actually 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)

    -- Note that floating-point registers in `activeStgRegs` must be sorted
    -- according to the calling convention.
    --  E.g. for X86:
    --     GOOD: F1,D1,XMM1,F2,D2,XMM2,...
    --     BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,...
    --  As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't
    --  want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1
    --  and D1 -> XMM2.
    let allRegs = Platform -> [GlobalReg]
activeStgRegs Platform
platform
    loads <- forM allRegs $ \GlobalReg
r -> if
      -- load live registers
      | 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
      -- load all non Floating-Point Registers
      | 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))
      -- load padding Floating-Point Registers
      | 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)

-- | Get a function pointer to the CLabel specified.
--
-- This is for Haskell functions, function type is assumed, so doesn't work
-- with foreign functions.
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, [])

-- | Create a new local var
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


-- | Execute an expression, assigning result to a var
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)


-- | Expand CmmRegOff
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]


-- | Convert a block id into a appropriate Llvm label
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

-- | Create Llvm int Literal
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

-- | Convert int type to a LLvmVar of word or i32 size
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)


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


-- | Returns TBAA meta data by unique
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]

-- | Returns TBAA meta data for given register
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


-- | A more convenient way of accumulating LLVM statements and declarations.
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

-- | Return element of single-element list; 'panic' if list is not a single-element list
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