{-# LANGUAGE CPP, GADTs #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code.
--
module LlvmCodeGen.CodeGen ( genLlvmProc ) where

#include "HsVersions.h"

import GhcPrelude

import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Regs

import BlockId
import CodeGen.Platform ( activeStgRegs, callerSaves )
import CLabel
import Cmm
import PprCmm
import CmmUtils
import CmmSwitch
import Hoopl.Block
import Hoopl.Graph
import Hoopl.Collections

import DynFlags
import FastString
import ForeignCall
import Outputable hiding (panic, pprPanic)
import qualified Outputable
import Platform
import OrdList
import UniqSupply
import Unique
import Util

import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer

import qualified Data.Semigroup as Semigroup
import Data.List ( nub )
import Data.Maybe ( catMaybes )

type Atomic = Bool
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
/= :: Signage -> Signage -> Bool
$c/= :: Signage -> Signage -> Bool
== :: Signage -> Signage -> Bool
$c== :: 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
showList :: [Signage] -> ShowS
$cshowList :: [Signage] -> ShowS
show :: Signage -> String
$cshow :: Signage -> String
showsPrec :: Int -> Signage -> ShowS
$cshowsPrec :: Int -> Signage -> ShowS
Show)

-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM proc Code generator
--
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
genLlvmProc (CmmProc infos :: LabelMap CmmStatics
infos lbl :: CLabel
lbl live :: [GlobalReg]
live graph :: CmmGraph
graph) = do
    let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough CmmGraph
graph
    (lmblocks :: [LlvmBasicBlock]
lmblocks, lmdata :: [LlvmCmmDecl]
lmdata) <- [GlobalReg]
-> [CmmBlock] -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen [GlobalReg]
live [CmmBlock]
blocks
    let info :: Maybe CmmStatics
info = KeyOf LabelMap -> LabelMap CmmStatics -> Maybe CmmStatics
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) LabelMap CmmStatics
infos
        proc :: LlvmCmmDecl
proc = Maybe CmmStatics
-> CLabel -> [GlobalReg] -> ListGraph LlvmStatement -> LlvmCmmDecl
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc Maybe CmmStatics
info CLabel
lbl [GlobalReg]
live ([LlvmBasicBlock] -> ListGraph LlvmStatement
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph [LlvmBasicBlock]
lmblocks)
    [LlvmCmmDecl] -> LlvmM [LlvmCmmDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmCmmDecl
procLlvmCmmDecl -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. a -> [a] -> [a]
:[LlvmCmmDecl]
lmdata)

genLlvmProc _ = String -> LlvmM [LlvmCmmDecl]
forall a. String -> a
panic "genLlvmProc: case that shouldn't reach here!"

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

-- | 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 and will get the prologue.
basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen :: [GlobalReg]
-> [CmmBlock] -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
basicBlocksCodeGen _    []                     = String -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
forall a. String -> a
panic "no entry block!"
basicBlocksCodeGen live :: [GlobalReg]
live (entryBlock :: CmmBlock
entryBlock:cmmBlocks :: [CmmBlock]
cmmBlocks)
  = do (prologue :: LlvmStatements
prologue, prologueTops :: [LlvmCmmDecl]
prologueTops) <- [GlobalReg] -> [CmmBlock] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
funPrologue [GlobalReg]
live (CmmBlock
entryBlockCmmBlock -> [CmmBlock] -> [CmmBlock]
forall a. a -> [a] -> [a]
:[CmmBlock]
cmmBlocks)

       -- Generate code
       (BasicBlock bid :: BlockId
bid entry :: [LlvmStatement]
entry, entryTops :: [LlvmCmmDecl]
entryTops) <- CmmBlock -> LlvmM (LlvmBasicBlock, [LlvmCmmDecl])
basicBlockCodeGen CmmBlock
entryBlock
       (blocks :: [LlvmBasicBlock]
blocks, topss :: [[LlvmCmmDecl]]
topss) <- ([(LlvmBasicBlock, [LlvmCmmDecl])]
 -> ([LlvmBasicBlock], [[LlvmCmmDecl]]))
-> LlvmM [(LlvmBasicBlock, [LlvmCmmDecl])]
-> LlvmM ([LlvmBasicBlock], [[LlvmCmmDecl]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(LlvmBasicBlock, [LlvmCmmDecl])]
-> ([LlvmBasicBlock], [[LlvmCmmDecl]])
forall a b. [(a, b)] -> ([a], [b])
unzip (LlvmM [(LlvmBasicBlock, [LlvmCmmDecl])]
 -> LlvmM ([LlvmBasicBlock], [[LlvmCmmDecl]]))
-> LlvmM [(LlvmBasicBlock, [LlvmCmmDecl])]
-> LlvmM ([LlvmBasicBlock], [[LlvmCmmDecl]])
forall a b. (a -> b) -> a -> b
$ (CmmBlock -> LlvmM (LlvmBasicBlock, [LlvmCmmDecl]))
-> [CmmBlock] -> LlvmM [(LlvmBasicBlock, [LlvmCmmDecl])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmBlock -> LlvmM (LlvmBasicBlock, [LlvmCmmDecl])
basicBlockCodeGen [CmmBlock]
cmmBlocks

       -- Compose
       let entryBlock :: LlvmBasicBlock
entryBlock = BlockId -> [LlvmStatement] -> LlvmBasicBlock
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
bid (LlvmStatements -> [LlvmStatement]
forall a. OrdList a -> [a]
fromOL LlvmStatements
prologue [LlvmStatement] -> [LlvmStatement] -> [LlvmStatement]
forall a. [a] -> [a] -> [a]
++ [LlvmStatement]
entry)
       ([LlvmBasicBlock], [LlvmCmmDecl])
-> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmBasicBlock
entryBlock LlvmBasicBlock -> [LlvmBasicBlock] -> [LlvmBasicBlock]
forall a. a -> [a] -> [a]
: [LlvmBasicBlock]
blocks, [LlvmCmmDecl]
prologueTops [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
entryTops [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [[LlvmCmmDecl]] -> [LlvmCmmDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LlvmCmmDecl]]
topss)


-- | Generate code for one block
basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
basicBlockCodeGen :: CmmBlock -> LlvmM (LlvmBasicBlock, [LlvmCmmDecl])
basicBlockCodeGen block :: CmmBlock
block
  = do let (_, nodes :: Block CmmNode O O
nodes, tail :: CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
           id :: BlockId
id = CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
       (mid_instrs :: LlvmStatements
mid_instrs, top :: [LlvmCmmDecl]
top) <- [CmmNode O O] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall e x. [CmmNode e x] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtsToInstrs ([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 :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
       (tail_instrs :: LlvmStatements
tail_instrs, top' :: [LlvmCmmDecl]
top')  <- CmmNode O C -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall e x. CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtToInstrs CmmNode O C
tail
       let instrs :: [LlvmStatement]
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)
       (LlvmBasicBlock, [LlvmCmmDecl])
-> LlvmM (LlvmBasicBlock, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> [LlvmStatement] -> LlvmBasicBlock
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [LlvmStatement]
instrs, [LlvmCmmDecl]
top' [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
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 :: [CmmNode e x] -> LlvmM StmtData
stmtsToInstrs :: [CmmNode e x] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtsToInstrs stmts :: [CmmNode e x]
stmts
   = do (instrss :: [LlvmStatements]
instrss, topss :: [[LlvmCmmDecl]]
topss) <- ([(LlvmStatements, [LlvmCmmDecl])]
 -> ([LlvmStatements], [[LlvmCmmDecl]]))
-> LlvmM [(LlvmStatements, [LlvmCmmDecl])]
-> LlvmM ([LlvmStatements], [[LlvmCmmDecl]])
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)
mapM CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall e x. CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtToInstrs [CmmNode e x]
stmts
        (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LlvmStatements] -> LlvmStatements
forall a. [OrdList a] -> OrdList a
concatOL [LlvmStatements]
instrss, [[LlvmCmmDecl]] -> [LlvmCmmDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[LlvmCmmDecl]]
topss)


-- | Convert a CmmStmt to a list of LlvmStatement's
stmtToInstrs :: CmmNode e x -> LlvmM StmtData
stmtToInstrs :: CmmNode e x -> LlvmM (LlvmStatements, [LlvmCmmDecl])
stmtToInstrs stmt :: CmmNode e x
stmt = case CmmNode e x
stmt of

    CmmComment _         -> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, []) -- nuke comments
    CmmTick    _         -> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])
    CmmUnwind  {}        -> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])

    CmmAssign reg :: CmmReg
reg src :: CmmExpr
src    -> CmmReg -> CmmExpr -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genAssign CmmReg
reg CmmExpr
src
    CmmStore addr :: CmmExpr
addr src :: CmmExpr
src    -> CmmExpr -> CmmExpr -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore CmmExpr
addr CmmExpr
src

    CmmBranch id :: BlockId
id         -> BlockId -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genBranch BlockId
id
    CmmCondBranch arg :: CmmExpr
arg true :: BlockId
true false :: BlockId
false likely :: Maybe Bool
likely
                         -> CmmExpr
-> BlockId
-> BlockId
-> Maybe Bool
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCondBranch CmmExpr
arg BlockId
true BlockId
false Maybe Bool
likely
    CmmSwitch arg :: CmmExpr
arg ids :: SwitchTargets
ids    -> CmmExpr -> SwitchTargets -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genSwitch CmmExpr
arg SwitchTargets
ids

    -- Foreign Call
    CmmUnsafeForeignCall target :: ForeignTarget
target res :: [CmmFormal]
res args :: [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 -> [GlobalReg]
cml_args_regs = [GlobalReg]
live } -> CmmExpr -> [GlobalReg] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genJump CmmExpr
arg [GlobalReg]
live

    _ -> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic "Llvm.CodeGen.stmtToInstrs"

-- | Wrapper function to declare an instrinct function by function type
getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 fname :: LMString
fname fty :: LlvmType
fty@(LMFunction funSig :: 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

    Maybe LlvmType
fn <- LMString -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
funLookup LMString
fname
    [LlvmCmmDecl]
tops <- case Maybe LlvmType
fn of
      Just _  ->
        [LlvmCmmDecl] -> LlvmM [LlvmCmmDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Nothing -> do
        LMString -> LlvmType -> LlvmM ()
forall key. Uniquable key => key -> LlvmType -> LlvmM ()
funInsert LMString
fname LlvmType
fty
        Unique
un <- LlvmM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
        let lbl :: CLabel
lbl = Unique -> CLabel
forall a. Uniquable a => a -> CLabel
mkAsmTempLabel Unique
un
        [LlvmCmmDecl] -> LlvmM [LlvmCmmDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> [([LMGlobal], [LlvmType])] -> LlvmCmmDecl
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) [([],[LlvmType
fty])]]

    ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
fv, LlvmStatements
forall a. OrdList a
nilOL, [LlvmCmmDecl]
tops)

getInstrinct2 _ _ = String -> LlvmM ExprData
forall a. HasCallStack => String -> a
error "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 fname :: LMString
fname retTy :: LlvmType
retTy parTys :: [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

-- | Memory barrier instruction for LLVM >= 3.0
barrier :: LlvmM StmtData
barrier :: LlvmM (LlvmStatements, [LlvmCmmDecl])
barrier = do
    let s :: LlvmStatement
s = Bool -> LlvmSyncOrdering -> LlvmStatement
Fence Bool
False LlvmSyncOrdering
SyncSeqCst
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL LlvmStatement
s, [])

-- | Insert a 'barrier', unless the target platform is in the provided list of
--   exceptions (where no code will be emitted instead).
barrierUnless :: [Arch] -> LlvmM StmtData
barrierUnless :: [Arch] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
barrierUnless exs :: [Arch]
exs = do
    Platform
platform <- LlvmM Platform
getLlvmPlatform
    if Platform -> Arch
platformArch Platform
platform Arch -> [Arch] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Arch]
exs
        then (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])
        else LlvmM (LlvmStatements, [LlvmCmmDecl])
barrier

-- | 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 MO_ReadBarrier) _ _ =
    [Arch] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
barrierUnless [Arch
ArchX86, Arch
ArchX86_64, Arch
ArchSPARC]
genCall (PrimTarget MO_WriteBarrier) _ _ = do
    [Arch] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
barrierUnless [Arch
ArchX86, Arch
ArchX86_64, Arch
ArchSPARC]

genCall (PrimTarget MO_Touch) _ _
 = (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
forall a. OrdList a
nilOL, [])

genCall (PrimTarget (MO_UF_Conv w :: Width
w)) [dst :: CmmFormal
dst] [e :: 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
    LlvmVar
dstV <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
    let ty :: LlvmType
ty = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
dst
        width :: LlvmType
width = Width -> LlvmType
widthToLlvmFloat Width
w
    LlvmVar
castV <- LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmM LlvmVar
mkLocalVar LlvmType
ty
    LlvmVar
ve <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
e
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmExpression -> LlvmStatement
Assignment LlvmVar
castV (LlvmExpression -> LlvmStatement)
-> LlvmExpression -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Uitofp LlvmVar
ve LlvmType
width
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
castV LlvmVar
dstV

genCall (PrimTarget (MO_UF_Conv _)) [_] args :: [CmmExpr]
args =
    String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic (String -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ "genCall: Too many arguments to MO_UF_Conv. " String -> ShowS
forall a. [a] -> [a] -> [a]
++
    "Can only handle 1, given" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmExpr]
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "."

-- Handle prefetching data
genCall t :: ForeignTarget
t@(PrimTarget (MO_Prefetch_Data localityInt :: Int
localityInt)) [] args :: [CmmExpr]
args
  | 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
<= 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 = \name :: 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 :: [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
    [LlvmVar]
argVars <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT LlvmAccum LlvmM [LlvmVar]
arg_varsW [(CmmExpr, ForeignHint)]
args_hints' ([], LlvmStatements
forall a. OrdList a
nilOL, [])
    LlvmVar
fptr    <- 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
t
    [LlvmVar]
argVars' <- Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed ([(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar])
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
forall a b. (a -> b) -> a -> b
$ [LlvmVar] -> [LlvmType] -> [(LlvmVar, LlvmType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LlvmVar]
argVars [LlvmType]
argTy

    WriterT LlvmAccum LlvmM ()
doTrashStmts
    let argSuffix :: [LlvmVar]
argSuffix = [LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32 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 1]
    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
StdCall LlvmVar
fptr ([LlvmVar]
argVars' [LlvmVar] -> [LlvmVar] -> [LlvmVar]
forall a. [a] -> [a] -> [a]
++ [LlvmVar]
argSuffix) []
  | Bool
otherwise = String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic (String -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ "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 w :: Width
w)) dsts :: [CmmFormal]
dsts args :: [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 w :: Width
w)) dsts :: [CmmFormal]
dsts args :: [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 w :: Width
w)) dsts :: [CmmFormal]
dsts args :: [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 w :: Width
w)) dsts :: [CmmFormal]
dsts args :: [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 w :: Width
w)) dsts :: [CmmFormal]
dsts args :: [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 w :: Width
w)) dsts :: [CmmFormal]
dsts args :: [CmmExpr]
args =
    Width
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genCallSimpleCast Width
w ForeignTarget
t [CmmFormal]
dsts [CmmExpr]
args

