llvm-tf-3.9: src/LLVM/Core/Instructions.hs
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module LLVM.Core.Instructions(
-- * ADT representation of IR
BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,
-- * Terminator instructions
ret,
condBr,
br,
switch,
invoke, invokeWithConv,
invokeFromFunction, invokeWithConvFromFunction,
unreachable,
-- * Arithmetic binary operations
-- | Arithmetic operations with the normal semantics.
-- The u instractions are unsigned, the s instructions are signed.
add, sub, mul, neg,
iadd, isub, imul, ineg,
iaddNoWrap, isubNoWrap, imulNoWrap, inegNoWrap,
fadd, fsub, fmul, fneg,
idiv, irem,
udiv, sdiv, fdiv, urem, srem, frem,
-- * Logical binary operations
-- |Logical instructions with the normal semantics.
shl, lshr, ashr, and, or, xor, inv,
-- * Vector operations
extractelement,
insertelement,
shufflevector,
-- * Aggregate operation
extractvalue,
insertvalue,
-- * Memory access
malloc, arrayMalloc,
alloca, arrayAlloca,
free,
load,
store,
getElementPtr, getElementPtr0,
-- * Conversions
ValueCons,
trunc, zext, sext, ext, zadapt, sadapt, adapt,
fptrunc, fpext,
fptoui, fptosi, fptoint,
uitofp, sitofp, inttofp,
ptrtoint, inttoptr,
bitcast,
bitcastElements,
-- * Comparison
CmpPredicate(..), IntPredicate(..), FPPredicate(..),
CmpOp, CmpRet, CmpResult, CmpValueResult,
cmp, pcmp, icmp, fcmp,
select,
-- * Fast math
setHasNoNaNs,
setHasNoInfs,
setHasNoSignedZeros,
setHasAllowReciprocal,
setFastMath,
-- * Other
phi, addPhiInputs,
call, callWithConv,
callFromFunction, callWithConvFromFunction,
Call, applyCall, runCall,
-- * Classes and types
Terminate,
Ret, CallArgs, ABinOp, ABinOpResult, IsConst,
FunctionArgs, FunctionCodeGen, FunctionResult,
AllocArg,
GetElementPtr, ElementPtrType, IsIndexArg,
GetValue, ValueType,
GetField, FieldType,
) where
import qualified LLVM.Core.Util as U
import qualified LLVM.Util.Proxy as LP
import LLVM.Core.Instructions.Private (ValueCons, convert, aunop)
import LLVM.Core.Data
import LLVM.Core.Type
import LLVM.Core.CodeGenMonad
import LLVM.Core.CodeGen
import qualified LLVM.FFI.Core as FFI
import qualified Type.Data.Num.Decimal.Number as Dec
import Type.Data.Num.Decimal.Literal (d1)
import Type.Data.Num.Decimal.Number (Pred, (:<:), (:>:))
import Type.Base.Proxy (Proxy)
import Foreign.Ptr (Ptr, FunPtr, )
import Foreign.C (CInt, CUInt)
import Control.Monad.IO.Class (liftIO)
import Control.Monad (liftM)
import Data.Typeable (Typeable)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Map (fromList, (!))
import Prelude hiding (and, or)
-- TODO:
-- Add vector version of arithmetic
-- Add rest of instructions
-- Use Terminate to ensure bb termination (how?)
-- more intrinsics are needed to, e.g., create an empty vector
data ArgDesc = AV String | AI Int | AL String | AE
instance Show ArgDesc where
-- show (AV s) = "V_" ++ s
-- show (AI i) = "I_" ++ show i
-- show (AL l) = "L_" ++ l
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
-- FIXME: complete definitions for unimplemented instructions
data InstrDesc =
-- terminators
IDRet TypeDesc ArgDesc | IDRetVoid
| IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc
| IDSwitch [(ArgDesc, ArgDesc)]
| IDIndirectBr
| IDInvoke
| IDUnwind
| IDUnreachable
-- binary operators (including bitwise)
| IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc
-- memory access and addressing
| IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc
| IDGetElementPtr TypeDesc [ArgDesc]
-- conversion
| 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
-- other
| IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc
| IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]
| IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg
-- vector operators
| IDExtractElement | IDInsertElement | IDShuffleVector
-- aggregate operators
| IDExtractValue | IDInsertValue
-- invalid
| IDInvalidOp
deriving Show
-- TODO: overflow support for binary operations (add/sub/mul)
getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)
getInstrDesc v = do
valueName <- U.getValueNameU v
opcode <- FFI.instGetOpcode v
t <- FFI.typeOf v >>= typeDesc2
-- FIXME: sizeof() does not work for types!
--tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral
tsize <- return 1
os <- U.getOperands v >>= mapM getArgDesc
os0 <- if length os > 0 then return $ os !! 0 else return AE
os1 <- if length os > 1 then return $ os !! 1 else return AE
t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41)
then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2
else return TDVoid)
p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0
let instr =
(if opcode >= 8 && opcode <= 25 -- binary arithmetic
then IDBinOp (getBinOp opcode) t os0 os1
else if opcode >= 30 && opcode <= 41 -- conversion
then (getConvOp opcode) t2 t os0
else case opcode of
{ 1 -> if null os then IDRetVoid else IDRet t os0;
2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1;
3 -> IDSwitch $ toPairs os;
-- TODO (can skip for now)
-- 4 -> IndirectBr ; 5 -> Invoke ;
6 -> IDUnwind; 7 -> IDUnreachable;
26 -> IDAlloca (getPtrType t) tsize (getImmInt os0);
27 -> IDLoad t os0; 28 -> IDStore t os0 os1;
29 -> IDGetElementPtr t os;
42 -> IDICmp (toIntPredicate p) os0 os1;
43 -> IDFCmp (toFPPredicate p) os0 os1;
44 -> IDPhi t $ toPairs os;
-- FIXME: getelementptr arguments are not handled
45 -> IDCall t (last os) (init os);
46 -> IDSelect t os0 os1;
-- TODO (can skip for now)
-- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ;
-- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ;
-- 53 -> ExtractValue ; 54 -> InsertValue ;
_ -> IDInvalidOp })
return (valueName, instr)
--if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode
where getBinOp o = 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)] ! o
getConvOp o = 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)] ! o
toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))
stride _ [] = []
stride n (x:xs) = x : stride n (drop (n-1) xs)
getPtrType (TDPtr t) = t
getPtrType _ = TDVoid
getImmInt (AI i) = i
getImmInt _ = 0
-- TODO: fix for non-int constants
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 = ()
--------------------------------------
-- |Acceptable arguments to the 'ret' instruction.
class Ret a r where
ret' :: a -> CodeGenFunction r Terminate
-- | Return from the current function with the given value. Use () as the return value for what would be a void function in C.
ret :: (Ret a r) => a -> CodeGenFunction r Terminate
ret = ret'
-- overlaps with Ret () ()!
{-
instance (IsFirstClass a, IsConst a) => Ret a a where
ret' = ret . valueOf
-}
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 ()
--------------------------------------
-- | Branch to the first basic block if the boolean is true, otherwise to the second basic block.
condBr :: Value Bool -- ^ Boolean to branch upon.
-> BasicBlock -- ^ Target for true.
-> BasicBlock -- ^ Target for false.
-> CodeGenFunction r Terminate
condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do
withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2
return terminate
--------------------------------------
-- | Unconditionally branch to the given basic block.
br :: BasicBlock -- ^ Branch target.
-> CodeGenFunction r Terminate
br (BasicBlock t) = do
withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t
return terminate
--------------------------------------
-- | Branch table instruction.
switch :: (IsInteger a)
=> Value a -- ^ Value to branch upon.
-> BasicBlock -- ^ Default branch target.
-> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets.
-> 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
--------------------------------------
-- |Inform the code generator that this code can never be reached.
unreachable :: CodeGenFunction r Terminate
unreachable = do
withCurrentBuilder_ FFI.buildUnreachable
return terminate
--------------------------------------
type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef
type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef
withArithmeticType ::
(IsArithmetic c) =>
(ArithmeticType c -> a -> CodeGenFunction r (v c)) ->
(a -> CodeGenFunction r (v c))
withArithmeticType f = f arithmeticType
-- |Acceptable arguments to arithmetic binary instructions.
class ABinOp a b where
type ABinOpResult a b :: *
abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b)
add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
add =
curry $ withArithmeticType $ \typ -> uncurry $ case typ of
IntegerType -> abinop FFI.constAdd FFI.buildAdd
FloatingType -> abinop FFI.constFAdd FFI.buildFAdd
sub :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
sub =
curry $ withArithmeticType $ \typ -> uncurry $ case typ of
IntegerType -> abinop FFI.constSub FFI.buildSub
FloatingType -> abinop FFI.constFSub FFI.buildFSub
mul :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
mul =
curry $ withArithmeticType $ \typ -> uncurry $ case typ of
IntegerType -> abinop FFI.constMul FFI.buildMul
FloatingType -> abinop FFI.constFMul FFI.buildFMul
iadd :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
iadd = abinop FFI.constAdd FFI.buildAdd
isub :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
isub = abinop FFI.constSub FFI.buildSub
imul :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
imul = abinop FFI.constMul FFI.buildMul
iaddNoWrap :: forall v a b c r. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
iaddNoWrap =
if isSigned (LP.Proxy :: LP.Proxy c)
then abinop FFI.constNSWAdd FFI.buildNSWAdd
else abinop FFI.constNUWAdd FFI.buildNUWAdd
isubNoWrap :: forall v a b c r. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
isubNoWrap =
if isSigned (LP.Proxy :: LP.Proxy c)
then abinop FFI.constNSWSub FFI.buildNSWSub
else abinop FFI.constNUWSub FFI.buildNUWSub
imulNoWrap :: forall v a b c r. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
imulNoWrap =
if isSigned (LP.Proxy :: LP.Proxy c)
then abinop FFI.constNSWMul FFI.buildNSWMul
else abinop FFI.constNUWMul FFI.buildNUWMul
-- | signed or unsigned integer division depending on the type
idiv ::
forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) =>
a -> b -> CodeGenFunction r (v c)
idiv =
if isSigned (LP.Proxy :: LP.Proxy c)
then abinop FFI.constSDiv FFI.buildSDiv
else abinop FFI.constUDiv FFI.buildUDiv
-- | signed or unsigned remainder depending on the type
irem ::
forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) =>
a -> b -> CodeGenFunction r (v c)
irem =
if isSigned (LP.Proxy :: LP.Proxy c)
then abinop FFI.constSRem FFI.buildSRem
else abinop FFI.constURem FFI.buildURem
{-# DEPRECATED udiv "use idiv instead" #-}
{-# DEPRECATED sdiv "use idiv instead" #-}
{-# DEPRECATED urem "use irem instead" #-}
{-# DEPRECATED srem "use irem instead" #-}
udiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
udiv = abinop FFI.constUDiv FFI.buildUDiv
sdiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
sdiv = abinop FFI.constSDiv FFI.buildSDiv
urem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
urem = abinop FFI.constURem FFI.buildURem
srem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
srem = abinop FFI.constSRem FFI.buildSRem
fadd :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
fadd = abinop FFI.constFAdd FFI.buildFAdd
fsub :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
fsub = abinop FFI.constFSub FFI.buildFSub
fmul :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
fmul = abinop FFI.constFMul FFI.buildFMul
-- | Floating point division.
fdiv :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
fdiv = abinop FFI.constFDiv FFI.buildFDiv
-- | Floating point remainder.
frem :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
frem = abinop FFI.constFRem FFI.buildFRem
shl :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
shl = abinop FFI.constShl FFI.buildShl
lshr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
lshr = abinop FFI.constLShr FFI.buildLShr
ashr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
ashr = abinop FFI.constAShr FFI.buildAShr
and :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
and = abinop FFI.constAnd FFI.buildAnd
or :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
or = abinop FFI.constOr FFI.buildOr
xor :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)
xor = abinop FFI.constXor FFI.buildXor
instance ABinOp (Value a) (Value a) where
type ABinOpResult (Value a) (Value a) = Value a
abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2
instance ABinOp (ConstValue a) (Value a) where
type ABinOpResult (ConstValue a) (Value a) = Value a
abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2
instance ABinOp (Value a) (ConstValue a) where
type ABinOpResult (Value a) (ConstValue a) = Value a
abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2
instance ABinOp (ConstValue a) (ConstValue a) where
type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a
abinop cop _ (ConstValue a1) (ConstValue a2) =
liftIO $ fmap ConstValue $ cop a1 a2
{-
instance (IsConst a) => ABinOp (Value a) a where
type ABinOpResult (Value a) a = Value a
abinop cop op a1 a2 = abinop cop op a1 (constOf a2)
instance (IsConst a) => ABinOp a (Value a) where
type ABinOpResult a (Value a) = Value a
abinop cop op a1 a2 = abinop cop op (constOf a1) a2
-}
--instance (IsConst a) => ABinOp a a (ConstValue a) where
-- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2)
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 -> aunop FFI.constNeg FFI.buildNeg
FloatingType -> aunop FFI.constFNeg FFI.buildFNeg
ineg ::
(ValueCons value, IsInteger a) =>
value a -> CodeGenFunction r (value a)
ineg = aunop 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 aunop FFI.constNSWNeg FFI.buildNSWNeg
else aunop FFI.constNUWNeg FFI.buildNUWNeg
fneg ::
(ValueCons value, IsFloating a) =>
value a -> CodeGenFunction r (value a)
{-
fneg = fsub (value zero :: Value a)
-}
fneg = aunop FFI.constFNeg FFI.buildFNeg
inv ::
(ValueCons value, IsInteger a) =>
value a -> CodeGenFunction r (value a)
inv = aunop FFI.constNot FFI.buildNot
--------------------------------------
-- | Get a value from a vector.
extractelement :: (Dec.Positive n)
=> Value (Vector n a) -- ^ Vector
-> Value Word32 -- ^ Index into the vector
-> CodeGenFunction r (Value a)
extractelement (Value vec) (Value i) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i
-- | Insert a value into a vector, nondestructive.
insertelement :: (Dec.Positive n)
=> Value (Vector n a) -- ^ Vector
-> Value a -- ^ Value to insert
-> Value Word32 -- ^ Index into the vector
-> 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
-- | Permute vector.
shufflevector :: (Dec.Positive n, Dec.Positive m)
=> 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
-- |Acceptable arguments to 'extractvalue' and 'insertvalue'.
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
-- | Get a value from an aggregate.
extractvalue :: forall r agg i.
GetValue agg i
=> Value agg -- ^ Aggregate
-> i -- ^ Index into the aggregate
-> 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)
-- | Insert a value into an aggregate, nondestructive.
insertvalue :: forall r agg i.
GetValue agg i
=> Value agg -- ^ Aggregate
-> Value (ValueType agg i) -- ^ Value to insert
-> i -- ^ Index into the aggregate
-> 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)
--------------------------------------
-- | Truncate a value to a shorter bit width.
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
-- | Zero extend a value to a wider width.
-- If possible, use 'ext' that chooses the right padding according to the types
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
-- | Sign extend a value to wider width.
-- If possible, use 'ext' that chooses the right padding according to the types
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
-- | Extend a value to wider width.
-- If the target type is signed, then preserve the sign,
-- If the target type is unsigned, then extended by zeros.
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
-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.
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
-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.
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
-- | It is 'sadapt' or 'zadapt' depending on the sign mode.
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
-- | Truncate a floating point value.
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
-- | Extend a floating point value.
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
{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-}
-- | Convert a floating point value to an unsigned integer.
fptoui :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
fptoui = convert FFI.constFPToUI FFI.buildFPToUI
{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-}
-- | Convert a floating point value to a signed integer.
fptosi :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
fptosi = convert FFI.constFPToSI FFI.buildFPToSI
-- | Convert a floating point value to an integer.
-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.
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
{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -}
-- | Convert an unsigned integer to a floating point value.
-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.
uitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
uitofp = convert FFI.constUIToFP FFI.buildUIToFP
{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -}
-- | Convert a signed integer to a floating point value.
-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.
sitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)
sitofp = convert FFI.constSIToFP FFI.buildSIToFP
-- | Convert an integer to a floating point value.
-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.
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
-- | Convert a pointer to an integer.
ptrtoint :: (ValueCons value, IsInteger b, IsPrimitive b) => value (Ptr a) -> CodeGenFunction r (value b)
ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt
-- | Convert an integer to a pointer.
inttoptr :: (ValueCons value, IsInteger a, IsType b) => value a -> CodeGenFunction r (value (Ptr b))
inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr
-- | Convert between to values of the same size by just copying the bit pattern.
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
-- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same.
bitcastElements :: (ValueCons value, Dec.Positive n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)
=> value (Vector n a) -> CodeGenFunction r (value (Vector n b))
bitcastElements = convert FFI.constBitCast FFI.buildBitCast
--------------------------------------
data CmpPredicate =
CmpEQ -- ^ equal
| CmpNE -- ^ not equal
| CmpGT -- ^ greater than
| CmpGE -- ^ greater or equal
| CmpLT -- ^ less than
| CmpLE -- ^ less or equal
deriving (Eq, Ord, Enum, Show, Typeable)
uintFromCmpPredicate :: CmpPredicate -> IntPredicate
uintFromCmpPredicate p =
case p of
CmpEQ -> IntEQ
CmpNE -> IntNE
CmpGT -> IntUGT
CmpGE -> IntUGE
CmpLT -> IntULT
CmpLE -> IntULE
sintFromCmpPredicate :: CmpPredicate -> IntPredicate
sintFromCmpPredicate p =
case p of
CmpEQ -> IntEQ
CmpNE -> IntNE
CmpGT -> IntSGT
CmpGE -> IntSGE
CmpLT -> IntSLT
CmpLE -> IntSLE
fpFromCmpPredicate :: CmpPredicate -> FPPredicate
fpFromCmpPredicate p =
case p of
CmpEQ -> FPOEQ
CmpNE -> FPONE
CmpGT -> FPOGT
CmpGE -> FPOGE
CmpLT -> FPOLT
CmpLE -> FPOLE
data IntPredicate =
IntEQ -- ^ equal
| IntNE -- ^ not equal
| IntUGT -- ^ unsigned greater than
| IntUGE -- ^ unsigned greater or equal
| IntULT -- ^ unsigned less than
| IntULE -- ^ unsigned less or equal
| IntSGT -- ^ signed greater than
| IntSGE -- ^ signed greater or equal
| IntSLT -- ^ signed less than
| IntSLE -- ^ signed less or equal
deriving (Eq, Ord, Enum, Show, Typeable)
fromIntPredicate :: IntPredicate -> CInt
fromIntPredicate p = fromIntegral (fromEnum p + 32)
toIntPredicate :: CInt -> IntPredicate
toIntPredicate p = toEnum $ fromIntegral p - 32
data FPPredicate =
FPFalse -- ^ Always false (always folded)
| FPOEQ -- ^ True if ordered and equal
| FPOGT -- ^ True if ordered and greater than
| FPOGE -- ^ True if ordered and greater than or equal
| FPOLT -- ^ True if ordered and less than
| FPOLE -- ^ True if ordered and less than or equal
| FPONE -- ^ True if ordered and operands are unequal
| FPORD -- ^ True if ordered (no nans)
| FPUNO -- ^ True if unordered: isnan(X) | isnan(Y)
| FPUEQ -- ^ True if unordered or equal
| FPUGT -- ^ True if unordered or greater than
| FPUGE -- ^ True if unordered, greater than, or equal
| FPULT -- ^ True if unordered or less than
| FPULE -- ^ True if unordered, less than, or equal
| FPUNE -- ^ True if unordered or not equal
| FPT -- ^ Always true (always folded)
deriving (Eq, Ord, Enum, Show, Typeable)
fromFPPredicate :: FPPredicate -> CInt
fromFPPredicate p = fromIntegral (fromEnum p)
toFPPredicate :: CInt -> FPPredicate
toFPPredicate p = toEnum $ fromIntegral p
type CmpValueResult a b = CmpValue a b (CmpResult (CmpType a b))
-- |Acceptable operands to comparison instructions.
class CmpRet (CmpType a b) => CmpOp a b where
type CmpType a b :: *
type CmpValue a b :: * -> *
cmpop ::
FFIConstBinOp -> FFIBinOp ->
a -> b -> CodeGenFunction r (CmpValueResult a b)
instance (CmpRet a) => CmpOp (Value a) (Value a) where
type CmpType (Value a) (Value a) = a
type CmpValue (Value a) (Value a) = Value
cmpop _ op (Value a1) (Value a2) = buildBinOp op a1 a2
instance (CmpRet a) => CmpOp (ConstValue a) (Value a) where
type CmpType (ConstValue a) (Value a) = a
type CmpValue (ConstValue a) (Value a) = Value
cmpop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2
instance (CmpRet a) => CmpOp (Value a) (ConstValue a) where
type CmpType (Value a) (ConstValue a) = a
type CmpValue (Value a) (ConstValue a) = Value
cmpop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2
instance (CmpRet a) => CmpOp (ConstValue a) (ConstValue a) where
type CmpType (ConstValue a) (ConstValue a) = a
type CmpValue (ConstValue a) (ConstValue a) = ConstValue
cmpop cop _ (ConstValue a1) (ConstValue a2) =
liftIO $ fmap ConstValue $ cop a1 a2
{-
instance (IsConst a, CmpRet a) => CmpOp a (Value a) where
type CmpType a (Value a) = a
cmpop op a1 a2 = cmpop op (valueOf a1) a2
instance (IsConst a, CmpRet a) => CmpOp (Value a) a where
type CmpType (Value a) a = a
cmpop op a1 a2 = cmpop op a1 (valueOf a2)
-}
class CmpRet c where
type CmpResult c :: *
cmpBld :: LP.Proxy c -> CmpPredicate -> FFIBinOp
cmpCnst :: LP.Proxy c -> CmpPredicate -> FFIConstBinOp
instance CmpRet Float where type CmpResult Float = Bool ; cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst
instance CmpRet Double where type CmpResult Double = Bool ; cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst
instance CmpRet FP128 where type CmpResult FP128 = Bool ; cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst
instance CmpRet Bool where type CmpResult Bool = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word8 where type CmpResult Word8 = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word16 where type CmpResult Word16 = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word32 where type CmpResult Word32 = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Word64 where type CmpResult Word64 = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance CmpRet Int8 where type CmpResult Int8 = Bool ; cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet Int16 where type CmpResult Int16 = Bool ; cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet Int32 where type CmpResult Int32 = Bool ; cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet Int64 where type CmpResult Int64 = Bool ; cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst
instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance (Dec.Positive n) => CmpRet (WordN n) where type CmpResult (WordN n) = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance (Dec.Positive n) => CmpRet (IntN n) where type CmpResult (IntN n) = Bool ; cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst
instance (CmpRet a, IsPrimitive a, Dec.Positive n) => CmpRet (Vector n a) where
type CmpResult (Vector n a) = (Vector n (CmpResult a))
cmpBld _ = cmpBld (LP.Proxy :: LP.Proxy a)
cmpCnst _ = cmpCnst (LP.Proxy :: LP.Proxy a)
{- |
Compare values of ordered types
and choose predicates according to the compared types.
Floating point numbers are compared in \"ordered\" mode,
that is @NaN@ operands yields 'False' as result.
Pointers are compared unsigned.
These choices are consistent with comparison in plain Haskell.
-}
cmp :: forall a b r.
(CmpOp a b) =>
CmpPredicate -> a -> b ->
CodeGenFunction r (CmpValueResult a b)
cmp p =
cmpop
(cmpCnst (LP.Proxy :: LP.Proxy (CmpType a b)) p)
(cmpBld (LP.Proxy :: LP.Proxy (CmpType a b)) p)
ucmpBld :: CmpPredicate -> FFIBinOp
ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))
scmpBld :: CmpPredicate -> FFIBinOp
scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))
fcmpBld :: CmpPredicate -> FFIBinOp
fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p))
ucmpCnst :: CmpPredicate -> FFIConstBinOp
ucmpCnst p = FFI.constICmp (fromIntPredicate (uintFromCmpPredicate p))
scmpCnst :: CmpPredicate -> FFIConstBinOp
scmpCnst p = FFI.constICmp (fromIntPredicate (sintFromCmpPredicate p))
fcmpCnst :: CmpPredicate -> FFIConstBinOp
fcmpCnst p = FFI.constFCmp (fromFPPredicate (fpFromCmpPredicate p))
_ucmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>
CmpPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)
_ucmp p = cmpop (ucmpCnst p) (ucmpBld p)
_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>
CmpPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)
_scmp p = cmpop (scmpCnst p) (scmpBld p)
pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) =>
IntPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)
pcmp p =
cmpop
(FFI.constICmp (fromIntPredicate p))
(flip FFI.buildICmp (fromIntPredicate p))
{-# DEPRECATED icmp "use cmp or pcmp instead" #-}
-- | Compare integers.
icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) =>
IntPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)
icmp p =
cmpop
(FFI.constICmp (fromIntPredicate p))
(flip FFI.buildICmp (fromIntPredicate p))
-- | Compare floating point values.
fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) =>
FPPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)
fcmp p =
cmpop
(FFI.constFCmp (fromFPPredicate p))
(flip FFI.buildFCmp (fromFPPredicate 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
--------------------------------------
-- XXX could do const song and dance
-- | Select between two values depending on a boolean.
select :: (IsFirstClass a, 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
{-
Function (a -> b -> IO c)
Value a -> Value b -> CodeGenFunction r c
-}
-- |Acceptable arguments to 'call'.
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 b b') => CallArgs (a -> b) (ConstValue a -> b') where
-- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (LP.Proxy :: LP.Proxy 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 a function with the given arguments. The 'call' instruction is variadic, i.e., the number of arguments
-- it takes depends on the type of /f/.
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) []
-- like Applicative.<*>
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 -- ^Normal return point.
-> BasicBlock -- ^Exception return point.
-> Function f -- ^Function to call.
-> Call f
invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) =
Call (U.makeInvoke norm expt f) []
-- | Call a function with exception handling.
invoke :: (CallArgs f g r)
=> BasicBlock -- ^Normal return point.
-> BasicBlock -- ^Exception return point.
-> Function f -- ^Function to call.
-> 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) []
-- | Call a function with the given arguments. The 'call' instruction
-- is variadic, i.e., the number of arguments it takes depends on the
-- type of /f/.
-- This also sets the calling convention of the call to the function.
-- As LLVM itself defines, if the calling conventions of the calling
-- /instruction/ and the function being /called/ are different, undefined
-- behavior results.
callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g
callWithConv cc f = doCall $ callWithConvFromFunction cc f
invokeWithConvFromFunction ::
FFI.CallingConvention -- ^Calling convention
-> BasicBlock -- ^Normal return point.
-> BasicBlock -- ^Exception return point.
-> Function f -- ^Function to call.
-> Call f
invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) =
Call (U.makeInvokeWithCc cc norm expt f) []
-- | Call a function with exception handling.
-- This also sets the calling convention of the call to the function.
-- As LLVM itself defines, if the calling conventions of the calling
-- /instruction/ and the function being /called/ are different, undefined
-- behavior results.
invokeWithConv :: (CallArgs f g r)
=> FFI.CallingConvention -- ^Calling convention
-> BasicBlock -- ^Normal return point.
-> BasicBlock -- ^Exception return point.
-> Function f -- ^Function to call.
-> g
invokeWithConv cc norm expt f =
doCall $ invokeWithConvFromFunction cc norm expt f
--------------------------------------
-- XXX could do const song and dance
-- |Join several variables (virtual registers) from different basic blocks into one.
-- All of the variables in the list are joined. See also 'addPhiInputs'.
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
-- |Add additional inputs to an existing phi node.
-- The reason for this instruction is that sometimes the structure of the code
-- makes it impossible to have all variables in scope at the point where you need the phi node.
addPhiInputs :: forall a r . (IsFirstClass a)
=> Value a -- ^Must be a variable from a call to 'phi'.
-> [(Value a, BasicBlock)] -- ^Variables to add.
-> CodeGenFunction r ()
addPhiInputs (Value inst) incoming =
liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]
--------------------------------------
-- | Acceptable argument to array memory allocation.
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
-- could be moved to Util.Memory
-- FFI.buildMalloc deprecated since LLVM-2.7
-- XXX What's the type returned by malloc
-- | Allocate heap memory.
malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))
malloc = arrayMalloc (1::Word32)
{-
I use a pointer type as size parameter of 'malloc'.
This way I hope that the parameter has always the correct size (32 or 64 bit).
A side effect is that we can convert the result of 'getelementptr' using 'bitcast',
that does not suffer from the slow assembly problem. (bug #8281)
-}
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 ())
{-
There is a bug in LLVM-2.7 and LLVM-2.8
(http://llvm.org/bugs/show_bug.cgi?id=8281)
that causes huge assembly times for expressions like
ptrtoint(getelementptr(zero,..)).
If you break those expressions into two statements
at separate lines, everything is fine.
But the C interface is too clever,
and rewrites two separate statements into a functional expression on a single line.
Such code is generated whenever you call
buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.
One possible way is to write a getelementptr expression
containing a nullptr in a way
that hides the constant nature of nullptr.
ptr <- alloca
store (value zero) ptr
z <- load ptr
size <- bitcast =<<
getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())
However, I found that bitcast on pointers causes no problems.
Thus I switched to using pointers for size quantities.
This still allows for optimizations involving pointers.
-}
-- XXX What's the type returned by arrayMalloc?
-- | Allocate heap (array) memory.
arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>
s -> CodeGenFunction r (Value (Ptr a)) -- XXX
arrayMalloc s = do
func <- staticNamedFunction "alignedMalloc" alignedMalloc
-- func <- externFunction "malloc"
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
-- XXX What's the type returned by malloc
-- | Allocate stack memory.
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
-- XXX What's the type returned by arrayAlloca?
-- | Allocate stack (array) memory.
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)
-- FFI.buildFree deprecated since LLVM-2.7
-- XXX What's the type of free?
-- | Free heap memory.
free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()
free ptr = do
func <- staticNamedFunction "alignedFree" alignedFree
-- func <- externFunction "free"
_ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr
return ()
-- | If we want to export that, then we should have a Size type
-- This is the official implementation,
-- but it suffers from the ptrtoint(gep) bug.
_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
-- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.
-- see ConstantExpr::getSizeOf
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, ())
-- see ConstantExpr::getAlignOf
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 a value from memory.
load :: Value (Ptr a) -- ^ Address to load from.
-> CodeGenFunction r (Value a)
load (Value p) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ FFI.buildLoad bldPtr p
-- | Store a value in memory
store :: Value a -- ^ Value to store.
-> Value (Ptr a) -- ^ Address to store to.
-> CodeGenFunction r ()
store (Value v) (Value p) = do
withCurrentBuilder_ $ \ bldPtr ->
FFI.buildStore bldPtr v p
return ()
{-
-- XXX type is wrong
-- | Address arithmetic. See LLVM description.
-- (The type isn't as accurate as it should be.)
getElementPtr :: (IsInteger i) =>
Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))
getElementPtr (Value ptr) ixs =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->
U.withEmptyCString $
FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)
-}
-- |Acceptable arguments to 'getElementPointer'.
class GetElementPtr optr ixs where
type ElementPtrType optr ixs :: *
getIxList :: LP.Proxy optr -> ixs -> [FFI.ValueRef]
-- |Acceptable single index to 'getElementPointer'.
class IsIndexArg a where
getArg :: a -> FFI.ValueRef
instance IsIndexArg (Value Word32) where
getArg (Value v) = v
instance IsIndexArg (Value Word64) where
getArg (Value v) = v
instance IsIndexArg (Value Int32) where
getArg (Value v) = v
instance IsIndexArg (Value Int64) where
getArg (Value v) = v
instance IsIndexArg (ConstValue Word32) where
getArg = unConst
instance IsIndexArg (ConstValue Word64) where
getArg = unConst
instance IsIndexArg (ConstValue Int32) where
getArg = unConst
instance IsIndexArg (ConstValue Int64) where
getArg = unConst
instance IsIndexArg Word32 where
getArg = unConst . constOf
instance IsIndexArg Word64 where
getArg = unConst . constOf
instance IsIndexArg Int32 where
getArg = unConst . constOf
instance IsIndexArg Int64 where
getArg = unConst . constOf
unConst :: ConstValue a -> FFI.ValueRef
unConst (ConstValue v) = v
-- End of indexing
instance GetElementPtr a () where
type ElementPtrType a () = a
getIxList _ () = []
-- Index in Array
instance (GetElementPtr o i, IsIndexArg a, Dec.Natural k) => GetElementPtr (Array k o) (a, i) where
type ElementPtrType (Array k o) (a, i) = ElementPtrType o i
getIxList _ (v, i) = getArg v : getIxList (LP.Proxy :: LP.Proxy o) i
-- Index in Vector
instance (GetElementPtr o i, IsIndexArg a, Dec.Positive k) => GetElementPtr (Vector k o) (a, i) where
type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i
getIxList _ (v, i) = getArg v : getIxList (LP.Proxy :: LP.Proxy o) i
-- Index in Struct and PackedStruct.
-- The index has to be a type level integer to statically determine the record field type
instance (GetElementPtr (FieldType fs a) i, Dec.Natural a) => GetElementPtr (Struct fs) (Proxy a, i) where
type ElementPtrType (Struct fs) (Proxy a, i) = ElementPtrType (FieldType fs a) i
getIxList _ (v, i) = unConst (constOf (Dec.integralFromProxy v :: Word32)) : getIxList (LP.Proxy :: LP.Proxy (FieldType fs a)) i
instance (GetElementPtr (FieldType fs a) i, Dec.Natural a) => GetElementPtr (PackedStruct fs) (Proxy a, i) where
type ElementPtrType (PackedStruct fs) (Proxy a, i) = ElementPtrType (FieldType fs a) i
getIxList _ (v, i) = unConst (constOf (Dec.integralFromProxy v :: Word32)) : getIxList (LP.Proxy :: LP.Proxy (FieldType fs a)) i
class GetField as i where type FieldType as i :: *
instance GetField (a, as) Dec.Zero where type FieldType (a, as) Dec.Zero = a
instance (GetField as (Pred (Dec.Pos i0 i1))) => GetField (a, as) (Dec.Pos i0 i1) where type FieldType (a,as) (Dec.Pos i0 i1) = FieldType as (Pred (Dec.Pos i0 i1))
-- | Address arithmetic. See LLVM description.
-- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.
-- (This is without a doubt the most confusing LLVM instruction, but the types help.)
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)
-- | Like getElementPtr, but with an initial index that is 0.
-- This is useful since any pointer first need to be indexed off the pointer, and then into
-- its actual value. This first indexing is often with 0.
getElementPtr0 :: (GetElementPtr o i) =>
Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))
getElementPtr0 p i = getElementPtr p (0::Word32, i)
--------------------------------------
{-
instance (IsConst a) => Show (ConstValue a) -- XXX
instance (IsConst a) => Eq (ConstValue a)
{-
instance (IsConst a) => Eq (ConstValue a) where
ConstValue x == ConstValue y =
if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOEQ) x y)
else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y)
ConstValue x /= ConstValue y =
if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPONE) x y)
else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y)
instance (IsConst a) => Ord (ConstValue a) where
ConstValue x < ConstValue y =
if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLT) x y)
else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y)
ConstValue x <= ConstValue y =
if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLE) x y)
else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y)
ConstValue x > ConstValue y =
if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGT) x y)
else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y)
ConstValue x >= ConstValue y =
if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGE) x y)
else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y)
-}
instance (Num a, IsConst a) => Num (ConstValue a) where
ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y)
ConstValue x - ConstValue y = ConstValue (FFI.constSub x y)
ConstValue x * ConstValue y = ConstValue (FFI.constMul x y)
negate (ConstValue x) = ConstValue (FFI.constNeg x)
fromInteger x = constOf (fromInteger x :: a)
-}