llvm-tf 3.0.2 → 3.0.3.1
raw patch · 30 files changed
+1263/−571 lines, 30 filesdep +llvm-ffidep +non-emptydep +storable-recorddep −llvm-basedep ~tfpdep ~transformers
Dependencies added: llvm-ffi, non-empty, storable-record, utility-ht
Dependencies removed: llvm-base
Dependency ranges changed: tfp, transformers
Files
- PROBLEMS.md +0/−20
- README.md +0/−58
- cbits/malloc.c +190/−0
- example/Align.hs +11/−8
- example/Arith.hs +2/−2
- example/Array.hs +1/−0
- example/DotProd.hs +5/−3
- example/HelloJIT.hs +1/−0
- example/List.hs +1/−1
- example/Struct.hs +2/−2
- example/Varargs.hs +1/−0
- example/Vector.hs +5/−5
- llvm-tf.cabal +35/−30
- src/LLVM/Core.hs +2/−1
- src/LLVM/Core/CodeGen.hs +154/−50
- src/LLVM/Core/CodeGenMonad.hs +39/−11
- src/LLVM/Core/Data.hs +25/−5
- src/LLVM/Core/Instructions.hs +194/−113
- src/LLVM/Core/Type.hs +113/−62
- src/LLVM/Core/UnaryVector.hs +159/−0
- src/LLVM/Core/Util.hs +24/−38
- src/LLVM/Core/Vector.hs +194/−93
- src/LLVM/ExecutionEngine.hs +3/−2
- src/LLVM/ExecutionEngine/Engine.hs +30/−28
- src/LLVM/ExecutionEngine/Target.hs +14/−13
- src/LLVM/Util/Arithmetic.hs +6/−5
- src/LLVM/Util/File.hs +21/−10
- src/LLVM/Util/Loop.hs +5/−5
- src/LLVM/Util/Memory.hs +10/−6
- src/LLVM/Util/Proxy.hs +16/−0
− PROBLEMS.md
@@ -1,20 +0,0 @@-Known problems-----------------If you have solutions to any of the problems listed below, please let-me know, or better yet, send a patch. Thanks!---Can't use LLVM bindings from ghci------------------------------------When I try to use the LLVM bindings in `ghci`, on Linux, loading the-bindings succeeds, but trying to do anything fails:-- $ ghci- Prelude> :m +LLVM.Core- Prelude LLVM.Core> m <- createModule "foo"- can't load .so/.DLL for: stdc++ (libstdc++.so: cannot open shared- object file: No such file or directory)--I don't know why this happens, but it looks like a `ghci` bug.
− README.md
@@ -1,58 +0,0 @@-Haskell LLVM bindings------------------------This package provides Haskell bindings for the popular-[LLVM](http://llvm.org/) compiler infrastructure project.---Compatibility----------------We try to stay up to date with LLVM releases. The current version of-this package is compatible with LLVM 2.9 and 2.8. Please understand-that the package may or may not work against older LLVM releases; we-don't have the time or resources to test across multiple releases.---Configuration----------------By default, when you run `cabal install`, the Haskell bindings will be-configured to look for LLVM in `/usr/local`.--If you have LLVM installed in a different location, e.g. `/usr`, you-can tell the `configure` script where to find it as follows:-- cabal install --configure-option=--with-llvm-prefix=/usr---Package status - what to expect----------------------------------This package is still under development.--The high level bindings are currently incomplete, so there are some-limits on what you can do. Adding new functions is generally easy,-though, so don't be afraid to get your hands dirty.--The high level interface is mostly safe, but the type system cannot-protect against everything that can go wrong, so take care. And, of-course, there's no way to guarantee anything about the generated code.---Staying in touch-------------------There is a low-volume mailing list named-[haskell-llvm@projects.haskellorg](http://projects.haskell.org/cgi-bin/mailman/listinfo/haskell-llvm).-If you use the LLVM bindings, you should think about joining.--If you want to contribute patches, please clone a copy of the-[git repository](https://github.com/bos/llvm):-- git clone git://github.com/bos/llvm--Patches are best submitted via the github "pull request" interface.--To file a bug or a request for an enhancement, please use the-[github issue tracker](https://github.com/bos/llvm/issues).
+ cbits/malloc.c view
@@ -0,0 +1,190 @@+#include <stdlib.h>+#include <stdint.h>++#ifdef DEBUG+#include <stdio.h>+#endif++#ifdef TEST+#include <stdio.h>+#endif+++size_t gcd(size_t x, size_t y) {+ while (x!=0) {+ size_t tmp = y%x;+ y = x;+ x = tmp;+ }+ return y;+};++__inline__+size_t lcm(size_t x, size_t y) {+ return x*(y/gcd(x,y));+};++__inline__+size_t round_down_multiple(size_t x, size_t y) {+ return x - (x%y);+};++/*+This is the alignment that malloc always warrants.+If smaller alignments are requested, then we do not need to pad.++FIXME:+This was only tested on ix86-linux.+How to get the right number for every platform?+*/+const size_t default_align = 8;++/*+We have to waste a lot of memory,+since we need an aligned address+and before that space for a pointer.+Less memory can be wasted if 'free' also gets size and align information.+In this case we could omit padding in some cases+and in the other cases we could put the pointer after the memory chunk,+which allows us to use less padding.+*/+void *aligned_malloc(size_t size, size_t requested_align) {+ const size_t ptrsize = sizeof(void *);+ /*+ Ensure that alignment always allows to store a pointer+ (to the whole allocated block).+ */+ const size_t align = lcm(requested_align, ptrsize);+ const size_t pad = align;+ void *ptr = malloc(pad+ptrsize+size);+ if (ptr) {+ void **alignedptr = (void **) round_down_multiple((size_t)(ptr+pad+ptrsize), align);+ *(alignedptr-1) = ptr;+#ifdef DEBUG+ printf("allocated size %x with alignment %x at %08x %08x \n",+ size, align, (size_t) ptr, (size_t) alignedptr);+#endif+ return alignedptr;+ } else {+ return NULL;+ }+};++/* align must be a power of two */+void *power2_aligned_malloc(size_t size, size_t align) {+ const size_t ptrsize = sizeof(void *);+ size_t pad = align>=default_align ? align-default_align : 0;+ void *ptr = malloc(pad+ptrsize+size);+ if (ptr) {+ void **alignedptr = (void **)((size_t)(ptr+pad+ptrsize) & (-align));+ *(alignedptr-1) = ptr;+#ifdef DEBUG+ printf("allocated size 0x%x with alignment 0x%x at %08x %08x \n",+ size, align, (size_t) ptr, (size_t) alignedptr);+#endif+ return alignedptr;+ } else {+ return NULL;+ }+};++void aligned_free(void *alignedptr) {+ if (alignedptr) {+ void **sptr = (void **) alignedptr;+ void *ptr = *(sptr - 1);+#ifdef DEBUG+ printf("freed %08x %08x \n", (size_t) ptr, (size_t) alignedptr);+#endif+ free(ptr);+ } else {+ /*+ What shall we do about NULL pointers?+ Crash immediately? Make an official crash by 'free'?+ */+ free(alignedptr);+ }+};+++/*+Abuse a pointer type as a size_t compatible type+and choose a name that will hopefully not clash+with names an llvm user already uses (such as 'malloc').+*/+void *aligned_malloc_sizeptr(void *size, void *align) {+ return aligned_malloc((size_t) size, (size_t) align);+}+++const int+ prepadsize = 1024,+ postpadsize = 1024;++void *padded_aligned_malloc(size_t size, size_t align) {+ void *ptr = aligned_malloc(prepadsize+size+postpadsize, align);+ return ptr ? ptr+prepadsize : NULL;+};++void padded_aligned_free(void *ptr) {+ aligned_free(ptr ? ptr-prepadsize : NULL);+};+++#ifdef TEST+void test_gcd (size_t x, size_t y) {+ printf("gcd(%d,%d) = %d\n", x, y, gcd (x,y));+}++void test_malloc (size_t size, size_t align) {+ uint8_t *ptr = aligned_malloc (size, align);+ if (ptr) {+ if (((size_t) ptr) % align) {+ printf ("ptr %08x not correctly aligned\n", (size_t) ptr);+ }+ size_t k;+ for (k = 0; k<size; k++) {+ ptr[k] = 0;+ }+ aligned_free (ptr);+ }+}++int main () {+ test_gcd (0,0);+ test_gcd (0,1);+ test_gcd (0,2);+ test_gcd (1,0);+ test_gcd (2,0);+ test_gcd (1,2);+ test_gcd (2,1);+ test_gcd (2,2);+ test_gcd (2,3);+ test_gcd (2,4);+ test_gcd (16,64);+ test_gcd (15,10);+ test_gcd (96,81);++ test_malloc (128, 1);+ test_malloc (128, 2);+ test_malloc (128, 3);+ test_malloc (128, 4);+ test_malloc (128, 5);+ test_malloc (128, 6);+ test_malloc (128, 8);+ test_malloc (128, 16);+ test_malloc (128, 32);+ test_malloc (128, 64);+ test_malloc (111, 1);+ test_malloc (111, 2);+ test_malloc (111, 3);+ test_malloc (111, 4);+ test_malloc (111, 5);+ test_malloc (111, 6);+ test_malloc (111, 8);+ test_malloc (111, 16);+ test_malloc (111, 32);+ test_malloc (111, 64);++ return 0;+}+#endif
example/Align.hs view
@@ -1,9 +1,12 @@ module Main (main) where import LLVM.ExecutionEngine-import LLVM.Core+ (getTargetData, aBIAlignmentOfType,+ storeSizeOfType, intPtrType, littleEndian)+import LLVM.Util.Proxy (Proxy(Proxy))+import LLVM.Core (Vector, unsafeTypeRef, initializeNativeTarget) -import Types.Data.Num (D1, D4)+import Type.Data.Num.Decimal.Literal (D1, D4) import Data.Word (Word32, Word64) @@ -15,10 +18,10 @@ td <- getTargetData print (littleEndian td,- aBIAlignmentOfType td $ typeRef (undefined :: Word32),- aBIAlignmentOfType td $ typeRef (undefined :: Word64),- aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float),- aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double),- storeSizeOfType td $ typeRef (undefined :: Vector D4 Float),+ aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word32),+ aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word64),+ aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)),+ aBIAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D1 Double)),+ storeSizeOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)), intPtrType td- )+ )
example/Arith.hs view
@@ -10,13 +10,13 @@ import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO) import LLVM.Core -import Types.Data.Num (D4)+import Type.Data.Num.Decimal.Literal (D4) import Data.Int (Int32) import Foreign.Storable (peek)+import Foreign.Ptr (Ptr) {--import Foreign.Ptr import Foreign.Marshal.Utils import Foreign.Marshal.Alloc as F -}
example/Array.hs view
@@ -4,6 +4,7 @@ import LLVM.Util.Optimize (optimizeModule) import LLVM.Core +import Foreign.Ptr (Ptr) import Data.Word (Word32)
example/DotProd.hs view
@@ -12,13 +12,15 @@ import LLVM.Util.File (writeCodeGenModule) import LLVM.Util.Foreign (withArrayLen) -import Types.Data.Num(D2, D4, D8, fromIntegerT)+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Literal (D2, D4, D8) +import Foreign.Ptr (Ptr) import Data.Word (Word32) mDotProd :: forall n a .- (PositiveT n,+ (Dec.Positive n, IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a) => CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) mDotProd =@@ -32,7 +34,7 @@ ab <- mul a b -- multiply them add s ab -- accumulate sum - r <- forLoop (valueOf (0::Word32)) (valueOf (fromIntegerT (undefined :: n)))+ r <- forLoop (valueOf (0::Word32)) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (valueOf 0) $ \ i r -> do ri <- extractelement s i add r ri
example/HelloJIT.hs view
@@ -3,6 +3,7 @@ import LLVM.ExecutionEngine (simpleFunction) import LLVM.Core +import Foreign.Ptr (Ptr) import Data.Word (Word8, Word32)
example/List.hs view
@@ -14,7 +14,7 @@ import qualified Foreign.Storable as St import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )-import Foreign.Ptr (FunPtr, )+import Foreign.Ptr (FunPtr, Ptr, ) import Data.IORef (IORef, newIORef, readIORef, writeIORef, )
example/Struct.hs view
@@ -7,8 +7,9 @@ import LLVM.Util.File (writeCodeGenModule) import LLVM.Core -import Types.Data.Num (D10, d0, d1, d2)+import Type.Data.Num.Decimal.Literal (D10, d0, d1, d2) +import Foreign.Ptr (Ptr) import Data.Word (Word32) @@ -41,4 +42,3 @@ let a = 10 p <- struct a putStrLn $ if structCheck a p /= 0 then "OK" else "failed"- return ()
example/Varargs.hs view
@@ -3,6 +3,7 @@ import LLVM.ExecutionEngine (simpleFunction) import LLVM.Core +import Foreign.Ptr (Ptr) import Data.Word (Word8, Word32)
example/Vector.hs view
@@ -9,7 +9,8 @@ import LLVM.Util.Loop (forLoop, ) import LLVM.Core -import Types.Data.Num (D16, fromIntegerT, )+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Literal (D16, ) import Control.Monad (liftM2, ) import Data.Word (Word32, )@@ -31,11 +32,11 @@ ret vacc let _ = retAcc :: Function (IO T) -- Force the type of retAcc. - -- A function that tests vector opreations.+ -- A function that tests vector operations. f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do let v = value (zero :: ConstValue (Vector N T))- n = fromIntegerT (undefined :: N) :: Word32+ n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton N) :: Word32 -- Fill the vector with x, x+1, x+2, ... (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do@@ -50,8 +51,7 @@ -- Sum the elements of the vector. s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do y <- extractelement vcb i- s' <- add s (y :: Value T)- return s'+ add s (y :: Value T) -- Update the global variable. vacc <- load acc
llvm-tf.cabal view
@@ -1,5 +1,5 @@ Name: llvm-tf-Version: 3.0.2+Version: 3.0.3.1 License: BSD3 License-File: LICENSE Synopsis: Bindings to the LLVM compiler toolkit using type families.@@ -7,9 +7,6 @@ High-level bindings to the LLVM compiler toolkit using type families instead of functional dependencies. .- * New in 3.0.0.0:- The low-level bindings have been split into the llvm-base package.- . We use the same module names as the @llvm@ package, which makes it harder to work with both packages from GHCi. You may use the @-hide-package@ option.@@ -32,21 +29,20 @@ Build-Type: Simple Extra-Source-Files:- *.md- test/*.hs- test/Makefile+ test/*.hs+ test/Makefile Source-Repository head Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ Source-Repository this- Tag: 3.0.2+ Tag: 3.0.3.1 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ Flag developer- Description: operate in developer mode+ Description: developer mode - warnings let compilation fail Default: False Flag buildExamples@@ -56,10 +52,13 @@ Library Default-Language: Haskell98 Build-Depends:- llvm-base == 3.0.*,- tfp >=0.7 && <0.9,- transformers >=0.3 && <0.4,+ llvm-ffi == 3.0.*,+ tfp >=1.0 && <1.1,+ transformers >=0.3 && <0.5, process >=1.1 && <1.3,+ storable-record >=0.0.2 && <0.1,+ non-empty >=0.2 && <0.3,+ utility-ht >=0.0.10 && <0.1, containers >=0.4 && <0.6, base >=3 && <5 @@ -74,26 +73,32 @@ Frameworks: vecLib CPP-Options: -D__MACOS__ + C-Sources:+-- cbits/free.c+ cbits/malloc.c+ Exposed-Modules:- LLVM.Core- LLVM.ExecutionEngine- LLVM.Util.Arithmetic- LLVM.Util.File- LLVM.Util.Foreign- LLVM.Util.Loop- LLVM.Util.Memory- LLVM.Util.Optimize+ LLVM.Core+ LLVM.ExecutionEngine+ LLVM.Util.Arithmetic+ LLVM.Util.File+ LLVM.Util.Foreign+ LLVM.Util.Loop+ LLVM.Util.Memory+ LLVM.Util.Optimize+ LLVM.Util.Proxy Other-Modules:- LLVM.Core.CodeGen- LLVM.Core.CodeGenMonad- LLVM.Core.Data- LLVM.Core.Instructions- LLVM.Core.Type- LLVM.Core.Util- LLVM.Core.Vector- LLVM.ExecutionEngine.Engine- LLVM.ExecutionEngine.Target+ LLVM.Core.CodeGen+ LLVM.Core.CodeGenMonad+ LLVM.Core.Data+ LLVM.Core.Instructions+ LLVM.Core.Type+ LLVM.Core.Util+ LLVM.Core.Vector+ LLVM.Core.UnaryVector+ LLVM.ExecutionEngine.Engine+ LLVM.ExecutionEngine.Target Executable llvm-align If flag(buildExamples)@@ -151,7 +156,7 @@ If flag(buildExamples) Build-Depends: llvm-tf,- llvm-base,+ llvm-ffi, tfp, base Else
src/LLVM/Core.hs view
@@ -48,8 +48,9 @@ withString, withStringNul, --constString, constStringNul, constVector, constArray,+ constCyclicVector, constCyclicArray, constStruct, constPackedStruct,- toVector, fromVector, vector,+ toVector, fromVector, vector, cyclicVector, -- * Code generation CodeGenFunction, CodeGenModule, -- * Functions
src/LLVM/Core/CodeGen.hs view
@@ -28,6 +28,7 @@ createString, createStringNul, withString, withStringNul, constVector, constArray, constStruct, constPackedStruct,+ constCyclicVector, constCyclicArray, -- * Basic blocks BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, fromLabel, toLabel,@@ -35,7 +36,9 @@ withCurrentBuilder ) where +import qualified LLVM.Core.UnaryVector as UnaryVector import qualified LLVM.Core.Util as U+import qualified LLVM.Util.Proxy as LP import LLVM.Core.CodeGenMonad import LLVM.Core.Type import LLVM.Core.Data@@ -43,17 +46,23 @@ import qualified LLVM.FFI.Core as FFI import LLVM.FFI.Core(Linkage(..), Visibility(..)) -import Types.Data.Num+import qualified Type.Data.Num.Decimal.Proof as DecProof+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy) import qualified Foreign.Storable as St import Foreign.StablePtr (StablePtr, castStablePtrToPtr)-import Foreign.Ptr (minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr)+import Foreign.Ptr (Ptr, minusPtr, nullPtr, FunPtr, castFunPtrToPtr)+import System.IO.Unsafe (unsafePerformIO) import Control.Monad (liftM, when) +import qualified Data.NonEmpty as NonEmpty+import qualified Data.Foldable as Fold import Data.Typeable (Typeable) import Data.Int (Int8, Int16, Int32, Int64) import Data.Word (Word8, Word16, Word32, Word64)+import Data.Maybe.HT (toMaybe) import Data.Maybe (fromMaybe) --------------------------------------@@ -84,11 +93,12 @@ deriving (Show, Typeable) getModuleValues :: U.Module -> IO [(String, ModuleValue)]-getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues+getModuleValues =+ liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a) castModuleValue (ModuleValue f) =- if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing+ toMaybe (U.valueHasType f (unsafeTypeRef (LP.Proxy :: LP.Proxy a))) (Value f) -------------------------------------- @@ -102,7 +112,7 @@ class IsConst a where constOf :: a -> ConstValue a -instance IsConst Bool where constOf = constEnum (typeRef True)+instance IsConst Bool where constOf = constEnum (typeRef (LP.Proxy :: LP.Proxy Bool)) --instance IsConst Char where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode instance IsConst Word8 where constOf = constI instance IsConst Word16 where constOf = constI@@ -121,7 +131,9 @@ constOfPtr proto p = let ip = p `minusPtr` nullPtr inttoptrC :: ConstValue int -> ConstValue ptr- inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto)+ inttoptrC (ConstValue v) =+ unsafeConstValue $+ FFI.constIntToPtr v $ unsafeTypeRef $ LP.fromValue proto in if St.sizeOf p == 4 then inttoptrC $ constOf (fromIntegral ip :: Word32) else if St.sizeOf p == 8 then@@ -133,19 +145,24 @@ instance (IsType a) => IsConst (Ptr a) where constOf p = constOfPtr p p +instance (IsFunction a) => IsConst (FunPtr a) where+ constOf p = constOfPtr p (castFunPtrToPtr p)+ instance IsConst (StablePtr a) where constOf p = constOfPtr p (castStablePtrToPtr p) -instance (IsPrimitive a, IsConst a, PositiveT n) => IsConst (Vector n a) where- constOf (Vector xs) = constVector (map constOf xs)+instance (IsPrimitive a, IsConst a, Dec.Positive n) => IsConst (Vector n a) where+ constOf (Vector x) = constVectorGen constOf x -instance (IsConst a, IsSized a, NaturalT n) => IsConst (Array n a) where+instance (IsConst a, IsSized a, Dec.Natural n) => IsConst (Array n a) where constOf (Array xs) = constArray (map constOf xs) instance (IsConstFields a) => IsConst (Struct a) where- constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False+ constOf (Struct a) =+ unsafeConstValue $ U.constStruct (constFieldsOf a) False instance (IsConstFields a) => IsConst (PackedStruct a) where- constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True+ constOf (PackedStruct a) =+ unsafeConstValue $ U.constStruct (constFieldsOf a) True class IsConstFields a where constFieldsOf :: a -> [FFI.ValueRef]@@ -155,14 +172,34 @@ instance IsConstFields () where constFieldsOf _ = [] -constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a-constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 +unsafeConstValue :: IO FFI.ValueRef -> ConstValue a+unsafeConstValue =+ ConstValue . unsafePerformIO++unsafeWithConstValue ::+ forall a.+ (IsType a) =>+ (FFI.TypeRef -> IO FFI.ValueRef) ->+ ConstValue a+unsafeWithConstValue f =+ unsafePerformIO $ fmap ConstValue $+ f =<< typeRef (LP.Proxy :: LP.Proxy a)++constEnum :: (Enum a) => IO FFI.TypeRef -> a -> ConstValue a+constEnum mt i =+ unsafeConstValue $ mt >>= \t -> FFI.constInt t (fromIntegral $ fromEnum i) 0+ constI :: (IsInteger a, Integral a) => a -> ConstValue a-constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i)+constI i =+ unsafeWithConstValue $ \typ ->+ FFI.constInt+ typ (fromIntegral i)+ (fromIntegral $ fromEnum $ isSigned $ LP.fromValue i) constF :: (IsFloating a, Real a) => a -> ConstValue a-constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i)+constF i =+ unsafeWithConstValue $ \typ -> FFI.constReal typ (realToFrac i) valueOf :: (IsConst a) => a -> Value a valueOf = value . constOf@@ -171,13 +208,13 @@ value (ConstValue a) = Value a zero :: forall a . (IsType a) => ConstValue a-zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a)+zero = unsafeWithConstValue FFI.constNull allOnes :: forall a . (IsInteger a) => ConstValue a-allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a)+allOnes = unsafeWithConstValue FFI.constAllOnes undef :: forall a . (IsType a) => ConstValue a-undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a)+undef = unsafeWithConstValue FFI.getUndef {- createString :: String -> ConstValue (DynamicArray Word8)@@ -191,7 +228,7 @@ -- |A function is simply a pointer to the function.-type Function a = Value (Ptr a)+type Function a = Value (FunPtr a) -- | Create a new named function. newNamedFunction :: forall a . (IsFunction a)@@ -200,7 +237,7 @@ -> CodeGenModule (Function a) newNamedFunction linkage name = do modul <- getModule- let typ = typeRef (undefined :: a)+ typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a) liftIO $ liftM Value $ U.addFunction modul linkage name typ -- | Create a new function. Use 'newNamedFunction' to create a function with external linkage, since@@ -330,10 +367,12 @@ liftIO $ liftM BasicBlock $ U.getInsertBlock bld toLabel :: BasicBlock -> Value Label-toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr)+toLabel (BasicBlock ptr) =+ Value (unsafePerformIO $ FFI.basicBlockAsValue ptr) fromLabel :: Value Label -> BasicBlock-fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr)+fromLabel (Value ptr) =+ BasicBlock (unsafePerformIO $ FFI.valueAsBasicBlock ptr) -------------------------------------- @@ -343,13 +382,21 @@ -- | Create a reference to an external function while code generating for a function. -- If LLVM cannot resolve its name, then you may try 'staticFunction'. externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a)-externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage+externFunction name =+ externCore name $+ fmap (unValue :: Function a -> FFI.ValueRef) .+ newNamedFunction ExternalLinkage -- | As 'externFunction', but for 'Global's rather than 'Function's externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a)-externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage+externGlobal isConst name =+ externCore name $+ fmap (unValue :: Global a -> FFI.ValueRef) .+ newNamedGlobal isConst ExternalLinkage -externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a)+externCore ::+ String -> (String -> CodeGenModule FFI.ValueRef) ->+ CodeGenFunction r (Value ptr) externCore name act = do es <- getExterns case lookup name es of@@ -357,7 +404,7 @@ Nothing -> do f <- liftCodeGenModule $ act name putExterns ((name, f) : es)- return $ Value f+ return $ Value f {- | Make an external C function with a fixed address callable from LLVM code.@@ -381,14 +428,14 @@ staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f) staticFunction func = liftCodeGenModule $ do val <- newNamedFunction ExternalLinkage ""- addGlobalMapping (unValue (val :: Function f)) (castFunPtrToPtr func)+ addFunctionMapping (unValue (val :: Function f)) func return val -- | As 'staticFunction', but for 'Global's rather than 'Function's staticGlobal :: forall a r. (IsType a) => Bool -> Ptr a -> CodeGenFunction r (Global a) staticGlobal isConst gbl = liftCodeGenModule $ do val <- newNamedGlobal isConst ExternalLinkage ""- addGlobalMapping (unValue (val :: Global a)) (castPtr gbl)+ addGlobalMapping (unValue (val :: Global a)) gbl return val --------------------------------------@@ -415,10 +462,11 @@ -> TGlobal a newNamedGlobal isConst linkage name = do modul <- getModule- let typ = typeRef (undefined :: a)- liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ- when isConst $ FFI.setGlobalConstant g 1- return g+ typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a)+ liftIO $ liftM Value $ do+ g <- U.addGlobal modul linkage name typ+ when isConst $ FFI.setGlobalConstant g 1+ return g -- | Create a new global variable. newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a@@ -457,34 +505,35 @@ withString :: String ->- (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) ->+ (forall n. (Dec.Natural n) => Global (Array n Word8) -> CodeGenModule a) -> CodeGenModule a withString s act = let n = length s in fromMaybe (error "withString: length must always be non-negative") $- reifyNaturalD (fromIntegral n) (\tn ->+ Dec.reifyNatural (fromIntegral n) (\tn -> do arr <- string n (U.constString s) act (fixArraySize tn arr)) withStringNul :: String ->- (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) ->+ (forall n. (Dec.Natural n) => Global (Array n Word8) -> CodeGenModule a) -> CodeGenModule a withStringNul s act = let n = length s + 1 in fromMaybe (error "withStringNul: length must always be non-negative") $- reifyNaturalD (fromIntegral n) (\tn ->+ Dec.reifyNatural (fromIntegral n) (\tn -> do arr <- string n (U.constStringNul s) act (fixArraySize tn arr)) -fixArraySize :: n -> Global (Array n a) -> Global (Array n a)+fixArraySize :: Proxy n -> Global (Array n a) -> Global (Array n a) fixArraySize _ = id string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8) string n s = do modul <- getModule name <- genMSym "str"- let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n)+ elemTyp <- liftIO $ typeRef (LP.Proxy :: LP.Proxy Word8)+ typ <- liftIO $ FFI.arrayType elemTyp (fromIntegral n) liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ FFI.setGlobalConstant g 1 FFI.setInitializer g s@@ -492,25 +541,80 @@ -------------------------------------- --- |Make a constant vector. Replicates or truncates the list to get length /n/.-constVector :: forall a n . (PositiveT n) => [ConstValue a] -> ConstValue (Vector n a)-constVector xs =- ConstValue $ U.constVector (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ]+-- |Make a constant vector.+constVector ::+ forall a n u.+ (Dec.Positive n, Dec.ToUnary n ~ u,+ UnaryVector.Length (FixedList u) ~ u) =>+ UnaryVector.FixedList u (ConstValue a) ->+ ConstValue (Vector n a)+constVector =+ constVectorGen id --- |Make a constant array. Replicates or truncates the list to get length /n/.-constArray :: forall a n . (IsSized a, NaturalT n) => [ConstValue a] -> ConstValue (Array n a)-constArray xs =- ConstValue $ U.constArray (typeRef (undefined :: a)) (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ]+constVectorGen ::+ forall a b n u.+ (Dec.Positive n, Dec.ToUnary n ~ u) =>+ (b -> ConstValue a) ->+ UnaryVector.FixedList u b ->+ ConstValue (Vector n a)+constVectorGen f xs =+ unsafeConstValue $+ U.constVector+ (case DecProof.unaryNat :: DecProof.UnaryNat n of+ DecProof.UnaryNat ->+ map (unConstValue . f) $+ Fold.toList+ (UnaryVector.Cons xs :: UnaryVector.T u b)) +{- |+Make a constant vector.+Replicates or truncates the list to get length @n@.+-}+constCyclicVector ::+ forall a n.+ (Dec.Positive n) =>+ NonEmpty.T [] (ConstValue a) ->+ ConstValue (Vector n a)+constCyclicVector xs =+ unsafeConstValue $+ U.constVector+ (take (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)) $+ map unConstValue $ NonEmpty.flatten $ NonEmpty.cycle xs)+++constArray ::+ forall a n . (IsSized a, Dec.Natural n) =>+ [ConstValue a] -> ConstValue (Array n a)+constArray xs = unsafeConstValue $ do+ typ <- typeRef (LP.Proxy :: LP.Proxy a)+ U.constArray typ $ map unConstValue xs++{- |+Make a constant array.+Replicates or truncates the list to get length @n@.+-}+constCyclicArray ::+ forall a n.+ (IsSized a, Dec.Natural n) =>+ NonEmpty.T [] (ConstValue a) ->+ ConstValue (Vector n a)+constCyclicArray xs = unsafeConstValue $ do+ typ <- typeRef (LP.Proxy :: LP.Proxy a)+ U.constArray typ+ (take (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)) $+ map unConstValue $ NonEmpty.flatten $ NonEmpty.cycle xs)+ -- |Make a constant struct.-constStruct :: (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c))+constStruct ::+ (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c)) constStruct struct =- ConstValue $ U.constStruct (constValueFieldsOf struct) False+ unsafeConstValue $ U.constStruct (constValueFieldsOf struct) False -- |Make a constant packed struct.-constPackedStruct :: (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c))+constPackedStruct ::+ (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c)) constPackedStruct struct =- ConstValue $ U.constStruct (constValueFieldsOf struct) True+ unsafeConstValue $ U.constStruct (constValueFieldsOf struct) True class IsConstStruct c where type ConstStructOf c :: *
src/LLVM/Core/CodeGenMonad.hs view
@@ -4,19 +4,24 @@ -- * Module code generation CodeGenModule, runCodeGenModule, genMSym, getModule, GlobalMappings(..), addGlobalMapping, getGlobalMappings,+ addFunctionMapping, -- * Function code generation CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, -- * Reexport liftIO ) where -import LLVM.Core.Util(Module, Builder, Function)+import LLVM.Core.Util (Module, Builder, Function) -import Foreign.Ptr (Ptr, )+import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.ExecutionEngine as EE +import Foreign.Ptr (FunPtr, Ptr, )+ import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, ) import Control.Monad.IO.Class (MonadIO, liftIO, ) import Control.Applicative (Applicative, )+import Data.Monoid (Monoid, mempty, mappend, (<>), ) import Data.Typeable (Typeable) @@ -25,7 +30,7 @@ data CGMState = CGMState { cgm_module :: Module, cgm_externs :: [(String, Function)],- cgm_global_mappings :: [(Function, Ptr ())],+ cgm_global_mappings :: GlobalMappings, cgm_next :: !Int } deriving (Show, Typeable)@@ -43,9 +48,12 @@ getModule = CGM $ gets cgm_module runCodeGenModule :: Module -> CodeGenModule a -> IO a-runCodeGenModule m (CGM body) = do- let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] }- evalStateT body cgm+runCodeGenModule m (CGM body) =+ evalStateT body $+ CGMState {+ cgm_module = m, cgm_next = 1,+ cgm_externs = [], cgm_global_mappings = mempty+ } -------------------------------------- @@ -84,15 +92,35 @@ let cgm' = (cgf_module cgf) { cgm_externs = es } CGF $ put (cgf { cgf_module = cgm' }) ++type Value = FFI.ValueRef+ addGlobalMapping ::- Function -> Ptr () -> CodeGenModule ()+ Value -> Ptr a -> CodeGenModule () addGlobalMapping value func = CGM $ modify $ \cgm ->- cgm { cgm_global_mappings =- (value,func) : cgm_global_mappings cgm }+ cgm { cgm_global_mappings =+ cgm_global_mappings cgm <>+ GlobalMappings (\ee -> EE.addGlobalMapping ee value func) } +addFunctionMapping ::+ Function -> FunPtr f -> CodeGenModule ()+addFunctionMapping value func = CGM $ modify $ \cgm ->+ cgm { cgm_global_mappings =+ cgm_global_mappings cgm <>+ GlobalMappings (\ee -> EE.addFunctionMapping ee value func) }+ newtype GlobalMappings =- GlobalMappings [(Function, Ptr ())]+ GlobalMappings (EE.ExecutionEngineRef -> IO ()) +instance Show GlobalMappings where+ show _ = "GlobalMappings"++instance Monoid GlobalMappings where+ mempty = GlobalMappings $ const $ return ()+ mappend (GlobalMappings x) (GlobalMappings y) =+ GlobalMappings (\ee -> x ee >> y ee)++ {- | Get a list created by calls to 'staticFunction' that must be passed to the execution engine@@ -101,7 +129,7 @@ getGlobalMappings :: CodeGenModule GlobalMappings getGlobalMappings =- CGM $ gets (GlobalMappings . cgm_global_mappings)+ CGM $ gets cgm_global_mappings runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a runCodeGenFunction bld fn (CGF body) = do
src/LLVM/Core/Data.hs view
@@ -1,9 +1,20 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE DeriveDataTypeable #-}-module LLVM.Core.Data(IntN(..), WordN(..), FP128(..),- Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where+{-# LANGUAGE ScopedTypeVariables #-}+module LLVM.Core.Data (+ IntN(..), WordN(..), FP128(..),+ Array(..), Vector(..), Label, Struct(..), PackedStruct(..),+ FixedList,+ ) where -import Foreign.Ptr (Ptr)+import qualified LLVM.Core.UnaryVector as UnaryVector+import LLVM.Core.UnaryVector (FixedList)++import qualified Type.Data.Num.Decimal.Proof as DecProof+import qualified Type.Data.Num.Decimal.Number as Dec++import qualified Data.Foldable as Fold+ import Data.Typeable (Typeable) @@ -26,13 +37,22 @@ newtype FP128 = FP128 Rational deriving (Show, Typeable) + -- |Fixed sized arrays, the array size is encoded in the /n/ parameter. newtype Array n a = Array [a] deriving (Show, Typeable) -- |Fixed sized vector, the array size is encoded in the /n/ parameter.-newtype Vector n a = Vector [a]- deriving (Show, Typeable)+newtype Vector n a = Vector (FixedList (Dec.ToUnary n) a)++instance (Dec.Natural n, Show a) => Show (Vector n a) where+ showsPrec p (Vector xs) =+ case DecProof.unaryNat :: DecProof.UnaryNat n of+ DecProof.UnaryNat ->+ showParen (p>10) $+ showString "Vector " .+ showList (Fold.toList+ (UnaryVector.Cons xs :: UnaryVector.T (Dec.ToUnary n) a)) -- |Label type, produced by a basic block. data Label
src/LLVM/Core/Instructions.hs view
@@ -53,7 +53,7 @@ bitcastElements, -- * Comparison CmpPredicate(..), IntPredicate(..), FPPredicate(..),- CmpOp, CmpRet, CmpResult,+ CmpOp, CmpRet, CmpResult, CmpValueResult, cmp, pcmp, icmp, fcmp, select, -- * Other@@ -64,14 +64,16 @@ -- * Classes and types Terminate,- Ret, CallArgs, ABinOp, ABinOpResult, IsConst,+ Ret, CallArgs, AUnOp, ABinOp, ABinOpResult, IsConst, FunctionArgs, FunctionCodeGen, FunctionResult, AllocArg, GetElementPtr, ElementPtrType, IsIndexArg,- GetValue, ValueType+ GetValue, ValueType,+ GetField, FieldType, ) where import qualified LLVM.Core.Util as U+import qualified LLVM.Util.Proxy as LP import LLVM.Core.Data import LLVM.Core.Type import LLVM.Core.CodeGenMonad@@ -79,10 +81,12 @@ import qualified LLVM.FFI.Core as FFI -import Types.Data.Num (Dec, DecN, (:.), d1, fromIntegerT, Pred)-import Types.Data.Ord (LTT, GTT)+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Literal (d1)+import Type.Data.Num.Decimal.Number (Pred, (:<:), (:>:))+import Type.Base.Proxy (Proxy) -import Foreign.Ptr (FunPtr, )+import Foreign.Ptr (Ptr, FunPtr, ) import Foreign.C (CInt, CUInt) import Control.Monad (liftM)@@ -309,7 +313,7 @@ -------------------------------------- type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef-type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef+type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef withArithmeticType ::@@ -323,6 +327,10 @@ type ABinOpResult a b :: * abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b) +-- |Acceptable arguments to arithmetic unary instructions.+class AUnOp a where+ aunop :: FFIConstUnOp -> FFIUnOp -> a -> CodeGenFunction r a+ add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) add = curry $ withArithmeticType $ \typ -> uncurry $ case typ of@@ -353,7 +361,7 @@ forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) idiv =- if isSigned (undefined :: c)+ if isSigned (LP.Proxy :: LP.Proxy c) then abinop FFI.constSDiv FFI.buildSDiv else abinop FFI.constUDiv FFI.buildUDiv -- | signed or unsigned remainder depending on the type@@ -361,7 +369,7 @@ forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) irem =- if isSigned (undefined :: c)+ if isSigned (LP.Proxy :: LP.Proxy c) then abinop FFI.constSRem FFI.buildSRem else abinop FFI.constURem FFI.buildURem @@ -420,7 +428,7 @@ instance ABinOp (ConstValue a) (ConstValue a) where type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a abinop cop _ (ConstValue a1) (ConstValue a2) =- return $ ConstValue $ cop a1 a2+ liftIO $ fmap ConstValue $ cop a1 a2 {- instance (IsConst a) => ABinOp (Value a) a where@@ -435,6 +443,14 @@ --instance (IsConst a) => ABinOp a a (ConstValue a) where -- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2) ++instance AUnOp (Value a) where+ aunop _ op (Value a) = buildUnOp op a++instance AUnOp (ConstValue a) where+ aunop cop _ (ConstValue a) = liftIO $ fmap ConstValue $ cop a++ buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a) buildBinOp op a1 a2 = liftM Value $@@ -442,6 +458,7 @@ U.withEmptyCString $ op bld a1 a2 type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef+type FFIConstUnOp = FFI.ValueRef -> IO FFI.ValueRef buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a) buildUnOp op a =@@ -449,28 +466,34 @@ withCurrentBuilder $ \ bld -> U.withEmptyCString $ op bld a -neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)+neg ::+ (IsArithmetic b, AUnOp a, a ~ v b) =>+ a -> CodeGenFunction r a neg = withArithmeticType $ \typ -> case typ of- IntegerType -> \(Value x) -> buildUnOp FFI.buildNeg x- FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a)+ IntegerType -> aunop FFI.constNeg FFI.buildNeg+ FloatingType -> aunop FFI.constFNeg FFI.buildFNeg -ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)-ineg (Value x) = buildUnOp FFI.buildNeg x+ineg ::+ (IsInteger b, AUnOp a, a ~ v b) =>+ a -> CodeGenFunction r a+ineg = aunop FFI.constNeg FFI.buildNeg -fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a)-fneg = fsub (value zero :: Value a)+fneg ::+ (IsFloating b, AUnOp a, a ~ v b) =>+ a -> CodeGenFunction r a {--fneg (Value x) = buildUnOp FFI.buildFNeg x+fneg = fsub (value zero :: Value a) -}+fneg = aunop FFI.constFNeg FFI.buildFNeg -inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)-inv (Value x) = buildUnOp FFI.buildNot x+inv :: (IsInteger b, AUnOp a, a ~ v b) => a -> CodeGenFunction r a+inv = aunop FFI.constNot FFI.buildNot -------------------------------------- -- | Get a value from a vector.-extractelement :: (PositiveT n)+extractelement :: (Dec.Positive n) => Value (Vector n a) -- ^ Vector -> Value Word32 -- ^ Index into the vector -> CodeGenFunction r (Value a)@@ -480,7 +503,7 @@ U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i -- | Insert a value into a vector, nondestructive.-insertelement :: (PositiveT n)+insertelement :: (Dec.Positive n) => Value (Vector n a) -- ^ Vector -> Value a -- ^ Value to insert -> Value Word32 -- ^ Index into the vector@@ -491,7 +514,7 @@ U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i -- | Permute vector.-shufflevector :: (PositiveT n, PositiveT m)+shufflevector :: (Dec.Positive n, Dec.Positive m) => Value (Vector n a) -> Value (Vector n a) -> ConstValue (Vector m Word32)@@ -505,24 +528,24 @@ -- |Acceptable arguments to 'extractvalue' and 'insertvalue'. class GetValue agg ix where type ValueType agg ix :: *- getIx :: agg -> ix -> CUInt+ getIx :: LP.Proxy agg -> ix -> CUInt -instance (GetField as i, NaturalT i) => GetValue (Struct as) i where- type ValueType (Struct as) i = FieldType as i- getIx _ n = fromIntegerT n+instance (GetField as i, Dec.Natural i) => GetValue (Struct as) (Proxy i) where+ type ValueType (Struct as) (Proxy i) = FieldType as i+ getIx _ n = Dec.integralFromProxy n -instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where+instance (IsFirstClass a, Dec.Natural n) => GetValue (Array n a) Word32 where type ValueType (Array n a) Word32 = a getIx _ n = fromIntegral n -instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where+instance (IsFirstClass a, Dec.Natural n) => GetValue (Array n a) Word64 where type ValueType (Array n a) Word64 = a getIx _ n = fromIntegral n -instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where- type ValueType (Array n a) (Dec i) = a- getIx _ n = fromIntegerT n+instance (IsFirstClass a, Dec.Natural n, Dec.Natural i, i :<: n) => GetValue (Array n a) (Proxy i) where+ type ValueType (Array n a) (Proxy i) = a+ getIx _ n = Dec.integralFromProxy n -- | Get a value from an aggregate.@@ -535,7 +558,7 @@ liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $- FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i)+ FFI.buildExtractValue bldPtr agg (getIx (LP.Proxy :: LP.Proxy agg) i) -- | Insert a value into an aggregate, nondestructive. insertvalue :: forall r agg i.@@ -548,7 +571,7 @@ liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $- FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i)+ FFI.buildInsertValue bldPtr agg e (getIx (LP.Proxy :: LP.Proxy agg) i) --------------------------------------@@ -556,29 +579,29 @@ -- XXX should allows constants -- | Truncate a value to a shorter bit width.-trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))+trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, SizeOf a :>: SizeOf b) => Value a -> CodeGenFunction r (Value b) trunc = convert FFI.buildTrunc -- | Zero extend a value to a wider width. -- If possible, use 'ext' that chooses the right padding according to the types-zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, SizeOf a :<: SizeOf b) => Value a -> CodeGenFunction r (Value b) zext = convert FFI.buildZExt -- | Sign extend a value to wider width. -- If possible, use 'ext' that chooses the right padding according to the types-sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, SizeOf a :<: SizeOf b) => Value a -> CodeGenFunction r (Value b) sext = convert FFI.buildSExt -- | Extend a value to wider width. -- If the target type is signed, then preserve the sign, -- If the target type is unsigned, then extended by zeros.-ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, SizeOf a :<: SizeOf b) => Value a -> CodeGenFunction r (Value b) ext =- if isSigned (undefined :: b)+ if isSigned (LP.Proxy :: LP.Proxy b) then convert FFI.buildSExt else convert FFI.buildZExt @@ -587,8 +610,8 @@ zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) zadapt =- case compare (sizeOf (typeDesc (undefined :: a)))- (sizeOf (typeDesc (undefined :: b))) of+ case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+ (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of LT -> convert FFI.buildZExt EQ -> convert FFI.buildBitCast GT -> convert FFI.buildTrunc@@ -597,8 +620,8 @@ sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) sadapt =- case compare (sizeOf (typeDesc (undefined :: a)))- (sizeOf (typeDesc (undefined :: b))) of+ case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+ (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of LT -> convert FFI.buildSExt EQ -> convert FFI.buildBitCast GT -> convert FFI.buildTrunc@@ -607,22 +630,22 @@ adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b) => Value a -> CodeGenFunction r (Value b) adapt =- case compare (sizeOf (typeDesc (undefined :: a)))- (sizeOf (typeDesc (undefined :: b))) of+ case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+ (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of LT ->- if isSigned (undefined :: b)+ if isSigned (LP.Proxy :: LP.Proxy b) then convert FFI.buildSExt else convert FFI.buildZExt EQ -> convert FFI.buildBitCast GT -> convert FFI.buildTrunc -- | Truncate a floating point value.-fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))+fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, SizeOf a :>: SizeOf b) => Value a -> CodeGenFunction r (Value b) fptrunc = convert FFI.buildFPTrunc -- | Extend a floating point value.-fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, SizeOf a :<: SizeOf b) => Value a -> CodeGenFunction r (Value b) fpext = convert FFI.buildFPExt @@ -640,7 +663,7 @@ -- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@. fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) fptoint =- if isSigned (undefined :: b)+ if isSigned (LP.Proxy :: LP.Proxy b) then convert FFI.buildFPToSI else convert FFI.buildFPToUI @@ -661,7 +684,7 @@ -- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@. inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) inttofp =- if isSigned (undefined :: a)+ if isSigned (LP.Proxy :: LP.Proxy a) then convert FFI.buildSIToFP else convert FFI.buildUIToFP @@ -680,7 +703,7 @@ bitcast = convert FFI.buildBitCast -- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same.-bitcastElements :: (PositiveT n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)+bitcastElements :: (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.buildBitCast @@ -690,8 +713,9 @@ convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b) convert conv (Value a) = liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b))+ withCurrentBuilder $ \ bldPtr -> do+ typ <- typeRef (LP.Proxy :: LP.Proxy b)+ U.withEmptyCString $ conv bldPtr a typ -------------------------------------- @@ -779,15 +803,37 @@ 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 :: *- cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (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- cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2+ 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@@ -800,23 +846,26 @@ class CmpRet c where type CmpResult c :: *- cmpBld :: c -> CmpPredicate -> FFIBinOp+ cmpBld :: LP.Proxy c -> CmpPredicate -> FFIBinOp+ cmpCnst :: LP.Proxy c -> CmpPredicate -> FFIConstBinOp -instance CmpRet Float where type CmpResult Float = Bool ; cmpBld _ = fcmpBld-instance CmpRet Double where type CmpResult Double = Bool ; cmpBld _ = fcmpBld-instance CmpRet FP128 where type CmpResult FP128 = Bool ; cmpBld _ = fcmpBld-instance CmpRet Bool where type CmpResult Bool = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word8 where type CmpResult Word8 = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word16 where type CmpResult Word16 = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word32 where type CmpResult Word32 = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word64 where type CmpResult Word64 = Bool ; cmpBld _ = ucmpBld-instance CmpRet Int8 where type CmpResult Int8 = Bool ; cmpBld _ = scmpBld-instance CmpRet Int16 where type CmpResult Int16 = Bool ; cmpBld _ = scmpBld-instance CmpRet Int32 where type CmpResult Int32 = Bool ; cmpBld _ = scmpBld-instance CmpRet Int64 where type CmpResult Int64 = Bool ; cmpBld _ = scmpBld-instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld-instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a)- where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; cmpBld _ = cmpBld (undefined :: a)+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 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) {- |@@ -827,11 +876,14 @@ Pointers are compared unsigned. These choices are consistent with comparison in plain Haskell. -}-cmp :: forall a b c r.- (CmpOp a b, c ~ CmpType a b) =>+cmp :: forall a b r.+ (CmpOp a b) => CmpPredicate -> a -> b ->- CodeGenFunction r (Value (CmpResult c))-cmp p = cmpop (cmpBld (undefined :: CmpType a b) p)+ CodeGenFunction r (CmpValueResult a b)+cmp p =+ cmpop+ (cmpCnst (LP.Proxy :: LP.Proxy (CmpType a b)) p)+ (cmpBld (LP.Proxy :: LP.Proxy (CmpType a b)) p) ucmpBld :: CmpPredicate -> FFIBinOp ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))@@ -843,29 +895,48 @@ fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p)) +ucmpCnst :: CmpPredicate -> FFIConstBinOp+ucmpCnst p = FFI.constICmp (fromIntPredicate (uintFromCmpPredicate p))++scmpCnst :: CmpPredicate -> FFIConstBinOp+scmpCnst p = FFI.constICmp (fromIntPredicate (sintFromCmpPredicate p))++fcmpCnst :: CmpPredicate -> FFIConstBinOp+fcmpCnst p = FFI.constFCmp (fromFPPredicate (fpFromCmpPredicate p))++ _ucmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>- CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)))+ CmpPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)+_ucmp p = cmpop (ucmpCnst p) (ucmpBld p) _scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>- CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)))+ CmpPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)+_scmp p = cmpop (scmpCnst p) (scmpBld p) pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) =>- IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c)))-pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))+ IntPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)+pcmp p =+ cmpop+ (FFI.constICmp (fromIntPredicate p))+ (flip FFI.buildICmp (fromIntPredicate p)) {-# DEPRECATED icmp "use cmp or pcmp instead" #-} -- | Compare integers. icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) =>- IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))+ IntPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)+icmp p =+ cmpop+ (FFI.constICmp (fromIntPredicate p))+ (flip FFI.buildICmp (fromIntPredicate p)) -- | Compare floating point values. fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) =>- FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p))+ FPPredicate -> a -> b -> CodeGenFunction r (CmpValueResult a b)+fcmp p =+ cmpop+ (FFI.constFCmp (fromFPPredicate p))+ (flip FFI.buildFCmp (fromFPPredicate p)) -------------------------------------- @@ -902,7 +973,7 @@ doCall f a = doCall (applyCall f a) --instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where--- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a))+-- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (LP.Proxy :: LP.Proxy a)) instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where type CalledFunction (CodeGenFunction r (Value a)) = IO a@@ -997,7 +1068,7 @@ phi incoming = liftM Value $ withCurrentBuilder $ \ bldPtr -> do- inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a))+ inst <- U.buildEmptyPhi bldPtr =<< typeRef (LP.Proxy :: LP.Proxy a) U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] return inst @@ -1078,8 +1149,8 @@ func <- staticFunction alignedMalloc -- func <- externFunction "malloc" - size <- sizeOfArray (undefined :: a) (getAllocArg s)- alignment <- alignOf (undefined :: a)+ size <- sizeOfArray (LP.Proxy :: LP.Proxy a) (getAllocArg s)+ alignment <- alignOf (LP.Proxy :: LP.Proxy a) bitcast =<< call (func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)))@@ -1091,8 +1162,9 @@ alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a)) alloca = liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a))+ withCurrentBuilder $ \ bldPtr -> do+ typ <- typeRef (LP.Proxy :: LP.Proxy a)+ U.withEmptyCString $ FFI.buildAlloca bldPtr typ -- XXX What's the type returned by arrayAlloca? -- | Allocate stack (array) memory.@@ -1100,9 +1172,10 @@ s -> CodeGenFunction r (Value (Ptr a)) arrayAlloca s = liftM Value $- withCurrentBuilder $ \ bldPtr ->+ withCurrentBuilder $ \ bldPtr -> do+ typ <- typeRef (LP.Proxy :: LP.Proxy a) U.withEmptyCString $- FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (case getAllocArg s of Value v -> v)+ FFI.buildArrayAlloca bldPtr typ (case getAllocArg s of Value v -> v) -- FFI.buildFree deprecated since LLVM-2.7 -- XXX What's the type of free?@@ -1118,26 +1191,34 @@ -- | If we want to export that, then we should have a Size type -- This is the official implementation, -- but it suffers from the ptrtoint(gep) bug.-_sizeOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64)+_sizeOf ::+ forall a r.+ (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word64) _sizeOf a = liftIO $ liftM Value $- FFI.sizeOf (typeRef a)+ FFI.sizeOf =<< typeRef a -_alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64)+_alignOf ::+ forall a r.+ (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word64) _alignOf a = liftIO $ liftM Value $- FFI.alignOf (typeRef a)+ FFI.alignOf =<< typeRef a -- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281. -- see ConstantExpr::getSizeOf-sizeOfArray :: forall a r . (IsSized a) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8))+sizeOfArray ::+ forall a r . (IsSized a) =>+ LP.Proxy a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8)) sizeOfArray _ len = bitcast =<< getElementPtr (value zero :: Value (Ptr a)) (len, ()) -- see ConstantExpr::getAlignOf-alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value (Ptr Word8))+alignOf ::+ forall a r . (IsSized a) =>+ LP.Proxy a -> CodeGenFunction r (Value (Ptr Word8)) alignOf _ = bitcast =<< getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())@@ -1177,7 +1258,7 @@ -- |Acceptable arguments to 'getElementPointer'. class GetElementPtr optr ixs where type ElementPtrType optr ixs :: *- getIxList :: optr -> ixs -> [FFI.ValueRef]+ getIxList :: LP.Proxy optr -> ixs -> [FFI.ValueRef] -- |Acceptable single index to 'getElementPointer'. class IsIndexArg a where@@ -1228,27 +1309,27 @@ getIxList _ () = [] -- Index in Array-instance (GetElementPtr o i, IsIndexArg a, NaturalT k) => GetElementPtr (Array k o) (a, i) where+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 (undefined :: o) i+ getIxList _ (v, i) = getArg v : getIxList (LP.Proxy :: LP.Proxy o) i -- Index in Vector-instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where+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 (undefined :: 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, NaturalT a) => GetElementPtr (Struct fs) (a, i) where- type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i- getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i-instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where- type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i- getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i+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 DecN) where type FieldType (a, as) (Dec DecN) = a-instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0)))+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,( ... ())))@.@@ -1256,7 +1337,7 @@ getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) => Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) getElementPtr (Value ptr) (a, ixs) =- let ixl = getArg a : getIxList (undefined :: o) ixs in+ let ixl = getArg a : getIxList (LP.Proxy :: LP.Proxy o) ixs in liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withArrayLen ixl $ \ idxLen idxPtr ->
src/LLVM/Core/Type.hs view
@@ -17,8 +17,8 @@ -- * Type classifier IsType(..), -- ** Special type classifiers- NaturalT,- PositiveT,+ Dec.Natural,+ Dec.Positive, IsArithmetic(arithmeticType), ArithmeticType(IntegerType,FloatingType), IsInteger, Signed,@@ -30,6 +30,7 @@ IsFunction, -- ** Others IsScalarOrVector, NumberOfElements,+ StructFields, UnknownSize, -- needed for arrays of structs -- ** Structs (:&), (&),@@ -38,6 +39,7 @@ isFloating, isSigned, typeRef,+ unsafeTypeRef, typeName, intrinsicTypeName, typeDesc2,@@ -48,11 +50,16 @@ import LLVM.Core.Util (functionType, structType) import LLVM.Core.Data+import LLVM.Util.Proxy (Proxy(Proxy)) -import Types.Data.Num-import Types.Data.Bool (True, False)+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Number ((:*:))+import Type.Data.Num.Decimal.Literal (D1, D8, D16, D32, D64, D128, D99)+import Type.Data.Bool (True, False) import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (FunPtr, Ptr)+import System.IO.Unsafe (unsafePerformIO) import Data.Typeable (Typeable) import Data.List (intercalate)@@ -65,30 +72,45 @@ -- TODO: -- Move IntN, WordN to a special module that implements those types -- properly in Haskell.--- Also more Array and Vector to a Haskell module to implement them.+-- Also move Array and Vector to a Haskell module to implement them. -- Add Label? -- Add structures (using tuples, maybe nested). -- |The 'IsType' class classifies all types that have an LLVM representation. class IsType a where- typeDesc :: a -> TypeDesc+ typeDesc :: Proxy a -> TypeDesc -typeRef :: (IsType a) => a -> FFI.TypeRef -- ^The argument is never evaluated+typeRef :: (IsType a) => Proxy a -> IO FFI.TypeRef typeRef = code . typeDesc where code TDFloat = FFI.floatType code TDDouble = FFI.doubleType code TDFP128 = FFI.fP128Type code TDVoid = FFI.voidType code (TDInt _ n) = FFI.integerType (fromInteger n)- code (TDArray n a) = FFI.arrayType (code a) (fromInteger n)- code (TDVector n a) = FFI.vectorType (code a) (fromInteger n)- code (TDPtr a) = FFI.pointerType (code a) 0- code (TDFunction va as b) = functionType va (code b) (map code as)+ code (TDArray n a) = withCode FFI.arrayType (code a) (fromInteger n)+ code (TDVector n a) = withCode FFI.vectorType (code a) (fromInteger n)+ code (TDPtr a) = withCode FFI.pointerType (code a) 0+ code (TDFunction va as b) = do+ bt <- code b+ ast <- mapM code as+ functionType va bt ast code TDLabel = FFI.labelType- code (TDStruct ts packed) = structType (map code ts) packed+ code (TDStruct ts packed) = withCode structType (mapM code ts) packed code TDInvalidType = error "typeRef TDInvalidType" -typeName :: (IsType a) => a -> String+unsafeTypeRef :: (IsType a) => Proxy a -> FFI.TypeRef+unsafeTypeRef = unsafePerformIO . typeRef+++withCode ::+ Monad m =>+ (a -> b -> m c) ->+ m a -> b -> m c+withCode f mx y =+ mx >>= \x -> f x y+++typeName :: (IsType a) => Proxy a -> String typeName = code . typeDesc where code TDFloat = "f32" code TDDouble = "f64"@@ -105,7 +127,7 @@ (if packed then "}>" else "}") code TDInvalidType = error "typeName TDInvalidType" -intrinsicTypeName :: (IsType a) => a -> String+intrinsicTypeName :: (IsType a) => Proxy a -> String intrinsicTypeName = code . typeDesc where code TDFloat = "f32" code TDDouble = "f64"@@ -171,6 +193,13 @@ fmap _ IntegerType = IntegerType fmap _ FloatingType = FloatingType +vectorArithmeticType :: ArithmeticType a -> ArithmeticType (Vector n a)+vectorArithmeticType t =+ case t of+ IntegerType -> IntegerType+ FloatingType -> FloatingType++ -- Usage: -- constI, allOnes -- many instructions. XXX some need vector@@ -184,7 +213,7 @@ -- |Integral or pointer type. class IsIntegerOrPointer a -isSigned :: (IsInteger a) => a -> Bool+isSigned :: (IsInteger a) => Proxy a -> Bool isSigned = is . typeDesc where is (TDInt s _) = s is (TDVector _ a) = is a@@ -196,7 +225,7 @@ -- |Floating types. class IsArithmetic a => IsFloating a -isFloating :: (IsArithmetic a) => a -> Bool+isFloating :: (IsArithmetic a) => Proxy a -> Bool isFloating = is . typeDesc where is TDFloat = True is TDDouble = True@@ -226,7 +255,7 @@ -- Context for Array being a type -- thus, allocation instructions -- |Types with a fixed size.-class (IsType a, PositiveT (SizeOf a)) => IsSized a where+class (IsType a, Dec.Natural (SizeOf a)) => IsSized a where type SizeOf a :: * sizeOf :: TypeDesc -> Integer@@ -241,7 +270,7 @@ -- |Function type. class (IsType a) => IsFunction a where- funcType :: [TypeDesc] -> a -> TypeDesc+ funcType :: [TypeDesc] -> Proxy a -> TypeDesc -- Only make instances for types that make sense in Haskell -- (i.e., some floating types are excluded).@@ -258,11 +287,15 @@ instance IsType Label where typeDesc _ = TDLabel -- Variable size integer types-instance (PositiveT n) => IsType (IntN n)- where typeDesc _ = TDInt True (fromIntegerT (undefined :: n))+instance (Dec.Positive n) => IsType (IntN n)+ where typeDesc _ =+ TDInt True+ (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)) -instance (PositiveT n) => IsType (WordN n)- where typeDesc _ = TDInt False (fromIntegerT (undefined :: n))+instance (Dec.Positive n) => IsType (WordN n)+ where typeDesc _ =+ TDInt False+ (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)) -- Fixed size integer types. instance IsType Bool where typeDesc _ = TDInt False 1@@ -276,19 +309,26 @@ instance IsType Int64 where typeDesc _ = TDInt True 64 -- Sequence types-instance (NaturalT n, IsSized a) => IsType (Array n a)- where typeDesc _ = TDArray (fromIntegerT (undefined :: n))- (typeDesc (undefined :: a))-instance (PositiveT n, IsPrimitive a) => IsType (Vector n a)- where typeDesc _ = TDVector (fromIntegerT (undefined :: n))- (typeDesc (undefined :: a))+instance (Dec.Natural n, IsSized a) => IsType (Array n a)+ where typeDesc _ =+ TDArray+ (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))+ (typeDesc (Proxy :: Proxy a))+instance (Dec.Positive n, IsPrimitive a) => IsType (Vector n a)+ where typeDesc _ =+ TDVector+ (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))+ (typeDesc (Proxy :: Proxy a)) -- Pointer type. instance (IsType a) => IsType (Ptr a) where- typeDesc _ = TDPtr (typeDesc (undefined :: a))+ typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy a)) +instance (IsFunction f) => IsType (FunPtr f) where+ typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy f))+ instance IsType (StablePtr a) where- typeDesc _ = TDPtr (typeDesc (undefined :: Int8))+ typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy Int8)) {- typeDesc _ = TDPtr TDVoid @@ -306,19 +346,19 @@ -- Struct types, basically a list of component types. instance (StructFields a) => IsType (Struct a) where- typeDesc ~(Struct a) = TDStruct (fieldTypes a) False+ typeDesc p = TDStruct (fieldTypes $ fmap (\(Struct a) -> a) p) False instance (StructFields a) => IsType (PackedStruct a) where- typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True+ typeDesc p = TDStruct (fieldTypes $ fmap (\(PackedStruct a) -> a) p) True -- Use a nested tuples for struct fields. class StructFields as where- fieldTypes :: as -> [TypeDesc]+ fieldTypes :: Proxy as -> [TypeDesc] instance (IsSized a, StructFields as) => StructFields (a :& as) where- fieldTypes ~(a, as) = typeDesc a : fieldTypes as+ fieldTypes p = typeDesc (fmap fst p) : fieldTypes (fmap snd p) instance StructFields () where- fieldTypes _ = []+ fieldTypes Proxy = [] -- An alias for pairs to make structs look nicer infixr :&@@ -331,8 +371,8 @@ instance IsArithmetic Float where arithmeticType = FloatingType instance IsArithmetic Double where arithmeticType = FloatingType instance IsArithmetic FP128 where arithmeticType = FloatingType-instance (PositiveT n) => IsArithmetic (IntN n) where arithmeticType = IntegerType-instance (PositiveT n) => IsArithmetic (WordN n) where arithmeticType = IntegerType+instance (Dec.Positive n) => IsArithmetic (IntN n) where arithmeticType = IntegerType+instance (Dec.Positive n) => IsArithmetic (WordN n) where arithmeticType = IntegerType instance IsArithmetic Bool where arithmeticType = IntegerType instance IsArithmetic Int8 where arithmeticType = IntegerType instance IsArithmetic Int16 where arithmeticType = IntegerType@@ -342,19 +382,20 @@ instance IsArithmetic Word16 where arithmeticType = IntegerType instance IsArithmetic Word32 where arithmeticType = IntegerType instance IsArithmetic Word64 where arithmeticType = IntegerType-instance (PositiveT n, IsPrimitive a, IsArithmetic a) =>+instance (Dec.Positive n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a) where- arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType+ arithmeticType = vectorArithmeticType arithmeticType+-- arithmeticType = fmap (pure :: a -> Vector n a) arithmeticType instance IsFloating Float instance IsFloating Double instance IsFloating FP128-instance (PositiveT n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)+instance (Dec.Positive n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a) data NotANumber -instance (PositiveT n) => IsInteger (IntN n) where type Signed (IntN n) = True-instance (PositiveT n) => IsInteger (WordN n) where type Signed (WordN n) = False+instance (Dec.Positive n) => IsInteger (IntN n) where type Signed (IntN n) = True+instance (Dec.Positive n) => IsInteger (WordN n) where type Signed (WordN n) = False instance IsInteger Bool where type Signed Bool = NotANumber instance IsInteger Int8 where type Signed Int8 = True instance IsInteger Int16 where type Signed Int16 = True@@ -364,11 +405,11 @@ instance IsInteger Word16 where type Signed Word16 = False instance IsInteger Word32 where type Signed Word32 = False instance IsInteger Word64 where type Signed Word64 = False-instance (PositiveT n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)+instance (Dec.Positive n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a) where type Signed (Vector n a) = Signed a -instance (PositiveT n) => IsIntegerOrPointer (IntN n)-instance (PositiveT n) => IsIntegerOrPointer (WordN n)+instance (Dec.Positive n) => IsIntegerOrPointer (IntN n)+instance (Dec.Positive n) => IsIntegerOrPointer (WordN n) instance IsIntegerOrPointer Bool instance IsIntegerOrPointer Int8 instance IsIntegerOrPointer Int16@@ -378,14 +419,14 @@ instance IsIntegerOrPointer Word16 instance IsIntegerOrPointer Word32 instance IsIntegerOrPointer Word64-instance (PositiveT n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a)+instance (Dec.Positive n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a) instance (IsType a) => IsIntegerOrPointer (Ptr a) instance IsFirstClass Float instance IsFirstClass Double instance IsFirstClass FP128-instance (PositiveT n) => IsFirstClass (IntN n)-instance (PositiveT n) => IsFirstClass (WordN n)+instance (Dec.Positive n) => IsFirstClass (IntN n)+instance (Dec.Positive n) => IsFirstClass (WordN n) instance IsFirstClass Bool instance IsFirstClass Int8 instance IsFirstClass Int16@@ -395,16 +436,17 @@ instance IsFirstClass Word16 instance IsFirstClass Word32 instance IsFirstClass Word64-instance (PositiveT n, IsPrimitive a) => IsFirstClass (Vector n a)-instance (NaturalT n, IsSized a) => IsFirstClass (Array n a)+instance (Dec.Positive n, IsPrimitive a) => IsFirstClass (Vector n a)+instance (Dec.Natural n, IsSized a) => IsFirstClass (Array n a) instance (IsType a) => IsFirstClass (Ptr a)+instance (IsFunction a) => IsFirstClass (FunPtr a) instance IsFirstClass (StablePtr a) instance IsFirstClass Label instance IsFirstClass () -- XXX This isn't right, but () can be returned instance (StructFields as) => IsFirstClass (Struct as) -instance (PositiveT n) => IsSized (IntN n) where type SizeOf (IntN n) = n-instance (PositiveT n) => IsSized (WordN n) where type SizeOf (WordN n) = n+instance (Dec.Positive n) => IsSized (IntN n) where type SizeOf (IntN n) = n+instance (Dec.Positive n) => IsSized (WordN n) where type SizeOf (WordN n) = n instance IsSized Float where type SizeOf Float = D32 instance IsSized Double where type SizeOf Double = D64 instance IsSized FP128 where type SizeOf FP128 = D128@@ -417,11 +459,20 @@ instance IsSized Word16 where type SizeOf Word16 = D16 instance IsSized Word32 where type SizeOf Word32 = D32 instance IsSized Word64 where type SizeOf Word64 = D64-instance (NaturalT n, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Array n a) where+{-+Can we derive Dec.Natural (n :*: SizeOf a)+from (Dec.Natural n, Dec.Natural (n :*: SizeOf a))?+-}+instance+ (Dec.Natural n, IsSized a, Dec.Natural (n :*: SizeOf a)) =>+ IsSized (Array n a) where type SizeOf (Array n a) = n :*: SizeOf a-instance (PositiveT n, IsPrimitive a, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Vector n a) where+instance+ (Dec.Positive n, IsPrimitive a, IsSized a, Dec.Natural (n :*: SizeOf a)) =>+ IsSized (Vector n a) where type SizeOf (Vector n a) = n :*: SizeOf a instance (IsType a) => IsSized (Ptr a) where type SizeOf (Ptr a) = PtrSize+instance (IsFunction a) => IsSized (FunPtr a) where type SizeOf (FunPtr a) = PtrSize instance IsSized (StablePtr a) where type SizeOf (StablePtr a) = PtrSize -- instance IsSized Label PtrSize -- labels are not quite first classed -- We cannot compute the sizes statically :(@@ -443,8 +494,8 @@ instance IsPrimitive Float instance IsPrimitive Double instance IsPrimitive FP128-instance (PositiveT n) => IsPrimitive (IntN n)-instance (PositiveT n) => IsPrimitive (WordN n)+instance (Dec.Positive n) => IsPrimitive (IntN n)+instance (Dec.Positive n) => IsPrimitive (WordN n) instance IsPrimitive Bool instance IsPrimitive Int8 instance IsPrimitive Int16@@ -458,9 +509,9 @@ instance IsPrimitive () -instance (PositiveT n) =>+instance (Dec.Positive n) => IsScalarOrVector (IntN n) where type NumberOfElements (IntN n) = D1-instance (PositiveT n) =>+instance (Dec.Positive n) => IsScalarOrVector (WordN n) where type NumberOfElements (WordN n) = D1 instance IsScalarOrVector Float where type NumberOfElements Float = D1 instance IsScalarOrVector Double where type NumberOfElements Double = D1@@ -477,18 +528,18 @@ instance IsScalarOrVector Label where type NumberOfElements Label = D1 instance IsScalarOrVector () where type NumberOfElements () = D1 -instance (PositiveT n, IsPrimitive a) =>+instance (Dec.Positive n, IsPrimitive a) => IsScalarOrVector (Vector n a) where type NumberOfElements (Vector n a) = n -- Functions. instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where- funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b)+ funcType ts _ = funcType (typeDesc (Proxy :: Proxy a) : ts) (Proxy :: Proxy b) instance (IsFirstClass a) => IsFunction (IO a) where- funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a))+ funcType ts _ = TDFunction False (reverse ts) (typeDesc (Proxy :: Proxy a)) instance (IsFirstClass a) => IsFunction (VarArgs a) where- funcType ts _ = TDFunction True (reverse ts) (typeDesc (undefined :: a))+ funcType ts _ = TDFunction True (reverse ts) (typeDesc (Proxy :: Proxy a)) -- |The 'VarArgs' type is a placeholder for the real 'IO' type that -- can be obtained with 'castVarArgs'.
+ src/LLVM/Core/UnaryVector.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Core.UnaryVector (+ T(Cons), vector, cyclicVector, empty, cons, withEmpty, withHead, with, head,+ FixedList, Length, With,+ ) where++import qualified Type.Data.Num.Unary as Unary++import Control.Applicative (Applicative, pure, liftA2, (<*>))++import qualified Data.Traversable as Trav+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import Data.Traversable (Traversable, foldMapDefault)+import Data.Foldable (Foldable, foldMap)++import Prelude hiding (replicate, map, head, unzip, zipWith)+++newtype T n a = Cons (FixedList n a)++type family FixedList n :: * -> *+type instance FixedList Unary.Zero = Empty.T+type instance FixedList (Unary.Succ n) = NonEmpty.T (FixedList n)++type family Length (f :: * -> *)+type instance Length Empty.T = Unary.Zero+type instance Length (NonEmpty.T f) = Unary.Succ (Length f)+++vector ::+ (Unary.Natural n, n ~ Length (FixedList n)) =>+ FixedList n a -> T n a+vector = Cons++cyclicVector ::+ (Unary.Natural n) =>+ NonEmpty.T [] a -> T n a+cyclicVector xt@(NonEmpty.Cons x xs) =+ runOp0 $+ Unary.switchNat+ (Op0 empty)+ (Op0 $ cons x $ cyclicVectorAppend xt xs)++cyclicVectorAppend ::+ (Unary.Natural n) =>+ NonEmpty.T [] a -> [a] -> T n a+cyclicVectorAppend ys xt =+ runOp0 $+ Unary.switchNat+ (Op0 empty)+ (Op0 $+ case xt of+ [] -> cyclicVector ys+ x:xs -> cons x $ cyclicVectorAppend ys xs)++empty :: T Unary.Zero a+empty = Cons Empty.Cons++cons :: a -> T n a -> T (Unary.Succ n) a+cons x (Cons xs) = Cons $ NonEmpty.Cons x xs+++withEmpty :: b -> T Unary.Zero a -> b+withEmpty x (Cons Empty.Cons) = x++withHead ::+ (a -> T n a -> b) ->+ T (Unary.Succ n) a -> b+withHead f (Cons (NonEmpty.Cons x xs)) = f x (Cons xs)+++newtype Head a n = Head {runHead :: T n a -> a}++head :: (Unary.Positive n) => T n a -> a+head =+ runHead $+ Unary.switchPos+ (Head $ \(Cons (NonEmpty.Cons a _)) -> a)+++newtype+ WithVector a b n =+ WithVector {+ runWithVector :: WithRec a b n -> T n a -> b+ }++type family WithRec a b n+type instance WithRec a b Unary.Zero = b+type instance WithRec a b (Unary.Succ n) = a -> WithRec a b n++type With n a b = WithRec a b n++with :: (Unary.Natural n) => With n a b -> T n a -> b+with =+ runWithVector $+ Unary.switchNat+ (WithVector withEmpty)+ (WithVector $ \f v -> withHead (\x -> with (f x)) v)+++newtype Op0 a n = Op0 {runOp0 :: T n a}++replicate :: (Unary.Natural n) => a -> T n a+replicate a =+ runOp0 $+ Unary.switchNat+ (Op0 empty)+ (Op0 $ cons a $ replicate a)+++newtype Op1 a b n = Op1 {runOp1 :: T n a -> T n b}++map ::+ (Unary.Natural n) =>+ (a -> b) -> T n a -> T n b+map f =+ runOp1 $+ Unary.switchNat+ (Op1 $ withEmpty empty)+ (Op1 $ withHead $ \a -> cons (f a) . map f)+++newtype Op2 a b c n = Op2 {runOp2 :: T n a -> T n b -> T n c}++zipWith ::+ (Unary.Natural n) =>+ (a -> b -> c) ->+ T n a -> T n b -> T n c+zipWith f =+ runOp2 $+ Unary.switchNat+ (Op2 $ const $ withEmpty empty)+ (Op2 $ \at bt ->+ withHead (\a as ->+ withHead (\b bs -> cons (f a b) $ zipWith f as bs) bt) at)+++newtype+ Sequence f a n =+ Sequence {runSequence :: T n (f a) -> f (T n a)}+++instance (Unary.Natural n) => Functor (T n) where+ fmap = map++instance (Unary.Natural n) => Applicative (T n) where+ pure = replicate+ f <*> a = zipWith ($) f a++instance (Unary.Natural n) => Foldable (T n) where+ foldMap = foldMapDefault++instance (Unary.Natural n) => Traversable (T n) where+ sequenceA =+ runSequence $+ Unary.switchNat+ (Sequence $ withEmpty $ pure empty)+ (Sequence $ withHead $ \x xs -> liftA2 cons x $ Trav.sequenceA xs)
src/LLVM/Core/Util.hs view
@@ -52,7 +52,7 @@ import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) import Foreign.Marshal.Alloc (alloca) import Foreign.Storable (Storable(..))-import Foreign.Marshal.Utils (fromBool)+import Foreign.Marshal.Utils (fromBool, toBool) import System.IO.Unsafe (unsafePerformIO) import Data.Typeable (Typeable)@@ -62,18 +62,15 @@ type Type = FFI.TypeRef --- unsafePerformIO just to wrap the non-effecting withArrayLen call-functionType :: Bool -> Type -> [Type] -> Type-functionType varargs retType paramTypes = unsafePerformIO $+functionType :: Bool -> Type -> [Type] -> IO Type+functionType varargs retType paramTypes = withArrayLen paramTypes $ \ len ptr ->- return $ FFI.functionType retType ptr (fromIntegral len)- (fromBool varargs)+ FFI.functionType retType ptr (fromIntegral len) (fromBool varargs) --- unsafePerformIO just to wrap the non-effecting withArrayLen call-structType :: [Type] -> Bool -> Type-structType types packed = unsafePerformIO $+structType :: [Type] -> Bool -> IO Type+structType types packed = withArrayLen types $ \ len ptr ->- return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0)+ FFI.structType ptr (fromIntegral len) (fromBool packed) -------------------------------------- -- Handle modules@@ -113,7 +110,6 @@ rc <- FFI.writeBitcodeToFile mdlPtr namePtr when (rc /= 0) $ ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc- return () -- |Read a module from a file. readBitcodeFromFile :: String -> IO Module@@ -260,7 +256,7 @@ return f getParam :: Function -> Int -> Value-getParam f = FFI.getParam f . fromIntegral+getParam f = unsafePerformIO . FFI.getParam f . fromIntegral getParams :: Value -> IO [(String, Value)] getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList@@ -279,7 +275,7 @@ constStringInternal :: Bool -> String -> Value constStringInternal nulTerm s = unsafePerformIO $ withCStringLen s $ \(sPtr, sLen) ->- return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm))+ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm)) constString :: String -> Value constString = constStringInternal False@@ -417,25 +413,20 @@ -------------------------------------- --- The unsafePerformIO is just for the non-effecting withArrayLen-constVector :: Int -> [Value] -> Value-constVector n xs = unsafePerformIO $ do- let xs' = take n (cycle xs)- withArrayLen xs' $ \ len ptr ->- return $ FFI.constVector ptr (fromIntegral len)+constVector :: [Value] -> IO Value+constVector xs = do+ withArrayLen xs $ \ len ptr ->+ FFI.constVector ptr (fromIntegral len) --- The unsafePerformIO is just for the non-effecting withArrayLen-constArray :: Type -> Int -> [Value] -> Value-constArray t n xs = unsafePerformIO $ do- let xs' = take n (cycle xs)- withArrayLen xs' $ \ len ptr ->- return $ FFI.constArray t ptr (fromIntegral len)+constArray :: Type -> [Value] -> IO Value+constArray t xs = do+ withArrayLen xs $ \ len ptr ->+ FFI.constArray t ptr (fromIntegral len) --- The unsafePerformIO is just for the non-effecting withArrayLen-constStruct :: [Value] -> Bool -> Value-constStruct xs packed = unsafePerformIO $ do+constStruct :: [Value] -> Bool -> IO Value+constStruct xs packed = do withArrayLen xs $ \ len ptr ->- return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0)+ FFI.constStruct ptr (fromIntegral len) (fromBool packed) -------------------------------------- @@ -463,22 +454,17 @@ return $ zip names vs isConstant :: Value -> IO Bool-isConstant v = do- isC <- FFI.isConstant v- if isC == 0 then return False else return True+isConstant v = fmap toBool $ FFI.isConstant v isIntrinsic :: Value -> IO Bool-isIntrinsic v = do- if FFI.getIntrinsicID v == 0 then return True else return False+isIntrinsic v = fmap toBool $ FFI.getIntrinsicID v -------------------------------------- type Use = FFI.UseRef hasUsers :: Value -> IO Bool-hasUsers v = do- nU <- FFI.getNumUses v- if nU == 0 then return False else return True+hasUsers v = fmap toBool $ FFI.getNumUses v getUses :: Value -> IO [Use] getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse@@ -492,7 +478,7 @@ isChildOf :: BasicBlock -> Value -> IO Bool isChildOf bb v = do bb2 <- FFI.getInstructionParent v- if bb == bb2 then return True else return False+ return $ bb == bb2 getDep :: Use -> IO (String, String) getDep u = do
src/LLVM/Core/Vector.hs view
@@ -3,147 +3,248 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-}-module LLVM.Core.Vector (MkVector(..), vector, ) where+{-# LANGUAGE Rank2Types #-}+module LLVM.Core.Vector (MkVector(..), vector, cyclicVector, ) where -import LLVM.Core.Type-import LLVM.Core.Data-import LLVM.ExecutionEngine.Target+import qualified LLVM.ExecutionEngine.Target as Target+import qualified LLVM.Core.UnaryVector as UnaryVector+import qualified LLVM.Util.Proxy as Proxy+import LLVM.Core.Type (IsPrimitive, unsafeTypeRef)+import LLVM.Core.Data (Vector(Vector), FixedList) -import Types.Data.Num+import qualified Type.Data.Num.Decimal.Proof as DecProof+import qualified Type.Data.Num.Decimal.Number as Dec+import qualified Type.Data.Num.Unary as Unary+import Type.Data.Num.Decimal.Literal (D2, D4, D8) -import Foreign.Ptr (castPtr)+import qualified Foreign.Storable.Traversable as Store import Foreign.Storable (Storable(..))-import Foreign.Marshal.Array (peekArray, pokeArray) -import Data.Function (on)+import Control.Applicative (Applicative, pure, liftA2, (<*>))+import Control.Functor.HT (unzip)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.NonEmpty as NonEmpty+import qualified Data.Empty as Empty+import Data.Traversable (Traversable, foldMapDefault)+import Data.Foldable (Foldable, foldMap)+import Data.NonEmpty ((!:))+ import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding (replicate, map, head, unzip, zipWith) + -- XXX Should these really be here?-class (PositiveT n, IsPrimitive a) => MkVector n a where+class (Dec.Positive n, IsPrimitive a) => MkVector n a where type Tuple n a :: * toVector :: Tuple n a -> Vector n a fromVector :: Vector n a -> Tuple n a -{--instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where- toVector a = Vector [a]--} instance (IsPrimitive a) => MkVector D2 a where type Tuple D2 a = (a,a)- toVector (a1, a2) = Vector [a1, a2]- fromVector (Vector [a1, a2]) = (a1, a2)- fromVector _ = error "fromVector: impossible"+ toVector (a1, a2) = vector (a1 !: a2 !: Empty.Cons)+ fromVector = with $ \a1 a2 -> (a1, a2) instance (IsPrimitive a) => MkVector D4 a where type Tuple D4 a = (a,a,a,a)- toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]- fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4)- fromVector _ = error "fromVector: impossible"+ toVector (a1, a2, a3, a4) = vector (a1 !: a2 !: a3 !: a4 !: Empty.Cons)+ fromVector = with $ \a1 a2 a3 a4 -> (a1, a2, a3, a4) instance (IsPrimitive a) => MkVector D8 a where type Tuple D8 a = (a,a,a,a,a,a,a,a)- toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]- fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8)- fromVector _ = error "fromVector: impossible"+ toVector (a1, a2, a3, a4, a5, a6, a7, a8) =+ vector (a1 !: a2 !: a3 !: a4 !: a5 !: a6 !: a7 !: a8 !: Empty.Cons)+ fromVector =+ with $ \a1 a2 a3 a4 a5 a6 a7 a8 ->+ (a1, a2, a3, a4, a5, a6, a7, a8) -instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where- sizeOf a = storeSizeOfType ourTargetData (typeRef a)- alignment a = aBIAlignmentOfType ourTargetData (typeRef a)- peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a)- poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs +head :: (Dec.Positive n) => Vector n a -> a+head =+ withPosDict1 $ \dict v ->+ case dict of+ DecProof.UnaryPos ->+ UnaryVector.head . unaryFromDecimalVector $ v+++unaryFromDecimalVector :: Vector n a -> UnaryVector.T (Dec.ToUnary n) a+unaryFromDecimalVector (Vector xs) = UnaryVector.Cons xs++decimalFromUnaryVector :: UnaryVector.T (Dec.ToUnary n) a -> Vector n a+decimalFromUnaryVector (UnaryVector.Cons xs) = Vector xs+++type With n a b = UnaryVector.With (Dec.ToUnary n) a b++with ::+ (Dec.Natural n) =>+ With n a b -> Vector n a -> b+with f =+ withNatDict1 $ \dict v ->+ case dict of+ DecProof.UnaryNat ->+ UnaryVector.with f $ unaryFromDecimalVector v+++withNatDict ::+ (Dec.Natural n) =>+ (DecProof.UnaryNat n -> Vector n a) -> Vector n a+withNatDict f = f DecProof.unaryNat++withNatDict1 ::+ (Dec.Natural n) =>+ (DecProof.UnaryNat n -> Vector n a -> b) -> Vector n a -> b+withNatDict1 f = f DecProof.unaryNat++withPosDict1 ::+ (Dec.Positive n) =>+ (DecProof.UnaryPos n -> Vector n a -> b) -> Vector n a -> b+withPosDict1 f = f DecProof.unaryPos+++withUnaryDecVector ::+ (Dec.Natural n) =>+ (forall m. (Dec.ToUnary n ~ m, Unary.Natural m) => UnaryVector.T m a) ->+ Vector n a+withUnaryDecVector v =+ withNatDict+ (\dict ->+ case dict of DecProof.UnaryNat -> decimalFromUnaryVector v)++instance (Storable a, Dec.Positive n, IsPrimitive a) => Storable (Vector n a) where+ sizeOf a =+ Target.storeSizeOfType ourTargetData $+ unsafeTypeRef $ Proxy.fromValue a+ alignment a =+ Target.aBIAlignmentOfType ourTargetData $+ unsafeTypeRef $ Proxy.fromValue a+ peek = Store.peekApplicative+ poke = Store.poke+ -- XXX The JITer target data. This isn't really right.-ourTargetData :: TargetData-ourTargetData = unsafePerformIO getTargetData+ourTargetData :: Target.TargetData+ourTargetData = unsafePerformIO Target.getTargetData -------------------------------------- -unVector :: Vector n a -> [a]+{- maybe we should export this in order to allow NumericPrelude instances+unVector :: (Dec.Positive n) => Vector n a -> FixedList n a unVector (Vector xs) = xs+-} --- |Make a constant vector. Replicates or truncates the list to get length /n/.--- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'.-vector :: forall a n. (PositiveT n) => [a] -> Vector n a-vector xs =- Vector (take (fromIntegerT (undefined :: n)) (cycle xs))+vector ::+ (Dec.Positive n) =>+ FixedList (Dec.ToUnary n) a -> Vector n a+vector = Vector -replic :: forall a n. (PositiveT n) => a -> Vector n a-replic = Vector . replicate (fromIntegerT (undefined :: n))+{- |+Make a constant vector. Replicates or truncates the list to get length /n/.+This behaviour is consistent with that of 'LLVM.Core.CodeGen.constCyclicVector'.+May be abused for constructing vectors from lists with statically unknown size.+-}+cyclicVector :: (Dec.Positive n) => NonEmpty.T [] a -> Vector n a+cyclicVector xs =+ withUnaryDecVector (UnaryVector.cyclicVector xs) -binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c-binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys)+replicate :: (Dec.Positive n) => a -> Vector n a+replicate a = withUnaryDecVector (pure a) -unop :: (a -> b) -> Vector n a -> Vector n b-unop op = Vector . map op . unVector -instance (Eq a, PositiveT n) => Eq (Vector n a) where- (==) = (==) `on` unVector+instance (Dec.Positive n) => Functor (Vector n) where+ fmap f a =+ withUnaryDecVector (fmap f $ unaryFromDecimalVector a) -instance (Ord a, PositiveT n) => Ord (Vector n a) where- compare = compare `on` unVector+instance (Dec.Positive n) => Applicative (Vector n) where+ pure = replicate+ f <*> a =+ withUnaryDecVector+ (unaryFromDecimalVector f <*> unaryFromDecimalVector a) -instance (Num a, PositiveT n) => Num (Vector n a) where- (+) = binop (+)- (-) = binop (-)- (*) = binop (*)- negate = unop negate- abs = unop abs- signum = unop signum- fromInteger = replic . fromInteger+instance (Dec.Positive n) => Foldable (Vector n) where+ foldMap = foldMapDefault -instance (Enum a, PositiveT n) => Enum (Vector n a) where- succ = unop succ- pred = unop pred+instance (Dec.Positive n) => Traversable (Vector n) where+ sequenceA =+ withNatDict1 $ \dict v ->+ case dict of+ DecProof.UnaryNat ->+ fmap decimalFromUnaryVector $ Trav.sequenceA $+ unaryFromDecimalVector v++++instance (Eq a, Dec.Positive n) => Eq (Vector n a) where+ x == y = Fold.and $ liftA2 (==) x y++instance (Ord a, Dec.Positive n) => Ord (Vector n a) where+ compare x y =+ Fold.foldr (\r rs -> if r==EQ then rs else r) EQ $+ liftA2 compare x y++instance (Num a, Dec.Positive n) => Num (Vector n a) where+ (+) = liftA2 (+)+ (-) = liftA2 (-)+ (*) = liftA2 (*)+ negate = fmap negate+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++instance (Enum a, Dec.Positive n) => Enum (Vector n a) where+ succ = fmap succ+ pred = fmap pred fromEnum = error "Vector fromEnum"- toEnum = replic . toEnum+ toEnum = pure . toEnum -instance (Real a, PositiveT n) => Real (Vector n a) where+instance (Real a, Dec.Positive n) => Real (Vector n a) where toRational = error "Vector toRational" -instance (Integral a, PositiveT n) => Integral (Vector n a) where- quot = binop quot- rem = binop rem- div = binop div- mod = binop mod- quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys- divMod (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod xs ys+instance (Integral a, Dec.Positive n) => Integral (Vector n a) where+ quot = liftA2 quot+ rem = liftA2 rem+ div = liftA2 div+ mod = liftA2 mod+ quotRem xs ys = unzip $ liftA2 quotRem xs ys+ divMod xs ys = unzip $ liftA2 divMod xs ys toInteger = error "Vector toInteger" -instance (Fractional a, PositiveT n) => Fractional (Vector n a) where- (/) = binop (/)- fromRational = replic . fromRational+instance (Fractional a, Dec.Positive n) => Fractional (Vector n a) where+ (/) = liftA2 (/)+ fromRational = pure . fromRational -instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where+instance (RealFrac a, Dec.Positive n) => RealFrac (Vector n a) where properFraction = error "Vector properFraction" -instance (Floating a, PositiveT n) => Floating (Vector n a) where- pi = replic pi- sqrt = unop sqrt- log = unop log- logBase = binop logBase- (**) = binop (**)- exp = unop exp- sin = unop sin- cos = unop cos- tan = unop tan- asin = unop asin- acos = unop acos- atan = unop atan- sinh = unop sinh- cosh = unop cosh- tanh = unop tanh- asinh = unop asinh- acosh = unop acosh- atanh = unop atanh+instance (Floating a, Dec.Positive n) => Floating (Vector n a) where+ pi = pure pi+ sqrt = fmap sqrt+ log = fmap log+ logBase = liftA2 logBase+ (**) = liftA2 (**)+ exp = fmap exp+ sin = fmap sin+ cos = fmap cos+ tan = fmap tan+ asin = fmap asin+ acos = fmap acos+ atan = fmap atan+ sinh = fmap sinh+ cosh = fmap cosh+ tanh = fmap tanh+ asinh = fmap asinh+ acosh = fmap acosh+ atanh = fmap atanh -instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where- floatRadix = floatRadix . head . unVector- floatDigits = floatDigits . head . unVector- floatRange = floatRange . head . unVector+instance (RealFloat a, Dec.Positive n) => RealFloat (Vector n a) where+ floatRadix = floatRadix . head+ floatDigits = floatDigits . head+ floatRange = floatRange . head decodeFloat = error "Vector decodeFloat" encodeFloat = error "Vector encodeFloat" exponent _ = 0@@ -153,4 +254,4 @@ isInfinite = error "Vector isInfinite" isDenormalized = error "Vector isDenormalized" isNegativeZero = error "Vector isNegativeZero"- isIEEE = isIEEE . head . unVector+ isIEEE = isIEEE . head
src/LLVM/ExecutionEngine.hs view
@@ -55,8 +55,9 @@ -- Note that the function is compiled for every call (Just-In-Time compilation). -- If you want to compile the function once and call it a lot of times -- then you should better use 'getPointerToFunction'.-generateFunction :: (Translatable f) =>- Value (Ptr f) -> EngineAccess f+generateFunction ::+ (Translatable f) =>+ Function f -> EngineAccess f generateFunction (Value f) = do run <- getRunFunction return $ translate run [] f
src/LLVM/ExecutionEngine/Engine.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -21,17 +20,20 @@ GenericValue, Generic(..) ) where +import qualified LLVM.Util.Proxy as Proxy+import qualified LLVM.Core.Util as U+ import LLVM.Core.CodeGen (Value(..), Function) import LLVM.Core.CodeGenMonad (GlobalMappings(..)) import LLVM.Core.Util (Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule) import LLVM.Core.Type (IsFirstClass, typeRef)+import LLVM.Util.Proxy (Proxy(Proxy)) import qualified LLVM.FFI.ExecutionEngine as FFI import qualified LLVM.FFI.Target as FFI import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef)-import qualified LLVM.Core.Util as U import qualified Control.Monad.Trans.State as MS import Control.Monad.Trans.State (StateT, runStateT, )@@ -40,16 +42,16 @@ import Control.Applicative (Applicative, ) import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar, ) -import Data.Typeable-import Data.Int-import Data.Word+import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64) import Foreign.Marshal.Alloc (alloca, free) import Foreign.Marshal.Array (withArrayLen) import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) import Foreign.Marshal.Utils (fromBool) import Foreign.C.String (peekCString)-import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr)+import Foreign.Ptr (Ptr, FunPtr, ) import Foreign.Storable (peek) import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, ) import System.IO.Unsafe (unsafePerformIO)@@ -60,7 +62,7 @@ fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine } -withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a)+withExecutionEngine :: ExecutionEngine -> (FFI.ExecutionEngineRef -> IO a) -> IO a withExecutionEngine = withForeignPtr . fromExecutionEngine @@ -105,10 +107,10 @@ -- It may be missing, but it never dies. -- XXX We could provide a destructor, what about functions obtained by runFunction? {-# NOINLINE theEngine #-}-theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine))+theEngine :: MVar (Maybe FFI.ExecutionEngineRef) theEngine = unsafePerformIO $ newMVar Nothing -createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine)+createExecutionEngine :: ModuleProvider -> IO FFI.ExecutionEngineRef createExecutionEngine prov = withModuleProvider prov $ \provPtr -> alloca $ \eePtr ->@@ -123,7 +125,7 @@ else peek eePtr -getTheEngine :: IO (Ptr FFI.ExecutionEngine)+getTheEngine :: IO FFI.ExecutionEngineRef getTheEngine = do mee <- takeMVar theEngine case mee of@@ -136,7 +138,7 @@ return ee data EAState = EAState {- ea_engine :: Ptr FFI.ExecutionEngine,+ ea_engine :: FFI.ExecutionEngineRef, ea_providers :: [ModuleProvider] } deriving (Show, Typeable)@@ -163,7 +165,7 @@ FFI.addModuleProvider (ea_engine ea) provPtr -getEngine :: EngineAccess (Ptr FFI.ExecutionEngine)+getEngine :: EngineAccess FFI.ExecutionEngineRef getEngine = EA $ MS.gets ea_engine getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef@@ -192,8 +194,9 @@ with 'staticFunction' instead of 'externFunction'. -} addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()-addFunctionValue (Value g) f =- addFunctionValueCore g (castFunPtrToPtr f)+addFunctionValue (Value g) f = do+ eePtr <- getEngine+ liftIO $ FFI.addFunctionMapping eePtr g f {- | Pass a list of global mappings to LLVM@@ -201,12 +204,7 @@ -} addGlobalMappings :: GlobalMappings -> EngineAccess () addGlobalMappings (GlobalMappings gms) =- mapM_ (uncurry addFunctionValueCore) gms--addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess ()-addFunctionValueCore g f = do- eePtr <- getEngine- liftIO $ FFI.addGlobalMapping eePtr g f+ liftIO . gms =<< getEngine addModule :: Module -> EngineAccess () addModule m = do@@ -216,7 +214,7 @@ -- | Get all the information needed to free a function. -- Freeing code might have to be done from a (C) finalizer, so it has to done from C. -- The function c_freeFunctionObject take these pointers as arguments and frees the function.-type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef)+type FreePointers = (FFI.ExecutionEngineRef, FFI.ModuleProviderRef, FFI.ValueRef) getFreePointers :: Function f -> EngineAccess FreePointers getFreePointers (Value f) = do ea <- EA MS.get@@ -265,13 +263,15 @@ fromGeneric _ = () toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue-toGenericInt signed val = unsafePerformIO $ createGenericValueWith $- FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed)+toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ do+ typ <- typeRef $ Proxy.fromValue val+ FFI.createGenericValueOfInt+ typ (fromIntegral val) (fromBool signed) fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a fromGenericInt signed val = unsafePerformIO $ withGenericValue val $ \ref ->- return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed)+ fmap fromIntegral $ FFI.genericValueToInt ref (fromBool signed) --instance Generic Bool where -- toGeneric = toGenericInt False . fromBool@@ -316,13 +316,15 @@ fromGeneric = fromGenericInt False toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue-toGenericReal val = unsafePerformIO $ createGenericValueWith $- FFI.createGenericValueOfFloat (typeRef val) (realToFrac val)+toGenericReal val = unsafePerformIO $ createGenericValueWith $ do+ typ <- typeRef $ Proxy.fromValue val+ FFI.createGenericValueOfFloat typ (realToFrac val) fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a fromGenericReal val = unsafePerformIO $- withGenericValue val $ \ ref ->- return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref+ withGenericValue val $ \ ref -> do+ typ <- typeRef (Proxy :: Proxy a)+ fmap realToFrac $ FFI.genericValueToFloat typ ref instance Generic Float where toGeneric = toGenericReal
src/LLVM/ExecutionEngine/Target.hs view
@@ -9,7 +9,8 @@ import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.Target as FFI -import Types.Data.Num (PositiveT, reifyPositiveD)+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy) import Foreign.C.String (withCString) import Data.Typeable (Typeable)@@ -35,11 +36,11 @@ } deriving (Typeable) -withIntPtrType :: (forall n . (PositiveT n) => WordN n -> a) -> a+withIntPtrType :: (forall n . (Dec.Positive n) => WordN n -> a) -> a withIntPtrType f = fromMaybe (error "withIntPtrType: pointer size must be non-negative") $- reifyPositiveD (fromIntegral sz) (\ n -> f (g n))- where g :: n -> WordN n+ Dec.reifyPositive (fromIntegral sz) (\ n -> f (g n))+ where g :: Proxy n -> WordN n g _ = error "withIntPtrType: argument used" sz = pointerSize $ unsafePerformIO getTargetData @@ -51,15 +52,15 @@ -- are really pure functions. makeTargetData :: FFI.TargetDataRef -> TargetData makeTargetData r = TargetData {- aBIAlignmentOfType = fromIntegral . FFI.aBIAlignmentOfType r,- aBISizeOfType = fromIntegral . FFI.aBISizeOfType r,- littleEndian = FFI.byteOrder r /= 0,- callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r,- intPtrType = FFI.intPtrType r,- pointerSize = fromIntegral $ FFI.pointerSize r,- preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r,- sizeOfTypeInBits = fromIntegral . FFI.sizeOfTypeInBits r,- storeSizeOfType = fromIntegral . FFI.storeSizeOfType r+ aBIAlignmentOfType = fromIntegral . unsafePerformIO . FFI.aBIAlignmentOfType r,+ aBISizeOfType = fromIntegral . unsafePerformIO . FFI.aBISizeOfType r,+ littleEndian = unsafePerformIO (FFI.byteOrder r) /= 0,+ callFrameAlignmentOfType = fromIntegral . unsafePerformIO . FFI.callFrameAlignmentOfType r,+ intPtrType = unsafePerformIO $ FFI.intPtrType r,+ pointerSize = fromIntegral $ unsafePerformIO $ FFI.pointerSize r,+ preferredAlignmentOfType = fromIntegral . unsafePerformIO . FFI.preferredAlignmentOfType r,+ sizeOfTypeInBits = fromIntegral . unsafePerformIO . FFI.sizeOfTypeInBits r,+ storeSizeOfType = fromIntegral . unsafePerformIO . FFI.storeSizeOfType r } getTargetData :: IO TargetData
src/LLVM/Util/Arithmetic.hs view
@@ -20,9 +20,10 @@ import qualified LLVM.Core as LLVM import LLVM.Util.Loop (mapVector, mapVector2)+import LLVM.Util.Proxy (Proxy(Proxy)) import LLVM.Core -import qualified Types.Data.Num as TypeNum+import qualified Type.Data.Num.Decimal.Number as Dec import Control.Monad (liftM2) @@ -182,7 +183,7 @@ 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 (undefined :: a))+ op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (Proxy :: Proxy a)) {- You can add these attributes, but the verifier pass in the optimizer checks whether they match@@ -195,7 +196,7 @@ 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 (undefined :: a))+ op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (Proxy :: Proxy a)) runCall (callFromFunction op `applyCall` x `applyCall` y) >>= addReadNone -------------------------------------------@@ -285,9 +286,9 @@ macOS = False #endif -instance (PositiveT n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where+instance (Dec.Positive n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where callIntrinsic1' s x =- if macOS && TypeNum.fromIntegerT (undefined :: n) == (4::Int) &&+ if macOS && Dec.integerFromSingleton (Dec.singleton :: Dec.Singleton n) == 4 && elem s ["sqrt", "log", "exp", "sin", "cos", "tan"] then do op <- externFunction ("v" ++ s ++ "f")
src/LLVM/Util/File.hs view
@@ -1,9 +1,15 @@-module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where+module LLVM.Util.File (writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where +import qualified LLVM.ExecutionEngine as EE+import LLVM.ExecutionEngine (Translatable)+import LLVM.Core+ (CodeGenModule, IsFunction, Module, Function,+ newModule, defineModule,+ getValueName, getModuleValues, castModuleValue,+ writeBitcodeToFile, readBitcodeFromFile)+ import System.Process (system) -import LLVM.ExecutionEngine-import LLVM.Core writeCodeGenModule :: FilePath -> CodeGenModule a -> IO ()@@ -17,10 +23,14 @@ _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name return () -optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t)+optimizeFunction ::+ (IsFunction t, Translatable t) =>+ CodeGenModule (Function t) -> IO (Function t) optimizeFunction = fmap snd . optimizeFunction' -optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t)+optimizeFunction' ::+ (IsFunction t, Translatable t) =>+ CodeGenModule (Function t) -> IO (Module, Function t) optimizeFunction' mdl = do m <- newModule mf <- defineModule m mdl@@ -40,10 +50,11 @@ return (m', mf') -optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t+optimizeFunctionCG ::+ (IsFunction t, Translatable t) =>+ CodeGenModule (Function t) -> IO t optimizeFunctionCG mdl = do (m', mf') <- optimizeFunction' mdl- rf <- runEngineAccess $ do- addModule m'- generateFunction mf'- return rf+ EE.runEngineAccess $ do+ EE.addModule m'+ EE.generateFunction mf'
src/LLVM/Util/Loop.hs view
@@ -6,7 +6,7 @@ module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where import LLVM.Core-import Types.Data.Num (fromIntegerT)+import qualified Type.Data.Num.Decimal.Number as Dec class Phi a where@@ -94,21 +94,21 @@ -------------------------------------- mapVector :: forall a b n r .- (PositiveT n, IsPrimitive b) =>+ (Dec.Positive n, IsPrimitive b) => (Value a -> CodeGenFunction r (Value b)) -> Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) mapVector f v =- forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do+ forLoop (valueOf 0) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (value undef) $ \ i w -> do x <- extractelement v i y <- f x insertelement w y i mapVector2 :: forall a b c n r .- (PositiveT n, IsPrimitive c) =>+ (Dec.Positive n, 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 =- forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do+ forLoop (valueOf 0) (valueOf (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n))) (value undef) $ \ i w -> do x <- extractelement v1 i y <- extractelement v2 i z <- f x y
src/LLVM/Util/Memory.hs view
@@ -6,11 +6,15 @@ IsLengthType, ) where +import LLVM.Util.Proxy (Proxy(Proxy)) import LLVM.Core +import Foreign.Ptr (Ptr, ) import Data.Word (Word8, Word32, Word64, ) +import Control.Functor.HT (void, ) + class IsFirstClass len => IsLengthType len where instance IsLengthType Word32 where@@ -23,7 +27,7 @@ TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ()) memcpyFunc = newNamedFunction ExternalLinkage $- "llvm.memcpy.p0i8.p0i8." ++ intrinsicTypeName (undefined :: len)+ "llvm.memcpy.p0i8.p0i8." ++ intrinsicTypeName (Proxy :: Proxy len) memcpy :: IsLengthType len =>@@ -37,7 +41,7 @@ memcpy = fmap (\f dest src len align volatile ->- fmap (const()) $ call f dest src len align volatile)+ void $ call f dest src len align volatile) memcpyFunc @@ -47,7 +51,7 @@ TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ()) memmoveFunc = newNamedFunction ExternalLinkage $- "llvm.memmove.p0i8.p0i8." ++ intrinsicTypeName (undefined :: len)+ "llvm.memmove.p0i8.p0i8." ++ intrinsicTypeName (Proxy :: Proxy len) memmove :: IsLengthType len =>@@ -61,7 +65,7 @@ memmove = fmap (\f dest src len align volatile ->- fmap (const()) $ call f dest src len align volatile)+ void $ call f dest src len align volatile) memmoveFunc @@ -71,7 +75,7 @@ TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ()) memsetFunc = newNamedFunction ExternalLinkage $- "llvm.memset.p0i8." ++ intrinsicTypeName (undefined :: len)+ "llvm.memset.p0i8." ++ intrinsicTypeName (Proxy :: Proxy len) memset :: IsLengthType len =>@@ -85,5 +89,5 @@ memset = fmap (\f dest val len align volatile ->- fmap (const()) $ call f dest val len align volatile)+ void $ call f dest val len align volatile) memsetFunc
+ src/LLVM/Util/Proxy.hs view
@@ -0,0 +1,16 @@+module LLVM.Util.Proxy where++import Control.Applicative (Applicative, pure, (<*>), )++data Proxy a = Proxy++instance Functor Proxy where+ fmap _f Proxy = Proxy++instance Applicative Proxy where+ pure _ = Proxy+ Proxy <*> Proxy = Proxy+++fromValue :: a -> Proxy a+fromValue _ = Proxy