diff --git a/PROBLEMS.md b/PROBLEMS.md deleted file mode 100644 --- a/PROBLEMS.md +++ /dev/null @@ -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. diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -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). diff --git a/cbits/malloc.c b/cbits/malloc.c new file mode 100644 --- /dev/null +++ b/cbits/malloc.c @@ -0,0 +1,190 @@ +#include +#include + +#ifdef DEBUG +#include +#endif + +#ifdef TEST +#include +#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 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 diff --git a/example/HelloJIT.hs b/example/HelloJIT.hs --- a/example/HelloJIT.hs +++ b/example/HelloJIT.hs @@ -3,6 +3,7 @@ import LLVM.ExecutionEngine (simpleFunction) import LLVM.Core +import Foreign.Ptr (Ptr) import Data.Word (Word8, Word32) diff --git a/example/List.hs b/example/List.hs --- a/example/List.hs +++ b/example/List.hs @@ -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, ) diff --git a/example/Struct.hs b/example/Struct.hs --- a/example/Struct.hs +++ b/example/Struct.hs @@ -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 () diff --git a/example/Varargs.hs b/example/Varargs.hs --- a/example/Varargs.hs +++ b/example/Varargs.hs @@ -3,6 +3,7 @@ import LLVM.ExecutionEngine (simpleFunction) import LLVM.Core +import Foreign.Ptr (Ptr) import Data.Word (Word8, Word32) diff --git a/example/Vector.hs b/example/Vector.hs --- a/example/Vector.hs +++ b/example/Vector.hs @@ -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 diff --git a/llvm-tf.cabal b/llvm-tf.cabal --- a/llvm-tf.cabal +++ b/llvm-tf.cabal @@ -1,5 +1,5 @@ Name: llvm-tf -Version: 3.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 diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs --- a/src/LLVM/Core.hs +++ b/src/LLVM/Core.hs @@ -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 diff --git a/src/LLVM/Core/CodeGen.hs b/src/LLVM/Core/CodeGen.hs --- a/src/LLVM/Core/CodeGen.hs +++ b/src/LLVM/Core/CodeGen.hs @@ -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 :: * diff --git a/src/LLVM/Core/CodeGenMonad.hs b/src/LLVM/Core/CodeGenMonad.hs --- a/src/LLVM/Core/CodeGenMonad.hs +++ b/src/LLVM/Core/CodeGenMonad.hs @@ -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 diff --git a/src/LLVM/Core/Data.hs b/src/LLVM/Core/Data.hs --- a/src/LLVM/Core/Data.hs +++ b/src/LLVM/Core/Data.hs @@ -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 diff --git a/src/LLVM/Core/Instructions.hs b/src/LLVM/Core/Instructions.hs --- a/src/LLVM/Core/Instructions.hs +++ b/src/LLVM/Core/Instructions.hs @@ -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 -> diff --git a/src/LLVM/Core/Type.hs b/src/LLVM/Core/Type.hs --- a/src/LLVM/Core/Type.hs +++ b/src/LLVM/Core/Type.hs @@ -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'. diff --git a/src/LLVM/Core/UnaryVector.hs b/src/LLVM/Core/UnaryVector.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/UnaryVector.hs @@ -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) diff --git a/src/LLVM/Core/Util.hs b/src/LLVM/Core/Util.hs --- a/src/LLVM/Core/Util.hs +++ b/src/LLVM/Core/Util.hs @@ -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 diff --git a/src/LLVM/Core/Vector.hs b/src/LLVM/Core/Vector.hs --- a/src/LLVM/Core/Vector.hs +++ b/src/LLVM/Core/Vector.hs @@ -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 diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs --- a/src/LLVM/ExecutionEngine.hs +++ b/src/LLVM/ExecutionEngine.hs @@ -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 diff --git a/src/LLVM/ExecutionEngine/Engine.hs b/src/LLVM/ExecutionEngine/Engine.hs --- a/src/LLVM/ExecutionEngine/Engine.hs +++ b/src/LLVM/ExecutionEngine/Engine.hs @@ -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 diff --git a/src/LLVM/ExecutionEngine/Target.hs b/src/LLVM/ExecutionEngine/Target.hs --- a/src/LLVM/ExecutionEngine/Target.hs +++ b/src/LLVM/ExecutionEngine/Target.hs @@ -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 diff --git a/src/LLVM/Util/Arithmetic.hs b/src/LLVM/Util/Arithmetic.hs --- a/src/LLVM/Util/Arithmetic.hs +++ b/src/LLVM/Util/Arithmetic.hs @@ -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") diff --git a/src/LLVM/Util/File.hs b/src/LLVM/Util/File.hs --- a/src/LLVM/Util/File.hs +++ b/src/LLVM/Util/File.hs @@ -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' diff --git a/src/LLVM/Util/Loop.hs b/src/LLVM/Util/Loop.hs --- a/src/LLVM/Util/Loop.hs +++ b/src/LLVM/Util/Loop.hs @@ -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 diff --git a/src/LLVM/Util/Memory.hs b/src/LLVM/Util/Memory.hs --- a/src/LLVM/Util/Memory.hs +++ b/src/LLVM/Util/Memory.hs @@ -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 diff --git a/src/LLVM/Util/Proxy.hs b/src/LLVM/Util/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Proxy.hs @@ -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