llvm-tf 3.9 → 9.0
raw patch · 20 files changed
+1374/−683 lines, 20 filesdep +QuickCheckdep ~llvm-ffi
Dependencies added: QuickCheck
Dependency ranges changed: llvm-ffi
Files
- Changes.md +11/−0
- example/BrainF.hs +1/−2
- llvm-tf.cabal +9/−5
- src/LLVM/Core.hs +3/−1
- src/LLVM/Core/Attribute.hs +300/−0
- src/LLVM/Core/CodeGen.hs +18/−5
- src/LLVM/Core/CodeGenMonad.hs +2/−2
- src/LLVM/Core/Data.hs +20/−2
- src/LLVM/Core/Guided.hs +5/−0
- src/LLVM/Core/Instructions.hs +205/−386
- src/LLVM/Core/Instructions/Guided.hs +356/−0
- src/LLVM/Core/Instructions/Private.hs +295/−36
- src/LLVM/Core/Instructions/TypeAssisted.hs +0/−186
- src/LLVM/Core/Type.hs +27/−4
- src/LLVM/Core/Util.hs +18/−6
- src/LLVM/Core/Vector.hs +21/−1
- src/LLVM/Util/Arithmetic.hs +7/−45
- src/LLVM/Util/Intrinsic.hs +71/−0
- src/LLVM/Util/Loop.hs +2/−2
- src/LLVM/Util/Proxy.hs +3/−0
Changes.md view
@@ -1,5 +1,16 @@ # Change log for the `llvm-tf` package +## 9.0++* `Instructions.bitcastElements`:+ Use `Guided.bitcast Guided.vector` instead.++* `Core.Guided`: new module for instructions on both scalars and vectors++* fixed bug: `cmp` on `IntN` did an unsigned comparison++* `Vector`: instance `QuickCheck.Arbitrary`+ ## 3.1.2 * `Instructions`: setters for FastMath flags
example/BrainF.hs view
@@ -79,8 +79,7 @@ -- the current basic block. -- A loop context is a triple of the phi node, the loop top label, -- and the loop exit label.- let generate [] [] _ =- return ()+ let generate [] [] _ = return () generate [] (_:_) _ = error "Missing ]" generate (']':_) [] _ = error "Missing [" generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do
llvm-tf.cabal view
@@ -1,5 +1,5 @@ Name: llvm-tf-Version: 3.9+Version: 9.0 License: BSD3 License-File: LICENSE Synopsis: Bindings to the LLVM compiler toolkit using type families.@@ -25,7 +25,7 @@ Maintainer: Henning Thielemann <llvm@henning-thielemann.de> Stability: experimental Category: Compilers/Interpreters, Code Generation-Tested-With: GHC == 7.4.2+Tested-With: GHC == 7.4.2, GHC == 8.6.5 Cabal-Version: 1.14 Build-Type: Simple @@ -39,7 +39,7 @@ Location: http://code.haskell.org/~thielema/llvm-tf/ Source-Repository this- Tag: 3.9+ Tag: 9.0 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -55,7 +55,7 @@ Library Default-Language: Haskell98 Build-Depends:- llvm-ffi >=3.9 && <4.0,+ llvm-ffi >=9.0 && <9.1, tfp >=1.0 && <1.1, transformers >=0.3 && <0.6, storable-record >=0.0.2 && <0.1,@@ -64,6 +64,7 @@ non-empty >=0.2 && <0.4, semigroups >=0.1 && <1.0, utility-ht >=0.0.10 && <0.1,+ QuickCheck >=2.0 && <3.0, containers >=0.4 && <0.7, base >=3 && <5 @@ -84,10 +85,13 @@ Exposed-Modules: LLVM.Core+ LLVM.Core.Attribute+ LLVM.Core.Guided LLVM.ExecutionEngine LLVM.Util.Arithmetic LLVM.Util.File LLVM.Util.Foreign+ LLVM.Util.Intrinsic LLVM.Util.Loop LLVM.Util.Memory LLVM.Util.Optimize@@ -98,7 +102,7 @@ LLVM.Core.CodeGenMonad LLVM.Core.Data LLVM.Core.Instructions- LLVM.Core.Instructions.TypeAssisted+ LLVM.Core.Instructions.Guided LLVM.Core.Instructions.Private LLVM.Core.Type LLVM.Core.Util
src/LLVM/Core.hs view
@@ -70,7 +70,9 @@ fromLabel, toLabel, getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, -- * Misc- addAttributes, Attribute(..),+ addAttributes, Attribute,+ FFI.AttributeIndex(..),+ FFI.attributeReturnIndex, FFI.attributeFunctionIndex, castVarArgs, -- * Debugging dumpValue, dumpType, getValueName, annotateValueList
+ src/LLVM/Core/Attribute.hs view
@@ -0,0 +1,300 @@+module LLVM.Core.Attribute (+ zeroext,+ signext,+ inreg,+ byval,+ sret,+ align,+ noalias,+ nocapture,+ nest,+ returned,+ nonnull,+ dereferenceable,+ dereferenceableOrNull,+ swiftself,+ swifterror,+ immarg,+ alignstack,+ allocsize,+ alwaysinline,+ builtin,+ cold,+ convergent,+ inaccessiblememonly,+ inaccessiblememOrArgmemonly,+ inlinehint,+ jumptable,+ minsize,+ naked,+ noJumpTables,+ nobuiltin,+ noduplicate,+ nofree,+ noimplicitfloat,+ noinline,+ nonlazybind,+ noredzone,+ indirectTlsSegRefs,+ noreturn,+ norecurse,+ willreturn,+ nosync,+ nounwind,+ nullPointerIsValid,+ optforfuzzing,+ optnone,+ optsize,+ patchableFunction,+ probeStack,+ readnone,+ readonly,+ stackProbeSize,+ noStackArgProbe,+ writeonly,+ argmemonly,+ returnsTwice,+ safestack,+ sanitizeAddress,+ sanitizeMemory,+ sanitizeThread,+ sanitizeHwaddress,+ sanitizeMemtag,+ speculativeLoadHardening,+ speculatable,+ ssp,+ sspreq,+ sspstrong,+ strictfp,+ uwtable,+ nocfCheck,+ shadowcallstack,+ ) where++import LLVM.Core.CodeGen (Attribute(Attribute))++import qualified LLVM.FFI.Core.Attribute as Attr++import Data.Word (Word64)+++simple :: Attr.Name -> Attribute+simple name = Attribute name 0++withParam :: Attr.Name -> Word64 -> Attribute+withParam = Attribute++-- * Parameter attributes++zeroext :: Attribute+zeroext = simple Attr.zeroext++signext :: Attribute+signext = simple Attr.signext++inreg :: Attribute+inreg = simple Attr.inreg++byval :: Attribute+byval = simple Attr.byval++sret :: Attribute+sret = simple Attr.sret++align :: Word64 -> Attribute+align = withParam Attr.align++noalias :: Attribute+noalias = simple Attr.noalias++nocapture :: Attribute+nocapture = simple Attr.nocapture++nest :: Attribute+nest = simple Attr.nest++returned :: Attribute+returned = simple Attr.returned++nonnull :: Attribute+nonnull = simple Attr.nonnull++dereferenceable :: Word64 -> Attribute+dereferenceable = withParam Attr.dereferenceable++dereferenceableOrNull :: Word64 -> Attribute+dereferenceableOrNull = withParam Attr.dereferenceableOrNull++swiftself :: Attribute+swiftself = simple Attr.swiftself++swifterror :: Attribute+swifterror = simple Attr.swifterror++immarg :: Attribute+immarg = simple Attr.immarg+++-- * Function attributes++alignstack :: Word64 -> Attribute+alignstack = withParam Attr.alignstack++allocsize :: Attribute+allocsize = simple Attr.allocsize++alwaysinline :: Attribute+alwaysinline = simple Attr.alwaysinline++builtin :: Attribute+builtin = simple Attr.builtin++cold :: Attribute+cold = simple Attr.cold++convergent :: Attribute+convergent = simple Attr.convergent++inaccessiblememonly :: Attribute+inaccessiblememonly = simple Attr.inaccessiblememonly++inaccessiblememOrArgmemonly :: Attribute+inaccessiblememOrArgmemonly = simple Attr.inaccessiblememOrArgmemonly++inlinehint :: Attribute+inlinehint = simple Attr.inlinehint++jumptable :: Attribute+jumptable = simple Attr.jumptable++minsize :: Attribute+minsize = simple Attr.minsize++naked :: Attribute+naked = simple Attr.naked++noJumpTables :: Attribute+noJumpTables = simple Attr.noJumpTables++nobuiltin :: Attribute+nobuiltin = simple Attr.nobuiltin++noduplicate :: Attribute+noduplicate = simple Attr.noduplicate++nofree :: Attribute+nofree = simple Attr.nofree++noimplicitfloat :: Attribute+noimplicitfloat = simple Attr.noimplicitfloat++noinline :: Attribute+noinline = simple Attr.noinline++nonlazybind :: Attribute+nonlazybind = simple Attr.nonlazybind++noredzone :: Attribute+noredzone = simple Attr.noredzone++indirectTlsSegRefs :: Attribute+indirectTlsSegRefs = simple Attr.indirectTlsSegRefs++noreturn :: Attribute+noreturn = simple Attr.noreturn++norecurse :: Attribute+norecurse = simple Attr.norecurse++willreturn :: Attribute+willreturn = simple Attr.willreturn++nosync :: Attribute+nosync = simple Attr.nosync++nounwind :: Attribute+nounwind = simple Attr.nounwind++nullPointerIsValid :: Attribute+nullPointerIsValid = simple Attr.nullPointerIsValid++optforfuzzing :: Attribute+optforfuzzing = simple Attr.optforfuzzing++optnone :: Attribute+optnone = simple Attr.optnone++optsize :: Attribute+optsize = simple Attr.optsize++patchableFunction :: Attribute+patchableFunction = simple Attr.patchableFunction++probeStack :: Attribute+probeStack = simple Attr.probeStack++readnone :: Attribute+readnone = simple Attr.readnone++readonly :: Attribute+readonly = simple Attr.readonly++stackProbeSize :: Attribute+stackProbeSize = simple Attr.stackProbeSize++noStackArgProbe :: Attribute+noStackArgProbe = simple Attr.noStackArgProbe++writeonly :: Attribute+writeonly = simple Attr.writeonly++argmemonly :: Attribute+argmemonly = simple Attr.argmemonly++returnsTwice :: Attribute+returnsTwice = simple Attr.returnsTwice++safestack :: Attribute+safestack = simple Attr.safestack++sanitizeAddress :: Attribute+sanitizeAddress = simple Attr.sanitizeAddress++sanitizeMemory :: Attribute+sanitizeMemory = simple Attr.sanitizeMemory++sanitizeThread :: Attribute+sanitizeThread = simple Attr.sanitizeThread++sanitizeHwaddress :: Attribute+sanitizeHwaddress = simple Attr.sanitizeHwaddress++sanitizeMemtag :: Attribute+sanitizeMemtag = simple Attr.sanitizeMemtag++speculativeLoadHardening :: Attribute+speculativeLoadHardening = simple Attr.speculativeLoadHardening++speculatable :: Attribute+speculatable = simple Attr.speculatable++ssp :: Attribute+ssp = simple Attr.ssp++sspreq :: Attribute+sspreq = simple Attr.sspreq++sspstrong :: Attribute+sspstrong = simple Attr.sspstrong++strictfp :: Attribute+strictfp = simple Attr.strictfp++uwtable :: Attribute+uwtable = simple Attr.uwtable++nocfCheck :: Attribute+nocfCheck = simple Attr.nocfCheck++shadowcallstack :: Attribute+shadowcallstack = simple Attr.shadowcallstack
src/LLVM/Core/CodeGen.hs view
@@ -14,7 +14,7 @@ -- * Function creation Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, addAttributes,- FFI.Attribute(..),+ FFI.AttributeIndex(..), Attribute(..), externFunction, staticFunction, staticNamedFunction, FunctionArgs, FunctionCodeGen, FunctionResult, TFunction,@@ -43,6 +43,7 @@ import LLVM.Core.Type import LLVM.Core.Data +import qualified LLVM.FFI.Core.Attribute as Attr import qualified LLVM.FFI.Core as FFI import LLVM.FFI.Core(Linkage(..), Visibility(..)) @@ -51,7 +52,7 @@ import Type.Base.Proxy (Proxy) import qualified Foreign.Storable as St-import Foreign.C.String (withCString)+import Foreign.C.String (withCString, withCStringLen) import Foreign.StablePtr (StablePtr, castStablePtrToPtr) import Foreign.Ptr (Ptr, minusPtr, nullPtr, FunPtr, castFunPtrToPtr) import System.IO.Unsafe (unsafePerformIO)@@ -64,6 +65,7 @@ import Data.Typeable (Typeable) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64)+import Data.Tuple.HT (mapSnd) import Data.Maybe.HT (toMaybe) import Data.Maybe (fromMaybe) @@ -321,11 +323,22 @@ setFuncCallConv (Value f) cc = do liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc) +data Attribute = Attribute Attr.Name Word64+ -- | Add attributes to a value. Beware, what attributes are allowed depends on -- what kind of value it is.-addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r ()-addAttributes (Value f) i as = do- liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as)+addAttributes ::+ Value a -> FFI.AttributeIndex -> [Attribute] -> CodeGenFunction r ()+addAttributes (Value f) i as =+ liftIO $ do+ context <- FFI.getGlobalContext+ Fold.forM_ as $ \(Attribute (Attr.Name name) val) -> do+ attrKind <-+ withCStringLen name $+ uncurry FFI.getEnumAttributeKindForName .+ mapSnd fromIntegral+ attr <- FFI.createEnumAttribute context attrKind val+ FFI.addCallSiteAttribute f i attr -- Convert a function of type f = t1->t2->...-> IO r to -- g = Value t1 -> Value t2 -> ... CodeGenFunction r ()
src/LLVM/Core/CodeGenMonad.hs view
@@ -98,8 +98,8 @@ addGlobalMapping :: Value -> Ptr a -> CodeGenModule ()-addGlobalMapping value func =- CGM $ addMappingToState $+addGlobalMapping value func = CGM $ do+ addMappingToState $ GlobalMappings (\ee -> EE.addGlobalMapping ee value func) addFunctionMapping ::
src/LLVM/Core/Data.hs view
@@ -12,8 +12,10 @@ import qualified Type.Data.Num.Decimal.Proof as DecProof import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy)) import qualified Data.Foldable as Fold+import qualified Data.Bits as Bits import Data.Typeable (Typeable) @@ -26,12 +28,28 @@ -- |Variable sized signed integer. -- The /n/ parameter should belong to @PosI@. newtype IntN n = IntN Integer- deriving (Show, Typeable)+ deriving (Show, Eq, Ord, Typeable) +instance (Dec.Positive n) => Bounded (IntN n) where+ minBound =+ withBitSize $+ IntN . negate . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy+ maxBound =+ withBitSize $+ IntN . subtract 1 . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy+ -- |Variable sized unsigned integer. -- The /n/ parameter should belong to @PosI@. newtype WordN n = WordN Integer- deriving (Show, Typeable)+ deriving (Show, Eq, Ord, Typeable)++instance (Dec.Positive n) => Bounded (WordN n) where+ minBound = WordN 0+ maxBound =+ withBitSize $ WordN . subtract 1 . Bits.shiftL 1 . Dec.integralFromProxy++withBitSize :: (Proxy n -> f n) -> f n+withBitSize f = f Proxy -- |128 bit floating point. newtype FP128 = FP128 Rational
+ src/LLVM/Core/Guided.hs view
@@ -0,0 +1,5 @@+module LLVM.Core.Guided (+ module LLVM.Core.Instructions.Guided,+ ) where++import LLVM.Core.Instructions.Guided
src/LLVM/Core/Instructions.hs view
@@ -1,11 +1,9 @@ {-# 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@@ -20,7 +18,7 @@ unreachable, -- * Arithmetic binary operations -- | Arithmetic operations with the normal semantics.- -- The u instractions are unsigned, the s instructions are signed.+ -- The u instructions are unsigned, the s instructions are signed. add, sub, mul, neg, iadd, isub, imul, ineg, iaddNoWrap, isubNoWrap, imulNoWrap, inegNoWrap,@@ -29,7 +27,7 @@ udiv, sdiv, fdiv, urem, srem, frem, -- * Logical binary operations -- |Logical instructions with the normal semantics.- shl, lshr, ashr, and, or, xor, inv,+ shl, shr, lshr, ashr, and, or, xor, inv, -- * Vector operations extractelement, insertelement,@@ -52,10 +50,9 @@ uitofp, sitofp, inttofp, ptrtoint, inttoptr, bitcast,- bitcastElements, -- * Comparison CmpPredicate(..), IntPredicate(..), FPPredicate(..),- CmpOp, CmpRet, CmpResult, CmpValueResult,+ CmpRet, CmpResult, CmpValueResult, cmp, pcmp, icmp, fcmp, select, -- * Fast math@@ -71,37 +68,48 @@ Call, applyCall, runCall, -- * Classes and types- Terminate,- Ret, CallArgs, ABinOp, ABinOpResult, IsConst,- FunctionArgs, FunctionCodeGen, FunctionResult,+ ValueCons2, BinOpValue,+ Terminate, Ret, CallArgs, CodeGen.IsConst,+ CodeGen.FunctionArgs, CodeGen.FunctionCodeGen, CodeGen.FunctionResult, AllocArg,- GetElementPtr, ElementPtrType, IsIndexArg,+ GetElementPtr, ElementPtrType, IsIndexArg, IsIndexType, 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 qualified LLVM.Core.CodeGen as CodeGen+import LLVM.Core.Instructions.Private+ (ValueCons, unValue, convert, unop,+ FFIBinOp, FFIConstBinOp,+ GetField, FieldType, GetElementPtr, ElementPtrType,+ IsIndexArg, IsIndexType, getIxList, getArg,+ CmpPredicate(..), IntPredicate(..), FPPredicate(..),+ fromIntPredicate, fromFPPredicate,+ toIntPredicate, toFPPredicate,+ uintFromCmpPredicate, sintFromCmpPredicate, fpFromCmpPredicate) import LLVM.Core.Data import LLVM.Core.Type import LLVM.Core.CodeGenMonad import LLVM.Core.CodeGen+ (BasicBlock(BasicBlock), Function, withCurrentBuilder,+ ConstValue(ConstValue), zero,+ Value(Value), value, valueOf) import qualified LLVM.FFI.Core as FFI import qualified Type.Data.Num.Decimal.Number as Dec import Type.Data.Num.Decimal.Literal (d1)-import Type.Data.Num.Decimal.Number (Pred, (:<:), (:>:))+import Type.Data.Num.Decimal.Number ((:<:), (:>:)) import Type.Base.Proxy (Proxy) import Foreign.Ptr (Ptr, FunPtr, )-import Foreign.C (CInt, CUInt)+import Foreign.C (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, (!))@@ -322,151 +330,143 @@ -------------------------------------- -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)+class (ValueCons value0, ValueCons value1) => ValueCons2 value0 value1 where+ type BinOpValue (value0 :: * -> *) (value1 :: * -> *) :: * -> *+ binop ::+ FFIConstBinOp -> FFIBinOp ->+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)++instance ValueCons2 Value Value where+ type BinOpValue Value Value = Value+ binop _ op (Value a1) (Value a2) = buildBinOp op a1 a2++instance ValueCons2 Value ConstValue where+ type BinOpValue Value ConstValue = Value+ binop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2++instance ValueCons2 ConstValue Value where+ type BinOpValue ConstValue Value = Value+ binop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2++instance ValueCons2 ConstValue ConstValue where+ type BinOpValue ConstValue ConstValue = ConstValue+ binop cop _ (ConstValue a1) (ConstValue a2) =+ liftIO $ fmap ConstValue $ cop a1 a2+++add, sub, mul ::+ (ValueCons2 value0 value1, IsArithmetic a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a) add = curry $ withArithmeticType $ \typ -> uncurry $ case typ of- IntegerType -> abinop FFI.constAdd FFI.buildAdd- FloatingType -> abinop FFI.constFAdd FFI.buildFAdd+ IntegerType -> binop FFI.constAdd FFI.buildAdd+ FloatingType -> binop 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+ IntegerType -> binop FFI.constSub FFI.buildSub+ FloatingType -> binop 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+ IntegerType -> binop FFI.constMul FFI.buildMul+ FloatingType -> binop 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+iadd, isub, imul ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+iadd = binop FFI.constAdd FFI.buildAdd+isub = binop FFI.constSub FFI.buildSub+imul = binop FFI.constMul FFI.buildMul -iaddNoWrap :: forall v a b c r. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+iaddNoWrap, isubNoWrap, imulNoWrap ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a) 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)+ sbinop FFI.constNSWAdd FFI.buildNSWAdd FFI.constNUWAdd FFI.buildNUWAdd 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)+ sbinop FFI.constNSWSub FFI.buildNSWSub FFI.constNUWSub FFI.buildNUWSub imulNoWrap =- if isSigned (LP.Proxy :: LP.Proxy c)- then abinop FFI.constNSWMul FFI.buildNSWMul- else abinop FFI.constNUWMul FFI.buildNUWMul+ sbinop FFI.constNSWMul FFI.buildNSWMul 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+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+idiv = sbinop FFI.constSDiv FFI.buildSDiv FFI.constUDiv FFI.buildUDiv -- | 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+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+irem = sbinop FFI.constSRem FFI.buildSRem FFI.constURem FFI.buildURem {-# 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+udiv, sdiv, urem, srem ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+udiv = binop FFI.constUDiv FFI.buildUDiv+sdiv = binop FFI.constSDiv FFI.buildSDiv+urem = binop FFI.constURem FFI.buildURem+srem = binop FFI.constSRem FFI.buildSRem -fadd :: (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+fadd, fsub, fmul ::+ (ValueCons2 value0 value1, IsFloating a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+fadd = binop FFI.constFAdd FFI.buildFAdd+fsub = binop FFI.constFSub FFI.buildFSub+fmul = binop FFI.constFMul FFI.buildFMul -- | 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+fdiv ::+ (ValueCons2 value0 value1, IsFloating a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+fdiv = binop 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+frem ::+ (ValueCons2 value0 value1, IsFloating a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+frem = binop FFI.constFRem FFI.buildFRem -{--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)+shl, lshr, ashr, and, or, xor ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+shl = binop FFI.constShl FFI.buildShl+lshr = binop FFI.constLShr FFI.buildLShr+ashr = binop FFI.constAShr FFI.buildAShr+and = binop FFI.constAnd FFI.buildAnd+or = binop FFI.constOr FFI.buildOr+xor = binop FFI.constXor FFI.buildXor -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--}+shr ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+shr = sbinop FFI.constAShr FFI.buildAShr FFI.constLShr FFI.buildLShr ---instance (IsConst a) => ABinOp a a (ConstValue a) where--- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2)+sbinop ::+ forall value0 value1 a b r.+ (ValueCons2 value0 value1, IsInteger a) =>+ FFIConstBinOp -> FFIBinOp ->+ FFIConstBinOp -> FFIBinOp ->+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)+sbinop scop sop ucop uop =+ if isSigned (LP.Proxy :: LP.Proxy a)+ then binop scop sop+ else binop ucop uop -buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)+buildBinOp ::+ FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a) buildBinOp op a1 a2 = liftM Value $ withCurrentBuilder $ \ bld ->@@ -477,13 +477,13 @@ value a -> CodeGenFunction r (value a) neg = withArithmeticType $ \typ -> case typ of- IntegerType -> aunop FFI.constNeg FFI.buildNeg- FloatingType -> aunop FFI.constFNeg FFI.buildFNeg+ IntegerType -> unop FFI.constNeg FFI.buildNeg+ FloatingType -> unop FFI.constFNeg FFI.buildFNeg ineg :: (ValueCons value, IsInteger a) => value a -> CodeGenFunction r (value a)-ineg = aunop FFI.constNeg FFI.buildNeg+ineg = unop FFI.constNeg FFI.buildNeg inegNoWrap :: forall value a r.@@ -491,26 +491,23 @@ 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+ then unop FFI.constNSWNeg FFI.buildNSWNeg+ else unop 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+fneg = unop FFI.constFNeg FFI.buildFNeg inv :: (ValueCons value, IsInteger a) => value a -> CodeGenFunction r (value a)-inv = aunop FFI.constNot FFI.buildNot+inv = unop FFI.constNot FFI.buildNot -------------------------------------- -- | Get a value from a vector.-extractelement :: (Dec.Positive n)+extractelement :: (Dec.Positive n, IsPrimitive a) => Value (Vector n a) -- ^ Vector -> Value Word32 -- ^ Index into the vector -> CodeGenFunction r (Value a)@@ -520,7 +517,7 @@ U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i -- | Insert a value into a vector, nondestructive.-insertelement :: (Dec.Positive n)+insertelement :: (Dec.Positive n, IsPrimitive a) => Value (Vector n a) -- ^ Vector -> Value a -- ^ Value to insert -> Value Word32 -- ^ Index into the vector@@ -531,7 +528,7 @@ U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i -- | Permute vector.-shufflevector :: (Dec.Positive n, Dec.Positive m)+shufflevector :: (Dec.Positive n, Dec.Positive m, IsPrimitive a) => Value (Vector n a) -> Value (Vector n a) -> ConstValue (Vector m Word32)@@ -620,7 +617,6 @@ 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)@@ -717,163 +713,38 @@ => 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+type CmpValueResult value0 value1 a = BinOpValue value0 value1 (CmpResult a) -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)--}+type CmpResult c = ShapedType (ShapeOf c) Bool -class CmpRet c where- type CmpResult c :: *+class (IsFirstClass c) => CmpRet c where 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 CmpRet Float where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst+instance CmpRet Double where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst+instance CmpRet FP128 where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst+instance CmpRet Bool where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word8 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word16 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word32 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word64 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Int8 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int16 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int32 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int64 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance (IsType a) =>+ CmpRet (Ptr a) where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst -instance (Dec.Positive n) => CmpRet (WordN n) where 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 (Dec.Positive n) => CmpRet (WordN n) where+ cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance (Dec.Positive n) => CmpRet (IntN n) where+ cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst instance (CmpRet a, IsPrimitive a, Dec.Positive n) => CmpRet (Vector n a) where- type CmpResult (Vector n a) = (Vector n (CmpResult a)) cmpBld _ = cmpBld (LP.Proxy :: LP.Proxy a) cmpCnst _ = cmpCnst (LP.Proxy :: LP.Proxy a) @@ -886,14 +757,14 @@ 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 :: forall value0 value1 a r.+ (ValueCons2 value0 value1, CmpRet a) =>+ CmpPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a) cmp p =- cmpop- (cmpCnst (LP.Proxy :: LP.Proxy (CmpType a b)) p)- (cmpBld (LP.Proxy :: LP.Proxy (CmpType a b)) p)+ binop+ (cmpCnst (LP.Proxy :: LP.Proxy a) p)+ (cmpBld (LP.Proxy :: LP.Proxy a) p) ucmpBld :: CmpPredicate -> FFIBinOp ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))@@ -915,36 +786,46 @@ 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)+_ucmp ::+ (ValueCons2 value0 value1, CmpRet a, IsInteger a) =>+ CmpPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+_ucmp p = binop (ucmpCnst p) (ucmpBld p) -_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>- CmpPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)-_scmp p = cmpop (scmpCnst p) (scmpBld p)+_scmp ::+ (ValueCons2 value0 value1, CmpRet a, IsInteger a) =>+ CmpPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+_scmp p = binop (scmpCnst p) (scmpBld p) -pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) =>- IntPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)+pcmp ::+ (ValueCons2 value0 value1, IsType a) =>+ IntPredicate -> value0 (Ptr a) -> value1 (Ptr a) ->+ CodeGenFunction r (BinOpValue value0 value1 (Ptr a)) pcmp p =- cmpop+ binop (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 ::+ (ValueCons2 value0 value1, CmpRet a, IsIntegerOrPointer a) =>+ IntPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a) icmp p =- cmpop+ binop (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 ::+ (ValueCons2 value0 value1, CmpRet a, IsFloating a) =>+ FPPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a) fcmp p =- cmpop+ binop (FFI.constFCmp (fromFPPredicate p)) (flip FFI.buildFCmp (fromFPPredicate p)) @@ -969,7 +850,7 @@ -- 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 :: (CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a) select (Value cnd) (Value thn) (Value els) = liftM Value $ withCurrentBuilder $ \ bldPtr ->@@ -1173,7 +1054,7 @@ arrayMalloc :: forall a r s . (IsSized a, AllocArg s) => s -> CodeGenFunction r (Value (Ptr a)) -- XXX arrayMalloc s = do- func <- staticNamedFunction "alignedMalloc" alignedMalloc+ func <- CodeGen.staticNamedFunction "alignedMalloc" alignedMalloc -- func <- externFunction "malloc" size <- sizeOfArray (LP.Proxy :: LP.Proxy a) (getAllocArg s)@@ -1209,7 +1090,7 @@ -- | Free heap memory. free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r () free ptr = do- func <- staticNamedFunction "alignedFree" alignedFree+ func <- CodeGen.staticNamedFunction "alignedFree" alignedFree -- func <- externFunction "free" _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr return ()@@ -1268,96 +1149,17 @@ 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 =+_getElementPtrDynamic :: (IsInteger i) =>+ Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))+_getElementPtrDynamic (Value ptr) ixs = liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr -> U.withEmptyCString $ FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)--} --- |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.)@@ -1377,6 +1179,23 @@ getElementPtr0 :: (GetElementPtr o i) => Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) getElementPtr0 p i = getElementPtr p (0::Word32, i)++_getElementPtr :: forall value o i i0 r.+ (ValueCons value, GetElementPtr o i, IsIndexType i0) =>+ value (Ptr o) -> (value i0, i) ->+ CodeGenFunction r (value (Ptr (ElementPtrType o i)))+_getElementPtr vptr (a, ixs) =+ let withArgs act =+ U.withArrayLen+ (unValue a : getIxList (LP.Proxy :: LP.Proxy o) ixs) $+ \ idxLen idxPtr ->+ act idxPtr (fromIntegral idxLen)+ in unop+ (\ptr -> withArgs $ FFI.constGEP ptr)+ (\bldPtr ptr cstr ->+ withArgs $ \idxPtr idxLen ->+ FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)+ vptr -------------------------------------- {-
+ src/LLVM/Core/Instructions/Guided.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE EmptyDataDecls #-}+{- |+This module provides some functions from the "LLVM.Core.Instructions" module+in a way that enables easier type handling.+E.g. 'trunc' on vectors requires you to prove+that reducing the bitsize of the elements+reduces the bitsize of the whole vector.+We solve the problem by adding a 'Guide' parameter.+It can be either 'scalar' or 'vector'.+We impose the bitsize constraint only on the element type,+but not on the size of the whole value (scalar or vector).++Another example:+If you call 'trunc' on a Vector input,+GHC cannot infer that the result must be a 'Data.Vector' of the same size.+Using the guide, it can.+However, in practice this is not as useful as I thought initially.+-}+module LLVM.Core.Instructions.Guided (+ Guide,+ scalar,+ vector,+ getElementPtr,+ getElementPtr0,+ trunc,+ ext,+ extBool,+ zadapt,+ sadapt,+ adapt,+ fptrunc,+ fpext,+ fptoint,+ inttofp,+ ptrtoint,+ inttoptr,+ bitcast,+ select,+ cmp,+ icmp,+ pcmp,+ fcmp,+ ) where++import qualified LLVM.Core.Instructions.Private as Priv+import qualified LLVM.Core.Type as Type+import qualified LLVM.Core.Util as U+import qualified LLVM.Util.Proxy as LP+import LLVM.Core.Instructions.Private (ValueCons)+import LLVM.Core.CodeGenMonad (CodeGenFunction)+import LLVM.Core.CodeGen (ConstValue, zero)+import LLVM.Core.Type+ (IsArithmetic, IsInteger, IsIntegerOrPointer, IsFloating,+ IsFirstClass, IsPrimitive,+ Signed, Positive, IsType, IsSized, SizeOf,+ isFloating, sizeOf, typeDesc)++import qualified LLVM.FFI.Core as FFI++import Type.Data.Num.Decimal.Number ((:<:), (:>:))++import Foreign.Ptr (Ptr)++import qualified Control.Functor.HT as FuncHT++import Data.Word (Word32)+++data Guide shape elem = Guide++instance Functor (Guide shape) where+ fmap _ Guide = Guide++scalar :: Guide Type.ScalarShape a+scalar = Guide++vector :: (Positive n) => Guide (Type.VectorShape n) a+vector = Guide++proxyFromGuide :: Guide shape elem -> LP.Proxy elem+proxyFromGuide Guide = LP.Proxy+++type Type shape a = Type.ShapedType shape a+type VT value shape a = value (Type shape a)++getElementPtr ::+ (ValueCons value, Priv.GetElementPtr o i, Priv.IsIndexType i0) =>+ Guide shape (Ptr o, i0) ->+ VT value shape (Ptr o) ->+ (VT value shape i0, i) ->+ CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtr guide vptr (a, ixs) =+ getElementPtrGen (fmap fst guide) vptr (Priv.unValue a, ixs)++getElementPtr0 ::+ (ValueCons value, Priv.GetElementPtr o i) =>+ Guide shape (Ptr o) ->+ VT value shape (Ptr o) -> i ->+ CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtr0 guide vptr ixs =+ getElementPtrGen guide vptr+ (Priv.unConst (zero :: ConstValue Word32), ixs)++getElementPtrGen ::+ (ValueCons value, Priv.GetElementPtr o i) =>+ Guide shape (Ptr o) ->+ VT value shape (Ptr o) -> (FFI.ValueRef, i) ->+ CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtrGen guide vptr (i0val,ixs) =+ let withArgs act =+ U.withArrayLen+ (i0val : Priv.getIxList (LP.element (proxyFromGuide guide)) ixs) $+ \ idxLen idxPtr ->+ act idxPtr (fromIntegral idxLen)+ in Priv.unop+ (\ptr -> withArgs $ FFI.constGEP ptr)+ (\bldPtr ptr cstr ->+ withArgs $ \idxPtr idxLen ->+ FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)+ vptr+++-- | Truncate a value to a shorter bit width.+trunc ::+ (ValueCons value, IsInteger av, IsInteger bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+trunc = convert FFI.constTrunc FFI.buildTrunc++isSigned :: (IsArithmetic a) => Guide shape a -> Bool+isSigned = Type.isSigned . proxyFromGuide++-- | 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 ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv, Signed a ~ Signed b,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+ext guide =+ if isSigned (fmap snd guide)+ then convert FFI.constSExt FFI.buildSExt guide+ else convert FFI.constZExt FFI.buildZExt guide++extBool ::+ (ValueCons value, IsInteger b, IsType bv,+ IsPrimitive b, Type shape Bool ~ av, Type shape b ~ bv) =>+ Guide shape (Bool,b) -> value av -> CodeGenFunction r (value bv)+extBool guide =+ if isSigned (fmap snd guide)+ then convert FFI.constSExt FFI.buildSExt guide+ else convert FFI.constZExt FFI.buildZExt guide+++compareGuideSizes :: (IsType a, IsType b) => Guide shape (a,b) -> Ordering+compareGuideSizes guide =+ case FuncHT.unzip $ proxyFromGuide guide of+ (a,b) -> compare (sizeOf (typeDesc a)) (sizeOf (typeDesc b))++-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.+zadapt ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+zadapt guide =+ case compareGuideSizes guide of+ LT -> convert FFI.constZExt FFI.buildZExt guide+ EQ -> convert FFI.constBitCast FFI.buildBitCast guide+ GT -> convert FFI.constTrunc FFI.buildTrunc guide++-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.+sadapt ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+sadapt guide =+ case compareGuideSizes guide of+ LT -> convert FFI.constSExt FFI.buildSExt guide+ EQ -> convert FFI.constBitCast FFI.buildBitCast guide+ GT -> convert FFI.constTrunc FFI.buildTrunc guide++-- | It is 'sadapt' or 'zadapt' depending on the sign mode.+adapt ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ Signed a ~ Signed b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+adapt guide =+ case compareGuideSizes guide of+ LT ->+ if isSigned (fmap snd guide)+ then convert FFI.constSExt FFI.buildSExt guide+ else convert FFI.constZExt FFI.buildZExt guide+ EQ -> convert FFI.constBitCast FFI.buildBitCast guide+ GT -> convert FFI.constTrunc FFI.buildTrunc guide++-- | Truncate a floating point value.+fptrunc ::+ (ValueCons value, IsFloating av, IsFloating bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc++-- | Extend a floating point value.+fpext ::+ (ValueCons value, IsFloating av, IsFloating bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+fpext = convert FFI.constFPExt FFI.buildFPExt++-- | Convert a floating point value to an integer.+-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.+fptoint ::+ (ValueCons value, IsFloating a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+fptoint guide =+ if isSigned (fmap snd guide)+ then convert FFI.constFPToSI FFI.buildFPToSI guide+ else convert FFI.constFPToUI FFI.buildFPToUI guide+++-- | Convert an integer to a floating point value.+-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.+inttofp ::+ (ValueCons value, IsInteger a, IsFloating b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+inttofp guide =+ if isSigned (fmap fst guide)+ then convert FFI.constSIToFP FFI.buildSIToFP guide+ else convert FFI.constUIToFP FFI.buildUIToFP guide+++-- | Convert a pointer to an integer.+ptrtoint ::+ (ValueCons value, IsType a, IsInteger b, IsType bv,+ IsPrimitive b, Type shape (Ptr a) ~ av, Type shape b ~ bv) =>+ Guide shape (Ptr a, b) -> value av -> CodeGenFunction r (value bv)+ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt++-- | Convert an integer to a pointer.+inttoptr ::+ (ValueCons value, IsInteger a, IsType b, IsType bv,+ IsPrimitive a, Type shape a ~ av, Type shape (Ptr b) ~ bv) =>+ Guide shape (a, Ptr b) -> value av -> CodeGenFunction r (value bv)+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 bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+bitcast = convert FFI.constBitCast FFI.buildBitCast+++convert ::+ (ValueCons value, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Priv.FFIConstConvert -> Priv.FFIConvert -> Guide shape (a,b) ->+ value av -> CodeGenFunction r (value bv)+convert cnvConst cnv Guide = Priv.convert cnvConst cnv++++select ::+ (ValueCons value, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ value bv -> value av -> value av -> CodeGenFunction r (value av)+select Guide = Priv.trinop FFI.constSelect FFI.buildSelect+++cmp ::+ (ValueCons value, IsArithmetic a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ Priv.CmpPredicate -> value av -> value av -> CodeGenFunction r (value bv)+cmp guide@Guide p =+ let cmpop constCmp buildCmp predi =+ Priv.binop (constCmp predi) (flip buildCmp predi)+ in if isFloating (proxyFromGuide guide)+ then+ cmpop FFI.constFCmp FFI.buildFCmp $+ Priv.fromFPPredicate $ Priv.fpFromCmpPredicate p+ else+ cmpop FFI.constICmp FFI.buildICmp $+ Priv.fromIntPredicate $+ if isSigned guide+ then Priv.sintFromCmpPredicate p+ else Priv.uintFromCmpPredicate p++_cmp ::+ (ValueCons value, IsArithmetic a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ Priv.CmpPredicate -> value av -> value av -> CodeGenFunction r (value bv)+_cmp guide@Guide p =+ if isFloating (proxyFromGuide guide)+ then+ let predi = Priv.fromFPPredicate $ Priv.fpFromCmpPredicate p+ in Priv.binop+ (FFI.constFCmp predi)+ (flip FFI.buildFCmp predi)+ else+ let predi =+ Priv.fromIntPredicate $+ if isSigned guide+ then Priv.sintFromCmpPredicate p+ else Priv.uintFromCmpPredicate p+ in Priv.binop+ (FFI.constICmp predi)+ (flip FFI.buildICmp predi)++{-# DEPRECATED icmp "use cmp or pcmp instead" #-}+-- | Compare integers.+icmp ::+ (ValueCons value, IsIntegerOrPointer a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ Priv.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)+icmp Guide p =+ Priv.binop+ (FFI.constICmp (Priv.fromIntPredicate p))+ (flip FFI.buildICmp (Priv.fromIntPredicate p))++-- | Compare pointers.+pcmp :: (ValueCons value, Type shape (Ptr a) ~ av, Type shape Bool ~ bv) =>+ Guide shape (Ptr a) ->+ Priv.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)+pcmp Guide p =+ Priv.binop+ (FFI.constICmp (Priv.fromIntPredicate p))+ (flip FFI.buildICmp (Priv.fromIntPredicate p))++-- | Compare floating point values.+fcmp ::+ (ValueCons value, IsFloating a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ Priv.FPPredicate -> value av -> value av -> CodeGenFunction r (value bv)+fcmp Guide p =+ Priv.binop+ (FFI.constFCmp (Priv.fromFPPredicate p))+ (flip FFI.buildFCmp (Priv.fromFPPredicate p))
src/LLVM/Core/Instructions/Private.hs view
@@ -1,24 +1,38 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} module LLVM.Core.Instructions.Private where import qualified LLVM.Core.Util as U import qualified LLVM.Util.Proxy as LP-import LLVM.Core.Type (IsType, typeRef)+import LLVM.Core.Type (IsType, IsPrimitive, typeRef)+import LLVM.Core.Data (Vector, Array, Struct, PackedStruct) import LLVM.Core.CodeGenMonad (CodeGenFunction) import LLVM.Core.CodeGen- (Value(Value), ConstValue(ConstValue), withCurrentBuilder)+ (ConstValue(ConstValue), constOf, Value(Value), withCurrentBuilder) import qualified LLVM.FFI.Core as FFI +import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Number (Pred)+import Type.Base.Proxy (Proxy)++import Foreign.C (CInt)+ import Control.Monad.IO.Class (liftIO) import Control.Monad (liftM) +import Data.Typeable (Typeable)+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64) -type FFIConstConvert = FFI.ValueRef -> FFI.TypeRef -> IO FFI.ValueRef +type FFIConstConvert = FFI.ValueRef -> FFI.TypeRef -> IO FFI.ValueRef type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef@@ -26,6 +40,11 @@ type FFIConstUnOp = FFI.ValueRef -> IO FFI.ValueRef type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef +type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef+type FFIBinOp =+ FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef ->+ U.CString -> IO FFI.ValueRef+ type FFIConstTrinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef type FFITrinOp =@@ -34,45 +53,285 @@ class ValueCons value where- convert :: (IsType b) =>- FFIConstConvert -> FFIConvert -> value a -> CodeGenFunction r (value b)- aunop ::- FFIConstUnOp -> FFIUnOp -> value a -> CodeGenFunction r (value b)- trinop ::- FFIConstTrinOp -> FFITrinOp ->- value a -> value b -> value c -> CodeGenFunction r (value d)-+ switchValueCons :: f ConstValue -> f Value -> f value instance ValueCons ConstValue where- convert cnv _ = convertConstValue cnv- aunop cop _ (ConstValue a) = liftIO $ fmap ConstValue $ cop a- trinop cop _ (ConstValue a) (ConstValue b) (ConstValue c) =- liftIO $ fmap ConstValue $ cop a b c+ switchValueCons f _ = f -convertConstValue ::- forall a b r. (IsType b) =>- FFIConstConvert -> ConstValue a -> CodeGenFunction r (ConstValue b)-convertConstValue conv (ConstValue a) =- liftM ConstValue $ liftIO $- conv a =<< typeRef (LP.Proxy :: LP.Proxy b)+instance ValueCons Value where+ switchValueCons _ f = f -instance ValueCons Value where- convert _ cnv = convertValue cnv- aunop _ op (Value a) =- liftM Value $- withCurrentBuilder $ \ bld ->- U.withEmptyCString $ op bld a- trinop _ op (Value a) (Value b) (Value c) =- liftM Value $- withCurrentBuilder $ \ bld ->- U.withEmptyCString $ op bld a b c+convert :: (ValueCons value, IsType b) =>+ FFIConstConvert -> FFIConvert -> value a -> CodeGenFunction r (value b)+convert cop op =+ getUnOp $+ switchValueCons+ (UnOp $ convertConstValue LP.Proxy cop)+ (UnOp $ convertValue LP.Proxy op) +convertConstValue ::+ (IsType b) =>+ LP.Proxy b -> FFIConstConvert ->+ ConstValue a -> CodeGenFunction r (ConstValue b)+convertConstValue proxy conv (ConstValue a) =+ liftM ConstValue $ liftIO $ conv a =<< typeRef proxy+ convertValue ::- forall a b r. (IsType b) =>- FFIConvert -> Value a -> CodeGenFunction r (Value b)-convertValue conv (Value a) =+ (IsType b) =>+ LP.Proxy b -> FFIConvert -> Value a -> CodeGenFunction r (Value b)+convertValue proxy conv (Value a) = liftM Value $ withCurrentBuilder $ \ bldPtr -> do- typ <- typeRef (LP.Proxy :: LP.Proxy b)+ typ <- typeRef proxy U.withEmptyCString $ conv bldPtr a typ+++newtype UnValue a value = UnValue {getUnValue :: value a -> FFI.ValueRef}++unValue :: (ValueCons value) => value a -> FFI.ValueRef+unValue =+ getUnValue $+ switchValueCons+ (UnValue $ \(ConstValue a) -> a)+ (UnValue $ \(Value a) -> a)++newtype UnOp a b r value =+ UnOp {getUnOp :: value a -> CodeGenFunction r (value b)}++unop ::+ (ValueCons value) =>+ FFIConstUnOp -> FFIUnOp -> value a -> CodeGenFunction r (value b)+unop cop op =+ getUnOp $+ switchValueCons+ (UnOp $ \(ConstValue a) -> liftIO $ fmap ConstValue $ cop a)+ (UnOp $ \(Value a) ->+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a)++newtype BinOp a b c r value =+ BinOp {getBinOp :: value a -> value b -> CodeGenFunction r (value c)}++binop ::+ (ValueCons value) =>+ FFIConstBinOp -> FFIBinOp ->+ value a -> value b -> CodeGenFunction r (value c)+binop cop op =+ getBinOp $+ switchValueCons+ (BinOp $ \(ConstValue a) (ConstValue b) ->+ liftIO $ fmap ConstValue $ cop a b)+ (BinOp $ \(Value a) (Value b) ->+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a b)++newtype TrinOp a b c d r value =+ TrinOp {+ getTrinOp ::+ value a -> value b -> value c -> CodeGenFunction r (value d)+ }++trinop ::+ (ValueCons value) =>+ FFIConstTrinOp -> FFITrinOp ->+ value a -> value b -> value c -> CodeGenFunction r (value d)+trinop cop op =+ getTrinOp $+ switchValueCons+ (TrinOp $ \(ConstValue a) (ConstValue b) (ConstValue c) ->+ liftIO $ fmap ConstValue $ cop a b c)+ (TrinOp $ \(Value a) (Value b) (Value c) ->+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a b c)++++-- | 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++{- |+In principle we do not need the getValueArg method,+because we could just use 'unValue'.+However, we want to prevent users+from defining their own (disfunctional) IsIndexType instances.+-}+class (IsPrimitive i) => IsIndexType i where+ getValueArg :: (ValueCons value) => value i -> FFI.ValueRef++instance IsIndexType Word32 where+ getValueArg = unValue++instance IsIndexType Word64 where+ getValueArg = unValue++instance IsIndexType Int32 where+ getValueArg = unValue++instance IsIndexType Int64 where+ getValueArg = unValue++instance IsIndexType i => IsIndexArg (ConstValue i) where+ getArg = getValueArg++instance IsIndexType i => IsIndexArg (Value i) where+ getArg = getValueArg++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 LP.Proxy () = []++-- 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 proxy (v, i) = getArg v : getIxList (LP.element proxy) 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 proxy (v, i) = getArg v : getIxList (LP.element proxy) i++fieldProxy :: LP.Proxy (struct fs) -> Proxy a -> LP.Proxy (FieldType fs a)+fieldProxy LP.Proxy _proxy = LP.Proxy++-- 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 proxy (a, i) =+ unConst (constOf (Dec.integralFromProxy a :: Word32)) :+ getIxList (fieldProxy proxy 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 proxy (a, i) =+ unConst (constOf (Dec.integralFromProxy a :: Word32)) :+ getIxList (fieldProxy proxy 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))++++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+ | FPTrue -- ^ 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
− src/LLVM/Core/Instructions/TypeAssisted.hs
@@ -1,186 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-module LLVM.Core.Instructions.TypeAssisted (- Assistant,- scalar,- vector,- trunc,- ext,- extBool,- zadapt,- sadapt,- adapt,- fptrunc,- fpext,- fptoint,- inttofp,- ptrtoint,- inttoptr,- bitcast,- select,- ) where--import qualified LLVM.Core.Instructions.Private as Priv-import qualified LLVM.Util.Proxy as LP-import LLVM.Core.Instructions.Private (ValueCons)-import LLVM.Core.Data (Vector)-import LLVM.Core.Type- (IsInteger, IsFloating, IsFirstClass, IsPrimitive,- Signed, Positive, IsType, IsSized, SizeOf,- isSigned, sizeOf, typeDesc)-import LLVM.Core.CodeGenMonad (CodeGenFunction)--import qualified LLVM.FFI.Core as FFI--import Type.Data.Num.Decimal.Number ((:<:), (:>:))--import Foreign.Ptr (Ptr)----data Assistant a b av bv = Assistant--scalar :: Assistant a b a b-scalar = Assistant--vector ::- (Positive n, IsPrimitive a, IsPrimitive b) =>- Assistant a b (Vector n a) (Vector n b)-vector = Assistant----- | Truncate a value to a shorter bit width.-trunc ::- (ValueCons value, IsInteger av, IsInteger bv,- IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-trunc = convert FFI.constTrunc FFI.buildTrunc---- | 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 av bv r.- (ValueCons value, IsInteger av, IsInteger bv, Signed a ~ Signed b,- IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-ext =- if isSigned (LP.Proxy :: LP.Proxy bv)- then convert FFI.constSExt FFI.buildSExt- else convert FFI.constZExt FFI.buildZExt--extBool :: forall value b av bv r.- (ValueCons value, IsInteger bv) =>- Assistant Bool b av bv -> value av -> CodeGenFunction r (value bv)-extBool =- if isSigned (LP.Proxy :: LP.Proxy bv)- 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 av bv r.- (ValueCons value, IsInteger av, IsInteger bv) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-zadapt =- case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy av)))- (sizeOf (typeDesc (LP.Proxy :: LP.Proxy bv))) 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 av bv r.- (ValueCons value, IsInteger av, IsInteger bv) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-sadapt =- case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy av)))- (sizeOf (typeDesc (LP.Proxy :: LP.Proxy bv))) 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 av bv r.- (ValueCons value, IsInteger av, IsInteger bv, Signed a ~ Signed b) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-adapt =- case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy av)))- (sizeOf (typeDesc (LP.Proxy :: LP.Proxy bv))) of- LT ->- if isSigned (LP.Proxy :: LP.Proxy bv)- 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 av, IsFloating bv,- IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc---- | Extend a floating point value.-fpext ::- (ValueCons value, IsFloating av, IsFloating bv,- IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-fpext = convert FFI.constFPExt FFI.buildFPExt---- | 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 av bv r.- (ValueCons value, IsFloating av, IsInteger bv) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-fptoint =- if isSigned (LP.Proxy :: LP.Proxy bv)- then convert FFI.constFPToSI FFI.buildFPToSI- else convert FFI.constFPToUI FFI.buildFPToUI----- | 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 av bv r.- (ValueCons value, IsInteger av, IsFloating bv) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-inttofp =- if isSigned (LP.Proxy :: LP.Proxy av)- then convert FFI.constSIToFP FFI.buildSIToFP- else convert FFI.constUIToFP FFI.buildUIToFP----- | Convert a pointer to an integer.-ptrtoint ::- (ValueCons value, IsInteger bv) =>- Assistant (Ptr a) b av bv -> value av -> CodeGenFunction r (value bv)-ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt---- | Convert an integer to a pointer.-inttoptr ::- (ValueCons value, IsInteger av, IsType bv) =>- Assistant a (Ptr b) av bv -> value av -> CodeGenFunction r (value bv)-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 bv,- IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>- Assistant a b av bv -> value av -> CodeGenFunction r (value bv)-bitcast = convert FFI.constBitCast FFI.buildBitCast---convert :: (ValueCons value, IsType bv) =>- Priv.FFIConstConvert -> Priv.FFIConvert -> Assistant a b av bv ->- value av -> CodeGenFunction r (value bv)-convert cnvConst cnv Assistant = Priv.convert cnvConst cnv----select ::- (ValueCons value, IsFirstClass a) =>- Assistant a Bool av bv ->- value bv -> value av -> value av -> CodeGenFunction r (value av)-select Assistant = Priv.trinop FFI.constSelect FFI.buildSelect-
src/LLVM/Core/Type.hs view
@@ -31,6 +31,7 @@ -- ** Others IsScalarOrVector, ShapeOf, ScalarShape, VectorShape,+ Shape, ShapedType, StructFields, UnknownSize, -- needed for arrays of structs -- ** Structs@@ -51,6 +52,8 @@ import LLVM.Core.Util (functionType, structType) import LLVM.Core.Data+ (IntN, WordN, Vector, Array, FP128,+ Struct(Struct), PackedStruct(PackedStruct), Label) import LLVM.Util.Proxy (Proxy(Proxy)) import qualified Type.Data.Num.Decimal.Number as Dec@@ -85,7 +88,7 @@ typeRef = code . typeDesc where code TDFloat = FFI.floatType code TDDouble = FFI.doubleType- code TDFP128 = FFI.fP128Type+ code TDFP128 = FFI.fp128Type code TDVoid = FFI.voidType code (TDInt _ n) = FFI.integerType (fromInteger n) code (TDArray n a) = withCode FFI.arrayType (code a) (fromInteger n)@@ -214,10 +217,13 @@ -- |Integral or pointer type. class IsIntegerOrPointer a -isSigned :: (IsInteger a) => Proxy a -> Bool+isSigned :: (IsArithmetic a) => Proxy a -> Bool isSigned = is . typeDesc where is (TDInt s _) = s is (TDVector _ a) = is a+ is TDFloat = True+ is TDDouble = True+ is TDFP128 = True is _ = error "isSigned got impossible input" -- Usage:@@ -238,13 +244,22 @@ -- Precondition for Vector -- |Primitive types. -- class (IsType a) => IsPrimitive a-class (IsType a, ShapeOf a ~ ScalarShape) => IsPrimitive a+class (IsScalarOrVector a, ShapeOf a ~ ScalarShape) => IsPrimitive a data ScalarShape data VectorShape n +class Shape shape where+ type ShapedType shape a :: *++instance Shape ScalarShape where+ type ShapedType ScalarShape a = a++instance Shape (VectorShape n) where+ type ShapedType (VectorShape n) a = Vector n a+ -- |Number of elements for instructions that handle both primitive and vector types-class (IsType a) => IsScalarOrVector a where+class (IsFirstClass a) => IsScalarOrVector a where type ShapeOf a :: * @@ -377,6 +392,11 @@ instance IsArithmetic FP128 where arithmeticType = FloatingType instance (Dec.Positive n) => IsArithmetic (IntN n) where arithmeticType = IntegerType instance (Dec.Positive n) => IsArithmetic (WordN n) where arithmeticType = IntegerType+{-+This instance is more dangerous than useful.+E.g. 'inv' can be mixed up with 'neg'.+For arithmetic on i1 you might better use @IntN D1@ or @WordN D1@.+-} instance IsArithmetic Bool where arithmeticType = IntegerType instance IsArithmetic Int8 where arithmeticType = IntegerType instance IsArithmetic Int16 where arithmeticType = IntegerType@@ -511,6 +531,7 @@ instance IsPrimitive Word64 instance IsPrimitive Label instance IsPrimitive ()+instance (IsType a) => IsPrimitive (Ptr a) instance (Dec.Positive n) =>@@ -531,6 +552,8 @@ instance IsScalarOrVector Word64 where type ShapeOf Word64 = ScalarShape instance IsScalarOrVector Label where type ShapeOf Label = ScalarShape instance IsScalarOrVector () where type ShapeOf () = ScalarShape+instance (IsType a) =>+ IsScalarOrVector (Ptr a) where type ShapeOf (Ptr a) = ScalarShape instance (Dec.Positive n, IsPrimitive a) => IsScalarOrVector (Vector n a) where
src/LLVM/Core/Util.hs view
@@ -218,10 +218,10 @@ withCString name $ \ namePtr -> FFI.appendBasicBlock func namePtr -getBasicBlocks :: Value -> IO [(String, Value)]+getBasicBlocks :: Value -> IO [(String, BasicBlock)] getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v- >>= annotateValueList+ >>= annotateBasicBlockList -------------------------------------- @@ -272,6 +272,9 @@ withValue :: Value -> (Value -> IO a) -> IO a withValue v f = f v +withBasicBlock :: FFI.BasicBlockRef -> (FFI.BasicBlockRef -> IO a) -> IO a+withBasicBlock v f = f v+ makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value makeCall = makeCallWithCc FFI.C @@ -303,9 +306,9 @@ FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) return i -getInstructions :: Value -> IO [(String, Value)]+getInstructions :: BasicBlock -> IO [(String, Value)] getInstructions bb =- getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb+ getObjList withBasicBlock FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList getOperands :: Value -> IO [(String, Value)]@@ -414,10 +417,14 @@ getValueNameU :: Value -> IO String getValueNameU a = do -- sometimes void values need explicit names too- cs <- FFI.getValueName a- str <- peekCString cs+ str <- peekCString =<< FFI.getValueName a if str == "" then return (show a) else return str +getBasicBlockNameU :: BasicBlock -> IO String+getBasicBlockNameU a = do+ str <- peekCString =<< FFI.getBasicBlockName a+ if str == "" then return (show a) else return str+ getObjList :: (obj -> (objPtr -> IO [Ptr a]) -> io) -> (objPtr -> IO (Ptr a)) -> (Ptr a -> IO (Ptr a)) -> obj -> io@@ -432,6 +439,11 @@ annotateValueList :: [Value] -> IO [(String, Value)] annotateValueList vs = do names <- mapM getValueNameU vs+ return $ zip names vs++annotateBasicBlockList :: [BasicBlock] -> IO [(String, BasicBlock)]+annotateBasicBlockList vs = do+ names <- mapM getBasicBlockNameU vs return $ zip names vs isConstant :: Value -> IO Bool
src/LLVM/Core/Vector.hs view
@@ -22,8 +22,11 @@ import qualified Foreign.Storable.Traversable as Store import Foreign.Storable (Storable(..)) +import qualified Test.QuickCheck as QC++import qualified Control.Monad.Trans.State as MS import Control.Applicative (Applicative, pure, liftA2, (<*>))-import Control.Functor.HT (unzip)+import Control.Functor.HT (unzip, outerProduct) import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold@@ -255,3 +258,20 @@ isDenormalized = error "Vector isDenormalized" isNegativeZero = error "Vector isNegativeZero" isIEEE = isIEEE . head+++indices :: (Dec.Positive n) => Vector n Int+indices =+ flip MS.evalState 0 $ Trav.sequenceA $ replicate $ MS.state (\k -> (k,k+1))++instance (Dec.Positive n, QC.Arbitrary a) => QC.Arbitrary (Vector n a) where+ arbitrary = Trav.sequenceA $ replicate QC.arbitrary+ shrink v =+ case indices of+ ixs ->+ concatMap+ (Trav.sequenceA .+ liftA2+ (\x doShrink ->+ if doShrink then QC.shrink x else [x]) v) $+ outerProduct (==) (Fold.toList ixs) ixs
src/LLVM/Util/Arithmetic.hs view
@@ -18,9 +18,9 @@ CallIntrinsic, ) where +import qualified LLVM.Util.Intrinsic as Intrinsic import qualified LLVM.Core as LLVM import LLVM.Util.Loop (mapVector, mapVector2)-import LLVM.Util.Proxy (Proxy(Proxy)) import LLVM.Core import qualified Type.Data.Num.Decimal.Number as Dec@@ -83,7 +83,7 @@ retrn x = x >>= ret -- | Use @x <- set $ ...@ to make a binding.-set :: TValue r a -> (CodeGenFunction r (TValue r a))+set :: TValue r a -> CodeGenFunction r (TValue r a) set x = do x' <- x; return (return x') instance Eq (TValue r a)@@ -161,44 +161,6 @@ y' <- y op x' y' -{--If we add the ReadNone attribute, then LLVM-2.8 complains:--llvm/examples$ Arith_dyn.exe-Attribute readnone only applies to the function!- %2 = call readnone double @llvm.sin.f64(double %0)-Attribute readnone only applies to the function!- %3 = call readnone double @llvm.exp.f64(double %2)-Broken module found, compilation aborted!-Stack dump:-0. Running pass 'Function Pass Manager' on module '_module'.-1. Running pass 'Module Verifier' on function '@_fun1'-Aborted--}-addReadNone :: Value a -> CodeGenFunction r (Value a)-addReadNone x = do--- addAttributes x 0 [ReadNoneAttribute]- return x--callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) =>- String -> Value a -> TValue r b-callIntrinsicP1 fn x = do- op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (Proxy :: Proxy a))-{--You can add these attributes,-but the verifier pass in the optimizer checks whether they match-the attributes that are declared for that intrinsic.-If we omit adding attributes then the right attributes are added automatically.- addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute]--}- runCall (callFromFunction op `applyCall` x) >>= addReadNone--callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) =>- String -> Value a -> Value b -> TValue r c-callIntrinsicP2 fn x y = do- op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (Proxy :: Proxy a))- runCall (callFromFunction op `applyCall` x `applyCall` y) >>= addReadNone- ------------------------------------------- class ArithFunction r z a b | a -> b r z, b r z -> a where@@ -267,12 +229,12 @@ callIntrinsic2' :: String -> Value a -> Value a -> TValue r a instance CallIntrinsic Float where- callIntrinsic1' = callIntrinsicP1- callIntrinsic2' = callIntrinsicP2+ callIntrinsic1' = Intrinsic.call1+ callIntrinsic2' = Intrinsic.call2 instance CallIntrinsic Double where- callIntrinsic1' = callIntrinsicP1- callIntrinsic2' = callIntrinsicP2+ callIntrinsic1' = Intrinsic.call1+ callIntrinsic2' = Intrinsic.call2 {- I think such a special case for certain systems@@ -292,7 +254,7 @@ elem s ["sqrt", "log", "exp", "sin", "cos", "tan"] then do op <- externFunction ("v" ++ s ++ "f")- call op x >>= addReadNone+ call op x else mapVector (callIntrinsic1' s) x callIntrinsic2' s = mapVector2 (callIntrinsic2' s)
+ src/LLVM/Util/Intrinsic.hs view
@@ -0,0 +1,71 @@+module LLVM.Util.Intrinsic (+ min, max, abs,+ truncate, floor,+ maybeUAddSat, maybeSAddSat, maybeUSubSat, maybeSSubSat,++ call1, call2,+ ) where++import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core+ (CodeGenFunction, Value, IsType, IsFirstClass,+ IsArithmetic, IsInteger, IsFloating)++import qualified LLVM.FFI.Core as FFI++import Data.Maybe.HT (toMaybe)++import Prelude hiding (min, max, abs, truncate, floor)+++valueTypeName :: (IsType a) => Value a -> String+valueTypeName =+ LLVM.intrinsicTypeName . ((\_ -> LP.Proxy) :: Value a -> LP.Proxy a)++functionName :: (IsType a) => String -> Value a -> String+functionName fn x = "llvm." ++ fn ++ "." ++ valueTypeName x++call1 ::+ (IsFirstClass a) =>+ String -> Value a -> CodeGenFunction r (Value a)+call1 fn x = do+ op <- LLVM.externFunction $ functionName fn x+ LLVM.call op x++call2 ::+ (IsFirstClass a) =>+ String -> Value a -> Value a -> CodeGenFunction r (Value a)+call2 fn x y = do+ op <- LLVM.externFunction $ functionName fn x+ LLVM.call op x y++++min, max ::+ (IsArithmetic a) => Value a -> Value a -> CodeGenFunction r (Value a)+min = call2 "minnum"+max = call2 "maxnum"++abs :: (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)+abs = call1 "fabs"++truncate, floor :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+truncate = call1 "trunc"+floor = call1 "floor"+++{- |+Available since LLVM-8.+-}+maybeUAddSat, maybeSAddSat, maybeUSubSat, maybeSSubSat ::+ (IsInteger a) => Maybe (Value a -> Value a -> CodeGenFunction r (Value a))+maybeUAddSat = opsat "uadd"+maybeSAddSat = opsat "sadd"+maybeUSubSat = opsat "usub"+maybeSSubSat = opsat "ssub"++opsat ::+ (IsFirstClass a) =>+ String -> Maybe (Value a -> Value a -> CodeGenFunction r (Value a))+opsat name = toMaybe (FFI.version >= 800) $ call2 (name++".sat")
src/LLVM/Util/Loop.hs view
@@ -94,7 +94,7 @@ -------------------------------------- mapVector :: forall a b n r .- (Dec.Positive n, IsPrimitive b) =>+ (Dec.Positive n, IsPrimitive a, IsPrimitive b) => (Value a -> CodeGenFunction r (Value b)) -> Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) mapVector f v =@@ -104,7 +104,7 @@ insertelement w y i mapVector2 :: forall a b c n r .- (Dec.Positive n, IsPrimitive c) =>+ (Dec.Positive n, IsPrimitive a, IsPrimitive b, IsPrimitive c) => (Value a -> Value b -> CodeGenFunction r (Value c)) -> Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c)) mapVector2 f v1 v2 =
src/LLVM/Util/Proxy.hs view
@@ -14,3 +14,6 @@ fromValue :: a -> Proxy a fromValue _ = Proxy++element :: Proxy (f a) -> Proxy a+element Proxy = Proxy