genCall (PrimTarget (MO_AtomicRMW width :: Width
width amop :: AtomicMachOp
amop)) [dst :: CmmFormal
dst] [addr :: CmmExpr
addr, n :: 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
    LlvmVar
addrVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
addr
    LlvmVar
nVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
n
    let targetTy :: LlvmType
targetTy = Width -> LlvmType
widthToLlvmInt Width
width
        ptrExpr :: LlvmExpression
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar (LlvmType -> LlvmType
pLift LlvmType
targetTy)
    LlvmVar
ptrVar <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW (LlvmType -> LlvmType
pLift LlvmType
targetTy) LlvmExpression
ptrExpr
    LlvmVar
dstVar <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
    let op :: LlvmAtomicOp
op = case AtomicMachOp
amop of
               AMO_Add  -> LlvmAtomicOp
LAO_Add
               AMO_Sub  -> LlvmAtomicOp
LAO_Sub
               AMO_And  -> LlvmAtomicOp
LAO_And
               AMO_Nand -> LlvmAtomicOp
LAO_Nand
               AMO_Or   -> LlvmAtomicOp
LAO_Or
               AMO_Xor  -> LlvmAtomicOp
LAO_Xor
    LlvmVar
retVar <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
targetTy (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmAtomicOp
-> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmExpression
AtomicRMW LlvmAtomicOp
op LlvmVar
ptrVar LlvmVar
nVar LlvmSyncOrdering
SyncSeqCst
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retVar LlvmVar
dstVar

genCall (PrimTarget (MO_AtomicRead _)) [dst :: CmmFormal
dst] [addr :: 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
    LlvmVar
dstV <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
    LlvmVar
v1 <- Bool -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
genLoadW Bool
True CmmExpr
addr (CmmFormal -> CmmType
localRegType CmmFormal
dst)
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
v1 LlvmVar
dstV

genCall (PrimTarget (MO_Cmpxchg _width :: Width
_width))
        [dst :: CmmFormal
dst] [addr :: CmmExpr
addr, old :: CmmExpr
old, new :: 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
    LlvmVar
addrVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
addr
    LlvmVar
oldVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
old
    LlvmVar
newVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
new
    let targetTy :: LlvmType
targetTy = LlvmVar -> LlvmType
getVarType LlvmVar
oldVar
        ptrExpr :: LlvmExpression
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar (LlvmType -> LlvmType
pLift LlvmType
targetTy)
    LlvmVar
ptrVar <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW (LlvmType -> LlvmType
pLift LlvmType
targetTy) LlvmExpression
ptrExpr
    LlvmVar
dstVar <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
    LlvmVar
retVar <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW ([LlvmType] -> LlvmType
LMStructU [LlvmType
targetTy,LlvmType
i1])
              (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmVar
-> LlvmVar
-> LlvmVar
-> LlvmSyncOrdering
-> LlvmSyncOrdering
-> LlvmExpression
CmpXChg LlvmVar
ptrVar LlvmVar
oldVar LlvmVar
newVar LlvmSyncOrdering
SyncSeqCst LlvmSyncOrdering
SyncSeqCst
    LlvmVar
retVar' <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
targetTy (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmVar -> Int -> LlvmExpression
ExtractV LlvmVar
retVar 0
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retVar' LlvmVar
dstVar

genCall (PrimTarget (MO_AtomicWrite _width :: Width
_width)) [] [addr :: CmmExpr
addr, val :: 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
    LlvmVar
addrVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
addr
    LlvmVar
valVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
    let ptrTy :: LlvmType
ptrTy = LlvmType -> LlvmType
pLift (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
valVar
        ptrExpr :: LlvmExpression
ptrExpr = LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Inttoptr LlvmVar
addrVar LlvmType
ptrTy
    LlvmVar
ptrVar <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
ptrTy LlvmExpression
ptrExpr
    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
$ LlvmAtomicOp
-> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmExpression
AtomicRMW LlvmAtomicOp
LAO_Xchg LlvmVar
ptrVar LlvmVar
valVar LlvmSyncOrdering
SyncSeqCst

-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
genCall t :: ForeignTarget
t@(PrimTarget op :: CallishMachOp
op) [] args :: [CmmExpr]
args
 | Just align :: Int
align <- CallishMachOp -> LMAlign
machOpMemcpyishAlign CallishMachOp
op = 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
    DynFlags
dflags <- WriterT LlvmAccum LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let isVolTy :: [LlvmType]
isVolTy = [LlvmType
i1]
        isVolVal :: [LlvmVar]
isVolVal = [LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i1 0]
        argTy :: [LlvmType]
argTy | MO_Memset _ <- CallishMachOp
op = [LlvmType
i8Ptr, LlvmType
i8,    DynFlags -> LlvmType
llvmWord DynFlags
dflags, LlvmType
i32] [LlvmType] -> [LlvmType] -> [LlvmType]
forall a. [a] -> [a] -> [a]
++ [LlvmType]
isVolTy
              | Bool
otherwise         = [LlvmType
i8Ptr, LlvmType
i8Ptr, DynFlags -> LlvmType
llvmWord DynFlags
dflags, LlvmType
i32] [LlvmType] -> [LlvmType] -> [LlvmType]
forall a. [a] -> [a] -> [a]
++ [LlvmType]
isVolTy
        funTy :: LMString -> LlvmType
funTy = \name :: 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 :: [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
    [LlvmVar]
argVars       <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT LlvmAccum LlvmM [LlvmVar]
arg_varsW [(CmmExpr, ForeignHint)]
args_hints ([], LlvmStatements
forall a. OrdList a
nilOL, [])
    LlvmVar
fptr          <- (LMString -> LlvmType)
-> ForeignTarget -> WriterT LlvmAccum LlvmM LlvmVar
getFunPtrW LMString -> LlvmType
funTy ForeignTarget
t
    [LlvmVar]
argVars' <- Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed ([(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar])
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
forall a b. (a -> b) -> a -> b
$ [LlvmVar] -> [LlvmType] -> [(LlvmVar, LlvmType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LlvmVar]
argVars [LlvmType]
argTy

    WriterT LlvmAccum LlvmM ()
doTrashStmts
    let alignVal :: LlvmVar
alignVal = LlvmType -> Int -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32 Int
align
        arguments :: [LlvmVar]
arguments = [LlvmVar]
argVars' [LlvmVar] -> [LlvmVar] -> [LlvmVar]
forall a. [a] -> [a] -> [a]
++ (LlvmVar
alignValLlvmVar -> [LlvmVar] -> [LlvmVar]
forall a. a -> [a] -> [a]
:[LlvmVar]
isVolVal)
    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
StdCall LlvmVar
fptr [LlvmVar]
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 w :: Width
w)) [dstH :: CmmFormal
dstH, dstL :: CmmFormal
dstL] [lhs :: CmmExpr
lhs, rhs :: 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
* 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.
    LlvmVar
lhsVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
lhs
    LlvmVar
rhsVar <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
rhs
    LlvmVar
lhsExt <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Zext LlvmVar
lhsVar LlvmType
width2x
    LlvmVar
rhsExt <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Zext LlvmVar
rhsVar LlvmType
width2x
    -- Do the actual multiplication (note that the result is also 2x width).
    LlvmVar
retV <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Mul LlvmVar
lhsExt LlvmVar
rhsExt
    -- Extract the lower bits of the result into retL.
    LlvmVar
retL <- 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
retV LlvmType
width
    -- Now we right-shift the higher bits by width.
    let widthLlvmLit :: LlvmVar
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
    LlvmVar
retShifted <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_LShr LlvmVar
retV LlvmVar
widthLlvmLit
    -- And extract them into retH.
    LlvmVar
retH <- 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
retShifted LlvmType
width
    LlvmVar
dstRegL <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dstL)
    LlvmVar
dstRegH <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
dstH)
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retL LlvmVar
dstRegL
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retH LlvmVar
dstRegH

-- 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 w :: Width
w))
        [dstQ :: CmmFormal
dstQ, dstR :: CmmFormal
dstR] [lhsH :: CmmExpr
lhsH, lhsL :: CmmExpr
lhsL, rhs :: 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
* 2)
    -- First zero-extend all parameters to double width.
    let zeroExtend :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
zeroExtend expr :: CmmExpr
expr = do
            LlvmVar
var <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
expr
            LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Zext LlvmVar
var LlvmType
width2x
    LlvmVar
lhsExtH <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
zeroExtend CmmExpr
lhsH
    LlvmVar
lhsExtL <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
zeroExtend CmmExpr
lhsL
    LlvmVar
rhsExt <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
zeroExtend CmmExpr
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 :: LlvmVar
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
    LlvmVar
lhsExtHShifted <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Shl LlvmVar
lhsExtH LlvmVar
widthLlvmLit
    LlvmVar
lhsExt <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Or LlvmVar
lhsExtHShifted LlvmVar
lhsExtL
    -- Finally, we can call 'udiv' and 'urem' to compute the results.
    LlvmVar
retExtDiv <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_UDiv LlvmVar
lhsExt LlvmVar
rhsExt
    LlvmVar
retExtRem <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
width2x (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_URem LlvmVar
lhsExt LlvmVar
rhsExt
    -- And since everything is in 2x width, we need to truncate the results and
    -- then return them.
    let narrow :: LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
narrow var :: 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
    LlvmVar
retDiv <- LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
narrow LlvmVar
retExtDiv
    LlvmVar
retRem <- LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
narrow LlvmVar
retExtRem
    LlvmVar
dstRegQ <- LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ CmmReg -> LlvmM LlvmVar
getCmmReg (CmmFormal -> CmmReg
CmmLocal CmmFormal
dstQ)
    LlvmVar
dstRegR <- LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ CmmReg -> LlvmM LlvmVar
getCmmReg (CmmFormal -> CmmReg
CmmLocal CmmFormal
dstR)
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retDiv LlvmVar
dstRegQ
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retRem LlvmVar
dstRegR

-- 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 w :: Width
w)) [dstV :: CmmFormal
dstV, dstO :: CmmFormal
dstO] [lhs :: CmmExpr
lhs, rhs :: 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 w :: Width
w)) [dstV :: CmmFormal
dstV, dstO :: CmmFormal
dstO] [lhs :: CmmExpr
lhs, rhs :: 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 w :: Width
w)) [dstO :: CmmFormal
dstO, dstV :: CmmFormal
dstV] [lhs :: CmmExpr
lhs, rhs :: 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 w :: Width
w)) [dstV :: CmmFormal
dstV, dstO :: CmmFormal
dstO] [lhs :: CmmExpr
lhs, rhs :: 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 w :: Width
w)) [dstV :: CmmFormal
dstV, dstO :: CmmFormal
dstO] [lhs :: CmmExpr
lhs, rhs :: 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 target :: ForeignTarget
target res :: [CmmFormal]
res args :: [CmmExpr]
args = 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
    DynFlags
dflags <- WriterT LlvmAccum LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    -- parameter types
    let arg_type :: (CmmExpr, ForeignHint) -> LlvmType
arg_type (_, AddrHint) = LlvmType
i8Ptr
        -- cast pointers to i8*. Llvm equivalent of void*
        arg_type (expr :: CmmExpr
expr, _) = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
expr

    -- ret type
    let ret_type :: [(CmmFormal, ForeignHint)] -> LlvmType
ret_type [] = LlvmType
LMVoid
        ret_type [(_, AddrHint)] = LlvmType
i8Ptr
        ret_type [(reg :: CmmFormal
reg, _)]      = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmFormal -> CmmType
localRegType CmmFormal
reg
        ret_type t :: [(CmmFormal, ForeignHint)]
t = String -> LlvmType
forall a. String -> a
panic (String -> LlvmType) -> String -> LlvmType
forall a b. (a -> b) -> a -> b
$ "genCall: Too many return values! Can only handle"
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 0 or 1, given " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([(CmmFormal, ForeignHint)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(CmmFormal, ForeignHint)]
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "."

    -- extract Cmm call convention, and translate to LLVM call convention
    Platform
platform <- LlvmM Platform -> WriterT LlvmAccum LlvmM Platform
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LlvmM Platform -> WriterT LlvmAccum LlvmM Platform)
-> LlvmM Platform -> WriterT LlvmAccum LlvmM Platform
forall a b. (a -> b) -> a -> b
$ LlvmM Platform
getLlvmPlatform
    let lmconv :: LlvmCallConvention
lmconv = case ForeignTarget
target of
            ForeignTarget _ (ForeignConvention conv :: CCallConv
conv _ _ _) ->
              case CCallConv
conv of
                 StdCallConv  -> case Platform -> Arch
platformArch Platform
platform of
                                 ArchX86    -> LlvmCallConvention
CC_X86_Stdcc
                                 ArchX86_64 -> LlvmCallConvention
CC_X86_Stdcc
                                 _          -> LlvmCallConvention
CC_Ccc
                 CCallConv    -> LlvmCallConvention
CC_Ccc
                 CApiConv     -> LlvmCallConvention
CC_Ccc
                 PrimCallConv -> String -> LlvmCallConvention
forall a. String -> a
panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"
                 JavaScriptCallConv -> String -> LlvmCallConvention
forall a. String -> a
panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv"

            PrimTarget   _ -> 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.
    -}

    -- call attributes
    let fnAttrs :: [LlvmFuncAttr]
fnAttrs | Bool
never_returns = LlvmFuncAttr
NoReturn LlvmFuncAttr -> [LlvmFuncAttr] -> [LlvmFuncAttr]
forall a. a -> [a] -> [a]
: [LlvmFuncAttr]
llvmStdFunAttrs
                | Bool
otherwise     = [LlvmFuncAttr]
llvmStdFunAttrs

        never_returns :: Bool
never_returns = case ForeignTarget
target of
             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> Bool
True
             _ -> Bool
False

    -- fun type
    let (res_hints :: [ForeignHint]
res_hints, arg_hints :: [ForeignHint]
arg_hints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
    let args_hints :: [(CmmExpr, ForeignHint)]
args_hints = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints
    let ress_hints :: [(CmmFormal, ForeignHint)]
ress_hints = [CmmFormal] -> [ForeignHint] -> [(CmmFormal, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmFormal]
res  [ForeignHint]
res_hints
    let ccTy :: LlvmCallType
ccTy  = LlvmCallType
StdCall -- tail calls should be done through CmmJump
    let retTy :: LlvmType
retTy = [(CmmFormal, ForeignHint)] -> LlvmType
ret_type [(CmmFormal, ForeignHint)]
ress_hints
    let argTy :: [LlvmParameter]
argTy = [LlvmType] -> [LlvmParameter]
tysToParams ([LlvmType] -> [LlvmParameter]) -> [LlvmType] -> [LlvmParameter]
forall a b. (a -> b) -> a -> b
$ ((CmmExpr, ForeignHint) -> LlvmType)
-> [(CmmExpr, ForeignHint)] -> [LlvmType]
forall a b. (a -> b) -> [a] -> [b]
map (CmmExpr, ForeignHint) -> LlvmType
arg_type [(CmmExpr, ForeignHint)]
args_hints
    let funTy :: LMString -> LlvmType
funTy = \name :: 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 (DynFlags -> LMAlign
llvmFunAlign DynFlags
dflags)


    [LlvmVar]
argVars <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT LlvmAccum LlvmM [LlvmVar]
arg_varsW [(CmmExpr, ForeignHint)]
args_hints ([], LlvmStatements
forall a. OrdList a
nilOL, [])
    LlvmVar
fptr    <- (LMString -> LlvmType)
-> ForeignTarget -> WriterT LlvmAccum LlvmM LlvmVar
getFunPtrW LMString -> LlvmType
funTy ForeignTarget
target

    let doReturn :: WriterT LlvmAccum LlvmM ()
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 (m :: * -> *) a. Monad m => a -> m a
return ()

    WriterT LlvmAccum LlvmM ()
doTrashStmts

    -- make the actual call
    case LlvmType
retTy of
        LMVoid -> do
            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

        _ -> do
            LlvmVar
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] -> a
ret_reg [reg :: a
reg] = a
reg
                ret_reg t :: [a]
t = String -> a
forall a. String -> a
panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "genCall: Bad number of registers! Can only handle"
                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 1, given " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "."
            let creg :: CmmFormal
creg = [CmmFormal] -> CmmFormal
forall a. [a] -> a
ret_reg [CmmFormal]
res
            LlvmVar
vreg <- CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW (CmmFormal -> CmmReg
CmmLocal CmmFormal
creg)
            if LlvmType
retTy LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmType -> LlvmType
pLower (LlvmVar -> LlvmType
getVarType LlvmVar
vreg)
                then do
                    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
v1 LlvmVar
vreg
                    WriterT LlvmAccum LlvmM ()
doReturn
                else do
                    let ty :: LlvmType
ty = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
vreg
                    let op :: LlvmCastOp
op = case LlvmType
ty of
                            vt :: LlvmType
vt | LlvmType -> Bool
isPointer LlvmType
vt -> LlvmCastOp
LM_Bitcast
                               | LlvmType -> Bool
isInt     LlvmType
vt -> LlvmCastOp
LM_Ptrtoint
                               | Bool
otherwise    ->
                                   String -> LlvmCastOp
forall a. String -> a
panic (String -> LlvmCastOp) -> String -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ "genCall: CmmReg bad match for"
                                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ " returned type!"

                    LlvmVar
v2 <- 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
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
op LlvmVar
v1 LlvmType
ty
                    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
v2 LlvmVar
vreg
                    WriterT LlvmAccum LlvmM ()
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 op :: CallishMachOp
op) w :: Width
w [dstV :: CmmFormal
dstV, dstO :: CmmFormal
dstO] [lhs :: CmmExpr
lhs, rhs :: CmmExpr
rhs] = do
    -- So far this was only tested for the following four CallishMachOps.
    let valid :: Bool
