llvm-tf-3.0.1: 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,
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
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,
cmp, pcmp, icmp, fcmp,
select,
-- * Other
phi, addPhiInputs,
call, callWithConv,
callFromFunction, callWithConvFromFunction,
Call, applyCall, runCall,
-- * Classes and types
Terminate,
Ret, CallArgs, ABinOp, ABinOpResult, IsConst,
FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult,
AllocArg,
GetElementPtr, ElementPtrType, IsIndexArg,
GetValue, ValueType
) where
import Prelude hiding (and, or)
import Data.Typeable
import Control.Monad(liftM)
import Data.Int
import Data.Word
import Data.Map(fromList, (!))
import Foreign.Ptr (FunPtr, )
import Foreign.C(CInt, CUInt)
import Types.Data.Ord(LTT, GTT)
import Types.Data.Num(Dec, DecN, (:.), d1, fromIntegerT, Pred)
import qualified LLVM.FFI.Core as FFI
import LLVM.Core.Data
import LLVM.Core.Type
import LLVM.Core.CodeGenMonad
import LLVM.Core.CodeGen
import qualified LLVM.Core.Util as U
-- 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 -> 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
-- | 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 (undefined :: 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 (undefined :: 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) =
return $ 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
type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef
buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a)
buildUnOp op a =
liftM Value $
withCurrentBuilder $ \ bld ->
U.withEmptyCString $ op bld a
neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)
neg =
withArithmeticType $ \typ -> case typ of
IntegerType -> \(Value x) -> buildUnOp FFI.buildNeg x
FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a)
ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)
ineg (Value x) = buildUnOp FFI.buildNeg x
fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a)
fneg = fsub (value zero :: Value a)
{-
fneg (Value x) = buildUnOp FFI.buildFNeg x
-}
inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)
inv (Value x) = buildUnOp FFI.buildNot x
--------------------------------------
-- | Get a value from a vector.
extractelement :: (PositiveT 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 :: (PositiveT 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 :: (PositiveT n, PositiveT 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 :: agg -> ix -> CUInt
instance (GetField as i, NaturalT i) => GetValue (Struct as) i where
type ValueType (Struct as) i = FieldType as i
getIx _ n = fromIntegerT n
instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where
type ValueType (Array n a) Word32 = a
getIx _ n = fromIntegral n
instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where
type ValueType (Array n a) Word64 = a
getIx _ n = fromIntegral n
instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where
type ValueType (Array n a) (Dec i) = a
getIx _ n = fromIntegerT 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 (undefined::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 (undefined::agg) i)
--------------------------------------
-- XXX should allows constants
-- | Truncate a value to a shorter bit width.
trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))
=> Value a -> CodeGenFunction r (Value b)
trunc = convert FFI.buildTrunc
-- | Zero extend a value to a wider width.
-- If possible, use 'ext' that chooses the right padding according to the types
zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))
=> Value a -> CodeGenFunction r (Value b)
zext = convert FFI.buildZExt
-- | Sign extend a value to wider width.
-- If possible, use 'ext' that chooses the right padding according to the types
sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))
=> Value a -> CodeGenFunction r (Value b)
sext = convert 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 a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))
=> Value a -> CodeGenFunction r (Value b)
ext =
if isSigned (undefined :: b)
then convert FFI.buildSExt
else convert FFI.buildZExt
-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.
zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b)
=> Value a -> CodeGenFunction r (Value b)
zadapt =
case compare (sizeOf (typeDesc (undefined :: a)))
(sizeOf (typeDesc (undefined :: b))) of
LT -> convert FFI.buildZExt
EQ -> convert FFI.buildBitCast
GT -> convert FFI.buildTrunc
-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.
sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b)
=> Value a -> CodeGenFunction r (Value b)
sadapt =
case compare (sizeOf (typeDesc (undefined :: a)))
(sizeOf (typeDesc (undefined :: b))) of
LT -> convert FFI.buildSExt
EQ -> convert FFI.buildBitCast
GT -> convert FFI.buildTrunc
-- | It is 'sadapt' or 'zadapt' depending on the sign mode.
adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b)
=> Value a -> CodeGenFunction r (Value b)
adapt =
case compare (sizeOf (typeDesc (undefined :: a)))
(sizeOf (typeDesc (undefined :: b))) of
LT ->
if isSigned (undefined :: b)
then convert FFI.buildSExt
else convert FFI.buildZExt
EQ -> convert FFI.buildBitCast
GT -> convert FFI.buildTrunc
-- | Truncate a floating point value.
fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))
=> Value a -> CodeGenFunction r (Value b)
fptrunc = convert FFI.buildFPTrunc
-- | Extend a floating point value.
fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))
=> Value a -> CodeGenFunction r (Value b)
fpext = convert 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 :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)
fptoui = convert 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 :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)
fptosi = convert FFI.buildFPToSI
-- | Convert a floating point value to an integer.
-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.
fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)
fptoint =
if isSigned (undefined :: b)
then convert FFI.buildFPToSI
else convert 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 :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)
uitofp = convert 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 :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)
sitofp = convert FFI.buildSIToFP
-- | Convert an integer to a floating point value.
-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.
inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)
inttofp =
if isSigned (undefined :: a)
then convert FFI.buildSIToFP
else convert FFI.buildUIToFP
-- | Convert a pointer to an integer.
ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b)
ptrtoint = convert FFI.buildPtrToInt
-- | Convert an integer to a pointer.
inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b))
inttoptr = convert FFI.buildIntToPtr
-- | Convert between to values of the same size by just copying the bit pattern.
bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)
=> Value a -> CodeGenFunction r (Value b)
bitcast = convert FFI.buildBitCast
-- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same.
bitcastElements :: (PositiveT 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.buildBitCast
type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef
convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b)
convert conv (Value a) =
liftM Value $
withCurrentBuilder $ \ bldPtr ->
U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b))
--------------------------------------
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
-- |Acceptable operands to comparison instructions.
class CmpRet (CmpType a b) => CmpOp a b where
type CmpType a b :: *
cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (CmpType a b)))
instance (CmpRet a) => CmpOp (Value a) (Value a) where
type CmpType (Value a) (Value a) = a
cmpop op (Value a1) (Value a2) = buildBinOp op 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 :: c -> CmpPredicate -> FFIBinOp
instance CmpRet Float where type CmpResult Float = Bool ; cmpBld _ = fcmpBld
instance CmpRet Double where type CmpResult Double = Bool ; cmpBld _ = fcmpBld
instance CmpRet FP128 where type CmpResult FP128 = Bool ; cmpBld _ = fcmpBld
instance CmpRet Bool where type CmpResult Bool = Bool ; cmpBld _ = ucmpBld
instance CmpRet Word8 where type CmpResult Word8 = Bool ; cmpBld _ = ucmpBld
instance CmpRet Word16 where type CmpResult Word16 = Bool ; cmpBld _ = ucmpBld
instance CmpRet Word32 where type CmpResult Word32 = Bool ; cmpBld _ = ucmpBld
instance CmpRet Word64 where type CmpResult Word64 = Bool ; cmpBld _ = ucmpBld
instance CmpRet Int8 where type CmpResult Int8 = Bool ; cmpBld _ = scmpBld
instance CmpRet Int16 where type CmpResult Int16 = Bool ; cmpBld _ = scmpBld
instance CmpRet Int32 where type CmpResult Int32 = Bool ; cmpBld _ = scmpBld
instance CmpRet Int64 where type CmpResult Int64 = Bool ; cmpBld _ = scmpBld
instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld
instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a)
where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; cmpBld _ = cmpBld (undefined :: 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 c r.
(CmpOp a b, c ~ CmpType a b) =>
CmpPredicate -> a -> b ->
CodeGenFunction r (Value (CmpResult c))
cmp p = cmpop (cmpBld (undefined :: 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))
_ucmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>
CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))
_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)))
_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>
CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))
_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)))
pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) =>
IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c)))
pcmp p = cmpop (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 (Value (CmpResult c))
icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))
-- | Compare floating point values.
fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) =>
FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))
fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p))
--------------------------------------
-- 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 (undefined :: 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 (undefined :: 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 <- staticFunction alignedMalloc
-- func <- externFunction "malloc"
size <- sizeOfArray (undefined :: a) (getAllocArg s)
alignment <- alignOf (undefined :: 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 ->
U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a))
-- 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 ->
U.withEmptyCString $
FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (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 <- staticFunction 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) => a -> CodeGenFunction r (Value Word64)
_sizeOf a =
liftIO $ liftM Value $
FFI.sizeOf (typeRef a)
_alignOf :: forall a r . (IsSized a) => 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) => 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) => 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 :: 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, NaturalT k) => GetElementPtr (Array k o) (a, i) where
type ElementPtrType (Array k o) (a, i) = ElementPtrType o i
getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i
-- Index in Vector
instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where
type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i
getIxList _ (v, i) = getArg v : getIxList (undefined :: 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, NaturalT a) => GetElementPtr (Struct fs) (a, i) where
type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i
getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i
instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where
type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i
getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i
class GetField as i where type FieldType as i :: *
instance GetField (a, as) (Dec DecN) where type FieldType (a, as) (Dec DecN) = a
instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0)))
-- | 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 (undefined :: 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)
-}