module LLVM.Core.Instructions(
BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,
ret,
condBr,
br,
switch,
invoke, invokeWithConv,
invokeFromFunction, invokeWithConvFromFunction,
unreachable,
add, sub, mul, neg,
iadd, isub, imul, ineg,
iaddNoWrap, isubNoWrap, imulNoWrap, inegNoWrap,
fadd, fsub, fmul, fneg,
idiv, irem,
udiv, sdiv, fdiv, urem, srem, frem,
shl, shr, lshr, ashr, and, or, xor, inv,
extractelement,
insertelement,
shufflevector,
extractvalue,
insertvalue,
malloc, arrayMalloc,
alloca, arrayAlloca,
free,
load,
store,
getElementPtr, getElementPtr0,
ValueCons,
trunc, zext, sext, ext, zadapt, sadapt, adapt,
fptrunc, fpext,
fptoui, fptosi, fptoint,
uitofp, sitofp, inttofp,
ptrtoint, inttoptr,
bitcast,
CmpPredicate(..), IntPredicate(..), FPPredicate(..),
CmpRet, CmpResult, CmpValueResult,
cmp, pcmp, icmp, fcmp,
select,
setHasNoNaNs,
setHasNoInfs,
setHasNoSignedZeros,
setHasAllowReciprocal,
setFastMath,
phi, addPhiInputs,
call, callWithConv,
callFromFunction, callWithConvFromFunction,
Call, applyCall, runCall,
ValueCons2, BinOpValue,
Terminate, Ret, CallArgs,
CodeGen.FunctionArgs, CodeGen.FunctionCodeGen, CodeGen.FunctionResult,
AllocArg,
GetElementPtr, ElementPtrType, IsIndexArg, IsIndexType,
GetValue, ValueType,
GetField, FieldType,
) where
import qualified LLVM.Core.Util as U
import qualified LLVM.Util.Proxy as LP
import qualified LLVM.Core.CodeGen as CodeGen
import LLVM.Core.Instructions.Private
(ValueCons, unValue, convert, unop,
FFIBinOp, FFIConstBinOp,
GetField, FieldType, GetElementPtr, ElementPtrType,
IsIndexArg, IsIndexType, getIxList, getArg,
CmpPredicate(..),
uintFromCmpPredicate, sintFromCmpPredicate, fpFromCmpPredicate)
import LLVM.Core.Data
import LLVM.Core.Type
import LLVM.Core.CodeGenMonad
import LLVM.Core.CodeGen
(BasicBlock(BasicBlock), Function, withCurrentBuilder,
ConstValue(ConstValue), zero,
Value(Value), value, valueOf)
import qualified LLVM.FFI.Core as FFI
import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))
import qualified Type.Data.Num.Decimal.Number as Dec
import Type.Data.Num.Decimal.Literal (d1)
import Type.Data.Num.Decimal.Number ((:<:), (:>:))
import Type.Base.Proxy (Proxy)
import Foreign.Ptr (Ptr, FunPtr, )
import Foreign.C (CUInt, CInt)
import Control.Monad.IO.Class (liftIO)
import Control.Monad (liftM)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Prelude hiding (and, or)
data ArgDesc = AV String | AI Int | AL String | AE
instance Show ArgDesc where
show (AV s) = s
show (AI i) = show i
show (AL l) = l
show AE = "voidarg?"
data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd
| BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub
| BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul
| BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem
| BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor
deriving Show
data InstrDesc =
IDRet TypeDesc ArgDesc | IDRetVoid
| IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc
| IDSwitch [(ArgDesc, ArgDesc)]
| IDIndirectBr
| IDInvoke
| IDUnwind
| IDUnreachable
| IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc
| IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc
| IDGetElementPtr TypeDesc [ArgDesc]
| IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc
| IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc
| IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc
| IDSItoFP TypeDesc TypeDesc ArgDesc
| IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc
| IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc
| IDBitcast TypeDesc TypeDesc ArgDesc
| IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc
| IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]
| IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg
| IDExtractElement | IDInsertElement | IDShuffleVector
| IDExtractValue | IDInsertValue
| IDInvalidOp
deriving Show
getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)
getInstrDesc v = do
valueName <- U.getValueNameU v
opcode <- FFI.instGetOpcode v
t <- FFI.typeOf v >>= typeDesc2
tsize <- return 1
ovs <- U.getOperands v
os <- mapM getArgDesc ovs
os0 <- return $ case os of {o:_ -> o; _ -> AE}
os1 <- return $ case os of {_:o:_ -> o; _ -> AE}
instr <-
case Map.lookup opcode binOpMap of
Just op -> return $ IDBinOp op t os0 os1
Nothing ->
case Map.lookup opcode convOpMap of
Just op -> do
t2 <-
case ovs of
(_name,ov):_ -> FFI.typeOf ov >>= typeDesc2
_ -> return TDVoid
return $ op t2 t os0
Nothing ->
case opcode of
1 -> return $ if null os then IDRetVoid else IDRet t os0
2 -> return $ if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1
3 -> return $ IDSwitch $ toPairs os
6 -> return IDUnwind; 7 -> return IDUnreachable
26 -> return $ IDAlloca (getPtrType t) tsize (getImmInt os0)
27 -> return $ IDLoad t os0; 28 -> return $ IDStore t os0 os1
29 -> return $ IDGetElementPtr t os
42 -> do
pInt <- FFI.cmpInstGetIntPredicate v
return $ IDICmp (FFI.toIntPredicate pInt) os0 os1
43 -> do
pFloat <- FFI.cmpInstGetRealPredicate v
return $ IDFCmp (FFI.toRealPredicate pFloat) os0 os1
44 -> return $ IDPhi t $ toPairs os
45 -> return $ IDCall t (last os) (init os)
46 -> return $ IDSelect t os0 os1
_ -> return IDInvalidOp
return (valueName, instr)
where toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))
stride _ [] = []
stride n (x:xs) = x : stride n (drop (n1) xs)
getPtrType (TDPtr t) = t
getPtrType _ = TDVoid
getImmInt (AI i) = i
getImmInt _ = 0
binOpMap :: Map CInt BinOpDesc
binOpMap =
Map.fromList
[(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),
(12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),
(16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),
(20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),
(24, BOOr), (25, BOXor)]
convOpMap :: Map CInt (TypeDesc -> TypeDesc -> ArgDesc -> InstrDesc)
convOpMap =
Map.fromList
[(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),
(34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),
(38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)]
getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc
getArgDesc (vname, v) = do
isC <- U.isConstant v
t <- FFI.typeOf v >>= typeDesc2
if isC
then case t of
TDInt _ _ -> do
cV <- FFI.constIntGetSExtValue v
return $ AI $ fromIntegral cV
_ -> return AE
else case t of
TDLabel -> return $ AL vname
_ -> return $ AV vname
type Terminate = ()
terminate :: Terminate
terminate = ()
class Ret a r where
ret' :: a -> CodeGenFunction r Terminate
ret :: (Ret a r) => a -> CodeGenFunction r Terminate
ret = ret'
instance Ret (Value a) a where
ret' (Value a) = do
withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a
return terminate
instance Ret () () where
ret' _ = do
withCurrentBuilder_ $ FFI.buildRetVoid
return terminate
withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r ()
withCurrentBuilder_ p = withCurrentBuilder p >> return ()
condBr :: Value Bool
-> BasicBlock
-> BasicBlock
-> CodeGenFunction r Terminate
condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do
withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2
return terminate
br :: BasicBlock
-> CodeGenFunction r Terminate
br (BasicBlock t) = do
withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t
return terminate
switch :: (IsInteger a)
=> Value a
-> BasicBlock
-> [(ConstValue a, BasicBlock)]
-> CodeGenFunction r Terminate
switch (Value val) (BasicBlock dflt) arms = do
withCurrentBuilder_ $ \ bldPtr -> do
inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms)
sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ]
return terminate
unreachable :: CodeGenFunction r Terminate
unreachable = do
withCurrentBuilder_ FFI.buildUnreachable
return terminate
withArithmeticType ::
(IsArithmetic c) =>
(ArithmeticType c -> a -> CodeGenFunction r (v c)) ->
(a -> CodeGenFunction r (v c))
withArithmeticType f = f arithmeticType
class (ValueCons value0, ValueCons value1) => ValueCons2 value0 value1 where
type BinOpValue (value0 :: * -> *) (value1 :: * -> *) :: * -> *
binop ::
FFIConstBinOp -> FFIBinOp ->
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)
instance ValueCons2 Value Value where
type BinOpValue Value Value = Value
binop _ op (Value a1) (Value a2) = buildBinOp op a1 a2
instance ValueCons2 Value ConstValue where
type BinOpValue Value ConstValue = Value
binop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2
instance ValueCons2 ConstValue Value where
type BinOpValue ConstValue Value = Value
binop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2
instance ValueCons2 ConstValue ConstValue where
type BinOpValue ConstValue ConstValue = ConstValue
binop cop _ (ConstValue a1) (ConstValue a2) =
liftIO $ fmap ConstValue $ cop a1 a2
add, sub, mul ::
(ValueCons2 value0 value1, IsArithmetic a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
add =
curry $ withArithmeticType $ \typ -> uncurry $ case typ of
IntegerType -> binop FFI.constAdd FFI.buildAdd
FloatingType -> binop FFI.constFAdd FFI.buildFAdd
sub =
curry $ withArithmeticType $ \typ -> uncurry $ case typ of
IntegerType -> binop FFI.constSub FFI.buildSub
FloatingType -> binop FFI.constFSub FFI.buildFSub
mul =
curry $ withArithmeticType $ \typ -> uncurry $ case typ of
IntegerType -> binop FFI.constMul FFI.buildMul
FloatingType -> binop FFI.constFMul FFI.buildFMul
iadd, isub, imul ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
iadd = binop FFI.constAdd FFI.buildAdd
isub = binop FFI.constSub FFI.buildSub
imul = binop FFI.constMul FFI.buildMul
iaddNoWrap, isubNoWrap, imulNoWrap ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
iaddNoWrap =
sbinop FFI.constNSWAdd FFI.buildNSWAdd FFI.constNUWAdd FFI.buildNUWAdd
isubNoWrap =
sbinop FFI.constNSWSub FFI.buildNSWSub FFI.constNUWSub FFI.buildNUWSub
imulNoWrap =
sbinop FFI.constNSWMul FFI.buildNSWMul FFI.constNUWMul FFI.buildNUWMul
idiv ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
idiv = sbinop FFI.constSDiv FFI.buildSDiv FFI.constUDiv FFI.buildUDiv
irem ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
irem = sbinop FFI.constSRem FFI.buildSRem FFI.constURem FFI.buildURem
udiv, sdiv, urem, srem ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
udiv = binop FFI.constUDiv FFI.buildUDiv
sdiv = binop FFI.constSDiv FFI.buildSDiv
urem = binop FFI.constURem FFI.buildURem
srem = binop FFI.constSRem FFI.buildSRem
fadd, fsub, fmul ::
(ValueCons2 value0 value1, IsFloating a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
fadd = binop FFI.constFAdd FFI.buildFAdd
fsub = binop FFI.constFSub FFI.buildFSub
fmul = binop FFI.constFMul FFI.buildFMul
fdiv ::
(ValueCons2 value0 value1, IsFloating a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
fdiv = binop FFI.constFDiv FFI.buildFDiv
frem ::
(ValueCons2 value0 value1, IsFloating a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
frem = binop FFI.constFRem FFI.buildFRem
shl, lshr, ashr, and, or, xor ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
shl = binop FFI.constShl FFI.buildShl
lshr = binop FFI.constLShr FFI.buildLShr
ashr = binop FFI.constAShr FFI.buildAShr
and = binop FFI.constAnd FFI.buildAnd
or = binop FFI.constOr FFI.buildOr
xor = binop FFI.constXor FFI.buildXor
shr ::
(ValueCons2 value0 value1, IsInteger a) =>
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)
shr = sbinop FFI.constAShr FFI.buildAShr FFI.constLShr FFI.buildLShr
sbinop ::
forall value0 value1 a b r.
(ValueCons2 value0 value1, IsInteger a) =>
FFIConstBinOp -> FFIBinOp ->
FFIConstBinOp -> FFIBinOp ->
value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)
sbinop scop sop ucop uop =
if isSigned (LP.Proxy :: LP.Proxy a)
then binop scop sop
else binop ucop uop
buildBinOp ::
FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)
buildBinOp op a1 a2 =
liftM Value $
withCurrentBuilder $ \ bld ->
U.withEmptyCString $ op bld a1 a2
neg ::
(ValueCons value, IsArithmetic a) =>
value a -> CodeGenFunction r (value a)
neg =
withArithmeticType $ \typ -> case typ of
IntegerType -> unop FFI.constNeg FFI.buildNeg
FloatingType -> unop FFI.constFNeg FFI.buildFNeg
ineg ::
(ValueCons value, IsInteger a) =>
value a -> CodeGenFunction r (value a)
ineg = unop FFI.constNeg FFI.buildNeg
inegNoWrap ::
forall value a r.
(ValueCons value, IsInteger a) =>
value a -> CodeGenFunction r (value a)
inegNoWrap =
if isSigned (LP.Proxy :: LP.Proxy a)
then unop FFI.constNSWNeg FFI.buildNSWNeg
else unop FFI.constNUWNeg FFI.buildNUWNeg
fneg ::
(ValueCons value, IsFloating a) =>
value a -> CodeGenFunction r (value a)
fneg = unop FFI.constFNeg FFI.buildFNeg
inv ::
(ValueCons value, IsInteger a) =>
value a -> CodeGenFunction r (value a)
inv = unop FFI.constNot FFI.buildNot
extractelement :: (Dec.Positive n, IsPrimitive a)
=> Value (Vector n a)
-> Value Word32
-> CodeGenFunction r (Value a)
extractelement (Value vec) (Value i) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i
insertelement :: (Dec.Positive n, IsPrimitive a)
=> Value (Vector n a)
-> Value a
-> Value Word32
-> CodeGenFunction r (Value (Vector n a))
insertelement (Value vec) (Value e) (Value i) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i
shufflevector :: (Dec.Positive n, Dec.Positive m, IsPrimitive a)
=> Value (Vector n a)
-> Value (Vector n a)
-> ConstValue (Vector m Word32)
-> CodeGenFunction r (Value (Vector m a))
shufflevector (Value a) (Value b) (ConstValue mask) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask
class GetValue agg ix where
type ValueType agg ix :: *
getIx :: LP.Proxy agg -> ix -> CUInt
instance (GetField as i, Dec.Natural i) => GetValue (Struct as) (Proxy i) where
type ValueType (Struct as) (Proxy i) = FieldType as i
getIx _ n = Dec.integralFromProxy n
instance (IsFirstClass a, Dec.Natural n) => GetValue (Array n a) Word32 where
type ValueType (Array n a) Word32 = a
getIx _ n = fromIntegral n
instance (IsFirstClass a, Dec.Natural n) => GetValue (Array n a) Word64 where
type ValueType (Array n a) Word64 = a
getIx _ n = fromIntegral n
instance (IsFirstClass a, Dec.Natural n, Dec.Natural i, i :<: n) => GetValue (Array n a) (Proxy i) where
type ValueType (Array n a) (Proxy i) = a
getIx _ n = Dec.integralFromProxy n
extractvalue :: forall r agg i.
GetValue agg i
=> Value agg
-> i
-> CodeGenFunction r (Value (ValueType agg i))
extractvalue (Value agg) i =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $
FFI.buildExtractValue bldPtr agg (getIx (LP.Proxy :: LP.Proxy agg) i)
insertvalue :: forall r agg i.
GetValue agg i
=> Value agg
-> Value (ValueType agg i)
-> i
-> CodeGenFunction r (Value agg)
insertvalue (Value agg) (Value e) i =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $
FFI.buildInsertValue bldPtr agg e (getIx (LP.Proxy :: LP.Proxy agg) i)
trunc :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)
=> value a -> CodeGenFunction r (value b)
trunc = convert FFI.constTrunc FFI.buildTrunc
zext :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)
=> value a -> CodeGenFunction r (value b)
zext = convert FFI.constZExt FFI.buildZExt
sext :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)
=> value a -> CodeGenFunction r (value b)
sext = convert FFI.constSExt FFI.buildSExt
ext :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)
=> value a -> CodeGenFunction r (value b)
ext =
if isSigned (LP.Proxy :: LP.Proxy b)
then convert FFI.constSExt FFI.buildSExt
else convert FFI.constZExt FFI.buildZExt
zadapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b)
=> value a -> CodeGenFunction r (value b)
zadapt =
case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))
(sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of
LT -> convert FFI.constZExt FFI.buildZExt
EQ -> convert FFI.constBitCast FFI.buildBitCast
GT -> convert FFI.constTrunc FFI.buildTrunc
sadapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b)
=> value a -> CodeGenFunction r (value b)
sadapt =
case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))
(sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of
LT -> convert FFI.constSExt FFI.buildSExt
EQ -> convert FFI.constBitCast FFI.buildBitCast
GT -> convert FFI.constTrunc FFI.buildTrunc
adapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b)
=> value a -> CodeGenFunction r (value b)
adapt =
case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))
(sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of
LT ->
if isSigned (LP.Proxy :: LP.Proxy b)
then convert FFI.constSExt FFI.buildSExt
else convert FFI.constZExt FFI.buildZExt
EQ -> convert FFI.constBitCast FFI.buildBitCast
GT -> convert FFI.constTrunc FFI.buildTrunc
fptrunc :: (ValueCons value, IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)
=> value a -> CodeGenFunction r (value b)
fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc
fpext :: (ValueCons value, IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)
=> value a -> CodeGenFunction r (value b)
fpext = convert FFI.constFPExt FFI.buildFPExt
fptoui :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
fptoui = convert FFI.constFPToUI FFI.buildFPToUI
fptosi :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
fptosi = convert FFI.constFPToSI FFI.buildFPToSI
fptoint :: forall value a b r. (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
fptoint =
if isSigned (LP.Proxy :: LP.Proxy b)
then convert FFI.constFPToSI FFI.buildFPToSI
else convert FFI.constFPToUI FFI.buildFPToUI
uitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
uitofp = convert FFI.constUIToFP FFI.buildUIToFP
sitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
sitofp = convert FFI.constSIToFP FFI.buildSIToFP
inttofp :: forall value a b r. (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
inttofp =
if isSigned (LP.Proxy :: LP.Proxy a)
then convert FFI.constSIToFP FFI.buildSIToFP
else convert FFI.constUIToFP FFI.buildUIToFP
ptrtoint :: (ValueCons value, IsInteger b, IsPrimitive b) => value (Ptr a) -> CodeGenFunction r (value b)
ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt
inttoptr :: (ValueCons value, IsInteger a, IsType b) => value a -> CodeGenFunction r (value (Ptr b))
inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr
bitcast :: (ValueCons value, IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)
=> value a -> CodeGenFunction r (value b)
bitcast = convert FFI.constBitCast FFI.buildBitCast
type CmpValueResult value0 value1 a = BinOpValue value0 value1 (CmpResult a)
type CmpResult c = ShapedType (ShapeOf c) Bool
class (IsFirstClass c) => CmpRet c where
cmpBld :: LP.Proxy c -> CmpPredicate -> FFIBinOp
cmpCnst :: LP.Proxy c -> CmpPredicate -> FFIConstBinOp
instance CmpRet Float where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst
instance CmpRet Double where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst
instance CmpRet FP128 where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst
instance CmpRet Bool where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word8 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word16 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word32 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word64 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Int8 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet Int16 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet Int32 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet Int64 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance (IsType a) =>
CmpRet (Ptr a) where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance (Dec.Positive n) => CmpRet (WordN n) where
cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance (Dec.Positive n) => CmpRet (IntN n) where
cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance (CmpRet a, IsPrimitive a, Dec.Positive n) => CmpRet (Vector n a) where
cmpBld _ = cmpBld (LP.Proxy :: LP.Proxy a)
cmpCnst _ = cmpCnst (LP.Proxy :: LP.Proxy a)
cmp :: forall value0 value1 a r.
(ValueCons2 value0 value1, CmpRet a) =>
CmpPredicate -> value0 a -> value1 a ->
CodeGenFunction r (CmpValueResult value0 value1 a)
cmp p =
binop
(cmpCnst (LP.Proxy :: LP.Proxy a) p)
(cmpBld (LP.Proxy :: LP.Proxy a) p)
ucmpBld :: CmpPredicate -> FFIBinOp
ucmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))
scmpBld :: CmpPredicate -> FFIBinOp
scmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))
fcmpBld :: CmpPredicate -> FFIBinOp
fcmpBld p = flip FFI.buildFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))
ucmpCnst :: CmpPredicate -> FFIConstBinOp
ucmpCnst p = FFI.constICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))
scmpCnst :: CmpPredicate -> FFIConstBinOp
scmpCnst p = FFI.constICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))
fcmpCnst :: CmpPredicate -> FFIConstBinOp
fcmpCnst p = FFI.constFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))
_ucmp ::
(ValueCons2 value0 value1, CmpRet a, IsInteger a) =>
CmpPredicate -> value0 a -> value1 a ->
CodeGenFunction r (CmpValueResult value0 value1 a)
_ucmp p = binop (ucmpCnst p) (ucmpBld p)
_scmp ::
(ValueCons2 value0 value1, CmpRet a, IsInteger a) =>
CmpPredicate -> value0 a -> value1 a ->
CodeGenFunction r (CmpValueResult value0 value1 a)
_scmp p = binop (scmpCnst p) (scmpBld p)
pcmp ::
(ValueCons2 value0 value1, IsType a) =>
IntPredicate -> value0 (Ptr a) -> value1 (Ptr a) ->
CodeGenFunction r (BinOpValue value0 value1 (Ptr a))
pcmp p =
binop
(FFI.constICmp (FFI.fromIntPredicate p))
(flip FFI.buildICmp (FFI.fromIntPredicate p))
icmp ::
(ValueCons2 value0 value1, CmpRet a, IsIntegerOrPointer a) =>
IntPredicate -> value0 a -> value1 a ->
CodeGenFunction r (CmpValueResult value0 value1 a)
icmp p =
binop
(FFI.constICmp (FFI.fromIntPredicate p))
(flip FFI.buildICmp (FFI.fromIntPredicate p))
fcmp ::
(ValueCons2 value0 value1, CmpRet a, IsFloating a) =>
FPPredicate -> value0 a -> value1 a ->
CodeGenFunction r (CmpValueResult value0 value1 a)
fcmp p =
binop
(FFI.constFCmp (FFI.fromRealPredicate p))
(flip FFI.buildFCmp (FFI.fromRealPredicate p))
setHasNoNaNs, setHasNoInfs, setHasNoSignedZeros, setHasAllowReciprocal,
setFastMath :: (IsFloating a) => Bool -> Value a -> CodeGenFunction r ()
setHasNoNaNs = fastMath FFI.setHasNoNaNs
setHasNoInfs = fastMath FFI.setHasNoInfs
setHasNoSignedZeros = fastMath FFI.setHasNoSignedZeros
setHasAllowReciprocal = fastMath FFI.setHasAllowReciprocal
setFastMath = fastMath FFI.setHasUnsafeAlgebra
fastMath ::
(IsFloating a) =>
(FFI.ValueRef -> FFI.Bool -> IO ()) ->
Bool -> Value a -> CodeGenFunction r ()
fastMath setter b (Value v) = liftIO $ setter v $ FFI.consBool b
select :: (CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a)
select (Value cnd) (Value thn) (Value els) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $
FFI.buildSelect bldPtr cnd thn els
type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef
class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>
CallArgs f g r where
type CalledFunction g :: *
type CallerResult g :: *
type CallerFunction f r :: *
doCall :: Call f -> g
instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where
type CalledFunction (Value a -> b') = a -> CalledFunction b'
type CallerResult (Value a -> b') = CallerResult b'
type CallerFunction (a -> b) r = Value a -> CallerFunction b r
doCall f a = doCall (applyCall f a)
instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where
type CalledFunction (CodeGenFunction r (Value a)) = IO a
type CallerResult (CodeGenFunction r (Value a)) = r
type CallerFunction (IO a) r = CodeGenFunction r (Value a)
doCall = runCall
doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a)
doCallDef mkCall args _ =
withCurrentBuilder $ \ bld ->
liftM Value $ mkCall bld (reverse args)
call :: (CallArgs f g r) => Function f -> g
call = doCall . callFromFunction
data Call a = Call Caller [FFI.ValueRef]
callFromFunction :: Function a -> Call a
callFromFunction (Value f) = Call (U.makeCall f) []
infixl 4 `applyCall`
applyCall :: Call (a -> b) -> Value a -> Call b
applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args)
runCall :: Call (IO a) -> CodeGenFunction r (Value a)
runCall (Call mkCall args) = doCallDef mkCall args ()
invokeFromFunction ::
BasicBlock
-> BasicBlock
-> Function f
-> Call f
invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) =
Call (U.makeInvoke norm expt f) []
invoke :: (CallArgs f g r)
=> BasicBlock
-> BasicBlock
-> Function f
-> g
invoke norm expt f = doCall $ invokeFromFunction norm expt f
callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f
callWithConvFromFunction cc (Value f) =
Call (U.makeCallWithCc cc f) []
callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g
callWithConv cc f = doCall $ callWithConvFromFunction cc f
invokeWithConvFromFunction ::
FFI.CallingConvention
-> BasicBlock
-> BasicBlock
-> Function f
-> Call f
invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) =
Call (U.makeInvokeWithCc cc norm expt f) []
invokeWithConv :: (CallArgs f g r)
=> FFI.CallingConvention
-> BasicBlock
-> BasicBlock
-> Function f
-> g
invokeWithConv cc norm expt f =
doCall $ invokeWithConvFromFunction cc norm expt f
phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)
phi incoming =
liftM Value $
withCurrentBuilder $ \ bldPtr -> do
inst <- U.buildEmptyPhi bldPtr =<< typeRef (LP.Proxy :: LP.Proxy a)
U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]
return inst
addPhiInputs :: forall a r . (IsFirstClass a)
=> Value a
-> [(Value a, BasicBlock)]
-> CodeGenFunction r ()
addPhiInputs (Value inst) incoming =
liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]
class AllocArg a where
getAllocArg :: a -> Value Word32
instance AllocArg (Value Word32) where
getAllocArg = id
instance AllocArg (ConstValue Word32) where
getAllocArg = value
instance AllocArg Word32 where
getAllocArg = valueOf
malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))
malloc = arrayMalloc (1::Word32)
foreign import ccall "&aligned_malloc_sizeptr"
alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))
foreign import ccall "&aligned_free"
alignedFree :: FunPtr (Ptr Word8 -> IO ())
arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>
s -> CodeGenFunction r (Value (Ptr a))
arrayMalloc s = do
func <- CodeGen.staticNamedFunction "alignedMalloc" alignedMalloc
size <- sizeOfArray (LP.Proxy :: LP.Proxy a) (getAllocArg s)
alignment <- alignOf (LP.Proxy :: LP.Proxy a)
bitcast =<<
call
(func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)))
size
alignment
alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))
alloca =
liftM Value $
withCurrentBuilder $ \ bldPtr -> do
typ <- typeRef (LP.Proxy :: LP.Proxy a)
U.withEmptyCString $ FFI.buildAlloca bldPtr typ
arrayAlloca :: forall a r s . (IsSized a, AllocArg s) =>
s -> CodeGenFunction r (Value (Ptr a))
arrayAlloca s =
liftM Value $
withCurrentBuilder $ \ bldPtr -> do
typ <- typeRef (LP.Proxy :: LP.Proxy a)
U.withEmptyCString $
FFI.buildArrayAlloca bldPtr typ (case getAllocArg s of Value v -> v)
free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()
free ptr = do
func <- CodeGen.staticNamedFunction "alignedFree" alignedFree
_ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr
return ()
_sizeOf ::
forall a r.
(IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word64)
_sizeOf a =
liftIO $ liftM Value $
FFI.sizeOf =<< typeRef a
_alignOf ::
forall a r.
(IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word64)
_alignOf a =
liftIO $ liftM Value $
FFI.alignOf =<< typeRef a
sizeOfArray ::
forall a r . (IsSized a) =>
LP.Proxy a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8))
sizeOfArray _ len =
bitcast =<<
getElementPtr (value zero :: Value (Ptr a)) (len, ())
alignOf ::
forall a r . (IsSized a) =>
LP.Proxy a -> CodeGenFunction r (Value (Ptr Word8))
alignOf _ =
bitcast =<<
getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())
load :: Value (Ptr a)
-> CodeGenFunction r (Value a)
load (Value p) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ FFI.buildLoad bldPtr p
store :: Value a
-> Value (Ptr a)
-> CodeGenFunction r ()
store (Value v) (Value p) = do
withCurrentBuilder_ $ \ bldPtr ->
FFI.buildStore bldPtr v p
return ()
_getElementPtrDynamic :: (IsInteger i) =>
Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))
_getElementPtrDynamic (Value ptr) ixs =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->
U.withEmptyCString $
FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)
getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) =>
Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))
getElementPtr (Value ptr) (a, ixs) =
let ixl = getArg a : getIxList (LP.Proxy :: LP.Proxy o) ixs in
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withArrayLen ixl $ \ idxLen idxPtr ->
U.withEmptyCString $
FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)
getElementPtr0 :: (GetElementPtr o i) =>
Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))
getElementPtr0 p i = getElementPtr p (0::Word32, i)
_getElementPtr :: forall value o i i0 r.
(ValueCons value, GetElementPtr o i, IsIndexType i0) =>
value (Ptr o) -> (value i0, i) ->
CodeGenFunction r (value (Ptr (ElementPtrType o i)))
_getElementPtr vptr (a, ixs) =
let withArgs act =
U.withArrayLen
(unValue a : getIxList (LP.Proxy :: LP.Proxy o) ixs) $
\ idxLen idxPtr ->
act idxPtr (fromIntegral idxLen)
in unop
(\ptr -> withArgs $ FFI.constGEP ptr)
(\bldPtr ptr cstr ->
withArgs $ \idxPtr idxLen ->
FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)
vptr