valid = CallishMachOp
op CallishMachOp -> [CallishMachOp] -> 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
                            ]
    MASSERT(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 :: LlvmVar
value, overflowBit :: LlvmVar
overflowBit, (stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
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 :: LlvmVar
overflow, zext :: LlvmStatement
zext) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
width (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Zext LlvmVar
overflowBit LlvmType
width
    LlvmVar
dstRegV <- CmmReg -> LlvmM LlvmVar
getCmmReg (CmmFormal -> CmmReg
CmmLocal CmmFormal
dstV)
    LlvmVar
dstRegO <- CmmReg -> LlvmM LlvmVar
getCmmReg (CmmFormal -> CmmReg
CmmLocal CmmFormal
dstO)
    let storeV :: LlvmStatement
storeV = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
value LlvmVar
dstRegV
        storeO :: LlvmStatement
storeO = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
overflow LlvmVar
dstRegO
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
zext LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
storeV LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
storeO, [LlvmCmmDecl]
top)
genCallWithOverflow _ _ _ _ =
    String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic "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 op :: CallishMachOp
op) w :: Width
w (argA :: CmmExpr
argA, argB :: CmmExpr
argB) (llvmTypeA :: LlvmType
llvmTypeA, llvmTypeB :: 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 :: [LlvmVar]
argsV1, args1 :: LlvmStatements
args1, top1 :: [LlvmCmmDecl]
top1) <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
args_hints ([], LlvmStatements
forall a. OrdList a
nilOL, [])
    (argsV2 :: [LlvmVar]
argsV2, args2 :: LlvmStatements
args2) <- Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars Signage
Signed ([(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements))
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
forall a b. (a -> b) -> a -> b
$ [LlvmVar] -> [LlvmType] -> [(LlvmVar, LlvmType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LlvmVar]
argsV1 [LlvmType]
argTy

    -- Get the function and make the call.
    LMString
fname <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
op
    (fptr :: LlvmVar
fptr, _, top2 :: [LlvmCmmDecl]
top2) <- LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct LMString
fname LlvmType
retTy [LlvmType]
argTy
    -- We use StdCall for primops. See also the last case of genCall.
    (retV :: LlvmVar
retV, call :: LlvmStatement
call) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
retTy (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
StdCall LlvmVar
fptr [LlvmVar]
argsV2 []

    -- This will result in a two element struct, we need to use "extractvalue"
    -- to get them out of it.
    (res1 :: LlvmVar
res1, ext1 :: LlvmStatement
ext1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
llvmTypeA (LlvmVar -> Int -> LlvmExpression
ExtractV LlvmVar
retV 0)
    (res2 :: LlvmVar
res2, ext2 :: LlvmStatement
ext2) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
llvmTypeB (LlvmVar -> Int -> LlvmExpression
ExtractV LlvmVar
retV 1)

    let stmts :: LlvmStatements
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]
tops = [LlvmCmmDecl]
top1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top2
    (LlvmVar, LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
-> LlvmM (LlvmVar, LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
res1, LlvmVar
res2, (LlvmStatements
stmts, [LlvmCmmDecl]
tops))

genCallExtract _ _ _ _ =
    String -> LlvmM (LlvmVar, LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
forall a. String -> a
panic "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 w :: Width
w t :: ForeignTarget
t@(PrimTarget op :: CallishMachOp
op) [dst :: CmmFormal
dst] args :: [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

    LMString
fname                       <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
op
    (fptr :: LlvmVar
fptr, _, top3 :: [LlvmCmmDecl]
top3)             <- LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct LMString
fname LlvmType
width [LlvmType
width]

    LlvmVar
dstV                        <- CmmReg -> LlvmM LlvmVar
getCmmReg (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)

    let (_, arg_hints :: [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
    (argsV :: [LlvmVar]
argsV, stmts2 :: LlvmStatements
stmts2, top2 :: [LlvmCmmDecl]
top2)       <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
args_hints ([], LlvmStatements
forall a. OrdList a
nilOL, [])
    (argsV' :: [LlvmVar]
argsV', stmts4 :: LlvmStatements
stmts4)            <- Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars Signage
Signed ([(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements))
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
forall a b. (a -> b) -> a -> b
$ [LlvmVar] -> [LlvmType] -> [(LlvmVar, LlvmType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LlvmVar]
argsV [LlvmType
width]
    (retV :: LlvmVar
retV, s1 :: LlvmStatement
s1)                  <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
width (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
StdCall LlvmVar
fptr [LlvmVar]
argsV' []
    (retVs' :: [LlvmVar]
retVs', stmts5 :: LlvmStatements
stmts5)            <- Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars (CallishMachOp -> Signage
cmmPrimOpRetValSignage CallishMachOp
op) [(LlvmVar
retV,LlvmType
dstTy)]
    let retV' :: LlvmVar
retV'                    = String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genCallSimpleCast" [LlvmVar]
retVs'
    let s2 :: LlvmStatement
s2                       = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retV' LlvmVar
dstV

    let stmts :: LlvmStatements
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
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts, [LlvmCmmDecl]
top2 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top3)
genCallSimpleCast _ _ dsts :: [CmmFormal]
dsts _ =
    String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic ("genCallSimpleCast: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmFormal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmFormal]
dsts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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 w :: Width
w t :: ForeignTarget
t@(PrimTarget op :: CallishMachOp
op) [dst :: CmmFormal
dst] args :: [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

    LMString
fname                       <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
op
    (fptr :: LlvmVar
fptr, _, top3 :: [LlvmCmmDecl]
top3)             <- LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct LMString
fname LlvmType
width (LlvmType -> CmmExpr -> LlvmType
forall a b. a -> b -> a
const LlvmType
width (CmmExpr -> LlvmType) -> [CmmExpr] -> [LlvmType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CmmExpr]
args)

    LlvmVar
dstV                        <- CmmReg -> LlvmM LlvmVar
getCmmReg (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)

    let (_, arg_hints :: [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
    (argsV :: [LlvmVar]
argsV, stmts2 :: LlvmStatements
stmts2, top2 :: [LlvmCmmDecl]
top2)       <- [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
args_hints ([], LlvmStatements
forall a. OrdList a
nilOL, [])
    (argsV' :: [LlvmVar]
argsV', stmts4 :: LlvmStatements
stmts4)            <- Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars Signage
Signed ([(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements))
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
forall a b. (a -> b) -> a -> b
$ [LlvmVar] -> [LlvmType] -> [(LlvmVar, LlvmType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LlvmVar]
argsV (LlvmType -> LlvmVar -> LlvmType
forall a b. a -> b -> a
const LlvmType
width (LlvmVar -> LlvmType) -> [LlvmVar] -> [LlvmType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LlvmVar]
argsV)
    (retV :: LlvmVar
retV, s1 :: LlvmStatement
s1)                  <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
width (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
StdCall LlvmVar
fptr [LlvmVar]
argsV' []
    (retVs' :: [LlvmVar]
retVs', stmts5 :: LlvmStatements
stmts5)             <- Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars (CallishMachOp -> Signage
cmmPrimOpRetValSignage CallishMachOp
op) [(LlvmVar
retV,LlvmType
dstTy)]
    let retV' :: LlvmVar
retV'                    = String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genCallSimpleCast2" [LlvmVar]
retVs'
    let s2 :: LlvmStatement
s2                       = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
retV' LlvmVar
dstV

    let stmts :: LlvmStatements
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
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts, [LlvmCmmDecl]
top2 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top3)
genCallSimpleCast2 _ _ dsts :: [CmmFormal]
dsts _ =
    String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic ("genCallSimpleCast2: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([CmmFormal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmFormal]
dsts) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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 funTy :: LMString -> LlvmType
funTy targ :: 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 funTy :: LMString -> LlvmType
funTy targ :: ForeignTarget
targ = case ForeignTarget
targ of
    ForeignTarget (CmmLit (CmmLabel lbl :: CLabel
lbl)) _ -> do
        LMString
name <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
lbl
        LMString -> LlvmType -> LlvmM ExprData
getHsFunc' LMString
name (LMString -> LlvmType
funTy LMString
name)

    ForeignTarget expr :: CmmExpr
expr _ -> do
        (v1 :: LlvmVar
v1, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
expr
        DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let fty :: LlvmType
fty = LMString -> LlvmType
funTy (LMString -> LlvmType) -> LMString -> LlvmType
forall a b. (a -> b) -> a -> b
$ String -> LMString
fsLit "dynamic"
            cast :: LlvmCastOp
cast = case LlvmVar -> LlvmType
getVarType LlvmVar
v1 of
                ty :: LlvmType
ty | LlvmType -> Bool
isPointer LlvmType
ty -> LlvmCastOp
LM_Bitcast
                ty :: LlvmType
ty | LlvmType -> Bool
isInt LlvmType
ty     -> LlvmCastOp
LM_Inttoptr

                ty :: LlvmType
ty -> String -> LlvmCastOp
forall a. String -> a
panic (String -> LlvmCastOp) -> String -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ "genCall: Expr is of bad type for function"
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ " call! (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"

        (v2 :: LlvmVar
v2,s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (LlvmType -> LlvmType
pLift LlvmType
fty) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
cast LlvmVar
v1 (LlvmType -> LlvmType
pLift LlvmType
fty)
        ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v2, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top)

    PrimTarget mop :: CallishMachOp
mop -> do
        LMString
name <- CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions CallishMachOp
mop
        let fty :: LlvmType
fty = LMString -> LlvmType
funTy LMString
name
        LMString -> LlvmType -> LlvmM ExprData
getInstrinct2 LMString
name LlvmType
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 xs :: [(CmmExpr, ForeignHint)]
xs ys :: ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
ys = do
    (vars :: [LlvmVar]
vars, stmts :: LlvmStatements
stmts, decls :: [LlvmCmmDecl]
decls) <- LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> WriterT
     LlvmAccum LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
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
    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 LlvmStatements
stmts [LlvmCmmDecl]
decls
    [LlvmVar] -> WriterT LlvmAccum LlvmM [LlvmVar]
forall (m :: * -> *) a. Monad m => a -> m a
return [LlvmVar]
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 [] (vars :: [LlvmVar]
vars, stmts :: LlvmStatements
stmts, tops :: [LlvmCmmDecl]
tops)
  = ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LlvmVar]
vars, LlvmStatements
stmts, [LlvmCmmDecl]
tops)

arg_vars ((e :: CmmExpr
e, AddrHint):rest :: [(CmmExpr, ForeignHint)]
rest) (vars :: [LlvmVar]
vars, stmts :: LlvmStatements
stmts, tops :: [LlvmCmmDecl]
tops)
  = do (v1 :: LlvmVar
v1, stmts' :: LlvmStatements
stmts', top' :: [LlvmCmmDecl]
top') <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
e
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let op :: LlvmCastOp
op = case LlvmVar -> LlvmType
getVarType LlvmVar
v1 of
               ty :: LlvmType
ty | LlvmType -> Bool
isPointer LlvmType
ty -> LlvmCastOp
LM_Bitcast
               ty :: LlvmType
ty | LlvmType -> Bool
isInt LlvmType
ty     -> LlvmCastOp
LM_Inttoptr

               a :: LlvmType
a  -> String -> LlvmCastOp
forall a. String -> a
panic (String -> LlvmCastOp) -> String -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ "genCall: Can't cast llvmType to i8*! ("
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
a) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"

       (v2 :: LlvmVar
v2, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
i8Ptr (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
op LlvmVar
v1 LlvmType
i8Ptr
       [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
rest ([LlvmVar]
vars [LlvmVar] -> [LlvmVar] -> [LlvmVar]
forall a. [a] -> [a] -> [a]
++ [LlvmVar
v2], LlvmStatements
stmts LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts' LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1,
                               [LlvmCmmDecl]
tops [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top')

arg_vars ((e :: CmmExpr
e, _):rest :: [(CmmExpr, ForeignHint)]
rest) (vars :: [LlvmVar]
vars, stmts :: LlvmStatements
stmts, tops :: [LlvmCmmDecl]
tops)
  = do (v1 :: LlvmVar
v1, stmts' :: LlvmStatements
stmts', top' :: [LlvmCmmDecl]
top') <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
e
       [(CmmExpr, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
arg_vars [(CmmExpr, ForeignHint)]
rest ([LlvmVar]
vars [LlvmVar] -> [LlvmVar] -> [LlvmVar]
forall a. [a] -> [a] -> [a]
++ [LlvmVar
v1], LlvmStatements
stmts LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts', [LlvmCmmDecl]
tops [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
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
signage vars :: [(LlvmVar, LlvmType)]
vars = do
    (vars :: [LlvmVar]
vars, stmts :: LlvmStatements
stmts) <- LlvmM ([LlvmVar], LlvmStatements)
-> WriterT LlvmAccum LlvmM ([LlvmVar], LlvmStatements)
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
    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 LlvmStatements
stmts [LlvmCmmDecl]
forall a. Monoid a => a
mempty
    [LlvmVar] -> WriterT LlvmAccum LlvmM [LlvmVar]
forall (m :: * -> *) a. Monad m => a -> m a
return [LlvmVar]
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
signage vars :: [(LlvmVar, LlvmType)]
vars = do
                [(LlvmVar, LlvmStatement)]
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)
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' :: [LlvmVar]
vars', stmts :: [LlvmStatement]
stmts) = [(LlvmVar, LlvmStatement)] -> ([LlvmVar], [LlvmStatement])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LlvmVar, LlvmStatement)]
done
                ([LlvmVar], LlvmStatements) -> LlvmM ([LlvmVar], LlvmStatements)
forall (m :: * -> *) a. Monad m => a -> m a
return ([LlvmVar]
vars', [LlvmStatement] -> LlvmStatements
forall a. [a] -> OrdList a
toOL [LlvmStatement]
stmts)

-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
castVar signage :: Signage
signage v :: LlvmVar
v t :: 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 (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v, LlvmStatement
Nop)

            | Bool
otherwise
            = do DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                 let op :: LlvmCastOp
op = case (LlvmVar -> LlvmType
getVarType LlvmVar
v, LlvmType
t) of
                      (LMInt n :: Int
n, LMInt m :: Int
m)
                          -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m then LlvmCastOp
extend else LlvmCastOp
LM_Trunc
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isFloat LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isFloat LlvmType
t
                          -> if DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
vt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
t
                                then LlvmCastOp
LM_Fpext else LlvmCastOp
LM_Fptrunc
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isInt LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isFloat LlvmType
t       -> LlvmCastOp
LM_Sitofp
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isFloat LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isInt LlvmType
t       -> LlvmCastOp
LM_Fptosi
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isInt LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isPointer LlvmType
t     -> LlvmCastOp
LM_Inttoptr
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isPointer LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isInt LlvmType
t     -> LlvmCastOp
LM_Ptrtoint
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isPointer LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isPointer LlvmType
t -> LlvmCastOp
LM_Bitcast
                      (vt :: LlvmType
vt, _) | LlvmType -> Bool
isVector LlvmType
vt Bool -> Bool -> Bool
&& LlvmType -> Bool
isVector LlvmType
t   -> LlvmCastOp
LM_Bitcast

                      (vt :: LlvmType
vt, _) -> String -> LlvmCastOp
forall a. String -> a
panic (String -> LlvmCastOp) -> String -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ "castVars: Can't cast this type ("
                                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
vt) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ") to (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
                 LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
t (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
op LlvmVar
v LlvmType
t
    where extend :: LlvmCastOp
extend = case Signage
signage of
            Signed      -> LlvmCastOp
LM_Sext
            Unsigned    -> LlvmCastOp
LM_Zext


cmmPrimOpRetValSignage :: CallishMachOp -> Signage
cmmPrimOpRetValSignage :: CallishMachOp -> Signage
cmmPrimOpRetValSignage mop :: CallishMachOp
mop = case CallishMachOp
mop of
    MO_Pdep _   -> Signage
Unsigned
    MO_Pext _   -> Signage
Unsigned
    _           -> Signage
Signed

-- | Decide what C function to use to implement a CallishMachOp
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
cmmPrimOpFunctions mop :: CallishMachOp
mop = do

  DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  let intrinTy1 :: String
intrinTy1 = "p0i8.p0i8." String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmType
llvmWord DynFlags
dflags)
      intrinTy2 :: String
intrinTy2 = "p0i8." String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> LlvmType
llvmWord DynFlags
dflags)
      unsupported :: LMString
unsupported = String -> LMString
forall a. String -> a
panic ("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]
++ " not supported here")

  LMString -> LlvmM LMString
forall (m :: * -> *) a. Monad m => a -> m a
return (LMString -> LlvmM LMString) -> LMString -> LlvmM LMString
forall a b. (a -> b) -> a -> b
$ case CallishMachOp
mop of
    MO_F32_Exp    -> String -> LMString
fsLit "expf"
    MO_F32_Log    -> String -> LMString
fsLit "logf"
    MO_F32_Sqrt   -> String -> LMString
fsLit "llvm.sqrt.f32"
    MO_F32_Fabs   -> String -> LMString
fsLit "llvm.fabs.f32"
    MO_F32_Pwr    -> String -> LMString
fsLit "llvm.pow.f32"

    MO_F32_Sin    -> String -> LMString
fsLit "llvm.sin.f32"
    MO_F32_Cos    -> String -> LMString
fsLit "llvm.cos.f32"
    MO_F32_Tan    -> String -> LMString
fsLit "tanf"

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

    MO_F32_Sinh   -> String -> LMString
fsLit "sinhf"
    MO_F32_Cosh   -> String -> LMString
fsLit "coshf"
    MO_F32_Tanh   -> String -> LMString
fsLit "tanhf"

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

    MO_F64_Exp    -> String -> LMString
fsLit "exp"
    MO_F64_Log    -> String -> LMString
fsLit "log"
    MO_F64_Sqrt   -> String -> LMString
fsLit "llvm.sqrt.f64"
    MO_F64_Fabs   -> String -> LMString
fsLit "llvm.fabs.f64"
    MO_F64_Pwr    -> String -> LMString
fsLit "llvm.pow.f64"

    MO_F64_Sin    -> String -> LMString
fsLit "llvm.sin.f64"
    MO_F64_Cos    -> String -> LMString
fsLit "llvm.cos.f64"
    MO_F64_Tan    -> String -> LMString
fsLit "tan"

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

    MO_F64_Sinh   -> String -> LMString
fsLit "sinh"
    MO_F64_Cosh   -> String -> LMString
fsLit "cosh"
    MO_F64_Tanh   -> String -> LMString
fsLit "tanh"

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

    MO_Memcpy _   -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.memcpy."  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
intrinTy1
    MO_Memmove _  -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.memmove." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
intrinTy1
    MO_Memset _   -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.memset."  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
intrinTy2
    MO_Memcmp _   -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "memcmp"

    (MO_PopCnt w :: Width
w) -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.ctpop."  String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    (MO_BSwap w :: Width
w)  -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.bswap."  String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    (MO_Clz w :: Width
w)    -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.ctlz."   String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    (MO_Ctz w :: Width
w)    -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.cttz."   String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)

    (MO_Pdep w :: Width
w)   ->  let w' :: String
w' = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
w)
                      in  if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
                            then String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.x86.bmi.pdep."   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
w'
                            else String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "hs_pdep"              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
w'
    (MO_Pext w :: Width
w)   ->  let w' :: String
w' = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> SDoc) -> Int -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
w)
                      in  if DynFlags -> Bool
isBmi2Enabled DynFlags
dflags
                            then String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.x86.bmi.pext."   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
w'
                            else String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "hs_pext"              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
w'

    (MO_Prefetch_Data _ )-> String -> LMString
fsLit "llvm.prefetch"

    MO_AddIntC w :: Width
w    -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.sadd.with.overflow."
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    MO_SubIntC w :: Width
w    -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.ssub.with.overflow."
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    MO_Add2 w :: Width
w       -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.uadd.with.overflow."
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    MO_AddWordC w :: Width
w   -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.uadd.with.overflow."
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)
    MO_SubWordC w :: Width
w   -> String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.usub.with.overflow."
                             String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ Width -> LlvmType
widthToLlvmInt Width
w)

    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
    MO_ReadBarrier   -> LMString
unsupported
    MO_WriteBarrier  -> LMString
unsupported
    MO_Touch         -> LMString
unsupported
    MO_UF_Conv _     -> LMString
unsupported

    MO_AtomicRead _  -> LMString
unsupported
    MO_AtomicRMW _ _ -> LMString
unsupported
    MO_AtomicWrite _ -> LMString
unsupported
    MO_Cmpxchg _     -> LMString
unsupported

-- | Tail function calls
genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData

-- Call to known function
genJump :: CmmExpr -> [GlobalReg] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genJump (CmmLit (CmmLabel lbl :: CLabel
lbl)) live :: [GlobalReg]
live = do
    (vf :: LlvmVar
vf, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- [GlobalReg] -> CLabel -> LlvmM ExprData
getHsFunc [GlobalReg]
live CLabel
lbl
    (stgRegs :: [LlvmVar]
stgRegs, stgStmts :: LlvmStatements
stgStmts) <- [GlobalReg] -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue [GlobalReg]
live
    let s1 :: LlvmStatement
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 :: LlvmStatement
s2  = Maybe LlvmVar -> LlvmStatement
Return Maybe LlvmVar
forall a. Maybe a
Nothing
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stgStmts 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, [LlvmCmmDecl]
top)


-- Call to unknown function / address
genJump expr :: CmmExpr
expr live :: [GlobalReg]
live = do
    LlvmType
fty <- [GlobalReg] -> LlvmM LlvmType
llvmFunTy [GlobalReg]
live
    (vf :: LlvmVar
vf, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
expr
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    let cast :: LlvmCastOp
cast = case LlvmVar -> LlvmType
getVarType LlvmVar
vf of
         ty :: LlvmType
ty | LlvmType -> Bool
isPointer LlvmType
ty -> LlvmCastOp
LM_Bitcast
         ty :: LlvmType
ty | LlvmType -> Bool
isInt LlvmType
ty     -> LlvmCastOp
LM_Inttoptr

         ty :: LlvmType
ty -> String -> LlvmCastOp
forall a. String -> a
panic (String -> LlvmCastOp) -> String -> LlvmCastOp
forall a b. (a -> b) -> a -> b
$ "genJump: Expr is of bad type for function call! ("
                     String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"

    (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (LlvmType -> LlvmType
pLift LlvmType
fty) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
cast LlvmVar
vf (LlvmType -> LlvmType
pLift LlvmType
fty)
    (stgRegs :: [LlvmVar]
stgRegs, stgStmts :: LlvmStatements
stgStmts) <- [GlobalReg] -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue [GlobalReg]
live
    let s2 :: LlvmStatement
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 :: LlvmStatement
s3 = Maybe LlvmVar -> LlvmStatement
Return Maybe LlvmVar
forall a. Maybe a
Nothing
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts 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
stgStmts 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)


-- | 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 reg :: CmmReg
reg val :: CmmExpr
val = do
    LlvmVar
vreg <- CmmReg -> LlvmM LlvmVar
getCmmReg CmmReg
reg
    (vval :: LlvmVar
vval, stmts2 :: LlvmStatements
stmts2, top2 :: [LlvmCmmDecl]
top2) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
val
    let stmts :: LlvmStatements
stmts = LlvmStatements
stmts2

    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
vreg
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    case LlvmType
ty of
      -- Some registers are pointer types, so need to cast value to pointer
      LMPointer _ | LlvmVar -> LlvmType
getVarType LlvmVar
vval LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> LlvmType
llvmWord DynFlags
dflags -> do
          (v :: LlvmVar
v, s1 :: LlvmStatement
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 :: LlvmStatement
s2 = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
v LlvmVar
vreg
          (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts 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, [LlvmCmmDecl]
top2)

      LMVector _ _ -> do
          (v :: LlvmVar
v, s1 :: LlvmStatement
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 :: LlvmStatement
s2 = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
v LlvmVar
vreg
          (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts 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, [LlvmCmmDecl]
top2)

      _ -> do
          let s1 :: LlvmStatement
s1 = LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
vval LlvmVar
vreg
          (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
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 -> 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 -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore addr :: CmmExpr
addr@(CmmReg (CmmGlobal r :: GlobalReg
r)) val :: CmmExpr
val
    = CmmExpr
-> GlobalReg
-> Int
-> CmmExpr
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalReg
r 0 CmmExpr
val

genStore addr :: CmmExpr
addr@(CmmRegOff (CmmGlobal r :: GlobalReg
r) n :: Int
n) val :: CmmExpr
val
    = CmmExpr
-> GlobalReg
-> Int
-> CmmExpr
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalReg
r Int
n CmmExpr
val

genStore addr :: CmmExpr
addr@(CmmMachOp (MO_Add _) [
                            (CmmReg (CmmGlobal r :: GlobalReg
r)),
                            (CmmLit (CmmInt n :: Integer
n _))])
                val :: CmmExpr
val
    = CmmExpr
-> GlobalReg
-> Int
-> CmmExpr
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalReg
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) CmmExpr
val

genStore addr :: CmmExpr
addr@(CmmMachOp (MO_Sub _) [
                            (CmmReg (CmmGlobal r :: GlobalReg
r)),
                            (CmmLit (CmmInt n :: Integer
n _))])
                val :: CmmExpr
val
    = CmmExpr
-> GlobalReg
-> Int
-> CmmExpr
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast CmmExpr
addr GlobalReg
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

-- generic case
genStore addr :: CmmExpr
addr val :: CmmExpr
val
    = Unique -> LlvmM [MetaAnnot]
getTBAAMeta Unique
topN LlvmM [MetaAnnot]
-> ([MetaAnnot] -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CmmExpr
-> CmmExpr -> [MetaAnnot] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_slow CmmExpr
addr CmmExpr
val

-- | CmmStore operation
-- This is a special case for storing to a global register pointer
-- offset such as I32[Sp+8].
genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
              -> LlvmM StmtData
genStore_fast :: CmmExpr
-> GlobalReg
-> Int
-> CmmExpr
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_fast addr :: CmmExpr
addr r :: GlobalReg
r n :: Int
n val :: CmmExpr
val
  = do DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       (gv :: LlvmVar
gv, grt :: LlvmType
grt, s1 :: LlvmStatements
s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
       [MetaAnnot]
meta          <- GlobalReg -> LlvmM [MetaAnnot]
getTBAARegMeta GlobalReg
r
       let (ix :: Int
ix,rem :: Int
rem) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` ((DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags (LlvmType -> Int) -> (LlvmType -> LlvmType) -> LlvmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmType -> LlvmType
pLower) LlvmType
grt  Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)
       case LlvmType -> Bool
isPointer LlvmType
grt Bool -> Bool -> Bool
&& Int
rem Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 of
            True -> do
                (vval :: LlvmVar
vval,  stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
val
                (ptr :: LlvmVar
ptr, s2 :: LlvmStatement
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 LlvmType -> LlvmType
pLower LlvmType
grt LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmVar -> LlvmType
getVarType LlvmVar
vval of
                     -- were fine
                     True  -> do
                         let s3 :: LlvmStatement
s3 = [MetaAnnot] -> LlvmStatement -> LlvmStatement
MetaStmt [MetaAnnot]
meta (LlvmStatement -> LlvmStatement) -> LlvmStatement -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
vval LlvmVar
ptr
                         (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
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
                     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' :: LlvmVar
ptr', s3 :: LlvmStatement
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 :: LlvmStatement
s4 = [MetaAnnot] -> LlvmStatement -> LlvmStatement
MetaStmt [MetaAnnot]
meta (LlvmStatement -> LlvmStatement) -> LlvmStatement -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
vval LlvmVar
ptr'
                         (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
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 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s4, [LlvmCmmDecl]
top)

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


-- | CmmStore operation
-- Generic case. Uses casts and pointer arithmetic if needed.
genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
genStore_slow :: CmmExpr
-> CmmExpr -> [MetaAnnot] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genStore_slow addr :: CmmExpr
addr val :: CmmExpr
val meta :: [MetaAnnot]
meta = do
    (vaddr :: LlvmVar
vaddr, stmts1 :: LlvmStatements
stmts1, top1 :: [LlvmCmmDecl]
top1) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
addr
    (vval :: LlvmVar
vval,  stmts2 :: LlvmStatements
stmts2, top2 :: [LlvmCmmDecl]
top2) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
val

    let stmts :: LlvmStatements
stmts = LlvmStatements
stmts1 LlvmStatements -> LlvmStatements -> LlvmStatements
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` LlvmStatements
stmts2
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    case LlvmVar -> LlvmType
getVarType LlvmVar
vaddr of
        -- sometimes we need to cast an int to a pointer before storing
        LMPointer ty :: LlvmType
ty@(LMPointer _) | LlvmVar -> LlvmType
getVarType LlvmVar
vval LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> LlvmType
llvmWord DynFlags
dflags -> do
            (v :: LlvmVar
v, s1 :: LlvmStatement
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 :: LlvmStatement
s2 = [MetaAnnot] -> LlvmStatement -> LlvmStatement
MetaStmt [MetaAnnot]
meta (LlvmStatement -> LlvmStatement) -> LlvmStatement -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
v LlvmVar
vaddr
            (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts 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, [LlvmCmmDecl]
top1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top2)

        LMPointer _ -> do
            let s1 :: LlvmStatement
s1 = [MetaAnnot] -> LlvmStatement -> LlvmStatement
MetaStmt [MetaAnnot]
meta (LlvmStatement -> LlvmStatement) -> LlvmStatement -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
vval LlvmVar
vaddr
            (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
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 _) | LlvmType
i LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> LlvmType
llvmWord DynFlags
dflags -> 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 :: LlvmVar
vptr, s1 :: LlvmStatement
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 :: LlvmStatement
s2 = [MetaAnnot] -> LlvmStatement -> LlvmStatement
MetaStmt [MetaAnnot]
meta (LlvmStatement -> LlvmStatement) -> LlvmStatement -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store LlvmVar
vval LlvmVar
vptr
            (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts 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, [LlvmCmmDecl]
top1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top2)

        other :: LlvmType
other ->
            String -> SDoc -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> SDoc -> a
pprPanic "genStore: ptr not right type!"
                    (CmmExpr -> SDoc
PprCmm.pprExpr CmmExpr
addr SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (
                        "Size of Ptr: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (DynFlags -> Int
llvmPtrBits DynFlags
dflags) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        ", Size of var: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
other) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        ", Var: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
vaddr)))


-- | Unconditional branch
genBranch :: BlockId -> LlvmM StmtData
genBranch :: BlockId -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genBranch id :: BlockId
id =
    let label :: LlvmVar
label = BlockId -> LlvmVar
blockIdToLlvm BlockId
id
    in (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
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 cond :: CmmExpr
cond idT :: BlockId
idT idF :: BlockId
idF likely :: 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 :: LlvmVar
vc, stmts1 :: LlvmStatements
stmts1, top1 :: [LlvmCmmDecl]
top1) <- EOption -> CmmExpr -> LlvmM ExprData
exprToVarOpt EOption
i1Option CmmExpr
cond
    if LlvmVar -> LlvmType
getVarType LlvmVar
vc LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmType
i1
        then do
            (vc' :: LlvmVar
vc', (stmts2 :: LlvmStatements
stmts2, top2 :: [LlvmCmmDecl]
top2)) <- case Maybe Bool
likely of
              Just b :: Bool
b -> Integer
-> LlvmType
-> LlvmVar
-> LlvmM (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
genExpectLit (if Bool
b then 1 else 0) LlvmType
i1  LlvmVar
vc
              _      -> (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
-> LlvmM (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LlvmVar
vc, (LlvmStatements
forall a. OrdList a
nilOL, []))
            let s1 :: LlvmStatement
s1 = LlvmVar -> LlvmVar -> LlvmVar -> LlvmStatement
BranchIf LlvmVar
vc' LlvmVar
labelT LlvmVar
labelF
            (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (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, [LlvmCmmDecl]
top1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
top2)
        else do
            DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a. String -> a
panic (String -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> String -> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ "genCondBranch: Cond expr not bool! (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
vc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"


-- | 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 expLit :: Integer
expLit expTy :: LlvmType
expTy var :: LlvmVar
var = do
  DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

  let
    lit :: LlvmVar
lit = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit Integer
expLit LlvmType
expTy

    llvmExpectName :: LMString
llvmExpectName
      | LlvmType -> Bool
isInt LlvmType
expTy = String -> LMString
fsLit (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "llvm.expect." String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
expTy)
      | Bool
otherwise   = String -> LMString
forall a. String -> a
panic (String -> LMString) -> String -> LMString
forall a b. (a -> b) -> a -> b
$ "genExpectedLit: Type not an int!"

  (llvmExpect :: LlvmVar
llvmExpect, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <-
    LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
getInstrinct LMString
llvmExpectName LlvmType
expTy [LlvmType
expTy, LlvmType
expTy]
  (var' :: LlvmVar
var', call :: LlvmStatement
call) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
expTy (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCallType
-> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> LlvmExpression
Call LlvmCallType
StdCall LlvmVar
llvmExpect [LlvmVar
var, LlvmVar
lit] []
  (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
-> LlvmM (LlvmVar, (LlvmStatements, [LlvmCmmDecl]))
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
var', (LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
call, [LlvmCmmDecl]
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 :: CmmExpr -> SwitchTargets -> LlvmM StmtData
genSwitch :: CmmExpr -> SwitchTargets -> LlvmM (LlvmStatements, [LlvmCmmDecl])
genSwitch cond :: CmmExpr
cond ids :: SwitchTargets
ids = do
    (vc :: LlvmVar
vc, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
cond
    let ty :: LlvmType
ty = LlvmVar -> LlvmType
getVarType LlvmVar
vc

    let labels :: [(LlvmVar, LlvmVar)]
labels = [ (LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
ty Integer
ix, BlockId -> LlvmVar
blockIdToLlvm BlockId
b)
                 | (ix :: Integer
ix, b :: BlockId
b) <- SwitchTargets -> [(Integer, BlockId)]
switchTargetsCases SwitchTargets
ids ]
    -- out of range is undefined, so let's just branch to first label
    let defLbl :: LlvmVar
defLbl | Just l :: BlockId
l <- SwitchTargets -> Maybe BlockId
switchTargetsDefault SwitchTargets
ids = BlockId -> LlvmVar
blockIdToLlvm BlockId
l
               | Bool
otherwise                          = (LlvmVar, LlvmVar) -> LlvmVar
forall a b. (a, b) -> b
snd ([(LlvmVar, LlvmVar)] -> (LlvmVar, LlvmVar)
forall a. [a] -> a
head [(LlvmVar, LlvmVar)]
labels)

    let s1 :: LlvmStatement
s1 = LlvmVar -> LlvmVar -> [(LlvmVar, LlvmVar)] -> LlvmStatement
Switch LlvmVar
vc LlvmVar
defLbl [(LlvmVar, LlvmVar)]
labels
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return ((LlvmStatements, [LlvmCmmDecl])
 -> LlvmM (LlvmStatements, [LlvmCmmDecl]))
-> (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall a b. (a -> b) -> a -> b
$ (LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top)


-- -----------------------------------------------------------------------------
-- * 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 opt :: EOption
opt e :: CmmExpr
e = case CmmExpr
e of

    CmmLit lit :: CmmLit
lit
        -> EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt CmmLit
lit

    CmmLoad e' :: CmmExpr
e' ty :: CmmType
ty
        -> Bool -> CmmExpr -> CmmType -> LlvmM ExprData
genLoad Bool
False CmmExpr
e' CmmType
ty

    -- Cmmreg in expression is the value, so must load. If you want actual
    -- reg pointer, call getCmmReg directly.
    CmmReg r :: CmmReg
r -> do
        (v1 :: LlvmVar
v1, ty :: LlvmType
ty, s1 :: LlvmStatements
s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal CmmReg
r
        case LlvmType -> Bool
isPointer LlvmType
ty of
             True  -> do
                 -- Cmm wants the value, so pointer types must be cast to ints
                 DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                 (v2 :: LlvmVar
v2, s2 :: LlvmStatement
s2) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (DynFlags -> LlvmType
llvmWord DynFlags
dflags) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Ptrtoint LlvmVar
v1 (DynFlags -> LlvmType
llvmWord DynFlags
dflags)
                 ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v2, LlvmStatements
s1 LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s2, [])

             False -> ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatements
s1, [])

    CmmMachOp op :: MachOp
op exprs :: [CmmExpr]
exprs
        -> EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp EOption
opt MachOp
op [CmmExpr]
exprs

    CmmRegOff r :: CmmReg
r i :: Int
i
        -> do DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
              CmmExpr -> LlvmM ExprData
exprToVar (CmmExpr -> LlvmM ExprData) -> CmmExpr -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ DynFlags -> (CmmReg, Int) -> CmmExpr
expandCmmReg DynFlags
dflags (CmmReg
r, Int
i)

    CmmStackSlot _ _
        -> String -> LlvmM ExprData
forall a. String -> a
panic "exprToVar: CmmStackSlot not supported!"


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

-- Unary Machop
genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp _ op :: MachOp
op [x :: CmmExpr
x] = case MachOp
op of

    MO_Not w :: Width
w ->
        let all1 :: LlvmVar
all1 = LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit (Width -> LlvmType
widthToLlvmInt Width
w) (-1)
        in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate (Width -> LlvmType
widthToLlvmInt Width
w) LlvmVar
all1 LlvmMachOp
LM_MO_Xor

    MO_S_Neg w :: Width
w ->
        let all0 :: LlvmVar
all0 = LlvmType -> Integer -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit (Width -> LlvmType
widthToLlvmInt Width
w) 0
        in LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate (Width -> LlvmType
widthToLlvmInt Width
w) LlvmVar
all0 LlvmMachOp
LM_MO_Sub

    MO_F_Neg w :: Width
w ->
        let all0 :: LlvmVar
all0 = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Double -> LlvmType -> LlvmLit
LMFloatLit (-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_Conv _ w :: Width
w -> LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv (Width -> LlvmType
widthToLlvmFloat Width
w) LlvmCastOp
LM_Sitofp
    MO_FS_Conv _ w :: Width
w -> LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv (Width -> LlvmType
widthToLlvmInt Width
w) LlvmCastOp
LM_Fptosi

    MO_SS_Conv from :: Width
from to :: 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 from :: Width
from to :: 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 from :: Width
from to :: 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 from :: Width
from to :: Width
to
        -> Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv Width
from (Width -> LlvmType
widthToLlvmFloat Width
to) LlvmCastOp
LM_Fptrunc LlvmCastOp
LM_Fpext

    MO_VS_Neg len :: Int
len w :: 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 (-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 len :: Int
len w :: 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 (-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_AlignmentCheck _ _ -> String -> LlvmM ExprData
forall a. String -> a
panic "-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 _          -> LlvmM ExprData
panicOp
    MO_Mul _          -> LlvmM ExprData
panicOp
    MO_Sub _          -> LlvmM ExprData
panicOp
    MO_S_MulMayOflo _ -> LlvmM ExprData
panicOp
    MO_S_Quot _       -> LlvmM ExprData
panicOp
    MO_S_Rem _        -> LlvmM ExprData
panicOp
    MO_U_MulMayOflo _ -> LlvmM ExprData
panicOp
    MO_U_Quot _       -> LlvmM ExprData
panicOp
    MO_U_Rem _        -> LlvmM ExprData
panicOp

    MO_Eq  _          -> LlvmM ExprData
panicOp
    MO_Ne  _          -> LlvmM ExprData
panicOp
    MO_S_Ge _         -> LlvmM ExprData
panicOp
    MO_S_Gt _         -> LlvmM ExprData
panicOp
    MO_S_Le _         -> LlvmM ExprData
panicOp
    MO_S_Lt _         -> LlvmM ExprData
panicOp
    MO_U_Ge _         -> LlvmM ExprData
panicOp
    MO_U_Gt _         -> LlvmM ExprData
panicOp
    MO_U_Le _         -> LlvmM ExprData
panicOp
    MO_U_Lt _         -> LlvmM ExprData
panicOp

    MO_F_Add        _ -> LlvmM ExprData
panicOp
    MO_F_Sub        _ -> LlvmM ExprData
panicOp
    MO_F_Mul        _ -> LlvmM ExprData
panicOp
    MO_F_Quot       _ -> LlvmM ExprData
panicOp
    MO_F_Eq         _ -> LlvmM ExprData
panicOp
    MO_F_Ne         _ -> LlvmM ExprData
panicOp
    MO_F_Ge         _ -> LlvmM ExprData
panicOp
    MO_F_Gt         _ -> LlvmM ExprData
panicOp
    MO_F_Le         _ -> LlvmM ExprData
panicOp
    MO_F_Lt         _ -> LlvmM ExprData
panicOp

    MO_And          _ -> LlvmM ExprData
panicOp
    MO_Or           _ -> LlvmM ExprData
panicOp
    MO_Xor          _ -> LlvmM ExprData
panicOp
    MO_Shl          _ -> LlvmM ExprData
panicOp
    MO_U_Shr        _ -> LlvmM ExprData
panicOp
    MO_S_Shr        _ -> LlvmM ExprData
panicOp

    MO_V_Insert   _ _ -> LlvmM ExprData
panicOp
    MO_V_Extract  _ _ -> LlvmM ExprData
panicOp

    MO_V_Add      _ _ -> LlvmM ExprData
panicOp
    MO_V_Sub      _ _ -> LlvmM ExprData
panicOp
    MO_V_Mul      _ _ -> LlvmM ExprData
panicOp

    MO_VS_Quot    _ _ -> LlvmM ExprData
panicOp
    MO_VS_Rem     _ _ -> LlvmM ExprData
panicOp

    MO_VU_Quot    _ _ -> LlvmM ExprData
panicOp
    MO_VU_Rem     _ _ -> LlvmM ExprData
panicOp

    MO_VF_Insert  _ _ -> LlvmM ExprData
panicOp
    MO_VF_Extract _ _ -> LlvmM ExprData
panicOp

    MO_VF_Add     _ _ -> LlvmM ExprData
panicOp
    MO_VF_Sub     _ _ -> LlvmM ExprData
panicOp
    MO_VF_Mul     _ _ -> LlvmM ExprData
panicOp
    MO_VF_Quot    _ _ -> LlvmM ExprData
panicOp

    where
        negate :: LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negate ty :: LlvmType
ty v2 :: LlvmVar
v2 negOp :: LlvmMachOp
negOp = do
            (vx :: LlvmVar
vx, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
            (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
negOp LlvmVar
v2 LlvmVar
vx
            ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top)

        negateVec :: LlvmType -> LlvmVar -> LlvmMachOp -> LlvmM ExprData
negateVec ty :: LlvmType
ty v2 :: LlvmVar
v2 negOp :: LlvmMachOp
negOp = do
            (vx :: LlvmVar
vx, stmts1 :: LlvmStatements
stmts1, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
            (vxs' :: [LlvmVar]
vxs', stmts2 :: LlvmStatements
stmts2) <- Signage
-> [(LlvmVar, LlvmType)] -> LlvmM ([LlvmVar], LlvmStatements)
castVars Signage
Signed [(LlvmVar
vx, LlvmType
ty)]
            let vx' :: LlvmVar
vx' = String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genMachOp: negateVec" [LlvmVar]
vxs'
            (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
negOp LlvmVar
v2 LlvmVar
vx'
            ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, 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, [LlvmCmmDecl]
top)

        fiConv :: LlvmType -> LlvmCastOp -> LlvmM ExprData
fiConv ty :: LlvmType
ty convOp :: LlvmCastOp
convOp = do
            (vx :: LlvmVar
vx, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
            (v1 :: LlvmVar
v1, s1 :: LlvmStatement
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
convOp LlvmVar
vx LlvmType
ty
            ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top)

        sameConv :: Width -> LlvmType -> LlvmCastOp -> LlvmCastOp -> LlvmM ExprData
sameConv from :: Width
from ty :: LlvmType
ty reduce :: LlvmCastOp
reduce expand :: LlvmCastOp
expand = do
            x' :: ExprData
x'@(vx :: LlvmVar
vx, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- CmmExpr -> LlvmM ExprData
exprToVar CmmExpr
x
            let sameConv' :: LlvmCastOp -> LlvmM ExprData
sameConv' op :: LlvmCastOp
op = do
                    (v1 :: LlvmVar
v1, s1 :: LlvmStatement
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
                    ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top)
            DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            let toWidth :: Int
toWidth = DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags 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 Width -> Int
widthInBits Width
from  of
                 w :: Int
w | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
toWidth -> LlvmCastOp -> LlvmM ExprData
sameConv' LlvmCastOp
expand
                 w :: Int
w | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
toWidth -> LlvmCastOp -> LlvmM ExprData
sameConv' LlvmCastOp
reduce
                 _w :: Int
_w              -> ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return ExprData
x'

        panicOp :: LlvmM ExprData
panicOp = String -> LlvmM ExprData
forall a. String -> a
panic (String -> LlvmM ExprData) -> String -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ "LLVM.CodeGen.genMachOp: non unary op encountered"
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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]
++ ")"

-- Handle GlobalRegs pointers
genMachOp opt :: EOption
opt o :: MachOp
o@(MO_Add _) e :: [CmmExpr]
e@[(CmmReg (CmmGlobal r :: GlobalReg
r)), (CmmLit (CmmInt n :: Integer
n _))]
    = EOption
-> MachOp -> GlobalReg -> Int -> [CmmExpr] -> LlvmM ExprData
genMachOp_fast EOption
opt MachOp
o GlobalReg
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) [CmmExpr]
e

genMachOp opt :: EOption
opt o :: MachOp
o@(MO_Sub _) e :: [CmmExpr]
e@[(CmmReg (CmmGlobal r :: GlobalReg
r)), (CmmLit (CmmInt n :: Integer
n _))]
    = EOption
-> MachOp -> GlobalReg -> Int -> [CmmExpr] -> LlvmM ExprData
genMachOp_fast EOption
opt MachOp
o GlobalReg
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 opt :: EOption
opt op :: MachOp
op e :: [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 -> GlobalReg -> Int -> [CmmExpr]
               -> LlvmM ExprData
genMachOp_fast :: EOption
-> MachOp -> GlobalReg -> Int -> [CmmExpr] -> LlvmM ExprData
genMachOp_fast opt :: EOption
opt op :: MachOp
op r :: GlobalReg
r n :: Int
n e :: [CmmExpr]
e
  = do (gv :: LlvmVar
gv, grt :: LlvmType
grt, s1 :: LlvmStatements
s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let (ix :: Int
ix,rem :: Int
rem) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` ((DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags (LlvmType -> Int) -> (LlvmType -> LlvmType) -> LlvmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmType -> LlvmType
pLower) LlvmType
grt  Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)
       case LlvmType -> Bool
isPointer LlvmType
grt Bool -> Bool -> Bool
&& Int
rem Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 of
            True -> do
                (ptr :: LlvmVar
ptr, s2 :: LlvmStatement
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 :: LlvmVar
var, s3 :: LlvmStatement
s3) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (DynFlags -> LlvmType
llvmWord DynFlags
dflags) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Ptrtoint LlvmVar
ptr (DynFlags -> LlvmType
llvmWord DynFlags
dflags)
                ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
var, 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, [])

            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 _ (MO_V_Extract l :: Int
l w :: Width
w) [val :: CmmExpr
val, idx :: 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
    LlvmVar
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
    LlvmVar
vidx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
idx
    LlvmVar
vval' <- String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genMachOp_slow" ([LlvmVar] -> LlvmVar)
-> WriterT LlvmAccum LlvmM [LlvmVar]
-> WriterT LlvmAccum LlvmM LlvmVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed [(LlvmVar
vval, Int -> LlvmType -> LlvmType
LMVector Int
l LlvmType
ty)]
    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
Extract LlvmVar
vval' LlvmVar
vidx
  where
    ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmInt Width
w

genMachOp_slow _ (MO_VF_Extract l :: Int
l w :: Width
w) [val :: CmmExpr
val, idx :: 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
    LlvmVar
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
    LlvmVar
vidx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
idx
    LlvmVar
vval' <- String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genMachOp_slow" ([LlvmVar] -> LlvmVar)
-> WriterT LlvmAccum LlvmM [LlvmVar]
-> WriterT LlvmAccum LlvmM LlvmVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed [(LlvmVar
vval, Int -> LlvmType -> LlvmType
LMVector Int
l LlvmType
ty)]
    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
Extract LlvmVar
vval' LlvmVar
vidx
  where
    ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmFloat Width
w

-- Element insertion
genMachOp_slow _ (MO_V_Insert l :: Int
l w :: Width
w) [val :: CmmExpr
val, elt :: CmmExpr
elt, idx :: 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
    LlvmVar
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
    LlvmVar
velt <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
elt
    LlvmVar
vidx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
idx
    LlvmVar
vval' <- String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genMachOp_slow" ([LlvmVar] -> LlvmVar)
-> WriterT LlvmAccum LlvmM [LlvmVar]
-> WriterT LlvmAccum LlvmM LlvmVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed [(LlvmVar
vval, LlvmType
ty)]
    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 -> LlvmVar -> LlvmExpression
Insert LlvmVar
vval' LlvmVar
velt LlvmVar
vidx
  where
    ty :: LlvmType
ty = Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmInt Width
w)

genMachOp_slow _ (MO_VF_Insert l :: Int
l w :: Width
w) [val :: CmmExpr
val, elt :: CmmExpr
elt, idx :: 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
    LlvmVar
vval <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
val
    LlvmVar
velt <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
elt
    LlvmVar
vidx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
idx
    LlvmVar
vval' <- String -> [LlvmVar] -> LlvmVar
forall a. String -> [a] -> a
singletonPanic "genMachOp_slow" ([LlvmVar] -> LlvmVar)
-> WriterT LlvmAccum LlvmM [LlvmVar]
-> WriterT LlvmAccum LlvmM LlvmVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
             Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed [(LlvmVar
vval, LlvmType
ty)]
    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 -> LlvmVar -> LlvmExpression
Insert LlvmVar
vval' LlvmVar
velt LlvmVar
vidx
  where
    ty :: LlvmType
ty = Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)

-- Binary MachOp
genMachOp_slow opt :: EOption
opt op :: MachOp
op [x :: CmmExpr
x, y :: CmmExpr
y] = case MachOp
op of

    MO_Eq _   -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Eq
    MO_Ne _   -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ne

    MO_S_Gt _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Sgt
    MO_S_Ge _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Sge
    MO_S_Lt _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Slt
    MO_S_Le _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Sle

    MO_U_Gt _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ugt
    MO_U_Ge _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Uge
    MO_U_Lt _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ult
    MO_U_Le _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Ule

    MO_Add _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Add
    MO_Sub _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Sub
    MO_Mul _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Mul

    MO_U_MulMayOflo _ -> String -> LlvmM ExprData
forall a. String -> a
panic "genMachOp: MO_U_MulMayOflo unsupported!"

    MO_S_MulMayOflo w :: Width
w -> Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
isSMulOK Width
w CmmExpr
x CmmExpr
y

    MO_S_Quot _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_SDiv
    MO_S_Rem  _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_SRem

    MO_U_Quot _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_UDiv
    MO_U_Rem  _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_URem

    MO_F_Eq _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Feq
    MO_F_Ne _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fne
    MO_F_Gt _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fgt
    MO_F_Ge _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fge
    MO_F_Lt _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Flt
    MO_F_Le _ -> EOption -> LlvmCmpOp -> LlvmM ExprData
genBinComp EOption
opt LlvmCmpOp
LM_CMP_Fle

    MO_F_Add  _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FAdd
    MO_F_Sub  _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FSub
    MO_F_Mul  _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FMul
    MO_F_Quot _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_FDiv

    MO_And _   -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_And
    MO_Or  _   -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Or
    MO_Xor _   -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Xor
    MO_Shl _   -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_Shl
    MO_U_Shr _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_LShr
    MO_S_Shr _ -> LlvmMachOp -> LlvmM ExprData
genBinMach LlvmMachOp
LM_MO_AShr

    MO_V_Add l :: Int
l w :: 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 l :: Int
l w :: 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 l :: Int
l w :: 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 l :: Int
l w :: 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  l :: Int
l w :: 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 l :: Int
l w :: 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  l :: Int
l w :: 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  l :: Int
l w :: 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  l :: Int
l w :: 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  l :: Int
l w :: 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 l :: Int
l w :: Width
w -> LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach (Int -> LlvmType -> LlvmType
LMVector Int
l (Width -> LlvmType
widthToLlvmFloat Width
w)) LlvmMachOp
LM_MO_FDiv

    MO_Not _       -> LlvmM ExprData
panicOp
    MO_S_Neg _     -> LlvmM ExprData
panicOp
    MO_F_Neg _     -> LlvmM ExprData
panicOp

    MO_SF_Conv _ _ -> LlvmM ExprData
panicOp
    MO_FS_Conv _ _ -> LlvmM ExprData
panicOp
    MO_SS_Conv _ _ -> LlvmM ExprData
panicOp
    MO_UU_Conv _ _ -> LlvmM ExprData
panicOp
    MO_XX_Conv _ _ -> LlvmM ExprData
panicOp
    MO_FF_Conv _ _ -> LlvmM ExprData
panicOp

    MO_V_Insert  {} -> LlvmM ExprData
panicOp
    MO_V_Extract {} -> LlvmM ExprData
panicOp

    MO_VS_Neg {} -> LlvmM ExprData
panicOp

    MO_VF_Insert  {} -> LlvmM ExprData
panicOp
    MO_VF_Extract {} -> LlvmM ExprData
panicOp

    MO_VF_Neg {} -> LlvmM ExprData
panicOp

    MO_AlignmentCheck {} -> LlvmM ExprData
panicOp

    where
        binLlvmOp :: (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binLlvmOp ty :: LlvmVar -> LlvmType
ty binOp :: 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
            LlvmVar
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
            LlvmVar
vy <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
y
            if LlvmVar -> LlvmType
getVarType LlvmVar
vx LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmVar -> LlvmType
getVarType LlvmVar
vy
                then do
                    LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW (LlvmVar -> LlvmType
ty LlvmVar
vx) (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

                else do
                    -- Error. Continue anyway so we can debug the generated ll file.
                    DynFlags
dflags <- WriterT LlvmAccum LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                    let style :: PprStyle
style = CodeStyle -> PprStyle
mkCodeStyle CodeStyle
CStyle
                        toString :: SDoc -> String
toString doc :: SDoc
doc = DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
dflags SDoc
doc PprStyle
style
                        cmmToStr :: CmmExpr -> [String]
cmmToStr = (String -> [String]
lines (String -> [String]) -> (CmmExpr -> String) -> CmmExpr -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> String
toString (SDoc -> String) -> (CmmExpr -> SDoc) -> CmmExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> SDoc
PprCmm.pprExpr)
                    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ [LMString] -> LlvmStatement
Comment ([LMString] -> LlvmStatement) -> [LMString] -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ (String -> LMString) -> [String] -> [LMString]
forall a b. (a -> b) -> [a] -> [b]
map String -> LMString
fsLit ([String] -> [LMString]) -> [String] -> [LMString]
forall a b. (a -> b) -> a -> b
$ CmmExpr -> [String]
cmmToStr CmmExpr
x
                    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement (LlvmStatement -> WriterT LlvmAccum LlvmM ())
-> LlvmStatement -> WriterT LlvmAccum LlvmM ()
forall a b. (a -> b) -> a -> b
$ [LMString] -> LlvmStatement
Comment ([LMString] -> LlvmStatement) -> [LMString] -> LlvmStatement
forall a b. (a -> b) -> a -> b
$ (String -> LMString) -> [String] -> [LMString]
forall a b. (a -> b) -> [a] -> [b]
map String -> LMString
fsLit ([String] -> [LMString]) -> [String] -> [LMString]
forall a b. (a -> b) -> a -> b
$ CmmExpr -> [String]
cmmToStr CmmExpr
y
                    LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW (LlvmVar -> LlvmType
ty LlvmVar
vx) (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

        binCastLlvmOp :: LlvmType
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binCastLlvmOp ty :: LlvmType
ty binOp :: 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
            LlvmVar
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
            LlvmVar
vy <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
y
            [LlvmVar]
vxy' <- Signage
-> [(LlvmVar, LlvmType)] -> WriterT LlvmAccum LlvmM [LlvmVar]
castVarsW Signage
Signed [(LlvmVar
vx, LlvmType
ty), (LlvmVar
vy, LlvmType
ty)]
            case [LlvmVar]
vxy' of
              [vx' :: LlvmVar
vx',vy' :: 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'
              _         -> String -> WriterT LlvmAccum LlvmM LlvmVar
forall a. String -> a
panic "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 opt :: EOption
opt cmp :: LlvmCmpOp
cmp = do
            ed :: ExprData
ed@(v1 :: LlvmVar
v1, stmts :: LlvmStatements
stmts, top :: [LlvmCmmDecl]
top) <- (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binLlvmOp (\_ -> LlvmType
i1) (LlvmCmpOp -> LlvmVar -> LlvmVar -> LlvmExpression
Compare LlvmCmpOp
cmp)
            DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            if LlvmVar -> LlvmType
getVarType LlvmVar
v1 LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmType
i1
                then case EOption -> Bool
i1Expected EOption
opt of
                    True  -> ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return ExprData
ed
                    False -> do
                        let w_ :: LlvmType
w_ = DynFlags -> LlvmType
llvmWord DynFlags
dflags
                        (v2 :: LlvmVar
v2, s1 :: LlvmStatement
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_
                        ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v2, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
top)
                else
                    String -> LlvmM ExprData
forall a. String -> a
panic (String -> LlvmM ExprData) -> String -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ "genBinComp: Compare returned type other then i1! "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ (DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc) -> LlvmType -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
v1)

        genBinMach :: LlvmMachOp -> LlvmM ExprData
genBinMach op :: LlvmMachOp
op = (LlvmVar -> LlvmType)
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binLlvmOp LlvmVar -> LlvmType
getVarType (LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
op)

        genCastBinMach :: LlvmType -> LlvmMachOp -> LlvmM ExprData
genCastBinMach ty :: LlvmType
ty op :: LlvmMachOp
op = LlvmType
-> (LlvmVar -> LlvmVar -> LlvmExpression) -> LlvmM ExprData
binCastLlvmOp LlvmType
ty (LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
op)

        -- | 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 _ x :: CmmExpr
x y :: 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
            LlvmVar
vx <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
x
            LlvmVar
vy <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
y

            DynFlags
dflags <- WriterT LlvmAccum LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
            let word :: LlvmType
word  = LlvmVar -> LlvmType
getVarType LlvmVar
vx
            let word2 :: LlvmType
word2 = Int -> LlvmType
LMInt (Int -> LlvmType) -> Int -> LlvmType
forall a b. (a -> b) -> a -> b
$ 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags (LlvmType -> Int) -> LlvmType -> Int
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
vx)
            let shift :: Int
shift = DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
word
            let shift1 :: LlvmVar
shift1 = DynFlags -> Int -> LlvmVar
forall a. Integral a => DynFlags -> a -> LlvmVar
toIWord DynFlags
dflags (Int
shift Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
            let shift2 :: LlvmVar
shift2 = DynFlags -> Int -> LlvmVar
forall a. Integral a => DynFlags -> a -> LlvmVar
toIWord DynFlags
dflags Int
shift

            if LlvmType -> Bool
isInt LlvmType
word
                then do
                    LlvmVar
x1     <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word2 (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Sext LlvmVar
vx LlvmType
word2
                    LlvmVar
y1     <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word2 (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Sext LlvmVar
vy LlvmType
word2
                    LlvmVar
r1     <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word2 (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Mul LlvmVar
x1 LlvmVar
y1
                    LlvmVar
rlow1  <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word (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
r1 LlvmType
word
                    LlvmVar
rlow2  <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_AShr LlvmVar
rlow1 LlvmVar
shift1
                    LlvmVar
rhigh1 <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word2 (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_AShr LlvmVar
r1 LlvmVar
shift2
                    LlvmVar
rhigh2 <- LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word (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
rhigh1 LlvmType
word
                    LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
doExprW LlvmType
word (LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar)
-> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Sub LlvmVar
rlow2 LlvmVar
rhigh2

                else
                    String -> WriterT LlvmAccum LlvmM LlvmVar
forall a. String -> a
panic (String -> WriterT LlvmAccum LlvmM LlvmVar)
-> String -> WriterT LlvmAccum LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ "isSMulOK: Not bit type! (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
word) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"

        panicOp :: LlvmM ExprData
panicOp = String -> LlvmM ExprData
forall a. String -> a
panic (String -> LlvmM ExprData) -> String -> LlvmM ExprData
forall a b. (a -> b) -> a -> b
$ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ "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]
++ ")"

-- More than two expression, invalid!
genMachOp_slow _ _ _ = String -> LlvmM ExprData
forall a. String -> a
panic "genMachOp: More than 2 expressions in MachOp!"


-- | Handle CmmLoad expression.
genLoad :: Atomic -> CmmExpr -> CmmType -> 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 :: Bool -> CmmExpr -> CmmType -> LlvmM ExprData
genLoad atomic :: Bool
atomic e :: CmmExpr
e@(CmmReg (CmmGlobal r :: GlobalReg
r)) ty :: CmmType
ty
    = Bool -> CmmExpr -> GlobalReg -> Int -> CmmType -> LlvmM ExprData
genLoad_fast Bool
atomic CmmExpr
e GlobalReg
r 0 CmmType
ty

genLoad atomic :: Bool
atomic e :: CmmExpr
e@(CmmRegOff (CmmGlobal r :: GlobalReg
r) n :: Int
n) ty :: CmmType
ty
    = Bool -> CmmExpr -> GlobalReg -> Int -> CmmType -> LlvmM ExprData
genLoad_fast Bool
atomic CmmExpr
e GlobalReg
r Int
n CmmType
ty

genLoad atomic :: Bool
atomic e :: CmmExpr
e@(CmmMachOp (MO_Add _) [
                            (CmmReg (CmmGlobal r :: GlobalReg
r)),
                            (CmmLit (CmmInt n :: Integer
n _))])
                ty :: CmmType
ty
    = Bool -> CmmExpr -> GlobalReg -> Int -> CmmType -> LlvmM ExprData
genLoad_fast Bool
atomic CmmExpr
e GlobalReg
r (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n) CmmType
ty

genLoad atomic :: Bool
atomic e :: CmmExpr
e@(CmmMachOp (MO_Sub _) [
                            (CmmReg (CmmGlobal r :: GlobalReg
r)),
                            (CmmLit (CmmInt n :: Integer
n _))])
                ty :: CmmType
ty
    = Bool -> CmmExpr -> GlobalReg -> Int -> CmmType -> LlvmM ExprData
genLoad_fast Bool
atomic CmmExpr
e GlobalReg
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

-- generic case
genLoad atomic :: Bool
atomic e :: CmmExpr
e ty :: CmmType
ty
    = Unique -> LlvmM [MetaAnnot]
getTBAAMeta Unique
topN LlvmM [MetaAnnot]
-> ([MetaAnnot] -> LlvmM ExprData) -> LlvmM ExprData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
genLoad_slow Bool
atomic CmmExpr
e CmmType
ty

-- | 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 -> GlobalReg -> Int -> CmmType
             -> LlvmM ExprData
genLoad_fast :: Bool -> CmmExpr -> GlobalReg -> Int -> CmmType -> LlvmM ExprData
genLoad_fast atomic :: Bool
atomic e :: CmmExpr
e r :: GlobalReg
r n :: Int
n ty :: CmmType
ty = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (gv :: LlvmVar
gv, grt :: LlvmType
grt, s1 :: LlvmStatements
s1) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
    [MetaAnnot]
meta          <- GlobalReg -> LlvmM [MetaAnnot]
getTBAARegMeta GlobalReg
r
    let ty' :: LlvmType
ty'      = CmmType -> LlvmType
cmmToLlvmType CmmType
ty
        (ix :: Int
ix,rem :: Int
rem) = Int
n Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` ((DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags (LlvmType -> Int) -> (LlvmType -> LlvmType) -> LlvmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmType -> LlvmType
pLower) LlvmType
grt  Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)
    case LlvmType -> Bool
isPointer LlvmType
grt Bool -> Bool -> Bool
&& Int
rem Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 of
            True  -> do
                (ptr :: LlvmVar
ptr, s2 :: LlvmStatement
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 LlvmType
grt LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmType
ty' of
                     -- were fine
                     True -> do
                         (var :: LlvmVar
var, s3 :: LlvmStatement
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
$ LlvmVar -> LlvmExpression
loadInstr LlvmVar
ptr)
                         ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
var, 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,
                                     [])

                     -- cast to pointer type needed
                     False -> do
                         let pty :: LlvmType
pty = LlvmType -> LlvmType
pLift LlvmType
ty'
                         (ptr' :: LlvmVar
ptr', s3 :: LlvmStatement
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 :: LlvmVar
var, s4 :: LlvmStatement
s4) <- 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
$ LlvmVar -> LlvmExpression
loadInstr LlvmVar
ptr')
                         ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
var, 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
                                    LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s4, [])

            -- If its a bit type then we use the slow method since
            -- we can't avoid casting anyway.
            False -> Bool -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
genLoad_slow Bool
atomic  CmmExpr
e CmmType
ty [MetaAnnot]
meta
  where
    loadInstr :: LlvmVar -> LlvmExpression
loadInstr ptr :: LlvmVar
ptr | Bool
atomic    = LlvmSyncOrdering -> Bool -> LlvmVar -> LlvmExpression
ALoad LlvmSyncOrdering
SyncSeqCst Bool
False LlvmVar
ptr
                  | Bool
otherwise = LlvmVar -> LlvmExpression
Load LlvmVar
ptr

-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
genLoad_slow :: Bool -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
genLoad_slow atomic :: Bool
atomic e :: CmmExpr
e ty :: CmmType
ty meta :: [MetaAnnot]
meta = 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
    LlvmVar
iptr <- CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
exprToVarW CmmExpr
e
    DynFlags
dflags <- WriterT LlvmAccum LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    case LlvmVar -> LlvmType
getVarType LlvmVar
iptr of
         LMPointer _ -> do
                    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
$ LlvmVar -> LlvmExpression
loadInstr LlvmVar
iptr)

         i :: LlvmType
i@(LMInt _) | LlvmType
i LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> LlvmType
llvmWord DynFlags
dflags -> do
                    let pty :: LlvmType
pty = LlvmType -> LlvmType
LMPointer (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ CmmType -> LlvmType
cmmToLlvmType CmmType
ty
                    LlvmVar
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
                    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
$ LlvmVar -> LlvmExpression
loadInstr LlvmVar
ptr)

         other :: LlvmType
other -> do String -> SDoc -> WriterT LlvmAccum LlvmM LlvmVar
forall a. String -> SDoc -> a
pprPanic "exprToVar: CmmLoad expression is not right type!"
                        (CmmExpr -> SDoc
PprCmm.pprExpr CmmExpr
e SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (
                            "Size of Ptr: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (DynFlags -> Int
llvmPtrBits DynFlags
dflags) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                            ", Size of var: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
other) String -> ShowS
forall a. [a] -> [a] -> [a]
++
                            ", Var: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
iptr)))
  where
    loadInstr :: LlvmVar -> LlvmExpression
loadInstr ptr :: LlvmVar
ptr | Bool
atomic    = LlvmSyncOrdering -> Bool -> LlvmVar -> LlvmExpression
ALoad LlvmSyncOrdering
SyncSeqCst Bool
False LlvmVar
ptr
                  | Bool
otherwise = LlvmVar -> LlvmExpression
Load LlvmVar
ptr


-- | 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 un :: Unique
un _))
  = do Maybe LlvmType
exists <- Unique -> LlvmM (Maybe LlvmType)
forall key. Uniquable key => key -> LlvmM (Maybe LlvmType)
varLookup Unique
un
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       case Maybe LlvmType
exists of
         Just ety :: LlvmType
ety -> LlvmVar -> LlvmM LlvmVar
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)
         Nothing  -> String -> LlvmM LlvmVar
forall a. String -> a
panic (String -> LlvmM LlvmVar) -> String -> LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ "getCmmReg: Cmm register " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
un) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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 g :: GlobalReg
g)
  = do Bool
onStack <- GlobalReg -> LlvmM Bool
checkStackReg GlobalReg
g
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       if Bool
onStack
         then LlvmVar -> LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> GlobalReg -> LlvmVar
lmGlobalRegVar DynFlags
dflags GlobalReg
g)
         else String -> LlvmM LlvmVar
forall a. String -> a
panic (String -> LlvmM LlvmVar) -> String -> LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ "getCmmReg: Cmm register " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
g) String -> ShowS
forall a. [a] -> [a] -> [a]
++ " 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 reg :: CmmReg
reg =
  case CmmReg
reg of
    CmmGlobal g :: GlobalReg
g -> do
      Bool
onStack <- GlobalReg -> LlvmM Bool
checkStackReg GlobalReg
g
      DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      if Bool
onStack then LlvmM (LlvmVar, LlvmType, LlvmStatements)
loadFromStack else do
        let r :: LlvmVar
r = DynFlags -> GlobalReg -> LlvmVar
lmGlobalRegArg DynFlags
dflags GlobalReg
g
        (LlvmVar, LlvmType, LlvmStatements)
-> LlvmM (LlvmVar, LlvmType, LlvmStatements)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
r, LlvmVar -> LlvmType
getVarType LlvmVar
r, LlvmStatements
forall a. OrdList a
nilOL)
    _ -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
loadFromStack
 where loadFromStack :: LlvmM (LlvmVar, LlvmType, LlvmStatements)
loadFromStack = do
         LlvmVar
ptr <- CmmReg -> LlvmM LlvmVar
getCmmReg CmmReg
reg
         let ty :: LlvmType
ty = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
ptr
         (v :: LlvmVar
v, s :: LlvmStatement
s) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
ty (LlvmVar -> LlvmExpression
Load LlvmVar
ptr)
         (LlvmVar, LlvmType, LlvmStatements)
-> LlvmM (LlvmVar, LlvmType, LlvmStatements)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v, LlvmType
ty, LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL LlvmStatement
s)

-- | Allocate a local CmmReg on the stack
allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
allocReg (CmmLocal (LocalReg un :: Unique
un ty :: 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' 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 _ = String -> (LlvmVar, LlvmStatements)
forall a. String -> a
panic (String -> (LlvmVar, LlvmStatements))
-> String -> (LlvmVar, LlvmStatements)
forall a b. (a -> b) -> a -> b
$ "allocReg: Global reg encountered! Global registers should"
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ " have been handled elsewhere!"


-- | Generate code for a literal
genLit :: EOption -> CmmLit -> LlvmM ExprData
genLit :: EOption -> CmmLit -> LlvmM ExprData
genLit opt :: EOption
opt (CmmInt i :: Integer
i w :: 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 (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 _ (CmmFloat r :: Rational
r w :: Width
w)
  = ExprData -> LlvmM ExprData
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) (Width -> LlvmType
widthToLlvmFloat Width
w),
              LlvmStatements
forall a. OrdList a
nilOL, [])

genLit opt :: EOption
opt (CmmVec ls :: [CmmLit]
ls)
  = do [LlvmLit]
llvmLits <- (CmmLit -> LlvmM LlvmLit) -> [CmmLit] -> LlvmM [LlvmLit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmLit -> LlvmM LlvmLit
toLlvmLit [CmmLit]
ls
       ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ [LlvmLit] -> LlvmLit
LMVectorLit [LlvmLit]
llvmLits, LlvmStatements
forall a. OrdList a
nilOL, [])
  where
    toLlvmLit :: CmmLit -> LlvmM LlvmLit
    toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit lit :: CmmLit
lit = do
        (llvmLitVar :: LlvmVar
llvmLitVar, _, _) <- EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt CmmLit
lit
        case LlvmVar
llvmLitVar of
          LMLitVar llvmLit :: LlvmLit
llvmLit -> LlvmLit -> LlvmM LlvmLit
forall (m :: * -> *) a. Monad m => a -> m a
return LlvmLit
llvmLit
          _ -> String -> LlvmM LlvmLit
forall a. String -> a
panic "genLit"

genLit _ cmm :: CmmLit
cmm@(CmmLabel l :: CLabel
l)
  = do LlvmVar
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
       DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       let lmty :: LlvmType
lmty = CmmType -> LlvmType
cmmToLlvmType (CmmType -> LlvmType) -> CmmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
cmm
       (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr LlvmType
lmty (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Ptrtoint LlvmVar
var (DynFlags -> LlvmType
llvmWord DynFlags
dflags)
       ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL LlvmStatement
s1, [])

genLit opt :: EOption
opt (CmmLabelOff label :: CLabel
label off :: Int
off) = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (vlbl :: LlvmVar
vlbl, stmts :: LlvmStatements
stmts, stat :: [LlvmCmmDecl]
stat) <- EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt (CLabel -> CmmLit
CmmLabel CLabel
label)
    let voff :: LlvmVar
voff = DynFlags -> Int -> LlvmVar
forall a. Integral a => DynFlags -> a -> LlvmVar
toIWord DynFlags
dflags Int
off
    (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (LlvmVar -> LlvmType
getVarType LlvmVar
vlbl) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Add LlvmVar
vlbl LlvmVar
voff
    ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v1, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s1, [LlvmCmmDecl]
stat)

genLit opt :: EOption
opt (CmmLabelDiffOff l1 :: CLabel
l1 l2 :: CLabel
l2 off :: Int
off w :: Width
w) = do
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (vl1 :: LlvmVar
vl1, stmts1 :: LlvmStatements
stmts1, stat1 :: [LlvmCmmDecl]
stat1) <- EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt (CLabel -> CmmLit
CmmLabel CLabel
l1)
    (vl2 :: LlvmVar
vl2, stmts2 :: LlvmStatements
stmts2, stat2 :: [LlvmCmmDecl]
stat2) <- EOption -> CmmLit -> LlvmM ExprData
genLit EOption
opt (CLabel -> CmmLit
CmmLabel CLabel
l2)
    let voff :: LlvmVar
voff = DynFlags -> Int -> LlvmVar
forall a. Integral a => DynFlags -> a -> LlvmVar
toIWord DynFlags
dflags Int
off
    let ty1 :: LlvmType
ty1 = LlvmVar -> LlvmType
getVarType LlvmVar
vl1
    let ty2 :: LlvmType
ty2 = LlvmVar -> LlvmType
getVarType LlvmVar
vl2
    if (LlvmType -> Bool
isInt LlvmType
ty1) Bool -> Bool -> Bool
&& (LlvmType -> Bool
isInt LlvmType
ty2)
       Bool -> Bool -> Bool
&& (DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
ty1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags LlvmType
ty2)
       then do
            (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (LlvmVar -> LlvmType
getVarType LlvmVar
vl1) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Sub LlvmVar
vl1 LlvmVar
vl2
            (v2 :: LlvmVar
v2, s2 :: LlvmStatement
s2) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (LlvmVar -> LlvmType
getVarType LlvmVar
v1 ) (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmMachOp -> LlvmVar -> LlvmVar -> LlvmExpression
LlvmOp LlvmMachOp
LM_MO_Add LlvmVar
v1 LlvmVar
voff
            let ty :: LlvmType
ty = Width -> LlvmType
widthToLlvmInt Width
w
            let stmts :: LlvmStatements
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 Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> Width
wordWidth DynFlags
dflags
              then do
                (v3 :: LlvmVar
v3, s3 :: LlvmStatement
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_Trunc LlvmVar
v2 LlvmType
ty
                ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v3, LlvmStatements
stmts LlvmStatements -> LlvmStatement -> LlvmStatements
forall a. OrdList a -> a -> OrdList a
`snocOL` LlvmStatement
s3, [LlvmCmmDecl]
stat1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
stat2)
              else
                ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v2, LlvmStatements
stmts, [LlvmCmmDecl]
stat1 [LlvmCmmDecl] -> [LlvmCmmDecl] -> [LlvmCmmDecl]
forall a. [a] -> [a] -> [a]
++ [LlvmCmmDecl]
stat2)
        else
            String -> LlvmM ExprData
forall a. String -> a
panic "genLit: CmmLabelDiffOff encountered with different label ty!"

genLit opt :: EOption
opt (CmmBlock b :: 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 _ CmmHighStackMark
  = String -> LlvmM ExprData
forall a. String -> a
panic "genStaticLit - CmmHighStackMark unsupported!"


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

-- | Find CmmRegs that get assigned and allocate them on the stack
--
-- Any register that gets written needs to be allcoated 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 :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
funPrologue :: [GlobalReg] -> [CmmBlock] -> LlvmM (LlvmStatements, [LlvmCmmDecl])
funPrologue live :: [GlobalReg]
live cmmBlocks :: [CmmBlock]
cmmBlocks = do

  [GlobalReg]
trash <- LlvmM [GlobalReg]
getTrashRegs
  let getAssignedRegs :: CmmNode O O -> [CmmReg]
      getAssignedRegs :: CmmNode O O -> [CmmReg]
getAssignedRegs (CmmAssign reg :: CmmReg
reg _)  = [CmmReg
reg]
      -- Calls will trash all registers. Unfortunately, this needs them to
      -- be stack-allocated in the first place.
      getAssignedRegs (CmmUnsafeForeignCall _ rs :: [CmmFormal]
rs _) = (GlobalReg -> CmmReg) -> [GlobalReg] -> [CmmReg]
forall a b. (a -> b) -> [a] -> [b]
map GlobalReg -> CmmReg
CmmGlobal [GlobalReg]
trash [CmmReg] -> [CmmReg] -> [CmmReg]
forall a. [a] -> [a] -> [a]
++ (CmmFormal -> CmmReg) -> [CmmFormal] -> [CmmReg]
forall a b. (a -> b) -> [a] -> [b]
map CmmFormal -> CmmReg
CmmLocal [CmmFormal]
rs
      getAssignedRegs _                  = []
      getRegsBlock :: (a, Block CmmNode O O, c) -> [CmmReg]
getRegsBlock (_, body :: Block CmmNode O O
body, _)          = (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 :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
body
      assignedRegs :: [CmmReg]
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 :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit) [CmmBlock]
cmmBlocks
      isLive :: GlobalReg -> Bool
isLive r :: GlobalReg
r     = GlobalReg
r GlobalReg -> [GlobalReg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GlobalReg]
alwaysLive Bool -> Bool -> Bool
|| GlobalReg
r GlobalReg -> [GlobalReg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GlobalReg]
live

  DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  [LlvmStatements]
stmtss <- ((CmmReg -> LlvmM LlvmStatements)
 -> [CmmReg] -> LlvmM [LlvmStatements])
-> [CmmReg]
-> (CmmReg -> LlvmM LlvmStatements)
-> LlvmM [LlvmStatements]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CmmReg -> LlvmM LlvmStatements)
-> [CmmReg] -> LlvmM [LlvmStatements]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [CmmReg]
assignedRegs ((CmmReg -> LlvmM LlvmStatements) -> LlvmM [LlvmStatements])
-> (CmmReg -> LlvmM LlvmStatements) -> LlvmM [LlvmStatements]
forall a b. (a -> b) -> a -> b
$ \reg :: CmmReg
reg ->
    case CmmReg
reg of
      CmmLocal (LocalReg un :: Unique
un _) -> do
        let (newv :: LlvmVar
newv, stmts :: 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 (m :: * -> *) a. Monad m => a -> m a
return LlvmStatements
stmts
      CmmGlobal r :: GlobalReg
r -> do
        let reg :: LlvmVar
reg   = DynFlags -> GlobalReg -> LlvmVar
lmGlobalRegVar DynFlags
dflags GlobalReg
r
            arg :: LlvmVar
arg   = DynFlags -> GlobalReg -> LlvmVar
lmGlobalRegArg DynFlags
dflags GlobalReg
r
            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 GlobalReg -> Bool
isLive 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) 1
        GlobalReg -> LlvmM ()
markStackReg GlobalReg
r
        LlvmStatements -> LlvmM LlvmStatements
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 -> LlvmStatement
Store LlvmVar
rval LlvmVar
reg]

  (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return ([LlvmStatements] -> LlvmStatements
forall a. [OrdList a] -> OrdList a
concatOL [LlvmStatements]
stmtss, [])

-- | Function epilogue. Load STG variables to use as argument for call.
-- STG Liveness optimisation done here.
funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue :: [GlobalReg] -> LlvmM ([LlvmVar], LlvmStatements)
funEpilogue live :: [GlobalReg]
live = do

    -- Have information and liveness optimisation is enabled?
    let liveRegs :: [GlobalReg]
liveRegs = [GlobalReg]
alwaysLive [GlobalReg] -> [GlobalReg] -> [GlobalReg]
forall a. [a] -> [a] -> [a]
++ [GlobalReg]
live
        isSSE :: GlobalReg -> Bool
isSSE (FloatReg _)  = Bool
True
        isSSE (DoubleReg _) = Bool
True
        isSSE (XmmReg _)    = Bool
True
        isSSE (YmmReg _)    = Bool
True
        isSSE (ZmmReg _)    = Bool
True
        isSSE _             = Bool
False

    -- Set to value or "undef" depending on whether the register is
    -- actually live
    DynFlags
dflags <- LlvmM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let loadExpr :: GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadExpr r :: GlobalReg
r = do
          (v :: LlvmVar
v, _, s :: LlvmStatements
s) <- CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
getCmmRegVal (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
          (Maybe LlvmVar, LlvmStatements)
-> LlvmM (Maybe LlvmVar, LlvmStatements)
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
$ LlvmVar
v, LlvmStatements
s)
        loadUndef :: GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadUndef r :: GlobalReg
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
$ DynFlags -> GlobalReg -> LlvmVar
lmGlobalRegVar DynFlags
dflags GlobalReg
r)
          (Maybe LlvmVar, LlvmStatements)
-> LlvmM (Maybe LlvmVar, LlvmStatements)
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)
    Platform
platform <- (DynFlags -> Platform) -> LlvmM Platform
forall a. (DynFlags -> a) -> LlvmM a
getDynFlag DynFlags -> Platform
targetPlatform
    [(Maybe LlvmVar, LlvmStatements)]
loads <- ((GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements))
 -> [GlobalReg] -> LlvmM [(Maybe LlvmVar, LlvmStatements)])
-> [GlobalReg]
-> (GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements))
-> LlvmM [(Maybe LlvmVar, LlvmStatements)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements))
-> [GlobalReg] -> LlvmM [(Maybe LlvmVar, LlvmStatements)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Platform -> [GlobalReg]
activeStgRegs Platform
platform) ((GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements))
 -> LlvmM [(Maybe LlvmVar, LlvmStatements)])
-> (GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements))
-> LlvmM [(Maybe LlvmVar, LlvmStatements)]
forall a b. (a -> b) -> a -> b
$ \r :: GlobalReg
r -> case () of
      _ | GlobalReg
r GlobalReg -> [GlobalReg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GlobalReg]
liveRegs  -> GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadExpr GlobalReg
r
        | Bool -> Bool
not (GlobalReg -> Bool
isSSE GlobalReg
r)      -> GlobalReg -> LlvmM (Maybe LlvmVar, LlvmStatements)
loadUndef GlobalReg
r
        | Bool
otherwise          -> (Maybe LlvmVar, LlvmStatements)
-> LlvmM (Maybe LlvmVar, LlvmStatements)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LlvmVar
forall a. Maybe a
Nothing, LlvmStatements
forall a. OrdList a
nilOL)

    let (vars :: [Maybe LlvmVar]
vars, stmts :: [LlvmStatements]
stmts) = [(Maybe LlvmVar, LlvmStatements)]
-> ([Maybe LlvmVar], [LlvmStatements])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe LlvmVar, LlvmStatements)]
loads
    ([LlvmVar], LlvmStatements) -> LlvmM ([LlvmVar], LlvmStatements)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe LlvmVar] -> [LlvmVar]
forall a. [Maybe a] -> [a]
catMaybes [Maybe LlvmVar]
vars, [LlvmStatements] -> LlvmStatements
forall a. [OrdList a] -> OrdList a
concatOL [LlvmStatements]
stmts)


-- | A series of statements to trash all the STG registers.
--
-- In LLVM we pass the STG registers around everywhere in function calls.
-- So this means LLVM considers them live across the entire function, when
-- in reality they usually aren't. For Caller save registers across C calls
-- the saving and restoring of them is done by the Cmm code generator,
-- using Cmm local vars. So to stop LLVM saving them as well (and saving
-- all of them since it thinks they're always live, we trash them just
-- before the call by assigning the 'undef' value to them. The ones we
-- need are restored from the Cmm local var and the ones we don't need
-- are fine to be trashed.
getTrashStmts :: LlvmM LlvmStatements
getTrashStmts :: LlvmM LlvmStatements
getTrashStmts = do
  [GlobalReg]
regs <- LlvmM [GlobalReg]
getTrashRegs
  [LlvmStatement]
stmts <- ((GlobalReg -> LlvmM LlvmStatement)
 -> [GlobalReg] -> LlvmM [LlvmStatement])
-> [GlobalReg]
-> (GlobalReg -> LlvmM LlvmStatement)
-> LlvmM [LlvmStatement]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GlobalReg -> LlvmM LlvmStatement)
-> [GlobalReg] -> LlvmM [LlvmStatement]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [GlobalReg]
regs ((GlobalReg -> LlvmM LlvmStatement) -> LlvmM [LlvmStatement])
-> (GlobalReg -> LlvmM LlvmStatement) -> LlvmM [LlvmStatement]
forall a b. (a -> b) -> a -> b
$ \ r :: GlobalReg
r -> do
    LlvmVar
reg <- CmmReg -> LlvmM LlvmVar
getCmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
r)
    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
reg
    LlvmStatement -> LlvmM LlvmStatement
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatement -> LlvmM LlvmStatement)
-> LlvmStatement -> LlvmM LlvmStatement
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmVar -> LlvmStatement
Store (LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ LlvmType -> LlvmLit
LMUndefLit LlvmType
ty) LlvmVar
reg
  LlvmStatements -> LlvmM LlvmStatements
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]
stmts

getTrashRegs :: LlvmM [GlobalReg]
getTrashRegs :: LlvmM [GlobalReg]
getTrashRegs = do Platform
plat <- LlvmM Platform
getLlvmPlatform
                  [GlobalReg] -> LlvmM [GlobalReg]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GlobalReg] -> LlvmM [GlobalReg])
-> [GlobalReg] -> LlvmM [GlobalReg]
forall a b. (a -> b) -> a -> b
$ (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
plat) (Platform -> [GlobalReg]
activeStgRegs Platform
plat)

-- | 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 :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
getHsFunc :: [GlobalReg] -> CLabel -> LlvmM ExprData
getHsFunc live :: [GlobalReg]
live lbl :: CLabel
lbl
  = do LlvmType
fty <- [GlobalReg] -> LlvmM LlvmType
llvmFunTy [GlobalReg]
live
       LMString
name <- CLabel -> LlvmM LMString
strCLabel_llvm CLabel
lbl
       LMString -> LlvmType -> LlvmM ExprData
getHsFunc' LMString
name LlvmType
fty

getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
getHsFunc' name :: LMString
name fty :: LlvmType
fty
  = do LlvmVar
fun <- LMString -> LlvmM LlvmVar
getGlobalPtr LMString
name
       if LlvmVar -> LlvmType
getVarType LlvmVar
fun LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmType
fty
         then ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
fun, LlvmStatements
forall a. OrdList a
nilOL, [])
         else do (v1 :: LlvmVar
v1, s1 :: LlvmStatement
s1) <- LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr (LlvmType -> LlvmType
pLift LlvmType
fty)
                               (LlvmExpression -> LlvmM (LlvmVar, LlvmStatement))
-> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
forall a b. (a -> b) -> a -> b
$ LlvmCastOp -> LlvmVar -> LlvmType -> LlvmExpression
Cast LlvmCastOp
LM_Bitcast LlvmVar
fun (LlvmType -> LlvmType
pLift LlvmType
fty)
                 ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return  (LlvmVar
v1, LlvmStatement -> LlvmStatements
forall a. a -> OrdList a
unitOL LlvmStatement
s1, [])

-- | Create a new local var
mkLocalVar :: LlvmType -> LlvmM LlvmVar
mkLocalVar :: LlvmType -> LlvmM LlvmVar
mkLocalVar ty :: LlvmType
ty = do
    Unique
un <- LlvmM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
    LlvmVar -> LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar -> LlvmM LlvmVar) -> LlvmVar -> LlvmM LlvmVar
