diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -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 diff --git a/example/BrainF.hs b/example/BrainF.hs --- a/example/BrainF.hs +++ b/example/BrainF.hs @@ -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 diff --git a/llvm-tf.cabal b/llvm-tf.cabal --- a/llvm-tf.cabal +++ b/llvm-tf.cabal @@ -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 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 diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs --- a/src/LLVM/Core.hs +++ b/src/LLVM/Core.hs @@ -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 diff --git a/src/LLVM/Core/Attribute.hs b/src/LLVM/Core/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Attribute.hs @@ -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 diff --git a/src/LLVM/Core/CodeGen.hs b/src/LLVM/Core/CodeGen.hs --- a/src/LLVM/Core/CodeGen.hs +++ b/src/LLVM/Core/CodeGen.hs @@ -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 () diff --git a/src/LLVM/Core/CodeGenMonad.hs b/src/LLVM/Core/CodeGenMonad.hs --- a/src/LLVM/Core/CodeGenMonad.hs +++ b/src/LLVM/Core/CodeGenMonad.hs @@ -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 :: diff --git a/src/LLVM/Core/Data.hs b/src/LLVM/Core/Data.hs --- a/src/LLVM/Core/Data.hs +++ b/src/LLVM/Core/Data.hs @@ -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 diff --git a/src/LLVM/Core/Guided.hs b/src/LLVM/Core/Guided.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Guided.hs @@ -0,0 +1,5 @@ +module LLVM.Core.Guided ( + module LLVM.Core.Instructions.Guided, + ) where + +import LLVM.Core.Instructions.Guided diff --git a/src/LLVM/Core/Instructions.hs b/src/LLVM/Core/Instructions.hs --- a/src/LLVM/Core/Instructions.hs +++ b/src/LLVM/Core/Instructions.hs @@ -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 -------------------------------------- {- diff --git a/src/LLVM/Core/Instructions/Guided.hs b/src/LLVM/Core/Instructions/Guided.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Instructions/Guided.hs @@ -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)) diff --git a/src/LLVM/Core/Instructions/Private.hs b/src/LLVM/Core/Instructions/Private.hs --- a/src/LLVM/Core/Instructions/Private.hs +++ b/src/LLVM/Core/Instructions/Private.hs @@ -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 diff --git a/src/LLVM/Core/Instructions/TypeAssisted.hs b/src/LLVM/Core/Instructions/TypeAssisted.hs deleted file mode 100644 --- a/src/LLVM/Core/Instructions/TypeAssisted.hs +++ /dev/null @@ -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 - diff --git a/src/LLVM/Core/Type.hs b/src/LLVM/Core/Type.hs --- a/src/LLVM/Core/Type.hs +++ b/src/LLVM/Core/Type.hs @@ -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 diff --git a/src/LLVM/Core/Util.hs b/src/LLVM/Core/Util.hs --- a/src/LLVM/Core/Util.hs +++ b/src/LLVM/Core/Util.hs @@ -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 diff --git a/src/LLVM/Core/Vector.hs b/src/LLVM/Core/Vector.hs --- a/src/LLVM/Core/Vector.hs +++ b/src/LLVM/Core/Vector.hs @@ -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 diff --git a/src/LLVM/Util/Arithmetic.hs b/src/LLVM/Util/Arithmetic.hs --- a/src/LLVM/Util/Arithmetic.hs +++ b/src/LLVM/Util/Arithmetic.hs @@ -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) diff --git a/src/LLVM/Util/Intrinsic.hs b/src/LLVM/Util/Intrinsic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Intrinsic.hs @@ -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") diff --git a/src/LLVM/Util/Loop.hs b/src/LLVM/Util/Loop.hs --- a/src/LLVM/Util/Loop.hs +++ b/src/LLVM/Util/Loop.hs @@ -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 = diff --git a/src/LLVM/Util/Proxy.hs b/src/LLVM/Util/Proxy.hs --- a/src/LLVM/Util/Proxy.hs +++ b/src/LLVM/Util/Proxy.hs @@ -14,3 +14,6 @@ fromValue :: a -> Proxy a fromValue _ = Proxy + +element :: Proxy (f a) -> Proxy a +element Proxy = Proxy