forall a b. (a -> b) -> a -> b
$ Unique -> LlvmType -> LlvmVar
LMLocalVar Unique
un LlvmType
ty


-- | Execute an expression, assigning result to a var
doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr ty :: LlvmType
ty expr :: LlvmExpression
expr = do
    LlvmVar
v <- LlvmType -> LlvmM LlvmVar
mkLocalVar LlvmType
ty
    (LlvmVar, LlvmStatement) -> LlvmM (LlvmVar, LlvmStatement)
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
v, LlvmVar -> LlvmExpression -> LlvmStatement
Assignment LlvmVar
v LlvmExpression
expr)


-- | Expand CmmRegOff
expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
expandCmmReg dflags :: DynFlags
dflags (reg :: CmmReg
reg, off :: Int
off)
  = let width :: Width
width = CmmType -> Width
typeWidth (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags 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 bid :: 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 :: LlvmType -> a -> LlvmVar
mkIntLit ty :: LlvmType
ty i :: 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 :: a -> LlvmVar
toI32 = LlvmType -> a -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit LlvmType
i32

toIWord :: Integral a => DynFlags -> a -> LlvmVar
toIWord :: DynFlags -> a -> LlvmVar
toIWord dflags :: DynFlags
dflags = LlvmType -> a -> LlvmVar
forall a. Integral a => LlvmType -> a -> LlvmVar
mkIntLit (DynFlags -> LlvmType
llvmWord DynFlags
dflags)


-- | Error functions
panic :: String -> a
panic :: String -> a
panic s :: String
s = String -> a
forall a. String -> a
Outputable.panic (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ "LlvmCodeGen.CodeGen." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

pprPanic :: String -> SDoc -> a
pprPanic :: String -> SDoc -> a
pprPanic s :: String
s d :: SDoc
d = String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
Outputable.pprPanic ("LlvmCodeGen.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 u :: Unique
u = do
    Maybe MetaId
mi <- Unique -> LlvmM (Maybe MetaId)
getUniqMeta Unique
u
    [MetaAnnot] -> LlvmM [MetaAnnot]
forall (m :: * -> *) a. Monad m => a -> m a
return [LMString -> MetaExpr -> MetaAnnot
MetaAnnot LMString
tbaa (MetaId -> MetaExpr
MetaNode MetaId
i) | let Just i :: MetaId
i = Maybe MetaId
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 stmtsA :: LlvmStatements
stmtsA declsA :: [LlvmCmmDecl]
declsA <> :: LlvmAccum -> LlvmAccum -> LlvmAccum
<> LlvmAccum stmtsB :: LlvmStatements
stmtsB declsB :: [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 action :: LlvmM ExprData
action = do
    (var :: LlvmVar
var, stmts :: LlvmStatements
stmts, decls :: [LlvmCmmDecl]
decls) <- LlvmM ExprData -> WriterT LlvmAccum LlvmM ExprData
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LlvmM ExprData
action
    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 LlvmStatements
stmts [LlvmCmmDecl]
decls
    LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => a -> m a
return LlvmVar
var

statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement stmt :: 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 a :: LlvmType
a b :: LlvmExpression
b = do
    (var :: LlvmVar
var, stmt :: LlvmStatement
stmt) <- LlvmM (LlvmVar, LlvmStatement)
-> WriterT LlvmAccum LlvmM (LlvmVar, LlvmStatement)
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
    LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement LlvmStatement
stmt
    LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
forall (m :: * -> *) a. Monad m => a -> m a
return LlvmVar
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 action :: WriterT LlvmAccum LlvmM LlvmVar
action = do
    (var :: LlvmVar
var, LlvmAccum stmts :: LlvmStatements
stmts decls :: [LlvmCmmDecl]
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
    ExprData -> LlvmM ExprData
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmVar
var, LlvmStatements
stmts, [LlvmCmmDecl]
decls)

runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
runStmtsDecls action :: WriterT LlvmAccum LlvmM ()
action = do
    LlvmAccum stmts :: LlvmStatements
stmts decls :: [LlvmCmmDecl]
decls <- WriterT LlvmAccum LlvmM () -> LlvmM LlvmAccum
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT WriterT LlvmAccum LlvmM ()
action
    (LlvmStatements, [LlvmCmmDecl])
-> LlvmM (LlvmStatements, [LlvmCmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (LlvmStatements
stmts, [LlvmCmmDecl]
decls)

getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
getCmmRegW = LlvmM LlvmVar -> WriterT LlvmAccum LlvmM LlvmVar
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 -> WriterT LlvmAccum LlvmM LlvmVar
genLoadW :: Bool -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
genLoadW atomic :: Bool
atomic e :: CmmExpr
e ty :: CmmType
ty = 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
$ Bool -> CmmExpr -> CmmType -> LlvmM ExprData
genLoad Bool
atomic CmmExpr
e CmmType
ty

doTrashStmts :: WriterT LlvmAccum LlvmM ()
doTrashStmts :: WriterT LlvmAccum LlvmM ()
doTrashStmts = do
    LlvmStatements
stmts <- LlvmM LlvmStatements -> WriterT LlvmAccum LlvmM LlvmStatements
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift LlvmM LlvmStatements
getTrashStmts
    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 LlvmStatements
stmts [LlvmCmmDecl]
forall a. Monoid a => a
mempty

-- | Return element of single-element list; 'panic' if list is not a single-element list
singletonPanic :: String -> [a] -> a
singletonPanic :: String -> [a] -> a
singletonPanic _ [x :: a
x] = a
x
singletonPanic s :: String
s _ = String -> a
forall a. String -> a
panic String
s