llvm-tf 9.1.1 → 9.2
raw patch · 55 files changed
+6072/−5159 lines, 55 filesdep ~QuickCheckdep ~basedep ~enumset
Dependency ranges changed: QuickCheck, base, enumset, llvm-ffi, tfp, utility-ht
Files
- Changes.md +28/−0
- example/Align.hs +1/−0
- example/Arith.hs +20/−20
- example/Array.hs +5/−7
- example/BrainF.hs +4/−4
- example/CallConv.hs +10/−13
- example/DotProd.hs +40/−43
- example/Fibonacci.hs +6/−1
- example/HelloJIT.hs +3/−5
- example/Intrinsic.hs +7/−9
- example/List.hs +7/−9
- example/Struct.hs +2/−3
- example/Varargs.hs +13/−12
- example/Vector.hs +2/−4
- llvm-tf.cabal +55/−27
- private/LLVM/Core/CodeGen.hs +721/−0
- private/LLVM/Core/CodeGenMonad.hs +181/−0
- private/LLVM/Core/Data.hs +134/−0
- private/LLVM/Core/Instructions.hs +1257/−0
- private/LLVM/Core/Instructions/Guided.hs +355/−0
- private/LLVM/Core/Instructions/Private.hs +303/−0
- private/LLVM/Core/Proxy.hs +19/−0
- private/LLVM/Core/Type.hs +698/−0
- private/LLVM/Core/UnaryVector.hs +42/−0
- private/LLVM/Core/Util.hs +480/−0
- private/LLVM/Core/Vector.hs +284/−0
- private/LLVM/ExecutionEngine/Engine.hs +315/−0
- private/LLVM/ExecutionEngine/Marshal.hs +455/−0
- private/LLVM/ExecutionEngine/Target.hs +126/−0
- src/LLVM/Core.hs +6/−3
- src/LLVM/Core/CodeGen.hs +0/−681
- src/LLVM/Core/CodeGenMonad.hs +0/−181
- src/LLVM/Core/Data.hs +0/−84
- src/LLVM/Core/Instructions.hs +0/−1251
- src/LLVM/Core/Instructions/Guided.hs +0/−356
- src/LLVM/Core/Instructions/Private.hs +0/−291
- src/LLVM/Core/Type.hs +0/−627
- src/LLVM/Core/UnaryVector.hs +0/−42
- src/LLVM/Core/Util.hs +0/−480
- src/LLVM/Core/Vector.hs +0/−277
- src/LLVM/ExecutionEngine.hs +7/−0
- src/LLVM/ExecutionEngine/Engine.hs +0/−297
- src/LLVM/ExecutionEngine/Marshal.hs +0/−186
- src/LLVM/ExecutionEngine/Target.hs +0/−92
- src/LLVM/Util/Arithmetic.hs +86/−35
- src/LLVM/Util/Foreign.hs +19/−12
- src/LLVM/Util/Intrinsic.hs +1/−1
- src/LLVM/Util/Memory.hs +3/−3
- src/LLVM/Util/Optimize.hs +9/−0
- src/LLVM/Util/Proxy.hs +4/−18
- test/Main.hs +21/−0
- test/Makefile +0/−16
- test/Test/Chop.hs +63/−0
- test/Test/Marshal.hs +280/−0
- test/TestValue.hs +0/−69
Changes.md view
@@ -1,5 +1,33 @@ # Change log for the `llvm-tf` package +## 9.2++* custom `Ptr` type:+ We leave the original `Ptr` type for data in `Storable` compatible format,+ and use `LLVM.Ptr` for data in LLVM layout.++* `instance Storable Vector`:+ Allows non-primitive elements and interleaves them.++* `instance Marshal Vector`:+ Should now be really compatible with LLVM.+ Formerly, it was wrong on big-endian systems+ and vectors of Bool, WordN, IntN.+ The correct implementation required a new class for storing vectors.++* `Ret` class: turned from multi-parameter type class+ to single parameter type class with type function `Result`.+ You may replace `Ret a r` by `Ret a, Result a ~ r` in your code,+ which may enable further simplifications.++* `CallArgs f g r` -> `CallArgs r f g`,+ `CallerFunction f r` -> `CallerFunction r f`++* `ArithFunction`, `ToArithFunction`:+ Replaced functional dependencies by type functions.++* `ArithFunction`: split off `Return`+ ## 9.0 * `Instructions.bitcastElements`:
example/Align.hs view
@@ -17,6 +17,7 @@ td <- EE.getTargetData print ( EE.littleEndian td,+ EE.dataLayoutStr td, EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word32), EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy Word64), EE.abiAlignmentOfType td $ unsafeTypeRef (Proxy :: Proxy (Vector D4 Float)),
example/Arith.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where import qualified LLVM.Util.Arithmetic as A@@ -7,25 +5,27 @@ import LLVM.Util.Arithmetic (CallIntrinsic, arithFunction, (%<), (?)) import LLVM.Util.File (writeCodeGenModule) -import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO)+import qualified LLVM.ExecutionEngine as EE import LLVM.Core import Type.Data.Num.Decimal.Literal (D4) import Data.Int (Int32) -import Foreign.Storable (peek)-import Foreign.Ptr (Ptr)-{--import Foreign.Marshal.Utils-import Foreign.Marshal.Alloc as F--}+import qualified Prelude as P+import Prelude hiding ((^)) -mSomeFn :: forall a.++(^) :: (Num a) => a -> Int -> a+(^) = (P.^)++mSomeFn :: (IsConst a, Floating a, IsFloating a, CallIntrinsic a, CmpRet a) => CodeGenModule (Function (a -> IO a)) mSomeFn = do- foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y+ foo <-+ createFunction InternalLinkage $ arithFunction $ \ x y ->+ exp (sin x) + y let foo' = A.toArithFunction foo createFunction ExternalLinkage $ arithFunction $ \ x -> do y <- A.set $ x^3@@ -38,8 +38,7 @@ mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) mVFun = do- fn :: Function (V -> IO V)- <- createFunction ExternalLinkage $ arithFunction $ \ x ->+ fn <- createFunction ExternalLinkage $ arithFunction $ \ x -> log x * exp x * x - 16 vectorToPtr fn@@ -51,9 +50,9 @@ initializeNativeTarget let mSomeFn' = mSomeFn- ioSomeFn <- simpleFunction mSomeFn'+ ioSomeFn <- EE.simpleFunction mSomeFn' let someFn :: Double -> Double- someFn = unsafeRemoveIO ioSomeFn+ someFn = EE.unsafeRemoveIO ioSomeFn writeCodeGenModule "Arith.bc" mSomeFn' @@ -62,19 +61,20 @@ writeCodeGenModule "ArithFib.bc" mFib - fib <- simpleFunction mFib+ fib <- EE.simpleFunction mFib fib 22 >>= print writeCodeGenModule "VArith.bc" mVFun - ioVFun <- simpleFunction mVFun- let v = toVector (1,2,3,4)+ ioVFun <- EE.simpleFunction mVFun+ let v = consVector 1 2 3 4 r <- vectorPtrWrap ioVFun v print r -vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+vectorToPtr ::+ Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) vectorToPtr f = createFunction ExternalLinkage $ \ px py -> do x <- load px@@ -87,4 +87,4 @@ F.with v $ \ aPtr -> F.alloca $ \ bPtr -> do f aPtr bPtr- peek bPtr+ EE.peek bPtr
example/Array.hs view
@@ -4,9 +4,8 @@ import LLVM.Util.Optimize (optimizeModule) import LLVM.Core -import Foreign.Ptr (Ptr) import Control.Monad (foldM, void)-import Data.Word (Word32)+import Data.Word (Word, Word32) cg :: CodeGenModule (Function (Double -> IO (Ptr Double)))@@ -43,11 +42,11 @@ foldM (\ptr x -> store x ptr >> getElementPtr ptr (1::Word32,())) test <- createNamedFunction ExternalLinkage "test" $ \ x -> do- a <- arrayMalloc (4 :: Word32)+ a <- arrayMalloc (4 :: Word) fillArray a $ map valueOf [1,2,3,4]- b <- arrayMalloc (4 :: Word32)+ b <- arrayMalloc (4 :: Word) fillArray b [x,x,x,x]- c <- arrayMalloc (4 :: Word32)+ c <- arrayMalloc (4 :: Word) _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c ret c let _ = test :: Function (Double -> IO (Ptr Double))@@ -58,8 +57,7 @@ main = do -- Initialize jitter initializeNativeTarget- m <- newModule- _f <- defineModule m $ setTarget hostTriple >> cg+ m <- createModule $ setTarget hostTriple >> cg >> getModule writeBitcodeToFile "Arr.bc" m _ <- optimizeModule 3 m writeBitcodeToFile "Arr-opt.bc" m
example/BrainF.hs view
@@ -16,8 +16,8 @@ -- ] } End loop -- +import qualified LLVM.ExecutionEngine as EE import qualified LLVM.Util.Memory as Memory-import LLVM.ExecutionEngine (simpleFunction) import LLVM.Util.File (writeCodeGenModule) import LLVM.Core @@ -26,7 +26,7 @@ import System.Exit (exitFailure) import Control.Monad (when)-import Data.Word (Word8, Word32)+import Data.Word (Word8, Word32, Word) import Data.Int (Int32) @@ -59,12 +59,12 @@ when debug $ writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536 - bfprog <- simpleFunction $ brainCompile debug prog 65536+ bfprog <- EE.simpleFunction $ brainCompile debug prog 65536 when (prog == text) $ putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:" bfprog -brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ()))+brainCompile :: Bool -> String -> Word -> CodeGenModule (Function (IO ())) brainCompile _debug instrs wmemtotal = do -- LLVM functions memset <- Memory.memset
example/CallConv.hs view
@@ -8,25 +8,22 @@ -- Our module will have these two functions. data Mod = Mod {- m1 :: Function (Word32 -> IO Word32),- m2 :: Function (Word32 -> Word32 -> IO Word32)+ f1 :: Function (Word32 -> IO Word32),+ f2 :: Function (Word32 -> Word32 -> IO Word32) } main :: IO () main = do- m <- newModule- _fns <- defineModule m $ setTarget hostTriple >> buildMod+ m <- createModule $ setTarget hostTriple >> buildMod >> getModule --_ <- optimizeModule 3 m writeBitcodeToFile "CallConv.bc" m buildMod :: CodeGenModule Mod buildMod = do- mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do- r <- add x y- ret r- setFuncCallConv mod2 GHC- mod1 <- newNamedFunction ExternalLinkage "test"- defineFunction mod1 $ \ arg -> do- r <- callWithConv GHC mod2 arg (valueOf 1)- ret r- return $ Mod {m1 = mod1, m2 = mod2}+ fun2 <- createNamedFunction InternalLinkage "plus" $ \ x y ->+ ret =<< add x y+ setFuncCallConv fun2 GHC+ fun1 <- newNamedFunction ExternalLinkage "test"+ defineFunction fun1 $ \ arg ->+ ret =<< callWithConv GHC fun2 arg (valueOf 1)+ return $ Mod {f1 = fun1, f2 = fun2}
example/DotProd.hs view
@@ -1,11 +1,6 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-} module Main (main) where -import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO)+import qualified LLVM.ExecutionEngine as EE import LLVM.Core import LLVM.Util.Loop (forLoop)@@ -13,19 +8,28 @@ import LLVM.Util.Foreign (withArrayLen) import qualified Type.Data.Num.Decimal.Number as Dec-import Type.Data.Num.Decimal.Literal (D2, D4, D8)+import qualified Type.Data.Num.Decimal.Literal as TypeNum+import Type.Base.Proxy (Proxy(Proxy)) -import Foreign.Ptr (Ptr)+import qualified Data.Traversable as Trav+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Maybe.HT (toMaybe)+import Data.Maybe (fromMaybe)+import Data.Tuple.HT (swap) import Data.Word (Word32) +import Control.Applicative (pure) -mDotProd :: forall n a .- (Dec.Positive n,- IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a) =>- CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a))++mDotProd ::+ (Dec.Positive n,+ IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a) =>+ CodeGenModule+ (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) mDotProd = createFunction ExternalLinkage $ \ size aPtr bPtr -> do- s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do+ s <- forLoop (valueOf 0) size (value zero) $ \ i s -> do ap <- getElementPtr aPtr (i, ()) -- index into aPtr bp <- getElementPtr bPtr (i, ()) -- index into bPtr@@ -34,14 +38,20 @@ ab <- mul a b -- multiply them add s ab -- accumulate sum - 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- ret (r :: Value a)+ r <-+ forLoop+ (valueOf (0::Word32))+ (valueOf (Dec.integralFromProxy (vectorSize aPtr)))+ (valueOf 0)+ (\ i r -> add r =<< extractelement s i)+ ret r +vectorSize :: Value (Ptr (Vector n a)) -> Proxy n+vectorSize _ = Proxy++ type R = Float-type T = Vector D4 R+type T = Vector TypeNum.D4 R main :: IO () main = do@@ -50,10 +60,10 @@ let mDotProd' = mDotProd writeCodeGenModule "DotProd.bc" mDotProd' - ioDotProd <- simpleFunction mDotProd'+ ioDotProd <- EE.simpleFunction mDotProd' let dotProd :: [T] -> [T] -> R dotProd a b =- unsafeRemoveIO $+ EE.unsafeRemoveIO $ withArrayLen a $ \ aLen aPtr -> withArrayLen b $ \ bLen bPtr -> ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr@@ -64,26 +74,13 @@ print $ dotProd (vectorize 0 a) (vectorize 0 b) print $ sum $ zipWith (*) a b -class Vectorize n a where- vectorize :: a -> [a] -> [Vector n a]--{--instance (IsPrimitive a) => Vectorize D1 a where- vectorize _ [] = []- vectorize x (x1:xs) = toVector x1 : vectorize x xs--}--instance (IsPrimitive a) => Vectorize D2 a where- vectorize _ [] = []- vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs- vectorize x xs = vectorize x $ xs ++ [x]--instance (IsPrimitive a) => Vectorize D4 a where- vectorize _ [] = []- vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs- vectorize x xs = vectorize x $ xs ++ [x]+vectorize :: (Positive n) => a -> [a] -> [Vector n a]+vectorize deflt =+ List.unfoldr (\xs -> toMaybe (not $ null xs) (vectorizeHead deflt xs)) -instance (IsPrimitive a) => Vectorize D8 a where- vectorize _ [] = []- vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs- vectorize x xs = vectorize x $ xs ++ [x]+vectorizeHead :: (Positive n) => a -> [a] -> (Vector n a, [a])+vectorizeHead deflt ys =+ swap $+ Trav.mapAccumL+ (\xt () -> swap $ fromMaybe (deflt,[]) $ ListHT.viewL xt)+ ys (pure ())
example/Fibonacci.hs view
@@ -27,7 +27,12 @@ -- Create a module, m <- newNamedModule "fib" -- and define its contents.- fns <- defineModule m buildMod+ td <- EE.getTargetData+ fns <-+ defineModule m $ do+ setTarget hostTriple+ setDataLayout (EE.dataLayoutStr td)+ buildMod -- Show the code for the two functions, just for fun. --dumpValue $ mfib fns
example/HelloJIT.hs view
@@ -1,9 +1,8 @@ module Main (main) where -import LLVM.ExecutionEngine (simpleFunction)+import qualified LLVM.ExecutionEngine as EE import LLVM.Core -import Foreign.Ptr (Ptr) import Data.Word (Word8, Word32) @@ -11,15 +10,14 @@ bldGreet = withStringNul "Hello, JIT!" (\greetz -> do puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) func <- createFunction ExternalLinkage $ do- tmp <- getElementPtr0 greetz (0::Word32, ())- _ <- call puts tmp :: CodeGenFunction r (Value Word32)+ _ <- call puts =<< getElementPtr0 greetz (0::Word32, ()) ret () return func) main :: IO () main = do initializeNativeTarget- greet <- simpleFunction bldGreet+ greet <- EE.simpleFunction bldGreet greet greet greet
example/Intrinsic.hs view
@@ -4,10 +4,7 @@ import qualified LLVM.Core as LLVM import qualified LLVM.ExecutionEngine as EE -import qualified Foreign.Marshal.Utils as MU-import Foreign.Marshal.Alloc (alloca, )-import Foreign.Storable (peek, )-import Foreign.Ptr (Ptr, FunPtr, )+import Foreign.Ptr (FunPtr) import qualified Type.Data.Num.Decimal as TypeNum import qualified Data.Word as W@@ -42,7 +39,8 @@ LLVM.call f xs mode modul ::- LLVM.CodeGenModule (LLVM.Function (Ptr Vector -> Ptr Vector -> IO ()))+ LLVM.CodeGenModule+ (LLVM.Function (LLVM.Ptr Vector -> LLVM.Ptr Vector -> IO ())) modul = LLVM.createFunction LLVM.ExternalLinkage $ \ptr0 ptr1 -> do flip LLVM.store ptr1 =<< flip roundps (LLVM.valueOf 1) =<< LLVM.load ptr0@@ -51,7 +49,7 @@ type Importer func = FunPtr func -> func foreign import ccall safe "dynamic" derefFloorPtr ::- Importer (Ptr Vector -> Ptr Vector -> IO ())+ Importer (LLVM.Ptr Vector -> LLVM.Ptr Vector -> IO ()) run :: IO () run = do@@ -63,10 +61,10 @@ LLVM.writeBitcodeToFile "floor.bc" m print vector- MU.with vector $ \ptr0 ->- alloca $ \ptr1 -> do+ EE.with vector $ \ptr0 ->+ EE.alloca $ \ptr1 -> do floorFunc ptr0 ptr1- print =<< peek ptr1+ print =<< EE.peek ptr1 main :: IO ()
example/List.hs view
@@ -3,9 +3,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} module Main (main) where +import qualified LLVM.ExecutionEngine as EE import LLVM.Util.Loop (Phi, phis, addPhis, )-import LLVM.ExecutionEngine (simpleFunction, )-import LLVM.Core+import LLVM.Core as LLVM import qualified System.IO as IO import Data.Word (Word32, )@@ -14,7 +14,7 @@ import qualified Foreign.Storable as St import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )-import Foreign.Ptr (FunPtr, Ptr, )+import Foreign.Ptr (FunPtr) import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) @@ -64,8 +64,7 @@ (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32)) mList = createFunction ExternalLinkage $ \ ref size ptr -> do- next <- staticFunction nelem- let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32)+ next <- staticNamedFunction "next" nelem s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do flip store ptri =<< call next ref return y@@ -73,16 +72,15 @@ renderList :: IO () renderList = do- m <- newModule- _f <- defineModule m $ setTarget hostTriple >> mList+ m <- createModule $ setTarget hostTriple >> mList >> getModule writeBitcodeToFile "List.bc" m - fill <- simpleFunction mList+ fill <- EE.simpleFunction mList stable <- newStablePtr =<< newIORef [3,5..] IO.withFile "listcontent.u32" IO.WriteMode $ \h -> let len = 100 in allocaArray len $ \ ptr ->- fill stable (fromIntegral len) ptr >>+ fill stable (fromIntegral len) (LLVM.fromPtr ptr) >> IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32)) freeStablePtr stable
example/Struct.hs view
@@ -3,13 +3,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Main (main) where -import LLVM.ExecutionEngine (simpleFunction)+import qualified LLVM.ExecutionEngine as EE import LLVM.Util.File (writeCodeGenModule) import LLVM.Core import Type.Data.Num.Decimal.Literal (D10, d0, d1, d2) -import Foreign.Ptr (Ptr) import Data.Word (Word32) @@ -38,7 +37,7 @@ main = do initializeNativeTarget writeCodeGenModule "Struct.bc" mStruct- struct <- simpleFunction mStruct+ struct <- EE.simpleFunction mStruct let a = 10 p <- struct a putStrLn $ if structCheck a p /= 0 then "OK" else "failed"
example/Varargs.hs view
@@ -1,12 +1,16 @@ module Main (main) where -import LLVM.ExecutionEngine (simpleFunction)+import qualified LLVM.ExecutionEngine as EE import LLVM.Core -import Foreign.Ptr (Ptr) import Data.Word (Word8, Word32) +firstChar ::+ (Natural n) =>+ Value (Ptr (Array n Word8)) -> CodeGenFunction r (Value (Ptr Word8))+firstChar str = getElementPtr0 str (0::Word32, ())+ bldVarargs :: CodeGenModule (Function (Word32 -> IO ())) bldVarargs = withStringNul "Hello\n" (\fmt1 ->@@ -15,17 +19,14 @@ printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32) func <- createFunction ExternalLinkage $ \ x -> do - tmp1 <- getElementPtr0 fmt1 (0::Word32, ())- let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32)- _ <- call p1 tmp1+ tmp1 <- firstChar fmt1+ _ <- call (castVarArgs printf) tmp1 - tmp2 <- getElementPtr0 fmt2 (0::Word32, ())- let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32)- _ <- call p2 tmp2 x+ tmp2 <- firstChar fmt2+ _ <- call (castVarArgs printf) tmp2 x - tmp3 <- getElementPtr0 fmt3 (0::Word32, ())- let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32)- _ <- call p3 tmp3 x x+ tmp3 <- firstChar fmt3+ _ <- call (castVarArgs printf) tmp3 x x ret () return func@@ -34,5 +35,5 @@ main :: IO () main = do initializeNativeTarget- varargs <- simpleFunction bldVarargs+ varargs <- EE.simpleFunction bldVarargs varargs 42
example/Vector.hs view
@@ -68,10 +68,8 @@ return f createFuncModule :: IO (Module, Function (T -> IO T))-createFuncModule = do- m <- newModule- iovec <- defineModule m $ setTarget hostTriple >> cgvec- return (m, iovec)+createFuncModule =+ createModule $ setTarget hostTriple >> liftM2 (,) getModule cgvec main :: IO () main = do
llvm-tf.cabal view
@@ -1,16 +1,10 @@ Name: llvm-tf-Version: 9.1.1+Version: 9.2 License: BSD3 License-File: LICENSE Synopsis: Bindings to the LLVM compiler toolkit using type families. Description:- High-level bindings to the LLVM compiler toolkit- using type families instead of functional dependencies.- .- 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.- We may change the module names later.+ High-level bindings to the LLVM compiler toolkit using type families. . A note on versioning: The versions of this package are loosely based on the LLVM version.@@ -21,17 +15,20 @@ but not necessarily when we add support for a new LLVM version. We support all those LLVM versions that are supported by our @llvm-ffi@ dependency.+ .+ This package is a descendant of the @llvm@ package+ which used functional dependencies.+ The original @llvm@ package will no longer work+ with current versions of LLVM nor GHC. Author: Henning Thielemann, Bryan O'Sullivan, Lennart Augustsson Maintainer: Henning Thielemann <llvm@henning-thielemann.de> Stability: experimental Category: Compilers/Interpreters, Code Generation Tested-With: GHC == 7.4.2, GHC == 8.6.5-Cabal-Version: 1.14+Cabal-Version: 2.0 Build-Type: Simple Extra-Source-Files:- test/*.hs- test/Makefile Changes.md Source-Repository head@@ -39,7 +36,7 @@ Location: http://code.haskell.org/~thielema/llvm-tf/ Source-Repository this- Tag: 9.1.1+ Tag: 9.2 Type: darcs Location: http://code.haskell.org/~thielema/llvm-tf/ @@ -52,7 +49,7 @@ Description: Build example executables Default: False -Library+Library private Default-Language: Haskell98 Build-Depends: llvm-ffi >=9.1 && <9.2,@@ -68,7 +65,7 @@ containers >=0.4 && <0.7, base >=3 && <5 - Hs-Source-Dirs: src+ Hs-Source-Dirs: private GHC-Options: -Wall If flag(developer)@@ -84,6 +81,34 @@ cbits/malloc.c Exposed-Modules:+ LLVM.Core.CodeGen+ LLVM.Core.CodeGenMonad+ LLVM.Core.Data+ LLVM.Core.Instructions+ LLVM.Core.Instructions.Guided+ LLVM.Core.Instructions.Private+ LLVM.Core.Proxy+ LLVM.Core.Type+ LLVM.Core.Util+ LLVM.Core.Vector+ LLVM.Core.UnaryVector+ LLVM.ExecutionEngine.Engine+ LLVM.ExecutionEngine.Target+ LLVM.ExecutionEngine.Marshal++Library+ Default-Language: Haskell98+ Build-Depends:+ private,+ llvm-ffi,+ tfp,+ utility-ht,+ base++ Hs-Source-Dirs: src+ GHC-Options: -Wall++ Exposed-Modules: LLVM.Core LLVM.Core.Attribute LLVM.Core.Guided@@ -97,20 +122,22 @@ LLVM.Util.Optimize LLVM.Util.Proxy +Test-Suite llvm-test+ Type: exitcode-stdio-1.0+ Build-Depends:+ QuickCheck,+ private,+ llvm-tf,+ tfp,+ utility-ht,+ base+ Default-Language: Haskell98+ GHC-Options: -Wall+ Hs-Source-Dirs: test+ Main-Is: Main.hs Other-Modules:- LLVM.Core.CodeGen- LLVM.Core.CodeGenMonad- LLVM.Core.Data- LLVM.Core.Instructions- LLVM.Core.Instructions.Guided- LLVM.Core.Instructions.Private- LLVM.Core.Type- LLVM.Core.Util- LLVM.Core.Vector- LLVM.Core.UnaryVector- LLVM.ExecutionEngine.Engine- LLVM.ExecutionEngine.Target- LLVM.ExecutionEngine.Marshal+ Test.Chop+ Test.Marshal Executable llvm-align If flag(buildExamples)@@ -183,6 +210,7 @@ Build-Depends: llvm-tf, tfp,+ utility-ht, base Else Buildable: False
+ private/LLVM/Core/CodeGen.hs view
@@ -0,0 +1,721 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Core.CodeGen(+ -- * Module creation+ newModule, newNamedModule, defineModule, createModule, createNamedModule,+ getModuleValues, ModuleValue, castModuleValue, setTarget, setDataLayout,+ -- * Globals+ Linkage(..),+ Visibility(..),+ -- * Function creation+ Function, newFunction, newNamedFunction, defineFunction,+ createFunction, createNamedFunction, setFuncCallConv, functionParameter,+ addAttributes,+ FFI.AttributeIndex(..), Attribute(..),+ externFunction, staticFunction, staticNamedFunction,+ FunctionArgs, FunctionCodeGen, FunctionResult,+ TFunction,+ CodeValue, CodeResult,+ -- * Global variable creation+ Global, newGlobal, newNamedGlobal,+ defineGlobal, createGlobal, createNamedGlobal, TGlobal,+ externGlobal, staticGlobal,+ -- * Values+ Value(..), ConstValue(..), UnValue,+ IsConst(..), valueOf, value,+ IsConstFields,+ zero, allOnes, undef,+ createString, createStringNul,+ withString, withStringNul,+ constVector, constArray, constStruct, constPackedStruct,+ constCyclicVector, constCyclicArray,+ -- * Basic blocks+ BasicBlock(..), newBasicBlock, newNamedBasicBlock,+ defineBasicBlock, createBasicBlock, getCurrentBasicBlock,+ fromLabel, toLabel,+ -- * Misc+ withCurrentBuilder+ ) where++import qualified LLVM.Core.UnaryVector as UnaryVector+import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Proxy as LP+import LLVM.Core.CodeGenMonad+import LLVM.Core.Type+import LLVM.Core.Data hiding (Ptr)++import qualified LLVM.FFI.Core.Attribute as Attr+import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core(Linkage(..), Visibility(..))++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 Un+import Type.Base.Proxy (Proxy)++import qualified Foreign+import Foreign.C.String (withCString, withCStringLen)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr)+import Foreign.Ptr (FunPtr, castFunPtrToPtr)+import System.IO.Unsafe (unsafePerformIO)++import Control.Monad.IO.Class (liftIO)+import Control.Monad (liftM, when)+import Control.Applicative ((<*>))++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, Word)+import Data.Tuple.HT (mapSnd)+import Data.Maybe.HT (toMaybe)+import Data.Maybe (fromMaybe)++import Text.Printf (printf)++--------------------------------------++-- | Create a new module.+newModule :: IO U.Module+newModule = newNamedModule "_module" -- XXX should generate a name++-- | Create a new explicitely named module.+newNamedModule :: String -- ^ module name+ -> IO U.Module+newNamedModule = U.createModule++-- | Give the body for a module.+defineModule :: U.Module -- ^ module that is defined+ -> CodeGenModule a -- ^ module body+ -> IO a+defineModule = runCodeGenModule++-- | Create a new module with the given body.+createModule :: CodeGenModule a -- ^ module body+ -> IO a+createModule cgm = newModule >>= \ m -> defineModule m cgm++-- | Create a new explicitly named module with the given body.+createNamedModule :: String -- ^ module name+ -> CodeGenModule a -- ^ module body+ -> IO a+createNamedModule name cgm = newNamedModule name >>= \ m -> defineModule m cgm++setTarget :: String -> CodeGenModule ()+setTarget triple = do+ modul <- getModule+ liftIO $ U.withModule modul $ \m -> withCString triple $ FFI.setTarget m++setDataLayout :: String -> CodeGenModule ()+setDataLayout layout = do+ modul <- getModule+ liftIO $ U.withModule modul $ \m -> withCString layout $ FFI.setDataLayout m+++--------------------------------------++newtype ModuleValue = ModuleValue FFI.ValueRef+ deriving (Show, Typeable)++getModuleValues :: U.Module -> IO [(String, ModuleValue)]+getModuleValues =+ liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues++castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a)+castModuleValue (ModuleValue f) =+ toMaybe (U.valueHasType f (unsafeTypeRef (LP.Proxy :: LP.Proxy a))) (Value f)++--------------------------------------++newtype Value a = Value { unValue :: FFI.ValueRef }+ deriving (Show, Typeable)++newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef }+ deriving (Show, Typeable)++-- XXX merge with IsArithmetic?+class IsConst a where+ constOf :: a -> ConstValue a++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 Word where constOf = constI+instance IsConst Word8 where constOf = constI+instance IsConst Word16 where constOf = constI+instance IsConst Word32 where constOf = constI+instance IsConst Word64 where constOf = constI+instance IsConst Int where constOf = constI+instance IsConst Int8 where constOf = constI+instance IsConst Int16 where constOf = constI+instance IsConst Int32 where constOf = constI+instance IsConst Int64 where constOf = constI+instance IsConst Float where constOf = constF+instance IsConst Double where constOf = constF+--instance IsConst FP128 where constOf = constF++instance (Dec.Positive n) => IsConst (WordN n) where+ constOf (WordN i) = constInteger i+instance (Dec.Positive n) => IsConst (IntN n) where+ constOf (IntN i) = constInteger i++constOfPtr :: (IsType ptr) => ptr -> Foreign.Ptr b -> ConstValue ptr+constOfPtr proto p =+ let ip = p `Foreign.minusPtr` Foreign.nullPtr+ inttoptrC :: ConstValue int -> ConstValue ptr+ inttoptrC (ConstValue v) =+ unsafeConstValue $+ FFI.constIntToPtr v $ unsafeTypeRef $ LP.fromValue proto+ in inttoptrC $ constOf ip++-- This instance doesn't belong here, but mutually recursive modules are painful.+instance IsConst (Foreign.Ptr a) where+ constOf p = constOfPtr p p++instance (IsType a) => IsConst (Data.Ptr a) where+ constOf p = constOfPtr p (Data.uncheckedToPtr 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, Dec.Positive n) => IsConst (Vector n a) where+ constOf (Vector x) = constVectorGen constOf x++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) =+ unsafeConstValue $ U.constStruct (constFieldsOf a) False+instance (IsConstFields a) => IsConst (PackedStruct a) where+ constOf (PackedStruct a) =+ unsafeConstValue $ U.constStruct (constFieldsOf a) True++class IsConstFields a where+ constFieldsOf :: a -> [FFI.ValueRef]++instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where+ constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as+instance IsConstFields () where+ constFieldsOf _ = []+++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) FFI.false++{-+ToDo:+Passes a BigInt as decimal number string.+Not very efficient but quite generic.+Maybe Hex is better?+-}+constInteger :: (IsType (intN n)) => Integer -> ConstValue (intN n)+constInteger i =+ unsafeWithConstValue $ \typ ->+ withCString (show i) $ \cstr ->+ FFI.constIntOfString typ cstr 10++constI :: (IsInteger a, Integral a) => a -> ConstValue a+constI i =+ unsafeWithConstValue $ \typ ->+ FFI.constInt typ (fromIntegral i) (FFI.consBool $ isSigned $ LP.fromValue i)++constF :: (IsFloating a, Real a) => a -> ConstValue a+constF i =+ unsafeWithConstValue $ \typ -> FFI.constReal typ (realToFrac i)++valueOf :: (IsConst a) => a -> Value a+valueOf = value . constOf++value :: ConstValue a -> Value a+value (ConstValue a) = Value a++zero :: forall a . (IsType a) => ConstValue a+zero = unsafeWithConstValue FFI.constNull++allOnes :: forall a . (IsInteger a) => ConstValue a+allOnes = unsafeWithConstValue FFI.constAllOnes++undef :: forall a . (IsType a) => ConstValue a+undef = unsafeWithConstValue FFI.getUndef++{-+createString :: String -> ConstValue (DynamicArray Word8)+createString = ConstValue . U.constString++constStringNul :: String -> ConstValue (DynamicArray Word8)+constStringNul = ConstValue . U.constStringNul+-}++--------------------------------------+++-- |A function is simply a pointer to the function.+type Function a = Value (FunPtr a)++-- | Create a new named function.+newNamedFunction :: forall a . (IsFunction a)+ => Linkage+ -> String -- ^ Function name+ -> CodeGenModule (Function a)+newNamedFunction linkage name = do+ modul <- getModule+ 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+-- it needs a known name.+newFunction :: forall a . (IsFunction a)+ => Linkage+ -> CodeGenModule (Function a)+newFunction linkage = genMSym "fun" >>= newNamedFunction linkage++-- | Define a function body. The basic block returned by the function is the function entry point.+defineFunction :: forall f . (FunctionArgs f)+ => Function f -- ^ Function to define (created by 'newFunction').+ -> FunctionCodeGen f -- ^ Function body.+ -> CodeGenModule ()+defineFunction fn body = do+ bld <- liftIO $ U.createBuilder+ let body' = do+ newBasicBlock >>= defineBasicBlock+ paramFunc (unValue fn) (proxyFromFunction fn) body 0+ runCodeGenFunction bld (unValue fn) body'++proxyFromFunction :: Function f -> LP.Proxy f+proxyFromFunction _ = LP.Proxy++-- | Create a new function with the given body.+createFunction :: (FunctionArgs f)+ => Linkage+ -> FunctionCodeGen f -- ^ Function body.+ -> CodeGenModule (Function f)+createFunction linkage body = do+ f <- newFunction linkage+ defineFunction f body+ return f++-- | Create a new function with the given body.+createNamedFunction :: (FunctionArgs f)+ => Linkage+ -> String+ -> FunctionCodeGen f -- ^ Function body.+ -> CodeGenModule (Function f)+createNamedFunction linkage name body = do+ f <- newNamedFunction linkage name+ defineFunction f body+ return f++-- | Set the calling convention of a function. By default it is the+-- C calling convention.+setFuncCallConv :: Function a+ -> FFI.CallingConvention+ -> CodeGenModule ()+setFuncCallConv (Value f) cc = do+ liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc)++data Attribute = Attribute Attr.Name Word64++-- | Add attributes to a value. Beware, what attributes are allowed depends on+-- what kind of value it is.+addAttributes ::+ Value a -> FFI.AttributeIndex -> [Attribute] -> CodeGenFunction r ()+addAttributes (Value f) i as =+ liftIO $ do+ context <- FFI.getGlobalContext+ Fold.forM_ as $ \(Attribute (Attr.Name name) val) -> do+ attrKind <-+ withCStringLen name $+ uncurry FFI.getEnumAttributeKindForName .+ mapSnd fromIntegral+ FFI.addCallSiteAttribute f i =<<+ FFI.createEnumAttribute context attrKind val++{- |+Convert a function @f@ of type @t1->t2->...-> IO r@ to+@Value t1 -> Value t2 -> ... CodeGenFunction r ()@.+-}+class IsFunction f => FunctionArgs f where+ type FunctionCodeGen f :: *+ type FunctionResult f :: *+ paramFunc ::+ FFI.ValueRef -> LP.Proxy f -> FunctionCodeGen f ->+ Int -> CodeGenFunction (FunctionResult f) ()++instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where+ type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b+ type FunctionResult (a -> b) = FunctionResult b+ paramFunc f proxy g n =+ paramFunc f (proxy<*>LP.Proxy) (g $ Value $ U.getParam f n) (n+1)++instance IsFirstClass a => FunctionArgs (IO a) where+ type FunctionCodeGen (IO a) = CodeGenFunction a ()+ type FunctionResult (IO a) = a+ paramFunc _ LP.Proxy code = const code+++type family UnaryParameter f i+type instance UnaryParameter (a -> b) Un.Zero = a+type instance UnaryParameter (a -> b) (Un.Succ i) = UnaryParameter b i++type FunctionParameter f i = UnaryParameter f (Dec.ToUnary i)++{- |+Preferably you use the parameter values provided by+'createFunction' or 'defineFunction',+but sometimes you need to access a parameter+after 'newFunction' and before 'defineFunction'.+In this case you can obtain a function parameter using this accessor.+-}+functionParameter ::+ (Dec.Natural i) => Function f -> Proxy i -> Value (FunctionParameter f i)+functionParameter (Value f) n =+ Value $ U.getParam f $ Dec.integralFromProxy n+++type family UnValue a+type instance UnValue (Value a) = a++type family CodeValue code+type instance CodeValue (CodeGenFunction r a) = a+type instance CodeValue (a -> b) = CodeValue b++type family CodeResult code+type instance CodeResult (CodeGenFunction r a) = r+type instance CodeResult (a -> b) = CodeResult b+++--------------------------------------++-- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction.+newtype BasicBlock = BasicBlock FFI.BasicBlockRef+ deriving (Show, Typeable)++createBasicBlock :: CodeGenFunction r BasicBlock+createBasicBlock = do+ b <- newBasicBlock+ defineBasicBlock b+ return b++newBasicBlock :: CodeGenFunction r BasicBlock+newBasicBlock = genFSym >>= newNamedBasicBlock++newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock+newNamedBasicBlock name = do+ fn <- getFunction+ liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name++defineBasicBlock :: BasicBlock -> CodeGenFunction r ()+defineBasicBlock (BasicBlock l) = do+ bld <- getBuilder+ liftIO $ U.positionAtEnd bld l++getCurrentBasicBlock :: CodeGenFunction r BasicBlock+getCurrentBasicBlock = do+ bld <- getBuilder+ liftIO $ liftM BasicBlock $ U.getInsertBlock bld++toLabel :: BasicBlock -> Value Label+toLabel (BasicBlock ptr) =+ Value (unsafePerformIO $ FFI.basicBlockAsValue ptr)++fromLabel :: Value Label -> BasicBlock+fromLabel (Value ptr) =+ BasicBlock (unsafePerformIO $ FFI.valueAsBasicBlock ptr)++--------------------------------------++--- XXX: the functions in this section (and addGlobalMapping) don't actually use any+-- Function state so should really be in the CodeGenModule monad++{- |+Create a reference to an external function while code generating for a function.+Functions are not redefined, that is,+all functions with the same name must have the same type.+If LLVM cannot resolve the function 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++-- | 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++externCore ::+ String -> (String -> CodeGenModule FFI.ValueRef) ->+ CodeGenFunction r (Value ptr)+externCore name act = do+ es <- getExterns+ case lookup name es of+ Just f -> return $ Value f+ Nothing -> do+ f <- liftCodeGenModule $ act name+ putExterns ((name, f) : es)+ return $ Value f++{- |+Make an external C function with a fixed address callable from LLVM code.+This callback function can also be a Haskell function,+that was imported like++> foreign import ccall "&nextElement"+> nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)++See @examples\/List.hs@.++When you only use 'externFunction', then LLVM cannot resolve the name.+(However, I do not know why.)+Thus 'staticFunction' manages a list of static functions.+This list is automatically installed by 'ExecutionEngine.simpleFunction'+and can be manually obtained by 'getGlobalMappings'+and installed by 'ExecutionEngine.addGlobalMappings'.+\"Installing\" means calling LLVM's @addGlobalMapping@ according to+<http://old.nabble.com/jit-with-external-functions-td7769793.html>.+-}+staticFunction :: forall f r.+ (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f)+staticFunction = staticNamedFunction ""++{- |+Due to <https://llvm.org/bugs/show_bug.cgi?id=20656>+this will fail with MCJIT of LLVM-3.6.+-}+staticNamedFunction :: forall f r.+ (IsFunction f) => String -> FunPtr f -> CodeGenFunction r (Function f)+staticNamedFunction name func = liftCodeGenModule $ do+ val <- newNamedFunction ExternalLinkage name+ 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 -> Data.Ptr a -> CodeGenFunction r (Global a)+staticGlobal isConst gbl = liftCodeGenModule $ do+ val <- newNamedGlobal isConst ExternalLinkage ""+ addGlobalMapping (unValue (val :: Global a)) gbl+ return val++--------------------------------------++withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a+withCurrentBuilder body = do+ bld <- getBuilder+ liftIO $ U.withBuilder bld body++--------------------------------------++-- Mark all block terminating instructions. Not used yet.+--data Terminate = Terminate++--------------------------------------++type Global a = Value (Data.Ptr a)++-- | Create a new named global variable.+newNamedGlobal :: forall a . (IsType a)+ => Bool -- ^Constant?+ -> Linkage -- ^Visibility+ -> String -- ^Name+ -> TGlobal a+newNamedGlobal isConst linkage name = do+ modul <- getModule+ typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a)+ liftIO $ liftM Value $ do+ g <- U.addGlobal modul linkage name typ+ when isConst $ FFI.setGlobalConstant g FFI.true+ return g++-- | Create a new global variable.+newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a+newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage++-- | Give a global variable a (constant) value.+defineGlobal :: Global a -> ConstValue a -> CodeGenModule ()+defineGlobal (Value g) (ConstValue v) =+ liftIO $ FFI.setInitializer g v++-- | Create and define a global variable.+createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a+createGlobal isConst linkage con = do+ g <- newGlobal isConst linkage+ defineGlobal g con+ return g++-- | Create and define a named global variable.+createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a+createNamedGlobal isConst linkage name con = do+ g <- newNamedGlobal isConst linkage name+ defineGlobal g con+ return g++type TFunction a = CodeGenModule (Function a)+type TGlobal a = CodeGenModule (Global a)++-- Special string creators+{-# DEPRECATED createString "use withString instead" #-}+createString :: String -> TGlobal (Array n Word8)+createString s = string (length s) (U.constString s)++{-# DEPRECATED createStringNul "use withStringNul instead" #-}+createStringNul :: String -> TGlobal (Array n Word8)+createStringNul s = string (length s + 1) (U.constStringNul s)++withString ::+ String ->+ (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") $+ Dec.reifyNatural (fromIntegral n) (\tn -> do+ arr <- string n (U.constString s)+ act (fixArraySize tn arr))++withStringNul ::+ String ->+ (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") $+ Dec.reifyNatural (fromIntegral n) (\tn -> do+ arr <- string n (U.constStringNul s)+ act (fixArraySize tn arr))++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"+ 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 FFI.true+ FFI.setInitializer g s+ return g++--------------------------------------++-- |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++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.fromFixedList 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+ let m = length xs+ n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)+ when (m /= n) $+ error $+ printf "LLVM.constArray: number of array elements (%d) mismatches typed array length (%d)"+ m n+ 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 struct =+ unsafeConstValue $ U.constStruct (constValueFieldsOf struct) False++-- |Make a constant packed struct.+constPackedStruct ::+ (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c))+constPackedStruct struct =+ unsafeConstValue $ U.constStruct (constValueFieldsOf struct) True++class IsConstStruct c where+ type ConstStructOf c :: *+ constValueFieldsOf :: c -> [FFI.ValueRef]++instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where+ type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs)+ constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as+instance IsConstStruct () where+ type ConstStructOf () = ()+ constValueFieldsOf _ = []
+ private/LLVM/Core/CodeGenMonad.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.CodeGenMonad(+ -- * Module code generation+ CodeGenModule, runCodeGenModule, genMSym, getModule,+ GlobalMappings(..), addGlobalMapping, getGlobalMappings,+ addFunctionMapping,+ -- * Function code generation+ CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns,+ ) where++import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Type as Type+import LLVM.Core.Util (Module, Builder, Function, getValueNameU, withModule, )++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.ExecutionEngine as EE++import Foreign.C.String (withCString, )+import Foreign.Ptr (FunPtr, nullPtr, )++import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, )+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad (when, )+import Control.Applicative (Applicative, )+import Data.Monoid (Monoid, mempty, mappend, )+import Data.Semigroup (Semigroup, (<>), )++import Data.Typeable (Typeable)++--------------------------------------++data CGMState = CGMState {+ cgm_module :: Module,+ cgm_externs :: [(String, Function)],+ cgm_global_mappings :: GlobalMappings,+ cgm_next :: !Int+ }+ deriving (Show, Typeable)+newtype CodeGenModule a = CGM (StateT CGMState IO a)+ deriving (Functor, Applicative, Monad, MonadIO, Typeable)++genMSym :: String -> CodeGenModule String+genMSym prefix = do+ s <- CGM get+ let n = cgm_next s+ CGM $ put (s { cgm_next = n + 1 })+ return $ "_" ++ prefix ++ show n++getModule :: CodeGenModule Module+getModule = CGM $ gets cgm_module++runCodeGenModule :: Module -> CodeGenModule a -> IO a+runCodeGenModule m (CGM body) =+ evalStateT body $+ CGMState {+ cgm_module = m, cgm_next = 1,+ cgm_externs = [], cgm_global_mappings = mempty+ }++--------------------------------------++data CGFState r = CGFState {+ cgf_module :: CGMState,+ cgf_builder :: Builder,+ cgf_function :: Function,+ cgf_next :: !Int+ }+ deriving (Show, Typeable)+newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)+ deriving (Functor, Applicative, Monad, MonadIO, Typeable)++genFSym :: CodeGenFunction a String+genFSym = do+ s <- CGF get+ let n = cgf_next s+ CGF $ put (s { cgf_next = n + 1 })+ return $ "_L" ++ show n++getFunction :: CodeGenFunction a Function+getFunction = CGF $ gets cgf_function++getBuilder :: CodeGenFunction a Builder+getBuilder = CGF $ gets cgf_builder++getFunctionModule :: CodeGenFunction a Module+getFunctionModule = CGF $ gets (cgm_module . cgf_module)++getExterns :: CodeGenFunction a [(String, Function)]+getExterns = CGF $ gets (cgm_externs . cgf_module)++putExterns :: [(String, Function)] -> CodeGenFunction a ()+putExterns es = do+ cgf <- CGF get+ let cgm' = (cgf_module cgf) { cgm_externs = es }+ CGF $ put (cgf { cgf_module = cgm' })+++type Value = FFI.ValueRef++addGlobalMapping :: (Type.IsType a) => Value -> Data.Ptr a -> CodeGenModule ()+addGlobalMapping value ptr = CGM $+ addMappingToState $+ GlobalMappings (\ee ->+ EE.addGlobalMapping ee value $ Data.uncheckedToPtr ptr)++addFunctionMapping :: Function -> FunPtr f -> CodeGenModule ()+addFunctionMapping value func = CGM $ do+ {-+ We need to fetch the name from the value+ since it might have been disambiguized after adding.+ -}+ name <- liftIO $ getValueNameU value+ modul <- gets cgm_module+ addMappingToState $+ GlobalMappings $ \ee -> do+ {-+ Between adding and application+ the program may have been restructured by optimization passes.+ I have not seen that the optimizer alters a Function Value pointer,+ but the optimizer can remove an unused function.+ That would render the original value invalid.+ -}+ currentValue <-+ liftIO $+ withCString name $ \cname ->+ withModule modul $ \cmodule ->+ FFI.getNamedFunction cmodule cname+ -- the optimizer could have removed the function+ when (currentValue/=nullPtr) $+ EE.addFunctionMapping ee currentValue func++addMappingToState :: GlobalMappings -> StateT CGMState IO ()+addMappingToState gm =+ modify $ \cgm ->+ cgm { cgm_global_mappings = cgm_global_mappings cgm <> gm }++newtype GlobalMappings =+ GlobalMappings (EE.ExecutionEngineRef -> IO ())++instance Show GlobalMappings where+ show _ = "GlobalMappings"++instance Semigroup GlobalMappings where+ GlobalMappings x <> GlobalMappings y =+ GlobalMappings (\ee -> x ee >> y ee)++instance Monoid GlobalMappings where+ mempty = GlobalMappings $ const $ return ()+ mappend = (<>)+++{- |+Get a list created by calls to 'staticFunction'+that must be passed to the execution engine+via 'LLVM.ExecutionEngine.addGlobalMappings'.+-}+getGlobalMappings :: CodeGenModule GlobalMappings+getGlobalMappings = CGM $ gets cgm_global_mappings++runCodeGenFunction ::+ Builder -> Function -> CodeGenFunction r a -> CodeGenModule a+runCodeGenFunction bld fn (CGF body) = do+ cgm <- CGM get+ let cgf = CGFState { cgf_module = cgm,+ cgf_builder = bld,+ cgf_function = fn,+ cgf_next = 1 }+ (a, cgf') <- liftIO $ runStateT body cgf+ CGM $ put (cgf_module cgf')+ return a++--------------------------------------++-- | Allows you to define part of a module while in the middle of defining a function.+liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a+liftCodeGenModule (CGM act) = do+ cgf <- CGF get+ (a, cgm') <- liftIO $ runStateT act (cgf_module cgf)+ CGF $ put (cgf { cgf_module = cgm' })+ return a
+ private/LLVM/Core/Data.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+module LLVM.Core.Data (+ Ptr(..), uncheckedFromPtr, uncheckedToPtr,+ IntN(..), WordN(..), FP128(..),+ Array(..), Vector(..), Label, Struct(..), PackedStruct(..),+ FixedList,+ ) where++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 Type.Base.Proxy (Proxy(Proxy))++import qualified Foreign++import qualified Data.Foldable as Fold+import qualified Data.Bits as Bits++import Data.Typeable (Typeable)++import qualified Test.QuickCheck as QC+++{- |+We export the constructor such that you can use 'Ptr' in foreign imports.+However, we recommend that you call 'uncheckedFromPtr' instead.+-}+newtype Ptr a = Ptr (Foreign.Ptr a)+ deriving (Show, Eq, Ord, Typeable)++uncheckedFromPtr :: Foreign.Ptr a -> Ptr a+uncheckedFromPtr = Ptr++uncheckedToPtr :: Ptr a -> Foreign.Ptr a+uncheckedToPtr (Ptr ptr) = ptr++instance Foreign.Storable (Ptr a) where+ sizeOf = Foreign.sizeOf . uncheckedToPtr+ alignment = Foreign.alignment . uncheckedToPtr+ poke p = Foreign.pokeByteOff p 0 . uncheckedToPtr+ peek p = fmap uncheckedFromPtr $ Foreign.peekByteOff p 0+++-- TODO:+-- Make instances IntN, WordN to actually do the right thing.+-- Make FP128 do the right thing+-- Make Array functions.++-- |Variable sized signed integer.+-- The /n/ parameter should belong to @PosI@.+newtype IntN n = IntN Integer+ deriving (Show, Eq, Ord, Typeable)++instance (Dec.Positive n) => QC.Arbitrary (IntN n) where+ arbitrary = arbitraryInt IntN (\(IntN a) -> a)++instance (Dec.Positive n) => Bounded (IntN n) where+ minBound =+ withBitSize $+ IntN . negate . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy+ maxBound =+ withBitSize $+ IntN . subtract 1 . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy++-- |Variable sized unsigned integer.+-- The /n/ parameter should belong to @PosI@.+newtype WordN n = WordN Integer+ deriving (Show, Eq, Ord, Typeable)++instance (Dec.Positive n) => QC.Arbitrary (WordN n) where+ arbitrary = arbitraryInt WordN (\(WordN a) -> a)++instance (Dec.Positive n) => Bounded (WordN n) where+ minBound = WordN 0+ maxBound =+ withBitSize $ WordN . subtract 1 . Bits.shiftL 1 . Dec.integralFromProxy++arbitraryInt :: (Bounded a) => (Integer -> a) -> (a -> Integer) -> QC.Gen a+arbitraryInt wrap unwrap =+ case (minBound, maxBound) of+ (a,b) -> do+ x <- QC.choose (unwrap a, unwrap b)+ return $ wrap x `asTypeOf` a `asTypeOf` b++withBitSize :: (Proxy n -> f n) -> f n+withBitSize f = f Proxy++-- |128 bit floating point.+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 (Eq, Show, Typeable)++instance (Dec.Integer n) => Fold.Foldable (Array n) where+ foldMap f (Array xs) = Fold.foldMap f xs++instance (Dec.Integer n, QC.Arbitrary a) => QC.Arbitrary (Array n a) where+ arbitrary = withArraySize $ fmap Array . QC.vector . Dec.integralFromProxy++withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a)+withArraySize f = f Proxy++-- |Fixed sized vector, the array size is encoded in the /n/ parameter.+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.fromFixedList xs+ :: UnaryVector.T (Dec.ToUnary n) a))++-- |Label type, produced by a basic block.+data Label+ deriving (Typeable)++-- |Struct types; a list (nested tuple) of component types.+newtype Struct a = Struct a+ deriving (Eq, Show, Typeable)+newtype PackedStruct a = PackedStruct a+ deriving (Eq, Show, Typeable)++instance (QC.Arbitrary a) => QC.Arbitrary (Struct a) where+ arbitrary = fmap Struct QC.arbitrary
+ private/LLVM/Core/Instructions.hs view
@@ -0,0 +1,1257 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module LLVM.Core.Instructions(+ -- * ADT representation of IR+ BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,+ -- * Terminator instructions+ ret,+ condBr,+ br,+ switch,+ invoke, invokeWithConv,+ invokeFromFunction, invokeWithConvFromFunction,+ unreachable,+ -- * Arithmetic binary operations+ -- | Arithmetic operations with the normal semantics.+ -- The u instructions are unsigned, the s instructions are signed.+ add, sub, mul, neg,+ iadd, isub, imul, ineg,+ iaddNoWrap, isubNoWrap, imulNoWrap, inegNoWrap,+ fadd, fsub, fmul, fneg,+ idiv, irem,+ udiv, sdiv, fdiv, urem, srem, frem,+ -- * Logical binary operations+ -- |Logical instructions with the normal semantics.+ shl, shr, lshr, ashr, and, or, xor, inv,+ -- * Vector operations+ extractelement,+ insertelement,+ shufflevector,+ -- * Aggregate operation+ extractvalue,+ insertvalue,+ -- * Memory access+ malloc, arrayMalloc,+ alloca, arrayAlloca,+ free,+ load,+ store,+ getElementPtr, getElementPtr0,+ -- * Conversions+ ValueCons,+ trunc, zext, sext, ext, zadapt, sadapt, adapt,+ fptrunc, fpext,+ fptoui, fptosi, fptoint,+ uitofp, sitofp, inttofp,+ ptrtoint, inttoptr,+ bitcast,+ -- * Comparison+ CmpPredicate(..), IntPredicate(..), FPPredicate(..),+ CmpRet, CmpResult, CmpValueResult,+ cmp, pcmp, icmp, fcmp,+ select,+ -- * Fast math+ setHasNoNaNs,+ setHasNoInfs,+ setHasNoSignedZeros,+ setHasAllowReciprocal,+ setFastMath,+ -- * Other+ phi, addPhiInputs,+ call, callWithConv,+ callFromFunction, callWithConvFromFunction,+ Call, applyCall, runCall,++ -- * Classes and types+ ValueCons2, BinOpValue,+ Terminate, Ret, Result, CallArgs,+ CodeGen.FunctionArgs, CodeGen.FunctionCodeGen, CodeGen.FunctionResult,+ AllocArg,+ GetElementPtr, ElementPtrType, IsIndexArg, IsIndexType,+ GetValue, ValueType,+ GetField, FieldType,+ ) where++import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Proxy as LP+import qualified LLVM.Core.CodeGen as CodeGen+import LLVM.Core.Instructions.Private+ (ValueCons, unValue, convert, unop,+ FFIBinOp, FFIConstBinOp,+ GetField, FieldType, GetElementPtr, ElementPtrType,+ IsIndexArg, IsIndexType, getIxList, getArg,+ CmpPredicate(..),+ uintFromCmpPredicate, sintFromCmpPredicate, fpFromCmpPredicate)+import LLVM.Core.Data+import LLVM.Core.Type+import LLVM.Core.CodeGenMonad+import LLVM.Core.CodeGen+ (BasicBlock(BasicBlock), Function, withCurrentBuilder,+ ConstValue(ConstValue), zero,+ Value(Value), value, valueOf, UnValue, CodeResult)++import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Literal (d1)+import Type.Data.Num.Decimal.Number ((:<:), (:>:))+import Type.Base.Proxy (Proxy)++import qualified Foreign+import Foreign.Ptr (FunPtr)+import Foreign.C (CUInt, CInt)++import Control.Monad.IO.Class (liftIO)+import Control.Monad (liftM)++import qualified Data.Map as Map+import Data.Map (Map)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)++import Prelude hiding (and, or)+++-- TODO:+-- Add vector version of arithmetic+-- Add rest of instructions+-- Use Terminate to ensure bb termination (how?)+-- more intrinsics are needed to, e.g., create an empty vector++data ArgDesc = AV String | AI Int | AL String | AE++instance Show ArgDesc where+ -- show (AV s) = "V_" ++ s+ -- show (AI i) = "I_" ++ show i+ -- show (AL l) = "L_" ++ l+ show (AV s) = s+ show (AI i) = show i+ show (AL l) = l+ show AE = "voidarg?"++data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd+ | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub+ | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul+ | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem+ | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor+ deriving Show++-- FIXME: complete definitions for unimplemented instructions+data InstrDesc =+ -- terminators+ IDRet TypeDesc ArgDesc | IDRetVoid+ | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc+ | IDSwitch [(ArgDesc, ArgDesc)]+ | IDIndirectBr+ | IDInvoke+ | IDUnwind+ | IDUnreachable+ -- binary operators (including bitwise)+ | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc+ -- memory access and addressing+ | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc+ | IDGetElementPtr TypeDesc [ArgDesc]+ -- conversion+ | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc+ | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc+ | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc+ | IDSItoFP TypeDesc TypeDesc ArgDesc+ | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc+ | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc+ | IDBitcast TypeDesc TypeDesc ArgDesc+ -- other+ | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc+ | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]+ | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg+ -- vector operators+ | IDExtractElement | IDInsertElement | IDShuffleVector+ -- aggregate operators+ | IDExtractValue | IDInsertValue+ -- invalid+ | IDInvalidOp+ deriving Show++-- TODO: overflow support for binary operations (add/sub/mul)+getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)+getInstrDesc v = do+ valueName <- U.getValueNameU v+ opcode <- FFI.instGetOpcode v+ t <- FFI.typeOf v >>= typeDesc2+ -- FIXME: sizeof() does not work for types!+ --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral+ tsize <- return 1+ ovs <- U.getOperands v+ os <- mapM getArgDesc ovs+ os0 <- return $ case os of {o:_ -> o; _ -> AE}+ os1 <- return $ case os of {_:o:_ -> o; _ -> AE}+ instr <-+ case Map.lookup opcode binOpMap of -- binary arithmetic+ Just op -> return $ IDBinOp op t os0 os1+ Nothing ->+ case Map.lookup opcode convOpMap of+ Just op -> do+ t2 <-+ case ovs of+ (_name,ov):_ -> FFI.typeOf ov >>= typeDesc2+ _ -> return TDVoid+ return $ op t2 t os0+ Nothing ->+ case opcode of+ 1 -> return $ if null os then IDRetVoid else IDRet t os0+ 2 -> return $ if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1+ 3 -> return $ IDSwitch $ toPairs os+ -- TODO (can skip for now)+ -- 4 -> return IndirectBr ; 5 -> return Invoke+ 6 -> return IDUnwind; 7 -> return IDUnreachable+ 26 -> return $ IDAlloca (getPtrType t) tsize (getImmInt os0)+ 27 -> return $ IDLoad t os0; 28 -> return $ IDStore t os0 os1+ 29 -> return $ IDGetElementPtr t os+ 42 -> do+ pInt <- FFI.cmpInstGetIntPredicate v+ return $ IDICmp (FFI.toIntPredicate pInt) os0 os1+ 43 -> do+ pFloat <- FFI.cmpInstGetRealPredicate v+ return $ IDFCmp (FFI.toRealPredicate pFloat) os0 os1+ 44 -> return $ IDPhi t $ toPairs os+ -- FIXME: getelementptr arguments are not handled+ 45 -> return $ IDCall t (last os) (init os)+ 46 -> return $ IDSelect t os0 os1+ -- TODO (can skip for now)+ -- 47 -> return UserOp1 ; 48 -> return UserOp2 ; 49 -> return VAArg+ -- 50 -> return ExtractElement ; 51 -> return InsertElement ; 52 -> return ShuffleVector+ -- 53 -> return ExtractValue ; 54 -> return InsertValue+ _ -> return IDInvalidOp+ return (valueName, instr)+ --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode+ where toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))+ stride _ [] = []+ stride n (x:xs) = x : stride n (drop (n-1) xs)+ getPtrType (TDPtr t) = t+ getPtrType _ = TDVoid+ getImmInt (AI i) = i+ getImmInt _ = 0++binOpMap :: Map CInt BinOpDesc+binOpMap =+ Map.fromList+ [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),+ (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),+ (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),+ (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),+ (24, BOOr), (25, BOXor)]++convOpMap :: Map CInt (TypeDesc -> TypeDesc -> ArgDesc -> InstrDesc)+convOpMap =+ Map.fromList+ [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),+ (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),+ (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)]++-- TODO: fix for non-int constants+getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc+getArgDesc (vname, v) = do+ isC <- U.isConstant v+ t <- FFI.typeOf v >>= typeDesc2+ if isC+ then case t of+ TDInt _ _ -> do+ cV <- FFI.constIntGetSExtValue v+ return $ AI $ fromIntegral cV+ _ -> return AE+ else case t of+ TDLabel -> return $ AL vname+ _ -> return $ AV vname++--------------------------------------++type Terminate = ()+terminate :: Terminate+terminate = ()++--------------------------------------++-- |Acceptable arguments to the 'ret' instruction.+class Ret a where+ type Result a+ ret' :: a -> CodeGenFunction (Result a) Terminate++-- | Return from the current function with the given value. Use () as the return value for what would be a void function in C.+ret :: (Ret a) => a -> CodeGenFunction (Result a) Terminate+ret = ret'++-- overlaps with Ret () ()!+{-+instance (IsFirstClass a, IsConst a) => Ret a a where+ ret' = ret . valueOf+-}++instance Ret (Value a) where+ type Result (Value a) = a+ ret' (Value a) = do+ withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a+ return terminate++instance Ret () where+ type Result () = ()+ ret' _ = do+ withCurrentBuilder_ $ FFI.buildRetVoid+ return terminate++withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r ()+withCurrentBuilder_ p = withCurrentBuilder p >> return ()++--------------------------------------++-- | Branch to the first basic block if the boolean is true, otherwise to the second basic block.+condBr :: Value Bool -- ^ Boolean to branch upon.+ -> BasicBlock -- ^ Target for true.+ -> BasicBlock -- ^ Target for false.+ -> CodeGenFunction r Terminate+condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do+ withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2+ return terminate++--------------------------------------++-- | Unconditionally branch to the given basic block.+br :: BasicBlock -- ^ Branch target.+ -> CodeGenFunction r Terminate+br (BasicBlock t) = do+ withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t+ return terminate++--------------------------------------++-- | Branch table instruction.+switch :: (IsInteger a)+ => Value a -- ^ Value to branch upon.+ -> BasicBlock -- ^ Default branch target.+ -> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets.+ -> CodeGenFunction r Terminate+switch (Value val) (BasicBlock dflt) arms = do+ withCurrentBuilder_ $ \ bldPtr -> do+ inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms)+ sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ]+ return terminate++--------------------------------------++-- |Inform the code generator that this code can never be reached.+unreachable :: CodeGenFunction r Terminate+unreachable = do+ withCurrentBuilder_ FFI.buildUnreachable+ return terminate++--------------------------------------+++withArithmeticType ::+ (IsArithmetic c) =>+ (ArithmeticType c -> a -> CodeGenFunction r (v c)) ->+ (a -> CodeGenFunction r (v c))+withArithmeticType f = f arithmeticType+++class (ValueCons value0, ValueCons value1) => ValueCons2 value0 value1 where+ type BinOpValue (value0 :: * -> *) (value1 :: * -> *) :: * -> *+ binop ::+ FFIConstBinOp -> FFIBinOp ->+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)++instance ValueCons2 Value Value where+ type BinOpValue Value Value = Value+ binop _ op (Value a1) (Value a2) = buildBinOp op a1 a2++instance ValueCons2 Value ConstValue where+ type BinOpValue Value ConstValue = Value+ binop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2++instance ValueCons2 ConstValue Value where+ type BinOpValue ConstValue Value = Value+ binop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2++instance ValueCons2 ConstValue ConstValue where+ type BinOpValue ConstValue ConstValue = ConstValue+ binop cop _ (ConstValue a1) (ConstValue a2) =+ liftIO $ fmap ConstValue $ cop a1 a2+++add, sub, mul ::+ (ValueCons2 value0 value1, IsArithmetic a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+add =+ curry $ withArithmeticType $ \typ -> uncurry $ case typ of+ IntegerType -> binop FFI.constAdd FFI.buildAdd+ FloatingType -> binop FFI.constFAdd FFI.buildFAdd++sub =+ curry $ withArithmeticType $ \typ -> uncurry $ case typ of+ IntegerType -> binop FFI.constSub FFI.buildSub+ FloatingType -> binop FFI.constFSub FFI.buildFSub++mul =+ curry $ withArithmeticType $ \typ -> uncurry $ case typ of+ IntegerType -> binop FFI.constMul FFI.buildMul+ FloatingType -> binop FFI.constFMul FFI.buildFMul++iadd, isub, imul ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+iadd = binop FFI.constAdd FFI.buildAdd+isub = binop FFI.constSub FFI.buildSub+imul = binop FFI.constMul FFI.buildMul++iaddNoWrap, isubNoWrap, imulNoWrap ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+iaddNoWrap =+ sbinop FFI.constNSWAdd FFI.buildNSWAdd FFI.constNUWAdd FFI.buildNUWAdd+isubNoWrap =+ sbinop FFI.constNSWSub FFI.buildNSWSub FFI.constNUWSub FFI.buildNUWSub+imulNoWrap =+ sbinop FFI.constNSWMul FFI.buildNSWMul FFI.constNUWMul FFI.buildNUWMul++-- | signed or unsigned integer division depending on the type+idiv ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+idiv = sbinop FFI.constSDiv FFI.buildSDiv FFI.constUDiv FFI.buildUDiv+-- | signed or unsigned remainder depending on the type+irem ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+irem = sbinop FFI.constSRem FFI.buildSRem FFI.constURem FFI.buildURem++{-# DEPRECATED udiv "use idiv instead" #-}+{-# DEPRECATED sdiv "use idiv instead" #-}+{-# DEPRECATED urem "use irem instead" #-}+{-# DEPRECATED srem "use irem instead" #-}+udiv, sdiv, urem, srem ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+udiv = binop FFI.constUDiv FFI.buildUDiv+sdiv = binop FFI.constSDiv FFI.buildSDiv+urem = binop FFI.constURem FFI.buildURem+srem = binop FFI.constSRem FFI.buildSRem++fadd, fsub, fmul ::+ (ValueCons2 value0 value1, IsFloating a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+fadd = binop FFI.constFAdd FFI.buildFAdd+fsub = binop FFI.constFSub FFI.buildFSub+fmul = binop FFI.constFMul FFI.buildFMul++-- | Floating point division.+fdiv ::+ (ValueCons2 value0 value1, IsFloating a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+fdiv = binop FFI.constFDiv FFI.buildFDiv+-- | Floating point remainder.+frem ::+ (ValueCons2 value0 value1, IsFloating a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+frem = binop FFI.constFRem FFI.buildFRem++shl, lshr, ashr, and, or, xor ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+shl = binop FFI.constShl FFI.buildShl+lshr = binop FFI.constLShr FFI.buildLShr+ashr = binop FFI.constAShr FFI.buildAShr+and = binop FFI.constAnd FFI.buildAnd+or = binop FFI.constOr FFI.buildOr+xor = binop FFI.constXor FFI.buildXor++shr ::+ (ValueCons2 value0 value1, IsInteger a) =>+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)+shr = sbinop FFI.constAShr FFI.buildAShr FFI.constLShr FFI.buildLShr++sbinop ::+ forall value0 value1 a b r.+ (ValueCons2 value0 value1, IsInteger a) =>+ FFIConstBinOp -> FFIBinOp ->+ FFIConstBinOp -> FFIBinOp ->+ value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)+sbinop scop sop ucop uop =+ if isSigned (LP.Proxy :: LP.Proxy a)+ then binop scop sop+ else binop ucop uop+++buildBinOp ::+ FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)+buildBinOp op a1 a2 =+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a1 a2++neg ::+ (ValueCons value, IsArithmetic a) =>+ value a -> CodeGenFunction r (value a)+neg =+ withArithmeticType $ \typ -> case typ of+ IntegerType -> unop FFI.constNeg FFI.buildNeg+ FloatingType -> unop FFI.constFNeg FFI.buildFNeg++ineg ::+ (ValueCons value, IsInteger a) =>+ value a -> CodeGenFunction r (value a)+ineg = unop FFI.constNeg FFI.buildNeg++inegNoWrap ::+ forall value a r.+ (ValueCons value, IsInteger a) =>+ value a -> CodeGenFunction r (value a)+inegNoWrap =+ if isSigned (LP.Proxy :: LP.Proxy a)+ then unop FFI.constNSWNeg FFI.buildNSWNeg+ else unop FFI.constNUWNeg FFI.buildNUWNeg++fneg ::+ (ValueCons value, IsFloating a) =>+ value a -> CodeGenFunction r (value a)+fneg = unop FFI.constFNeg FFI.buildFNeg++inv ::+ (ValueCons value, IsInteger a) =>+ value a -> CodeGenFunction r (value a)+inv = unop FFI.constNot FFI.buildNot++--------------------------------------++-- | Get a value from a vector.+extractelement :: (Dec.Positive n, IsPrimitive a)+ => Value (Vector n a) -- ^ Vector+ -> Value Word32 -- ^ Index into the vector+ -> CodeGenFunction r (Value a)+extractelement (Value vec) (Value i) =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i++-- | Insert a value into a vector, nondestructive.+insertelement :: (Dec.Positive n, IsPrimitive a)+ => Value (Vector n a) -- ^ Vector+ -> Value a -- ^ Value to insert+ -> Value Word32 -- ^ Index into the vector+ -> CodeGenFunction r (Value (Vector n a))+insertelement (Value vec) (Value e) (Value i) =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i++-- | Permute vector.+shufflevector :: (Dec.Positive n, Dec.Positive m, IsPrimitive a)+ => Value (Vector n a)+ -> Value (Vector n a)+ -> ConstValue (Vector m Word32)+ -> CodeGenFunction r (Value (Vector m a))+shufflevector (Value a) (Value b) (ConstValue mask) =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask+++-- |Acceptable arguments to 'extractvalue' and 'insertvalue'.+class GetValue agg ix where+ type ValueType agg ix :: *+ getIx :: LP.Proxy agg -> ix -> CUInt++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, Dec.Natural n) => GetValue (Array n a) Word where+ type ValueType (Array n a) Word = a+ getIx _ n = fromIntegral n++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, Dec.Natural n) => GetValue (Array n a) Word64 where+ type ValueType (Array n a) Word64 = a+ getIx _ n = fromIntegral 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.+extractvalue :: forall r agg i.+ GetValue agg i+ => Value agg -- ^ Aggregate+ -> i -- ^ Index into the aggregate+ -> CodeGenFunction r (Value (ValueType agg i))+extractvalue (Value agg) i =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $+ FFI.buildExtractValue bldPtr agg (getIx (LP.Proxy :: LP.Proxy agg) i)++-- | Insert a value into an aggregate, nondestructive.+insertvalue :: forall r agg i.+ GetValue agg i+ => Value agg -- ^ Aggregate+ -> Value (ValueType agg i) -- ^ Value to insert+ -> i -- ^ Index into the aggregate+ -> CodeGenFunction r (Value agg)+insertvalue (Value agg) (Value e) i =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $+ FFI.buildInsertValue bldPtr agg e (getIx (LP.Proxy :: LP.Proxy agg) i)+++--------------------------------------++-- | Truncate a value to a shorter bit width.+trunc :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)+ => value a -> CodeGenFunction r (value b)+trunc = convert FFI.constTrunc FFI.buildTrunc++-- | Zero extend a value to a wider width.+-- If possible, use 'ext' that chooses the right padding according to the types+zext :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)+ => value a -> CodeGenFunction r (value b)+zext = convert FFI.constZExt FFI.buildZExt++-- | Sign extend a value to wider width.+-- If possible, use 'ext' that chooses the right padding according to the types+sext :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)+ => value a -> CodeGenFunction r (value b)+sext = convert FFI.constSExt 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 value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)+ => value a -> CodeGenFunction r (value b)+ext =+ if isSigned (LP.Proxy :: LP.Proxy b)+ then convert FFI.constSExt FFI.buildSExt+ else convert FFI.constZExt FFI.buildZExt++-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.+zadapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b)+ => value a -> CodeGenFunction r (value b)+zadapt =+ case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+ (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of+ LT -> convert FFI.constZExt FFI.buildZExt+ EQ -> convert FFI.constBitCast FFI.buildBitCast+ GT -> convert FFI.constTrunc FFI.buildTrunc++-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.+sadapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b)+ => value a -> CodeGenFunction r (value b)+sadapt =+ case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+ (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of+ LT -> convert FFI.constSExt FFI.buildSExt+ EQ -> convert FFI.constBitCast FFI.buildBitCast+ GT -> convert FFI.constTrunc FFI.buildTrunc++-- | It is 'sadapt' or 'zadapt' depending on the sign mode.+adapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b)+ => value a -> CodeGenFunction r (value b)+adapt =+ case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))+ (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of+ LT ->+ if isSigned (LP.Proxy :: LP.Proxy b)+ then convert FFI.constSExt FFI.buildSExt+ else convert FFI.constZExt FFI.buildZExt+ EQ -> convert FFI.constBitCast FFI.buildBitCast+ GT -> convert FFI.constTrunc FFI.buildTrunc++-- | Truncate a floating point value.+fptrunc :: (ValueCons value, IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)+ => value a -> CodeGenFunction r (value b)+fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc++-- | Extend a floating point value.+fpext :: (ValueCons value, IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)+ => value a -> CodeGenFunction r (value b)+fpext = convert FFI.constFPExt FFI.buildFPExt++{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-}+-- | Convert a floating point value to an unsigned integer.+fptoui :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)+fptoui = convert FFI.constFPToUI FFI.buildFPToUI++{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-}+-- | Convert a floating point value to a signed integer.+fptosi :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)+fptosi = convert FFI.constFPToSI FFI.buildFPToSI++-- | Convert a floating point value to an integer.+-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.+fptoint :: forall value a b r. (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)+fptoint =+ if isSigned (LP.Proxy :: LP.Proxy b)+ then convert FFI.constFPToSI FFI.buildFPToSI+ else convert FFI.constFPToUI FFI.buildFPToUI+++{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -}+-- | Convert an unsigned integer to a floating point value.+-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.+uitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)+uitofp = convert FFI.constUIToFP FFI.buildUIToFP++{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -}+-- | Convert a signed integer to a floating point value.+-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.+sitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)+sitofp = convert FFI.constSIToFP FFI.buildSIToFP++-- | Convert an integer to a floating point value.+-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.+inttofp :: forall value a b r. (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)+inttofp =+ if isSigned (LP.Proxy :: LP.Proxy a)+ then convert FFI.constSIToFP FFI.buildSIToFP+ else convert FFI.constUIToFP FFI.buildUIToFP+++-- | Convert a pointer to an integer.+ptrtoint :: (ValueCons value, IsInteger b, IsPrimitive b) => value (Ptr a) -> CodeGenFunction r (value b)+ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt++-- | Convert an integer to a pointer.+inttoptr :: (ValueCons value, IsInteger a, IsType b) => value a -> CodeGenFunction r (value (Ptr b))+inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr++-- | Convert between to values of the same size by just copying the bit pattern.+bitcast :: (ValueCons value, IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)+ => value a -> CodeGenFunction r (value b)+bitcast = convert FFI.constBitCast FFI.buildBitCast+++--------------------------------------++type CmpValueResult value0 value1 a = BinOpValue value0 value1 (CmpResult a)++type CmpResult c = ShapedType (ShapeOf c) Bool++class (IsFirstClass c) => CmpRet c where+ cmpBld :: LP.Proxy c -> CmpPredicate -> FFIBinOp+ cmpCnst :: LP.Proxy c -> CmpPredicate -> FFIConstBinOp++instance CmpRet Float where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst+instance CmpRet Double where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst+instance CmpRet FP128 where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst+instance CmpRet Bool where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word8 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word16 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word32 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Word64 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance CmpRet Int where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int8 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int16 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int32 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet Int64 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst+instance CmpRet (Foreign.Ptr a)+ where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance (IsType a) =>+ CmpRet (Ptr a) where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst++instance (Dec.Positive n) => CmpRet (WordN n) where+ cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst+instance (Dec.Positive n) => CmpRet (IntN n) where+ cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst++instance (CmpRet a, IsPrimitive a, Dec.Positive n) => CmpRet (Vector n a) where+ cmpBld _ = cmpBld (LP.Proxy :: LP.Proxy a)+ cmpCnst _ = cmpCnst (LP.Proxy :: LP.Proxy a)+++{- |+Compare values of ordered types+and choose predicates according to the compared types.+Floating point numbers are compared in \"ordered\" mode,+that is @NaN@ operands yields 'False' as result.+Pointers are compared unsigned.+These choices are consistent with comparison in plain Haskell.+-}+cmp :: forall value0 value1 a r.+ (ValueCons2 value0 value1, CmpRet a) =>+ CmpPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+cmp p =+ binop+ (cmpCnst (LP.Proxy :: LP.Proxy a) p)+ (cmpBld (LP.Proxy :: LP.Proxy a) p)++ucmpBld :: CmpPredicate -> FFIBinOp+ucmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))++scmpBld :: CmpPredicate -> FFIBinOp+scmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))++fcmpBld :: CmpPredicate -> FFIBinOp+fcmpBld p = flip FFI.buildFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))+++ucmpCnst :: CmpPredicate -> FFIConstBinOp+ucmpCnst p = FFI.constICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))++scmpCnst :: CmpPredicate -> FFIConstBinOp+scmpCnst p = FFI.constICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))++fcmpCnst :: CmpPredicate -> FFIConstBinOp+fcmpCnst p = FFI.constFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))+++_ucmp ::+ (ValueCons2 value0 value1, CmpRet a, IsInteger a) =>+ CmpPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+_ucmp p = binop (ucmpCnst p) (ucmpBld p)++_scmp ::+ (ValueCons2 value0 value1, CmpRet a, IsInteger a) =>+ CmpPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+_scmp p = binop (scmpCnst p) (scmpBld p)++pcmp ::+ (ValueCons2 value0 value1, IsType a) =>+ IntPredicate -> value0 (Ptr a) -> value1 (Ptr a) ->+ CodeGenFunction r (BinOpValue value0 value1 (Ptr a))+pcmp p =+ binop+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p))+++{-# DEPRECATED icmp "use cmp or pcmp instead" #-}+-- | Compare integers.+icmp ::+ (ValueCons2 value0 value1, CmpRet a, IsIntegerOrPointer a) =>+ IntPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+icmp p =+ binop+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p))++-- | Compare floating point values.+fcmp ::+ (ValueCons2 value0 value1, CmpRet a, IsFloating a) =>+ FPPredicate -> value0 a -> value1 a ->+ CodeGenFunction r (CmpValueResult value0 value1 a)+fcmp p =+ binop+ (FFI.constFCmp (FFI.fromRealPredicate p))+ (flip FFI.buildFCmp (FFI.fromRealPredicate p))++--------------------------------------++setHasNoNaNs, setHasNoInfs, setHasNoSignedZeros, setHasAllowReciprocal,+ setFastMath :: (IsFloating a) => Bool -> Value a -> CodeGenFunction r ()+setHasNoNaNs = fastMath FFI.setHasNoNaNs+setHasNoInfs = fastMath FFI.setHasNoInfs+setHasNoSignedZeros = fastMath FFI.setHasNoSignedZeros+setHasAllowReciprocal = fastMath FFI.setHasAllowReciprocal+setFastMath = fastMath FFI.setHasUnsafeAlgebra++fastMath ::+ (IsFloating a) =>+ (FFI.ValueRef -> FFI.Bool -> IO ()) ->+ Bool -> Value a -> CodeGenFunction r ()+fastMath setter b (Value v) = liftIO $ setter v $ FFI.consBool b+++--------------------------------------++-- XXX could do const song and dance+-- | Select between two values depending on a boolean.+select :: (CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a)+select (Value cnd) (Value thn) (Value els) =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $+ FFI.buildSelect bldPtr cnd thn els++--------------------------------------++type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef++{-+Function (a -> b -> IO c)+Value a -> Value b -> CodeGenFunction r c+-}++-- |Acceptable arguments to 'call'.+class (f ~ CalledFunction g, r ~ CodeResult g, g ~ CallerFunction r f) =>+ CallArgs r f g where+ type CalledFunction g :: *+ type CallerFunction r f :: *+ doCall :: Call f -> g++instance (Value a ~ a', CallArgs r b b') => CallArgs r (a -> b) (a' -> b') where+ type CalledFunction (a' -> b') = UnValue a' -> CalledFunction b'+ type CallerFunction r (a -> b) = Value a -> CallerFunction r b+ doCall f a = doCall (applyCall f a)++instance+ (r ~ r', Value a ~ a') =>+ CallArgs r (IO a) (CodeGenFunction r' a') where+ type CalledFunction (CodeGenFunction r' a') = IO (UnValue a')+ type CallerFunction r (IO a) = CodeGenFunction r (Value a)+ doCall = runCall++doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a)+doCallDef mkCall args _ =+ withCurrentBuilder $ \ bld ->+ liftM Value $ mkCall bld (reverse args)++-- | Call a function with the given arguments. The 'call' instruction is variadic, i.e., the number of arguments+-- it takes depends on the type of /f/.+call :: (CallArgs r f g) => Function f -> g+call = doCall . callFromFunction++data Call a = Call Caller [FFI.ValueRef]++callFromFunction :: Function a -> Call a+callFromFunction (Value f) = Call (U.makeCall f) []++-- like Applicative.<*>+infixl 4 `applyCall`++applyCall :: Call (a -> b) -> Value a -> Call b+applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args)++runCall :: Call (IO a) -> CodeGenFunction r (Value a)+runCall (Call mkCall args) = doCallDef mkCall args ()+++invokeFromFunction ::+ BasicBlock -- ^Normal return point.+ -> BasicBlock -- ^Exception return point.+ -> Function f -- ^Function to call.+ -> Call f+invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) =+ Call (U.makeInvoke norm expt f) []++-- | Call a function with exception handling.+invoke :: (CallArgs r f g)+ => BasicBlock -- ^Normal return point.+ -> BasicBlock -- ^Exception return point.+ -> Function f -- ^Function to call.+ -> g+invoke norm expt f = doCall $ invokeFromFunction norm expt f++callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f+callWithConvFromFunction cc (Value f) =+ Call (U.makeCallWithCc cc f) []++-- | Call a function with the given arguments. The 'call' instruction+-- is variadic, i.e., the number of arguments it takes depends on the+-- type of /f/.+-- This also sets the calling convention of the call to the function.+-- As LLVM itself defines, if the calling conventions of the calling+-- /instruction/ and the function being /called/ are different, undefined+-- behavior results.+callWithConv :: (CallArgs r f g) => FFI.CallingConvention -> Function f -> g+callWithConv cc f = doCall $ callWithConvFromFunction cc f++invokeWithConvFromFunction ::+ FFI.CallingConvention -- ^Calling convention+ -> BasicBlock -- ^Normal return point.+ -> BasicBlock -- ^Exception return point.+ -> Function f -- ^Function to call.+ -> Call f+invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) =+ Call (U.makeInvokeWithCc cc norm expt f) []++-- | Call a function with exception handling.+-- This also sets the calling convention of the call to the function.+-- As LLVM itself defines, if the calling conventions of the calling+-- /instruction/ and the function being /called/ are different, undefined+-- behavior results.+invokeWithConv :: (CallArgs r f g)+ => FFI.CallingConvention -- ^Calling convention+ -> BasicBlock -- ^Normal return point.+ -> BasicBlock -- ^Exception return point.+ -> Function f -- ^Function to call.+ -> g+invokeWithConv cc norm expt f =+ doCall $ invokeWithConvFromFunction cc norm expt f++--------------------------------------++-- XXX could do const song and dance+-- |Join several variables (virtual registers) from different basic blocks into one.+-- All of the variables in the list are joined. See also 'addPhiInputs'.+phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)+phi incoming =+ liftM Value $+ withCurrentBuilder $ \ bldPtr -> do+ inst <- U.buildEmptyPhi bldPtr =<< typeRef (LP.Proxy :: LP.Proxy a)+ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]+ return inst++-- |Add additional inputs to an existing phi node.+-- The reason for this instruction is that sometimes the structure of the code+-- makes it impossible to have all variables in scope at the point where you need the phi node.+addPhiInputs :: forall a r . (IsFirstClass a)+ => Value a -- ^Must be a variable from a call to 'phi'.+ -> [(Value a, BasicBlock)] -- ^Variables to add.+ -> CodeGenFunction r ()+addPhiInputs (Value inst) incoming =+ liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]+++--------------------------------------++-- | Acceptable argument to array memory allocation.+class AllocArg a where+ getAllocArg :: a -> Value Word+instance (i ~ Word) => AllocArg (Value i) where+ getAllocArg = id+instance (i ~ Word) => AllocArg (ConstValue i) where+ getAllocArg = value+instance AllocArg Word where+ getAllocArg = valueOf++-- could be moved to Util.Memory+-- FFI.buildMalloc deprecated since LLVM-2.7+-- XXX What's the type returned by malloc+-- | Allocate heap memory.+malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))+malloc = arrayMalloc (1::Word)++type BytePtr = Ptr Word8++{-+I use a pointer type as size parameter of 'malloc'.+This way I hope that the parameter has always the correct size (32 or 64 bit).+A side effect is that we can convert the result of 'getelementptr' using 'bitcast',+that does not suffer from the slow assembly problem. (bug #8281)+-}+foreign import ccall "&aligned_malloc_sizeptr"+ alignedMalloc :: FunPtr (BytePtr -> BytePtr -> IO BytePtr)++foreign import ccall "&aligned_free"+ alignedFree :: FunPtr (BytePtr -> IO ())+++{-+There is a bug in LLVM-2.7 and LLVM-2.8+(http://llvm.org/bugs/show_bug.cgi?id=8281)+that causes huge assembly times for expressions like+ptrtoint(getelementptr(zero,..)).+If you break those expressions into two statements+at separate lines, everything is fine.+But the C interface is too clever,+and rewrites two separate statements into a functional expression on a single line.+Such code is generated whenever you call+buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.+One possible way is to write a getelementptr expression+containing a nullptr in a way+that hides the constant nature of nullptr.++ ptr <- alloca+ store (value zero) ptr+ z <- load ptr+ size <- bitcast =<<+ getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())++However, I found that bitcast on pointers causes no problems.+Thus I switched to using pointers for size quantities.+This still allows for optimizations involving pointers.+-}++-- XXX What's the type returned by arrayMalloc?+-- | Allocate heap (array) memory.+arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>+ s -> CodeGenFunction r (Value (Ptr a)) -- XXX+arrayMalloc s = do+ func <- CodeGen.staticNamedFunction "alignedMalloc" alignedMalloc+-- func <- externFunction "malloc"++ size <- sizeOfArray (LP.Proxy :: LP.Proxy a) (getAllocArg s)+ alignment <- alignOf (LP.Proxy :: LP.Proxy a)+ bitcast =<< call func size alignment++-- XXX What's the type returned by malloc+-- | Allocate stack memory.+alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))+alloca =+ liftM Value $+ withCurrentBuilder $ \ bldPtr -> 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.+arrayAlloca :: forall a r s . (IsSized a, AllocArg s) =>+ s -> CodeGenFunction r (Value (Ptr a))+arrayAlloca s =+ liftM Value $+ withCurrentBuilder $ \ bldPtr -> do+ typ <- typeRef (LP.Proxy :: LP.Proxy a)+ U.withEmptyCString $+ 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?+-- | Free heap memory.+free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()+free ptr = do+ func <- CodeGen.staticNamedFunction "alignedFree" alignedFree+-- func <- externFunction "free"+ _ <- call func =<< bitcast ptr+ return ()+++-- | If we want to export that, then we should have a Size type+-- This is the official implementation,+-- but it suffers from the ptrtoint(gep) bug.+_sizeOf ::+ forall a r.+ (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word)+_sizeOf a =+ liftIO $ liftM Value $+ FFI.sizeOf =<< typeRef a++_alignOf ::+ forall a r.+ (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word)+_alignOf a =+ liftIO $ liftM Value $+ FFI.alignOf =<< typeRef a+++-- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.+-- see ConstantExpr::getSizeOf+sizeOfArray ::+ forall a r . (IsSized a) =>+ LP.Proxy a -> Value Word -> CodeGenFunction r (Value BytePtr)+sizeOfArray _ len =+ bitcast =<<+ getElementPtr (value zero :: Value (Ptr a)) (len, ())++-- see ConstantExpr::getAlignOf+alignOf ::+ forall a r . (IsSized a) =>+ LP.Proxy a -> CodeGenFunction r (Value BytePtr)+alignOf _ =+ bitcast =<<+ getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())+++-- | Load a value from memory.+load :: Value (Ptr a) -- ^ Address to load from.+ -> CodeGenFunction r (Value a)+load (Value p) =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withEmptyCString $ FFI.buildLoad bldPtr p++-- | Store a value in memory+store :: Value a -- ^ Value to store.+ -> Value (Ptr a) -- ^ Address to store to.+ -> CodeGenFunction r ()+store (Value v) (Value p) = do+ withCurrentBuilder_ $ \ bldPtr ->+ FFI.buildStore bldPtr v p+ return ()++-- | Address arithmetic. See LLVM description.+-- (The type isn't as accurate as it should be.)+_getElementPtrDynamic :: (IsInteger i) =>+ Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))+_getElementPtrDynamic (Value ptr) ixs =+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->+ U.withEmptyCString $+ FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)++-- | Address arithmetic. See LLVM description.+-- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.+-- (This is without a doubt the most confusing LLVM instruction, but the types help.)+getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) =>+ Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))+getElementPtr (Value ptr) (a, ixs) =+ let ixl = getArg a : getIxList (LP.Proxy :: LP.Proxy o) ixs in+ liftM Value $+ withCurrentBuilder $ \ bldPtr ->+ U.withArrayLen ixl $ \ idxLen idxPtr ->+ U.withEmptyCString $+ FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)++-- | Like getElementPtr, but with an initial index that is 0.+-- This is useful since any pointer first need to be indexed off the pointer, and then into+-- its actual value. This first indexing is often with 0.+getElementPtr0 :: (GetElementPtr o i) =>+ Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))+getElementPtr0 p i = getElementPtr p (0::Word32, i)++_getElementPtr :: forall value o i i0 r.+ (ValueCons value, GetElementPtr o i, IsIndexType i0) =>+ value (Ptr o) -> (value i0, i) ->+ CodeGenFunction r (value (Ptr (ElementPtrType o i)))+_getElementPtr vptr (a, ixs) =+ let withArgs act =+ U.withArrayLen+ (unValue a : getIxList (LP.Proxy :: LP.Proxy o) ixs) $+ \ idxLen idxPtr ->+ act idxPtr (fromIntegral idxLen)+ in unop+ (\ptr -> withArgs $ FFI.constGEP ptr)+ (\bldPtr ptr cstr ->+ withArgs $ \idxPtr idxLen ->+ FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)+ vptr++--------------------------------------+{-+instance (IsConst a) => Show (ConstValue a) -- XXX+instance (IsConst a) => Eq (ConstValue a)++{-+instance (IsConst a) => Eq (ConstValue a) where+ ConstValue x == ConstValue y =+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOEQ) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntEQ) x y)+ ConstValue x /= ConstValue y =+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPONE) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntNE) x y)++instance (IsConst a) => Ord (ConstValue a) where+ ConstValue x < ConstValue y =+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOLT) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLT) x y)+ ConstValue x <= ConstValue y =+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOLE) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLE) x y)+ ConstValue x > ConstValue y =+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOGT) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGT) x y)+ ConstValue x >= ConstValue y =+ if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOGE) x y)+ else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGE) x y)+-}++instance (Num a, IsConst a) => Num (ConstValue a) where+ ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y)+ ConstValue x - ConstValue y = ConstValue (FFI.constSub x y)+ ConstValue x * ConstValue y = ConstValue (FFI.constMul x y)+ negate (ConstValue x) = ConstValue (FFI.constNeg x)+ fromInteger x = constOf (fromInteger x :: a)+-}
+ private/LLVM/Core/Instructions/Guided.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE EmptyDataDecls #-}+{- |+This module provides some functions from the "LLVM.Core.Instructions" module+in a way that enables easier type handling.+E.g. 'trunc' on vectors requires you to prove+that reducing the bitsize of the elements+reduces the bitsize of the whole vector.+We solve the problem by adding a 'Guide' parameter.+It can be either 'scalar' or 'vector'.+We impose the bitsize constraint only on the element type,+but not on the size of the whole value (scalar or vector).++Another example:+If you call 'trunc' on a Vector input,+GHC cannot infer that the result must be a 'Data.Vector' of the same size.+Using the guide, it can.+However, in practice this is not as useful as I thought initially.+-}+module LLVM.Core.Instructions.Guided (+ Guide,+ scalar,+ vector,+ getElementPtr,+ getElementPtr0,+ trunc,+ ext,+ extBool,+ zadapt,+ sadapt,+ adapt,+ fptrunc,+ fpext,+ fptoint,+ inttofp,+ ptrtoint,+ inttoptr,+ bitcast,+ select,+ cmp,+ icmp,+ pcmp,+ fcmp,+ ) where++import qualified LLVM.Core.Instructions.Private as Priv+import qualified LLVM.Core.Type as Type+import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Proxy as LP+import LLVM.Core.Instructions.Private (ValueCons)+import LLVM.Core.CodeGenMonad (CodeGenFunction)+import LLVM.Core.CodeGen (ConstValue, zero)+import LLVM.Core.Type+ (IsArithmetic, IsInteger, IsIntegerOrPointer, IsFloating,+ IsFirstClass, IsPrimitive,+ Signed, Positive, IsType, IsSized, SizeOf,+ isFloating, sizeOf, typeDesc)++import qualified LLVM.FFI.Core as FFI++import Type.Data.Num.Decimal.Number ((:<:), (:>:))++import Foreign.Ptr (Ptr)++import qualified Control.Functor.HT as FuncHT++import Data.Word (Word32)+++data Guide shape elem = Guide++instance Functor (Guide shape) where+ fmap _ Guide = Guide++scalar :: Guide Type.ScalarShape a+scalar = Guide++vector :: (Positive n) => Guide (Type.VectorShape n) a+vector = Guide++proxyFromGuide :: Guide shape elem -> LP.Proxy elem+proxyFromGuide Guide = LP.Proxy+++type Type shape a = Type.ShapedType shape a+type VT value shape a = value (Type shape a)++getElementPtr ::+ (ValueCons value, Priv.GetElementPtr o i, Priv.IsIndexType i0) =>+ Guide shape (Ptr o, i0) ->+ VT value shape (Ptr o) ->+ (VT value shape i0, i) ->+ CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtr guide vptr (a, ixs) =+ getElementPtrGen (fmap fst guide) vptr (Priv.unValue a, ixs)++getElementPtr0 ::+ (ValueCons value, Priv.GetElementPtr o i) =>+ Guide shape (Ptr o) ->+ VT value shape (Ptr o) -> i ->+ CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtr0 guide vptr ixs =+ getElementPtrGen guide vptr+ (Priv.unConst (zero :: ConstValue Word32), ixs)++getElementPtrGen ::+ (ValueCons value, Priv.GetElementPtr o i) =>+ Guide shape (Ptr o) ->+ VT value shape (Ptr o) -> (FFI.ValueRef, i) ->+ CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))+getElementPtrGen guide vptr (i0val,ixs) =+ let withArgs act =+ U.withArrayLen+ (i0val : Priv.getIxList (LP.element (proxyFromGuide guide)) ixs) $+ \ idxLen idxPtr ->+ act idxPtr (fromIntegral idxLen)+ in Priv.unop+ (\ptr -> withArgs $ FFI.constGEP ptr)+ (\bldPtr ptr cstr ->+ withArgs $ \idxPtr idxLen ->+ FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)+ vptr+++-- | Truncate a value to a shorter bit width.+trunc ::+ (ValueCons value, IsInteger av, IsInteger bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+trunc = convert FFI.constTrunc FFI.buildTrunc++isSigned :: (IsArithmetic a) => Guide shape a -> Bool+isSigned = Type.isSigned . proxyFromGuide++-- | Extend a value to wider width.+-- If the target type is signed, then preserve the sign,+-- If the target type is unsigned, then extended by zeros.+ext ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv, Signed a ~ Signed b,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+ext guide =+ if isSigned (fmap snd guide)+ then convert FFI.constSExt FFI.buildSExt guide+ else convert FFI.constZExt FFI.buildZExt guide++extBool ::+ (ValueCons value, IsInteger b, IsType bv,+ IsPrimitive b, Type shape Bool ~ av, Type shape b ~ bv) =>+ Guide shape (Bool,b) -> value av -> CodeGenFunction r (value bv)+extBool guide =+ if isSigned (fmap snd guide)+ then convert FFI.constSExt FFI.buildSExt guide+ else convert FFI.constZExt FFI.buildZExt guide+++compareGuideSizes :: (IsType a, IsType b) => Guide shape (a,b) -> Ordering+compareGuideSizes guide =+ case FuncHT.unzip $ proxyFromGuide guide of+ (a,b) -> compare (sizeOf (typeDesc a)) (sizeOf (typeDesc b))++-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.+zadapt ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+zadapt guide =+ case compareGuideSizes guide of+ LT -> convert FFI.constZExt FFI.buildZExt guide+ EQ -> convert FFI.constBitCast FFI.buildBitCast guide+ GT -> convert FFI.constTrunc FFI.buildTrunc guide++-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.+sadapt ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+sadapt guide =+ case compareGuideSizes guide of+ LT -> convert FFI.constSExt FFI.buildSExt guide+ EQ -> convert FFI.constBitCast FFI.buildBitCast guide+ GT -> convert FFI.constTrunc FFI.buildTrunc guide++-- | It is 'sadapt' or 'zadapt' depending on the sign mode.+adapt ::+ (ValueCons value, IsInteger a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ Signed a ~ Signed b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+adapt guide =+ case compareGuideSizes guide of+ LT ->+ if isSigned (fmap snd guide)+ then convert FFI.constSExt FFI.buildSExt guide+ else convert FFI.constZExt FFI.buildZExt guide+ EQ -> convert FFI.constBitCast FFI.buildBitCast guide+ GT -> convert FFI.constTrunc FFI.buildTrunc guide++-- | Truncate a floating point value.+fptrunc ::+ (ValueCons value, IsFloating av, IsFloating bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc++-- | Extend a floating point value.+fpext ::+ (ValueCons value, IsFloating av, IsFloating bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+fpext = convert FFI.constFPExt FFI.buildFPExt++-- | Convert a floating point value to an integer.+-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.+fptoint ::+ (ValueCons value, IsFloating a, IsInteger b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+fptoint guide =+ if isSigned (fmap snd guide)+ then convert FFI.constFPToSI FFI.buildFPToSI guide+ else convert FFI.constFPToUI FFI.buildFPToUI guide+++-- | Convert an integer to a floating point value.+-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.+inttofp ::+ (ValueCons value, IsInteger a, IsFloating b, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+inttofp guide =+ if isSigned (fmap fst guide)+ then convert FFI.constSIToFP FFI.buildSIToFP guide+ else convert FFI.constUIToFP FFI.buildUIToFP guide+++-- | Convert a pointer to an integer.+ptrtoint ::+ (ValueCons value, IsType a, IsInteger b, IsType bv,+ IsPrimitive b, Type shape (Ptr a) ~ av, Type shape b ~ bv) =>+ Guide shape (Ptr a, b) -> value av -> CodeGenFunction r (value bv)+ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt++-- | Convert an integer to a pointer.+inttoptr ::+ (ValueCons value, IsInteger a, IsType b, IsType bv,+ IsPrimitive a, Type shape a ~ av, Type shape (Ptr b) ~ bv) =>+ Guide shape (a, Ptr b) -> value av -> CodeGenFunction r (value bv)+inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr++-- | Convert between to values of the same size by just copying the bit pattern.+bitcast ::+ (ValueCons value, IsFirstClass a, IsFirstClass bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,+ IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>+ Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)+bitcast = convert FFI.constBitCast FFI.buildBitCast+++convert ::+ (ValueCons value, IsType bv,+ IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>+ Priv.FFIConstConvert -> Priv.FFIConvert -> Guide shape (a,b) ->+ value av -> CodeGenFunction r (value bv)+convert cnvConst cnv Guide = Priv.convert cnvConst cnv++++select ::+ (ValueCons value, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ value bv -> value av -> value av -> CodeGenFunction r (value av)+select Guide = Priv.trinop FFI.constSelect FFI.buildSelect+++cmp ::+ (ValueCons value, IsArithmetic a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ Priv.CmpPredicate -> value av -> value av -> CodeGenFunction r (value bv)+cmp guide@Guide p =+ let cmpop constCmp buildCmp predi =+ Priv.binop (constCmp predi) (flip buildCmp predi)+ in if isFloating (proxyFromGuide guide)+ then+ cmpop FFI.constFCmp FFI.buildFCmp $+ FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p+ else+ cmpop FFI.constICmp FFI.buildICmp $+ FFI.fromIntPredicate $+ if isSigned guide+ then Priv.sintFromCmpPredicate p+ else Priv.uintFromCmpPredicate p++_cmp ::+ (ValueCons value, IsArithmetic a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ Priv.CmpPredicate -> value av -> value av -> CodeGenFunction r (value bv)+_cmp guide@Guide p =+ if isFloating (proxyFromGuide guide)+ then+ let predi = FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p+ in Priv.binop+ (FFI.constFCmp predi)+ (flip FFI.buildFCmp predi)+ else+ let predi =+ FFI.fromIntPredicate $+ if isSigned guide+ then Priv.sintFromCmpPredicate p+ else Priv.uintFromCmpPredicate p+ in Priv.binop+ (FFI.constICmp predi)+ (flip FFI.buildICmp predi)++{-# DEPRECATED icmp "use cmp or pcmp instead" #-}+-- | Compare integers.+icmp ::+ (ValueCons value, IsIntegerOrPointer a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ FFI.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)+icmp Guide p =+ Priv.binop+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p))++-- | Compare pointers.+pcmp :: (ValueCons value, Type shape (Ptr a) ~ av, Type shape Bool ~ bv) =>+ Guide shape (Ptr a) ->+ FFI.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)+pcmp Guide p =+ Priv.binop+ (FFI.constICmp (FFI.fromIntPredicate p))+ (flip FFI.buildICmp (FFI.fromIntPredicate p))++-- | Compare floating point values.+fcmp ::+ (ValueCons value, IsFloating a, IsPrimitive a,+ Type shape a ~ av, Type shape Bool ~ bv) =>+ Guide shape a ->+ FFI.FPPredicate -> value av -> value av -> CodeGenFunction r (value bv)+fcmp Guide p =+ Priv.binop+ (FFI.constFCmp (FFI.fromRealPredicate p))+ (flip FFI.buildFCmp (FFI.fromRealPredicate p))
+ private/LLVM/Core/Instructions/Private.hs view
@@ -0,0 +1,303 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Core.Instructions.Private where++import qualified LLVM.Core.Util as U+import qualified LLVM.Core.Proxy as LP+import LLVM.Core.Type (IsType, IsPrimitive, typeRef)+import LLVM.Core.Data (Vector, Array, Struct, PackedStruct)+import LLVM.Core.CodeGenMonad (CodeGenFunction)+import LLVM.Core.CodeGen+ (ConstValue(ConstValue), constOf, Value(Value), withCurrentBuilder)++import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Data.Num.Decimal.Number (Pred)+import Type.Base.Proxy (Proxy)++import Control.Monad.IO.Class (liftIO)+import Control.Monad (liftM)++import Data.Typeable (Typeable)+import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64, Word)++++type FFIConstConvert = FFI.ValueRef -> FFI.TypeRef -> IO FFI.ValueRef+type FFIConvert =+ FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef ->+ U.CString -> IO FFI.ValueRef++type FFIConstUnOp = FFI.ValueRef -> IO FFI.ValueRef+type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef++type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef+type FFIBinOp =+ FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef ->+ U.CString -> IO FFI.ValueRef++type FFIConstTrinOp =+ FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef+type FFITrinOp =+ FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef ->+ U.CString -> IO FFI.ValueRef+++class ValueCons value where+ switchValueCons :: f ConstValue -> f Value -> f value++instance ValueCons ConstValue where+ switchValueCons f _ = f++instance ValueCons Value where+ switchValueCons _ f = f+++convert :: (ValueCons value, IsType b) =>+ FFIConstConvert -> FFIConvert -> value a -> CodeGenFunction r (value b)+convert cop op =+ getUnOp $+ switchValueCons+ (UnOp $ convertConstValue LP.Proxy cop)+ (UnOp $ convertValue LP.Proxy op)++convertConstValue ::+ (IsType b) =>+ LP.Proxy b -> FFIConstConvert ->+ ConstValue a -> CodeGenFunction r (ConstValue b)+convertConstValue proxy conv (ConstValue a) =+ liftM ConstValue $ liftIO $ conv a =<< typeRef proxy++convertValue ::+ (IsType b) =>+ LP.Proxy b -> FFIConvert -> Value a -> CodeGenFunction r (Value b)+convertValue proxy conv (Value a) =+ liftM Value $+ withCurrentBuilder $ \ bldPtr -> do+ typ <- typeRef proxy+ U.withEmptyCString $ conv bldPtr a typ+++newtype UnValue a value = UnValue {getUnValue :: value a -> FFI.ValueRef}++unValue :: (ValueCons value) => value a -> FFI.ValueRef+unValue =+ getUnValue $+ switchValueCons+ (UnValue $ \(ConstValue a) -> a)+ (UnValue $ \(Value a) -> a)++newtype UnOp a b r value =+ UnOp {getUnOp :: value a -> CodeGenFunction r (value b)}++unop ::+ (ValueCons value) =>+ FFIConstUnOp -> FFIUnOp -> value a -> CodeGenFunction r (value b)+unop cop op =+ getUnOp $+ switchValueCons+ (UnOp $ \(ConstValue a) -> liftIO $ fmap ConstValue $ cop a)+ (UnOp $ \(Value a) ->+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a)++newtype BinOp a b c r value =+ BinOp {getBinOp :: value a -> value b -> CodeGenFunction r (value c)}++binop ::+ (ValueCons value) =>+ FFIConstBinOp -> FFIBinOp ->+ value a -> value b -> CodeGenFunction r (value c)+binop cop op =+ getBinOp $+ switchValueCons+ (BinOp $ \(ConstValue a) (ConstValue b) ->+ liftIO $ fmap ConstValue $ cop a b)+ (BinOp $ \(Value a) (Value b) ->+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a b)++newtype TrinOp a b c d r value =+ TrinOp {+ getTrinOp ::+ value a -> value b -> value c -> CodeGenFunction r (value d)+ }++trinop ::+ (ValueCons value) =>+ FFIConstTrinOp -> FFITrinOp ->+ value a -> value b -> value c -> CodeGenFunction r (value d)+trinop cop op =+ getTrinOp $+ switchValueCons+ (TrinOp $ \(ConstValue a) (ConstValue b) (ConstValue c) ->+ liftIO $ fmap ConstValue $ cop a b c)+ (TrinOp $ \(Value a) (Value b) (Value c) ->+ liftM Value $+ withCurrentBuilder $ \ bld ->+ U.withEmptyCString $ op bld a b c)++++-- | Acceptable arguments to 'getElementPointer'.+class GetElementPtr optr ixs where+ type ElementPtrType optr ixs :: *+ getIxList :: LP.Proxy optr -> ixs -> [FFI.ValueRef]++-- | Acceptable single index to 'getElementPointer'.+class IsIndexArg a where+ getArg :: a -> FFI.ValueRef++{- |+In principle we do not need the getValueArg method,+because we could just use 'unValue'.+However, we want to prevent users+from defining their own (disfunctional) IsIndexType instances.+-}+class (IsPrimitive i) => IsIndexType i where+ getValueArg :: (ValueCons value) => value i -> FFI.ValueRef++instance IsIndexType Word where+ getValueArg = unValue++instance IsIndexType Word32 where+ getValueArg = unValue++instance IsIndexType Word64 where+ getValueArg = unValue++instance IsIndexType Int where+ getValueArg = unValue++instance IsIndexType Int32 where+ getValueArg = unValue++instance IsIndexType Int64 where+ getValueArg = unValue++instance IsIndexType i => IsIndexArg (ConstValue i) where+ getArg = getValueArg++instance IsIndexType i => IsIndexArg (Value i) where+ getArg = getValueArg++instance IsIndexArg Word where+ getArg = unConst . constOf++instance IsIndexArg Word32 where+ getArg = unConst . constOf++instance IsIndexArg Word64 where+ getArg = unConst . constOf++instance IsIndexArg Int where+ getArg = unConst . constOf++instance IsIndexArg Int32 where+ getArg = unConst . constOf++instance IsIndexArg Int64 where+ getArg = unConst . constOf++unConst :: ConstValue a -> FFI.ValueRef+unConst (ConstValue v) = v++-- End of indexing+instance GetElementPtr a () where+ type ElementPtrType a () = a+ getIxList LP.Proxy () = []++-- Index in Array+instance+ (GetElementPtr o i, IsIndexArg a, Dec.Natural k) =>+ GetElementPtr (Array k o) (a, i) where+ type ElementPtrType (Array k o) (a, i) = ElementPtrType o i+ getIxList proxy (v, i) = getArg v : getIxList (LP.element proxy) i++-- Index in Vector+instance+ (GetElementPtr o i, IsIndexArg a, Dec.Positive k) =>+ GetElementPtr (Vector k o) (a, i) where+ type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i+ getIxList proxy (v, i) = getArg v : getIxList (LP.element proxy) i++fieldProxy :: LP.Proxy (struct fs) -> Proxy a -> LP.Proxy (FieldType fs a)+fieldProxy LP.Proxy _proxy = LP.Proxy++-- Index in Struct and PackedStruct.+-- The index has to be a type level integer to statically determine the record field type+instance+ (GetElementPtr (FieldType fs a) i, Dec.Natural a) =>+ GetElementPtr (Struct fs) (Proxy a, i) where+ type ElementPtrType (Struct fs) (Proxy a, i) =+ ElementPtrType (FieldType fs a) i+ getIxList proxy (a, i) =+ unConst (constOf (Dec.integralFromProxy a :: Word32)) :+ getIxList (fieldProxy proxy a) i+instance+ (GetElementPtr (FieldType fs a) i, Dec.Natural a) =>+ GetElementPtr (PackedStruct fs) (Proxy a, i) where+ type ElementPtrType (PackedStruct fs) (Proxy a, i) =+ ElementPtrType (FieldType fs a) i+ getIxList proxy (a, i) =+ unConst (constOf (Dec.integralFromProxy a :: Word32)) :+ getIxList (fieldProxy proxy a) i++class GetField as i where type FieldType as i :: *+instance GetField (a, as) Dec.Zero where+ type FieldType (a, as) Dec.Zero = a+instance+ (GetField as (Pred (Dec.Pos i0 i1))) =>+ GetField (a, as) (Dec.Pos i0 i1) where+ type FieldType (a,as) (Dec.Pos i0 i1) = FieldType as (Pred (Dec.Pos i0 i1))++++data CmpPredicate =+ CmpEQ -- ^ equal+ | CmpNE -- ^ not equal+ | CmpGT -- ^ greater than+ | CmpGE -- ^ greater or equal+ | CmpLT -- ^ less than+ | CmpLE -- ^ less or equal+ deriving (Eq, Ord, Enum, Show, Typeable)++uintFromCmpPredicate :: CmpPredicate -> IntPredicate+uintFromCmpPredicate p =+ case p of+ CmpEQ -> IntEQ+ CmpNE -> IntNE+ CmpGT -> IntUGT+ CmpGE -> IntUGE+ CmpLT -> IntULT+ CmpLE -> IntULE++sintFromCmpPredicate :: CmpPredicate -> IntPredicate+sintFromCmpPredicate p =+ case p of+ CmpEQ -> IntEQ+ CmpNE -> IntNE+ CmpGT -> IntSGT+ CmpGE -> IntSGE+ CmpLT -> IntSLT+ CmpLE -> IntSLE++fpFromCmpPredicate :: CmpPredicate -> FPPredicate+fpFromCmpPredicate p =+ case p of+ CmpEQ -> FPOEQ+ CmpNE -> FPONE+ CmpGT -> FPOGT+ CmpGE -> FPOGE+ CmpLT -> FPOLT+ CmpLE -> FPOLE
+ private/LLVM/Core/Proxy.hs view
@@ -0,0 +1,19 @@+module LLVM.Core.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++element :: Proxy (f a) -> Proxy a+element Proxy = Proxy
+ private/LLVM/Core/Type.hs view
@@ -0,0 +1,698 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+-- |The LLVM type system is captured with a number of Haskell type classes.+-- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type.+-- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for+-- those types that are LLVM first class types (passable as arguments etc).+-- All valid LLVM types belong to the 'IsType' class.+module LLVM.Core.Type(+ -- * Type classifier+ IsType(..),+ -- ** Special type classifiers+ Dec.Natural,+ Dec.Positive,+ IsArithmetic(arithmeticType),+ ArithmeticType(IntegerType,FloatingType),+ IsInteger, Signed,+ IsIntegerOrPointer,+ IsFloating,+ IsPrimitive,+ IsFirstClass,+ IsSized, SizeOf, sizeOf,+ IsFunction,+ Storable, fromPtr, toPtr,+ -- ** Others+ IsScalarOrVector,+ ShapeOf, ScalarShape, VectorShape,+ Shape, ShapedType,+ StructFields,+ PtrSize, IntSize,+ UnknownSize, -- needed for arrays of structs+ -- ** Structs+ ConsStruct(..), consStruct,+ CurryStruct, Curried, curryStruct, uncurryStruct,+ (:&), (&),+ -- ** Type tests+ TypeDesc(..),+ isFloating,+ isSigned,+ typeRef,+ unsafeTypeRef,+ typeName,+ intrinsicTypeName,+ typeDesc2,+ VarArgs, CastVarArgs,+ ) where++import qualified LLVM.FFI.Core as FFI++import qualified LLVM.Core.Data as Data+import LLVM.Core.Util (functionType, structType)+import LLVM.Core.Data+ (IntN, WordN, Vector, Array, FP128,+ Struct(Struct), PackedStruct(PackedStruct), Label)+import LLVM.Core.Proxy (Proxy(Proxy))++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 qualified Foreign+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (FunPtr)+import System.IO.Unsafe (unsafePerformIO)++import Data.Typeable (Typeable)+import Data.List (intercalate)+import Data.Bits (bitSize)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)+++#include "MachDeps.h"++-- TODO:+-- Move IntN, WordN to a special module that implements those types+-- properly in Haskell.+-- 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 :: Proxy a -> TypeDesc++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) = 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) = withCode structType (mapM code ts) packed+ code TDInvalidType = error "typeRef TDInvalidType"++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"+ code TDFP128 = "f128"+ code TDVoid = "void"+ code (TDInt _ n) = "i" ++ show n+ code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"+ code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"+ code (TDPtr a) = code a ++ "*"+ code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"+ code TDLabel = "label"+ code (TDStruct as packed) = (if packed then "<{" else "{") +++ intercalate "," (map code as) +++ (if packed then "}>" else "}")+ code TDInvalidType = error "typeName TDInvalidType"++intrinsicTypeName :: (IsType a) => Proxy a -> String+intrinsicTypeName = code . typeDesc+ where code TDFloat = "f32"+ code TDDouble = "f64"+ code TDFP128 = "f128"+ code (TDInt _ n) = "i" ++ show n+ code (TDVector n a) = "v" ++ show n ++ code a+ code _ = error "intrinsicTypeName: type not supported in intrinsics"++typeDesc2 :: FFI.TypeRef -> IO TypeDesc+typeDesc2 t = do+ tk <- FFI.getTypeKind t+ case tk of+ FFI.VoidTypeKind -> return TDVoid+ FFI.FloatTypeKind -> return TDFloat+ FFI.DoubleTypeKind -> return TDDouble+ -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80"+ FFI.FP128TypeKind -> return TDFP128+ -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128"+ FFI.LabelTypeKind -> return TDLabel+ FFI.IntegerTypeKind -> do+ n <- FFI.getIntTypeWidth t+ return $ TDInt False (fromIntegral n)+ -- FIXME: FFI.FunctionTypeKind+ -- FIXME: FFI.StructTypeKind -> return "(Struct ...)"+ FFI.ArrayTypeKind -> do+ n <- FFI.getArrayLength t+ et <- FFI.getElementType t+ etd <- typeDesc2 et+ return $ TDArray (fromIntegral n) etd+ FFI.PointerTypeKind -> do+ et <- FFI.getElementType t+ etd <- typeDesc2 et+ return $ TDPtr etd+ -- FIXME: FFI.OpaqueTypeKind -> return "Opaque"+ FFI.VectorTypeKind -> do+ n <- FFI.getVectorSize t+ et <- FFI.getElementType t+ etd <- typeDesc2 et+ return $ TDVector (fromIntegral n) etd+ -- FIXME: LLVMMetadataTypeKind, /**< Metadata */+ -- FIXME: LLVMX86_MMXTypeKind /**< X86 MMX */+ _ -> return TDInvalidType++-- |Type descriptor, used to convey type information through the LLVM API.+data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer+ | TDArray Integer TypeDesc | TDVector Integer TypeDesc+ | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel+ | TDStruct [TypeDesc] Bool | TDInvalidType+ deriving (Eq, Ord, Show, Typeable)++-- XXX isFloating and typeName could be extracted from typeRef+-- Usage:+-- superclass of IsConst+-- add, sub, mul, neg context+-- used to get type name to call intrinsic+-- |Arithmetic types, i.e., integral and floating types.+class IsFirstClass a => IsArithmetic a where+ arithmeticType :: ArithmeticType a++data ArithmeticType a = IntegerType | FloatingType++instance Functor ArithmeticType where+ 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+-- used to find signedness in Arithmetic+-- |Integral types.+class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where+ type Signed a :: *++-- Usage:+-- icmp+-- |Integral or pointer type.+class IsIntegerOrPointer a++isSigned :: (IsArithmetic a) => Proxy a -> Bool+isSigned = is . typeDesc+ where is (TDInt s _) = s+ is (TDVector _ a) = is a+ is TDFloat = True+ is TDDouble = True+ is TDFP128 = True+ is _ = error "isSigned got impossible input"++-- Usage:+-- constF+-- many instructions+-- |Floating types.+class IsArithmetic a => IsFloating a++isFloating :: (IsArithmetic a) => Proxy a -> Bool+isFloating = is . typeDesc+ where is TDFloat = True+ is TDDouble = True+ is TDFP128 = True+ is (TDVector _ a) = is a+ is _ = False++-- Usage:+-- Precondition for Vector+-- |Primitive types.+-- class (IsType a) => IsPrimitive a+class (IsScalarOrVector a, ShapeOf a ~ ScalarShape) => IsPrimitive a++data ScalarShape+data VectorShape n++class Shape shape where+ type ShapedType shape a :: *++instance Shape ScalarShape where+ type ShapedType ScalarShape a = a++instance Shape (VectorShape n) where+ type ShapedType (VectorShape n) a = Vector n a++-- |Number of elements for instructions that handle both primitive and vector types+class (IsFirstClass a) => IsScalarOrVector a where+ type ShapeOf a :: *+++-- Usage:+-- Precondition for function args and result.+-- Used by some instructions, like ret and phi.+-- XXX IsSized as precondition?+-- |First class types, i.e., the types that can be passed as arguments, etc.+class IsType a => IsFirstClass a++-- Usage:+-- Context for Array being a type+-- thus, allocation instructions+-- |Types with a fixed size.+class (IsType a, Dec.Natural (SizeOf a)) => IsSized a where+ type SizeOf a :: *++sizeOf :: TypeDesc -> Integer+sizeOf TDFloat = 32+sizeOf TDDouble = 64+sizeOf TDFP128 = 128+sizeOf (TDInt _ bits) = bits+sizeOf (TDArray n typ) = n * sizeOf typ+sizeOf (TDVector n typ) = n * sizeOf typ+sizeOf (TDStruct ts _packed) = sum (map sizeOf ts)+sizeOf _ = error "type has no size"++-- |Function type.+class (IsType a) => IsFunction a where+ funcType :: [TypeDesc] -> Proxy a -> TypeDesc++-- Only make instances for types that make sense in Haskell+-- (i.e., some floating types are excluded).++-- Floating point types.+instance IsType Float where typeDesc _ = TDFloat+instance IsType Double where typeDesc _ = TDDouble+instance IsType FP128 where typeDesc _ = TDFP128++-- Void type+instance IsType () where typeDesc _ = TDVoid++-- Label type+instance IsType Label where typeDesc _ = TDLabel++-- Variable size integer types+instance (Dec.Positive n) => IsType (IntN n)+ where typeDesc _ =+ TDInt True+ (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton 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+instance IsType Word8 where typeDesc _ = TDInt False 8+instance IsType Word16 where typeDesc _ = TDInt False 16+instance IsType Word32 where typeDesc _ = TDInt False 32+instance IsType Word64 where typeDesc _ = TDInt False 64+instance IsType Word where+ typeDesc _ = TDInt False (toInteger$bitSize(0::Word))+instance IsType Int8 where typeDesc _ = TDInt True 8+instance IsType Int16 where typeDesc _ = TDInt True 16+instance IsType Int32 where typeDesc _ = TDInt True 32+instance IsType Int64 where typeDesc _ = TDInt True 64+instance IsType Int where+ typeDesc _ = TDInt True (toInteger$bitSize(0::Int))++-- Sequence types+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 (Foreign.Ptr a) where+ typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy (Struct ())))++instance (IsType a) => IsType (Data.Ptr a) where+ 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 (Proxy :: Proxy (Struct ())))+{-+ typeDesc _ = TDPtr TDVoid++List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed.+-}+++-- Functions.+instance (IsFirstClass a, IsFunction b) => IsType (a->b) where+ typeDesc = funcType []++-- Function base type, always IO.+instance (IsFirstClass a) => IsType (IO a) where+ typeDesc = funcType []++-- Struct types, basically a list of component types.+instance (StructFields a) => IsType (Struct a) where+ typeDesc p = TDStruct (fieldTypes $ fmap (\(Struct a) -> a) p) False++instance (StructFields a) => IsType (PackedStruct a) where+ typeDesc p = TDStruct (fieldTypes $ fmap (\(PackedStruct a) -> a) p) True++-- Use a nested tuples for struct fields.+class StructFields as where+ fieldTypes :: Proxy as -> [TypeDesc]++instance (IsSized a, StructFields as) => StructFields (a :& as) where+ fieldTypes p = typeDesc (fmap fst p) : fieldTypes (fmap snd p)+instance StructFields () where+ fieldTypes Proxy = []+++-- Simplifies construction, pattern matching and conversion to and from records+class ConsStruct f where+ type PartialStruct f+ type ConsResult f+ curryConsStruct :: (PartialStruct f -> Struct (ConsResult f)) -> f++instance ConsStruct (Struct a) where+ type PartialStruct (Struct a) = ()+ type ConsResult (Struct a) = a+ curryConsStruct g = g ()++instance (ConsStruct f) => ConsStruct (a->f) where+ type PartialStruct (a->f) = (a, PartialStruct f)+ type ConsResult (a->f) = ConsResult f+ curryConsStruct g a = curryConsStruct (\r -> g (a,r))++consStruct :: (ConsStruct f, ConsResult f ~ PartialStruct f) => f+consStruct = curryConsStruct Struct++class CurryStruct a where+ type Curried a b+ curryStruct' :: (a -> b) -> Curried a b+ uncurryStruct' :: Curried a b -> a -> b++instance CurryStruct () where+ type Curried () b = b+ curryStruct' f = f ()+ uncurryStruct' f () = f++instance (CurryStruct r) => CurryStruct (a,r) where+ type Curried (a,r) b = a -> Curried r b+ curryStruct' f a = curryStruct' (\r -> f (a,r))+ uncurryStruct' f (a,r) = uncurryStruct' (f a) r++curryStruct :: (CurryStruct a) => (Struct a -> b) -> Curried a b+curryStruct f = curryStruct' (f . Struct)++uncurryStruct :: (CurryStruct a) => Curried a b -> (Struct a -> b)+uncurryStruct f (Struct a) = uncurryStruct' f a+++-- An alias for pairs to make structs look nicer+infixr :&+type (:&) a as = (a, as)+infixr &+(&) :: a -> as -> a :& as+a & as = (a, as)+++--- Instances to classify types+instance IsArithmetic Float where arithmeticType = FloatingType+instance IsArithmetic Double where arithmeticType = FloatingType+instance IsArithmetic FP128 where arithmeticType = FloatingType+instance (Dec.Positive n) => IsArithmetic (IntN n) where arithmeticType = IntegerType+instance (Dec.Positive n) => IsArithmetic (WordN n) where arithmeticType = IntegerType+{-+This instance is more dangerous than useful.+E.g. 'inv' can be mixed up with 'neg'.+For arithmetic on i1 you might better use @IntN D1@ or @WordN D1@.+-}+instance IsArithmetic Bool where arithmeticType = IntegerType+instance IsArithmetic Int8 where arithmeticType = IntegerType+instance IsArithmetic Int16 where arithmeticType = IntegerType+instance IsArithmetic Int32 where arithmeticType = IntegerType+instance IsArithmetic Int64 where arithmeticType = IntegerType+instance IsArithmetic Int where arithmeticType = IntegerType+instance IsArithmetic Word8 where arithmeticType = IntegerType+instance IsArithmetic Word16 where arithmeticType = IntegerType+instance IsArithmetic Word32 where arithmeticType = IntegerType+instance IsArithmetic Word64 where arithmeticType = IntegerType+instance IsArithmetic Word where arithmeticType = IntegerType+instance (Dec.Positive n, IsPrimitive a, IsArithmetic a) =>+ IsArithmetic (Vector n a) where+ arithmeticType = vectorArithmeticType arithmeticType+-- arithmeticType = fmap (pure :: a -> Vector n a) arithmeticType++instance IsFloating Float+instance IsFloating Double+instance IsFloating FP128+instance (Dec.Positive n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)++data Indecisive++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 = Indecisive+instance IsInteger Int8 where type Signed Int8 = True+instance IsInteger Int16 where type Signed Int16 = True+instance IsInteger Int32 where type Signed Int32 = True+instance IsInteger Int64 where type Signed Int64 = True+instance IsInteger Int where type Signed Int = True+instance IsInteger Word8 where type Signed Word8 = False+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 IsInteger Word where type Signed Word = False+instance (Dec.Positive n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)+ where type Signed (Vector n a) = Signed a++instance (Dec.Positive n) => IsIntegerOrPointer (IntN n)+instance (Dec.Positive n) => IsIntegerOrPointer (WordN n)+instance IsIntegerOrPointer Bool+instance IsIntegerOrPointer Int8+instance IsIntegerOrPointer Int16+instance IsIntegerOrPointer Int32+instance IsIntegerOrPointer Int64+instance IsIntegerOrPointer Int+instance IsIntegerOrPointer Word8+instance IsIntegerOrPointer Word16+instance IsIntegerOrPointer Word32+instance IsIntegerOrPointer Word64+instance IsIntegerOrPointer Word+instance (Dec.Positive n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a)+instance IsIntegerOrPointer (Foreign.Ptr a)+instance (IsType a) => IsIntegerOrPointer (Data.Ptr a)++instance IsFirstClass Float+instance IsFirstClass Double+instance IsFirstClass FP128+instance (Dec.Positive n) => IsFirstClass (IntN n)+instance (Dec.Positive n) => IsFirstClass (WordN n)+instance IsFirstClass Bool+instance IsFirstClass Int+instance IsFirstClass Int8+instance IsFirstClass Int16+instance IsFirstClass Int32+instance IsFirstClass Int64+instance IsFirstClass Word+instance IsFirstClass Word8+instance IsFirstClass Word16+instance IsFirstClass Word32+instance IsFirstClass Word64+instance (Dec.Positive n, IsPrimitive a) => IsFirstClass (Vector n a)+instance (Dec.Natural n, IsSized a) => IsFirstClass (Array n a)+instance IsFirstClass (Foreign.Ptr a)+instance (IsType a) => IsFirstClass (Data.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)+++{- |+Types where LLVM and 'Foreign.Storable' memory layout are compatible.+-}+class (Foreign.Storable a, IsFirstClass a, IsSized a) => Storable a+instance Storable Float+instance Storable Double+instance Storable Int+instance Storable Int8+instance Storable Int16+instance Storable Int32+instance Storable Int64+instance Storable Word+instance Storable Word8+instance Storable Word16+instance Storable Word32+instance Storable Word64+instance (Foreign.Storable a) => Storable (Foreign.Ptr a)+instance (IsType a) => Storable (Data.Ptr a)+instance (IsFunction a) => Storable (FunPtr a)+instance Storable (StablePtr a) where++fromPtr :: (Storable a) => Foreign.Ptr a -> Data.Ptr a+fromPtr = Data.uncheckedFromPtr++toPtr :: (Storable a) => Data.Ptr a -> Foreign.Ptr a+toPtr = Data.uncheckedToPtr+++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+instance IsSized Bool where type SizeOf Bool = D1+instance IsSized Int8 where type SizeOf Int8 = D8+instance IsSized Int16 where type SizeOf Int16 = D16+instance IsSized Int32 where type SizeOf Int32 = D32+instance IsSized Int64 where type SizeOf Int64 = D64+instance IsSized Int where type SizeOf Int = IntSize+instance IsSized Word8 where type SizeOf Word8 = D8+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 IsSized Word where type SizeOf Word = IntSize+{-+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+ (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 IsSized (Foreign.Ptr a) where type SizeOf (Foreign.Ptr a) = PtrSize+instance (IsType a) => IsSized (Data.Ptr a) where+ type SizeOf (Data.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 :(+instance (StructFields as) => IsSized (Struct as) where+ type SizeOf (Struct as) = UnknownSize+instance (StructFields as) => IsSized (PackedStruct as) where+ type SizeOf (PackedStruct as) = UnknownSize++type UnknownSize = D99 -- XXX this is wrong!++type IntSize = PtrSize+#if WORD_SIZE_IN_BITS == 32+type PtrSize = D32+#elif WORD_SIZE_IN_BITS == 64+type PtrSize = D64+#else+#error cannot determine type of PtrSize+#endif++instance IsPrimitive Float+instance IsPrimitive Double+instance IsPrimitive FP128+instance (Dec.Positive n) => IsPrimitive (IntN n)+instance (Dec.Positive n) => IsPrimitive (WordN n)+instance IsPrimitive Bool+instance IsPrimitive Int8+instance IsPrimitive Int16+instance IsPrimitive Int32+instance IsPrimitive Int64+instance IsPrimitive Int+instance IsPrimitive Word8+instance IsPrimitive Word16+instance IsPrimitive Word32+instance IsPrimitive Word64+instance IsPrimitive Word+instance IsPrimitive Label+instance IsPrimitive ()+instance IsPrimitive (Foreign.Ptr a)+instance (IsType a) => IsPrimitive (Data.Ptr a)+++instance (Dec.Positive n) =>+ IsScalarOrVector (IntN n) where type ShapeOf (IntN n) = ScalarShape+instance (Dec.Positive n) =>+ IsScalarOrVector (WordN n) where type ShapeOf (WordN n) = ScalarShape+instance IsScalarOrVector Float where type ShapeOf Float = ScalarShape+instance IsScalarOrVector Double where type ShapeOf Double = ScalarShape+instance IsScalarOrVector FP128 where type ShapeOf FP128 = ScalarShape+instance IsScalarOrVector Bool where type ShapeOf Bool = ScalarShape+instance IsScalarOrVector Int8 where type ShapeOf Int8 = ScalarShape+instance IsScalarOrVector Int16 where type ShapeOf Int16 = ScalarShape+instance IsScalarOrVector Int32 where type ShapeOf Int32 = ScalarShape+instance IsScalarOrVector Int64 where type ShapeOf Int64 = ScalarShape+instance IsScalarOrVector Int where type ShapeOf Int = ScalarShape+instance IsScalarOrVector Word8 where type ShapeOf Word8 = ScalarShape+instance IsScalarOrVector Word16 where type ShapeOf Word16 = ScalarShape+instance IsScalarOrVector Word32 where type ShapeOf Word32 = ScalarShape+instance IsScalarOrVector Word64 where type ShapeOf Word64 = ScalarShape+instance IsScalarOrVector Word where type ShapeOf Word = ScalarShape+instance IsScalarOrVector Label where type ShapeOf Label = ScalarShape+instance IsScalarOrVector () where type ShapeOf () = ScalarShape+instance IsScalarOrVector (Foreign.Ptr a) where+ type ShapeOf (Foreign.Ptr a) = ScalarShape+instance (IsType a) => IsScalarOrVector (Data.Ptr a) where+ type ShapeOf (Data.Ptr a) = ScalarShape++instance (Dec.Positive n, IsPrimitive a) =>+ IsScalarOrVector (Vector n a) where+ type ShapeOf (Vector n a) = VectorShape n+++-- Functions.+instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where+ 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 (Proxy :: Proxy a))+instance (IsFirstClass a) => IsFunction (VarArgs a) where+ 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'.+data VarArgs a+ deriving (Typeable)+instance IsType (VarArgs a) where+ typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly"++-- |Define what vararg types are permissible.+class CastVarArgs a b+instance (x~y, CastVarArgs a b) => CastVarArgs (x -> a) (y -> b)+instance (x~y) => CastVarArgs (VarArgs x) (IO y)+instance (IsFirstClass x, CastVarArgs (VarArgs a) b) =>+ CastVarArgs (VarArgs a) (x -> b)+++++-- XXX Structures not implemented. Tuples is probably an easy way.+
+ private/LLVM/Core/UnaryVector.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Core.UnaryVector (+ T, vector, cyclicVector,+ FixedLength.fromFixedList, FixedLength.toFixedList, FixedLength.head,+ FixedList, Length,+ FixedLength.Curried, FixedLength.uncurry, FixedLength.curry,+ ) where++import qualified Type.Data.Num.Unary as Unary++import qualified Data.FixedLength as FixedLength+import Data.FixedLength (T, List, Length, end, (!:))++import qualified Data.NonEmpty as NonEmpty++import Prelude hiding (head)+++type FixedList n = List n+++vector :: (Unary.Natural n, n ~ Length (List n)) => List n a -> T n a+vector = FixedLength.fromFixedList++cyclicVector :: (Unary.Natural n) => NonEmpty.T [] a -> T n a+cyclicVector xt@(NonEmpty.Cons x xs) =+ runOp0 $+ Unary.switchNat+ (Op0 end)+ (Op0 $ x !: cyclicVectorAppend xt xs)++cyclicVectorAppend :: (Unary.Natural n) => NonEmpty.T [] a -> [a] -> T n a+cyclicVectorAppend ys xt =+ runOp0 $+ Unary.switchNat+ (Op0 end)+ (Op0 $+ case xt of+ [] -> cyclicVector ys+ x:xs -> x !: cyclicVectorAppend ys xs)++newtype Op0 a n = Op0 {runOp0 :: T n a}
+ private/LLVM/Core/Util.hs view
@@ -0,0 +1,480 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.Util(+ -- * Module handling+ Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,+ getModuleValues, getFunctions, getGlobalVariables, valueHasType,+ -- * Pass manager handling+ PassManager(..), withPassManager, createPassManager, createFunctionPassManager,+ runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager,+ -- * Instruction builder+ Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock,+ -- * Basic blocks+ BasicBlock,+ appendBasicBlock, getBasicBlocks,+ -- * Functions+ Function,+ addFunction, getParam, getParams,+ -- * Structs+ structType,+ -- * Globals+ addGlobal,+ constString, constStringNul, constVector, constArray, constStruct,+ -- * Instructions+ makeCall, makeInvoke,+ makeCallWithCc, makeInvokeWithCc,+ withValue, getInstructions, getOperands,+ -- * Uses and Users+ hasUsers, getUsers, getUses, getUser, isChildOf, getDep,+ -- * Misc+ CString, withArrayLen,+ withEmptyCString,+ functionType, buildEmptyPhi, addPhiIns,+ showTypeOf, getValueNameU, getObjList, annotateValueList,+ isConstant, isIntrinsic,+ -- * Transformation passes+ addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,+ addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,+ ) where++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.BitWriter as FFI+import qualified LLVM.FFI.BitReader as FFI+import qualified LLVM.FFI.Transforms.Scalar as FFI++import Foreign.C.String (withCString, withCStringLen, CString, peekCString)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (Storable(..))+import System.IO.Unsafe (unsafePerformIO)++import Data.Typeable (Typeable)+import Data.List (intercalate)+import Control.Monad (liftM, when)+++type Type = FFI.TypeRef++functionType :: Bool -> Type -> [Type] -> IO Type+functionType varargs retType paramTypes =+ withArrayLen paramTypes $ \ len ptr ->+ FFI.functionType retType ptr (fromIntegral len) (FFI.consBool varargs)++structType :: [Type] -> Bool -> IO Type+structType types packed =+ withArrayLen types $ \ len ptr ->+ FFI.structType ptr (fromIntegral len) (FFI.consBool packed)++--------------------------------------+-- Handle modules++-- Don't use a finalizer for the module, but instead provide an+-- explicit destructor. This is because handing a module to+-- a module provider changes ownership of the module to the provider,+-- and we don't want to free it by mistake.++-- | Type of top level modules.+newtype Module = Module {+ fromModule :: FFI.ModuleRef+ }+ deriving (Show, Typeable)++withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a+withModule modul f = f (fromModule modul)++createModule :: String -> IO Module+createModule name =+ withCString name $ \ namePtr -> do+ liftM Module $ FFI.moduleCreateWithName namePtr++-- | Free all storage related to a module. *Note*, this is a dangerous call, since referring+-- to the module after this call is an error. The reason for the explicit call to free+-- the module instead of an automatic lifetime management is that modules have a+-- somewhat complicated ownership. Handing a module to a module provider changes+-- the ownership of the module, and the module provider will free the module when necessary.+destroyModule :: Module -> IO ()+destroyModule = FFI.disposeModule . fromModule++-- |Write a module to a file.+writeBitcodeToFile :: String -> Module -> IO ()+writeBitcodeToFile name mdl =+ withCString name $ \ namePtr ->+ withModule mdl $ \ mdlPtr -> do+ rc <- FFI.writeBitcodeToFile mdlPtr namePtr+ when (rc /= 0) $+ ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc++-- |Read a module from a file.+readBitcodeFromFile :: String -> IO Module+readBitcodeFromFile name =+ withCString name $ \ namePtr ->+ alloca $ \ bufPtr ->+ alloca $ \ modPtr ->+ alloca $ \ errStr -> do+ rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr+ if FFI.deconsBool rrc then do+ msg <- peek errStr >>= peekCString+ ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg+ else do+ buf <- peek bufPtr+ prc <- FFI.parseBitcode buf modPtr errStr+ if FFI.deconsBool prc then do+ msg <- peek errStr >>= peekCString+ ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg+ else do+ ptr <- peek modPtr+ return $ Module ptr+{-+ liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr+-}++getModuleValues :: Module -> IO [(String, Value)]+getModuleValues mdl = do+ fs <- getFunctions mdl+ gs <- getGlobalVariables mdl+ return (fs ++ gs)++getFunctions :: Module -> IO [(String, Value)]+getFunctions mdl =+ getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl+ >>= annotateValueList++getGlobalVariables :: Module -> IO [(String, Value)]+getGlobalVariables mdl =+ getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl+ >>= annotateValueList++-- This is safe because we just ask for the type of a value.+valueHasType :: Value -> Type -> Bool+valueHasType v t = unsafePerformIO $ do+ vt <- FFI.typeOf v+ return $ vt == t -- LLVM uses hash consing for types, so pointer equality works.++showTypeOf :: Value -> IO String+showTypeOf v = FFI.typeOf v >>= showType'++showType' :: Type -> IO String+showType' p = do+ pk <- FFI.getTypeKind p+ case pk of+ FFI.VoidTypeKind -> return "()"+ FFI.FloatTypeKind -> return "Float"+ FFI.DoubleTypeKind -> return "Double"+ FFI.X86_FP80TypeKind -> return "X86_FP80"+ FFI.FP128TypeKind -> return "FP128"+ FFI.PPC_FP128TypeKind -> return "PPC_FP128"+ FFI.LabelTypeKind -> return "Label"+ FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"+ FFI.FunctionTypeKind -> do+ r <- FFI.getReturnType p+ c <- FFI.countParamTypes p+ let n = fromIntegral c+ as <- allocaArray n $ \ args -> do+ FFI.getParamTypes p args+ peekArray n args+ ts <- mapM showType' (as ++ [r])+ return $ "(" ++ intercalate " -> " ts ++ ")"+ FFI.StructTypeKind -> return "(Struct ...)"+ FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"+ FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"+ FFI.OpaqueTypeKind -> return "Opaque"+ FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")"++--------------------------------------+-- Handle instruction builders++newtype Builder = Builder {+ fromBuilder :: ForeignPtr FFI.Builder+ }+ deriving (Show, Typeable)++withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a+withBuilder = withForeignPtr . fromBuilder++createBuilder :: IO Builder+createBuilder = do+ ptr <- FFI.createBuilder+ liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr++positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO ()+positionAtEnd bld bblk =+ withBuilder bld $ \ bldPtr ->+ FFI.positionAtEnd bldPtr bblk++getInsertBlock :: Builder -> IO FFI.BasicBlockRef+getInsertBlock bld =+ withBuilder bld $ \ bldPtr ->+ FFI.getInsertBlock bldPtr++--------------------------------------++type BasicBlock = FFI.BasicBlockRef++appendBasicBlock :: Function -> String -> IO BasicBlock+appendBasicBlock func name =+ withCString name $ \ namePtr ->+ FFI.appendBasicBlock func namePtr++getBasicBlocks :: Value -> IO [(String, BasicBlock)]+getBasicBlocks v =+ getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v+ >>= annotateBasicBlockList++--------------------------------------++type Function = FFI.ValueRef++addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function+addFunction modul linkage name typ =+ withModule modul $ \ modulPtr ->+ withCString name $ \ namePtr -> do+ f <- FFI.addFunction modulPtr namePtr typ+ FFI.setLinkage f (FFI.fromLinkage linkage)+ return f++getParam :: Function -> Int -> Value+getParam f = unsafePerformIO . FFI.getParam f . fromIntegral++getParams :: Value -> IO [(String, Value)]+getParams v =+ getObjList withValue FFI.getFirstParam FFI.getNextParam v+ >>= annotateValueList++--------------------------------------++addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value+addGlobal modul linkage name typ =+ withModule modul $ \ modulPtr ->+ withCString name $ \ namePtr -> do+ v <- FFI.addGlobal modulPtr typ namePtr+ FFI.setLinkage v (FFI.fromLinkage linkage)+ return v++-- unsafePerformIO is safe because it's only used for the withCStringLen conversion+constStringInternal :: Bool -> String -> Value+constStringInternal nulTerm s = unsafePerformIO $+ withCStringLen s $ \(sPtr, sLen) ->+ FFI.constString sPtr (fromIntegral sLen) (FFI.consBool (not nulTerm))++constString :: String -> Value+constString = constStringInternal False++constStringNul :: String -> Value+constStringNul = constStringInternal True++--------------------------------------++type Value = FFI.ValueRef++withValue :: Value -> (Value -> IO a) -> IO a+withValue v f = f v++withBasicBlock :: FFI.BasicBlockRef -> (FFI.BasicBlockRef -> IO a) -> IO a+withBasicBlock v f = f v++makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value+makeCall = makeCallWithCc FFI.C++makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value+makeCallWithCc cc func bldPtr args = do+{-+ print "makeCall"+ FFI.dumpValue func+ mapM_ FFI.dumpValue args+ print "----------------------"+-}+ withArrayLen args $ \ argLen argPtr ->+ withEmptyCString $ \cstr -> do+ i <- FFI.buildCall bldPtr func argPtr+ (fromIntegral argLen) cstr+ FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)+ return i++makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->+ [Value] -> IO Value+makeInvoke = makeInvokeWithCc FFI.C++makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->+ [Value] -> IO Value+makeInvokeWithCc cc norm expt func bldPtr args =+ withArrayLen args $ \ argLen argPtr ->+ withEmptyCString $ \cstr -> do+ i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr+ FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)+ return i++getInstructions :: BasicBlock -> IO [(String, Value)]+getInstructions bb =+ getObjList withBasicBlock FFI.getFirstInstruction FFI.getNextInstruction bb+ >>= annotateValueList++getOperands :: Value -> IO [(String, Value)]+getOperands ii = geto ii >>= annotateValueList+ where geto i = do+ num <- FFI.getNumOperands i+ let oloop instr number total = if number >= total then return [] else do+ o <- FFI.getOperand instr number+ os <- oloop instr (number + 1) total+ return (o : os)+ oloop i 0 num++--------------------------------------++buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value+buildEmptyPhi bldPtr typ = do+ withEmptyCString $ FFI.buildPhi bldPtr typ++withEmptyCString :: (CString -> IO a) -> IO a+withEmptyCString = withCString ""++addPhiIns :: Value -> [(Value, BasicBlock)] -> IO ()+addPhiIns inst incoming = do+ let (vals, bblks) = unzip incoming+ withArrayLen vals $ \ count valPtr ->+ withArray bblks $ \ bblkPtr ->+ FFI.addIncoming inst valPtr bblkPtr (fromIntegral count)++--------------------------------------++-- | Manage compile passes.+newtype PassManager = PassManager {+ fromPassManager :: ForeignPtr FFI.PassManager+ }+ deriving (Show, Typeable)++withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)+ -> IO a+withPassManager = withForeignPtr . fromPassManager++-- | Create a pass manager.+createPassManager :: IO PassManager+createPassManager = do+ ptr <- FFI.createPassManager+ liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr++-- | Create a pass manager for a module.+createFunctionPassManager :: Module -> IO PassManager+createFunctionPassManager modul =+ withModule modul $ \modulPtr -> do+ ptr <- FFI.createFunctionPassManagerForModule modulPtr+ liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr++-- | Add a control flow graph simplification pass to the manager.+addCFGSimplificationPass :: PassManager -> IO ()+addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass++-- | Add a constant propagation pass to the manager.+addConstantPropagationPass :: PassManager -> IO ()+addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass++addDemoteMemoryToRegisterPass :: PassManager -> IO ()+addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass++-- | Add a global value numbering pass to the manager.+addGVNPass :: PassManager -> IO ()+addGVNPass pm = withPassManager pm FFI.addGVNPass++addInstructionCombiningPass :: PassManager -> IO ()+addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass++addPromoteMemoryToRegisterPass :: PassManager -> IO ()+addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass++addReassociatePass :: PassManager -> IO ()+addReassociatePass pm = withPassManager pm FFI.addReassociatePass++runFunctionPassManager :: PassManager -> Function -> IO FFI.Bool+runFunctionPassManager pm fcn = withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn++initializeFunctionPassManager :: PassManager -> IO FFI.Bool+initializeFunctionPassManager pm = withPassManager pm FFI.initializeFunctionPassManager++finalizeFunctionPassManager :: PassManager -> IO FFI.Bool+finalizeFunctionPassManager pm = withPassManager pm FFI.finalizeFunctionPassManager++--------------------------------------++constVector :: [Value] -> IO Value+constVector xs = do+ withArrayLen xs $ \ len ptr ->+ FFI.constVector ptr (fromIntegral len)++constArray :: Type -> [Value] -> IO Value+constArray t xs = do+ withArrayLen xs $ \ len ptr ->+ FFI.constArray t ptr (fromIntegral len)++constStruct :: [Value] -> Bool -> IO Value+constStruct xs packed = do+ withArrayLen xs $ \ len ptr ->+ FFI.constStruct ptr (fromIntegral len) (FFI.consBool packed)++--------------------------------------++getValueNameU :: Value -> IO String+getValueNameU a = do+ -- sometimes void values need explicit names too+ str <- peekCString =<< FFI.getValueName a+ if str == "" then return (show a) else return str++getBasicBlockNameU :: BasicBlock -> IO String+getBasicBlockNameU a = do+ str <- peekCString =<< FFI.getBasicBlockName a+ if str == "" then return (show a) else return str++getObjList ::+ (obj -> (objPtr -> IO [Ptr a]) -> io) -> (objPtr -> IO (Ptr a)) ->+ (Ptr a -> IO (Ptr a)) -> obj -> io+getObjList withF firstF nextF obj =+ withF obj $ \ objPtr -> do+ let oloop p =+ if p == nullPtr+ then return []+ else fmap (p:) $ oloop =<< nextF p+ oloop =<< firstF objPtr++annotateValueList :: [Value] -> IO [(String, Value)]+annotateValueList vs = do+ names <- mapM getValueNameU vs+ return $ zip names vs++annotateBasicBlockList :: [BasicBlock] -> IO [(String, BasicBlock)]+annotateBasicBlockList vs = do+ names <- mapM getBasicBlockNameU vs+ return $ zip names vs++isConstant :: Value -> IO Bool+isConstant v = fmap FFI.deconsBool $ FFI.isConstant v++isIntrinsic :: Value -> IO Bool+isIntrinsic v = fmap (/=0) $ FFI.getIntrinsicID v++--------------------------------------++type Use = FFI.UseRef++hasUsers :: Value -> IO Bool+hasUsers v = fmap (>0) $ FFI.getNumUses v++getUses :: Value -> IO [Use]+getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse++getUsers :: [Use] -> IO [(String, Value)]+getUsers us = mapM FFI.getUser us >>= annotateValueList++getUser :: Use -> IO Value+getUser = FFI.getUser++isChildOf :: BasicBlock -> Value -> IO Bool+isChildOf bb v = do+ bb2 <- FFI.getInstructionParent v+ return $ bb == bb2++getDep :: Use -> IO (String, String)+getDep u = do+ producer <- FFI.getUsedValue u >>= getValueNameU+ consumer <- FFI.getUser u >>= getValueNameU+ return (producer, consumer)
+ private/LLVM/Core/Vector.hs view
@@ -0,0 +1,284 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+module LLVM.Core.Vector (MkVector(..), vector, cyclicVector, consVector) where++import qualified LLVM.Core.UnaryVector as UnaryVector+import LLVM.Core.Data (Vector(Vector), FixedList)++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 qualified Type.Base.Proxy as Proxy+import Type.Data.Num.Decimal.Literal (D2, D4, D8)++import qualified Foreign.Storable.Traversable as Store+import Foreign.Storable.FixedArray (sizeOfArray)+import Foreign.Storable (Storable(..))++import qualified Test.QuickCheck as QC++import qualified Control.Monad.Trans.State as MS+import Control.Applicative (Applicative, pure, liftA2, (<*>))+import Control.Functor.HT (unzip, outerProduct)++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 Prelude hiding (replicate, map, head, unzip, zipWith, uncurry)+++-- XXX Should these really be here?+class (Dec.Positive n) => MkVector n where+ type Tuple n a :: *+ toVector :: Tuple n a -> Vector n a+ fromVector :: Vector n a -> Tuple n a+++instance MkVector D2 where+ type Tuple D2 a = (a,a)+ toVector (a1, a2) = consVector a1 a2+ fromVector = uncurry (,)++instance MkVector D4 where+ type Tuple D4 a = (a,a,a,a)+ toVector (a1, a2, a3, a4) = consVector a1 a2 a3 a4+ fromVector = uncurry (,,,)++instance MkVector D8 where+ type Tuple D8 a = (a,a,a,a,a,a,a,a)+ toVector (a1, a2, a3, a4, a5, a6, a7, a8) =+ consVector a1 a2 a3 a4 a5 a6 a7 a8+ fromVector = uncurry (,,,,,,,)+++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.fromFixedList xs++decimalFromUnaryVector :: UnaryVector.T (Dec.ToUnary n) a -> Vector n a+decimalFromUnaryVector = Vector . UnaryVector.toFixedList+++type Curried n a b = UnaryVector.Curried (Dec.ToUnary n) a b++uncurry :: (Dec.Natural n) => Curried n a b -> Vector n a -> b+uncurry f =+ withNatDict1 $ \dict v ->+ case dict of+ DecProof.UnaryNat ->+ UnaryVector.uncurry 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) => Storable (Vector n a) where+ sizeOf v = sizeOfArray (Dec.integralFromProxy $ size v) (head v)+ alignment = alignment . head+ peek = Store.peekApplicative+ poke = Store.poke++size :: Vector n a -> Proxy.Proxy n+size _ = Proxy.Proxy++--------------------------------------++{- 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+-}++vector :: (Dec.Positive n) => FixedList (Dec.ToUnary n) a -> Vector n a+vector = Vector++{- |+Make a constant vector. Replicates or truncates the list to get length /n/.+This behaviour is consistent uncurry that of 'LLVM.Core.CodeGen.constCyclicVector'.+May be abused for constructing vectors from lists uncurry statically unknown size.+-}+cyclicVector :: (Dec.Positive n) => NonEmpty.T [] a -> Vector n a+cyclicVector xs =+ withUnaryDecVector (UnaryVector.cyclicVector xs)+++class ConsVector f where+ type NumberOfArguments f+ type ResultSize f+ type ResultElement f+ consAux ::+ (NumberOfArguments f ~ m, ResultSize f ~ n, ResultElement f ~ a) =>+ (FixedList m a -> Vector n a) -> f++instance ConsVector (Vector n a) where+ type NumberOfArguments (Vector n a) = Unary.Zero+ type ResultSize (Vector n a) = n+ type ResultElement (Vector n a) = a+ consAux f = f Empty.Cons++instance (a ~ ResultElement f, ConsVector f) => ConsVector (a -> f) where+ type NumberOfArguments (a->f) = Unary.Succ (NumberOfArguments f)+ type ResultSize (a->f) = ResultSize f+ type ResultElement (a->f) = ResultElement f+ consAux f x = consAux (f . NonEmpty.Cons x)++consVector ::+ (ConsVector f, ResultSize f ~ n, NumberOfArguments f ~ u,+ u ~ Dec.ToUnary n, Dec.FromUnary u ~ n, Dec.Natural n) => f+consVector = consAux Vector+++replicate :: (Dec.Positive n) => a -> Vector n a+replicate a = withUnaryDecVector (pure a)+++instance (Dec.Positive n) => Functor (Vector n) where+ fmap f a =+ withUnaryDecVector (fmap f $ unaryFromDecimalVector a)++instance (Dec.Positive n) => Applicative (Vector n) where+ pure = replicate+ f <*> a =+ withUnaryDecVector+ (unaryFromDecimalVector f <*> unaryFromDecimalVector a)++instance (Dec.Positive n) => Foldable (Vector n) where+ foldMap = foldMapDefault++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 = pure . toEnum++instance (Real a, Dec.Positive n) => Real (Vector n a) where+ toRational = error "Vector toRational"++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, Dec.Positive n) => Fractional (Vector n a) where+ (/) = liftA2 (/)+ fromRational = pure . fromRational++instance (RealFrac a, Dec.Positive n) => RealFrac (Vector n a) where+ properFraction = error "Vector properFraction"++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, 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+ scaleFloat 0 x = x+ scaleFloat _ _ = error "Vector scaleFloat"+ isNaN = error "Vector isNaN"+ isInfinite = error "Vector isInfinite"+ isDenormalized = error "Vector isDenormalized"+ isNegativeZero = error "Vector isNegativeZero"+ isIEEE = isIEEE . head+++indices :: (Dec.Positive n) => Vector n Int+indices =+ flip MS.evalState 0 $ Trav.sequenceA $ replicate $ MS.state (\k -> (k,k+1))++instance (Dec.Positive n, QC.Arbitrary a) => QC.Arbitrary (Vector n a) where+ arbitrary = Trav.sequenceA $ replicate QC.arbitrary+ shrink v =+ case indices of+ ixs ->+ concatMap+ (Trav.sequenceA .+ liftA2+ (\x doShrink ->+ if doShrink then QC.shrink x else [x]) v) $+ outerProduct (==) (Fold.toList ixs) ixs
+ private/LLVM/ExecutionEngine/Engine.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.ExecutionEngine.Engine(+ EngineAccess,+ ExecutionEngine(..),+ getEngine,+ runEngineAccess, runEngineAccessWithModule,+ runEngineAccessInterpreterWithModule,+ getExecutionEngineTargetData,+ ExecutionFunction,+ Importer,+ getExecutionFunction,+ getPointerToFunction,+ addModule,+ addFunctionValue, addGlobalMappings,+ runFunction, getRunFunction,+ GenericValue, Generic(..)+ ) where++import qualified LLVM.Core.Proxy as Proxy+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Util as U++import LLVM.Core.CodeGen (Value(..), Function)+import LLVM.Core.CodeGenMonad (GlobalMappings(..))+import LLVM.Core.Util (Module, withModule, createModule)+import LLVM.Core.Type (IsFirstClass, typeRef)+import LLVM.Core.Proxy (Proxy(Proxy))++import qualified LLVM.FFI.ExecutionEngine as FFI+import qualified LLVM.FFI.Target as FFI+import qualified LLVM.FFI.Core as FFI (consBool, deconsBool, )++import qualified Control.Monad.Trans.Reader as MR+import Control.Exception (bracket)+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad (liftM, )+import Control.Applicative (Applicative, pure, (<*>), (<$>), )++import qualified Data.EnumBitSet as EnumSet+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)++import Foreign.Marshal.Alloc (alloca, free)+import Foreign.Marshal.Array (withArrayLen)+import Foreign.ForeignPtr+ (ForeignPtr, newForeignPtr, withForeignPtr, touchForeignPtr)+import Foreign.C.String (peekCString)+import Foreign.Ptr (Ptr, FunPtr, )+import Foreign.Storable (peek)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )+import System.IO.Unsafe (unsafePerformIO)+++newtype+ ExecutionEngine = ExecutionEngine {+ fromEngine :: ForeignPtr FFI.ExecutionEngine+ }++withEngine :: ExecutionEngine -> (FFI.ExecutionEngineRef -> IO a) -> IO a+withEngine = withForeignPtr . fromEngine++createExecutionEngineForModule ::+ Bool -> FFI.EngineKindSet -> Module -> IO ExecutionEngine+createExecutionEngineForModule hostCPU kind m =+ alloca $ \eePtr ->+ alloca $ \errPtr -> do+ success <-+ withModule m $ \mPtr ->+ if hostCPU+ then+ FFI.createExecutionEngineKindForModuleCPU+ eePtr kind mPtr errPtr+ else+ if EnumSet.get FFI.JIT kind+ then FFI.createExecutionEngineForModule eePtr mPtr errPtr+ else FFI.createInterpreterForModule eePtr mPtr errPtr+ if FFI.deconsBool success+ then ioError . userError =<< bracket (peek errPtr) free peekCString+ else+ liftM ExecutionEngine $+ newForeignPtr FFI.ptrDisposeExecutionEngine =<<+ peek eePtr++getTheEngine :: FFI.EngineKindSet -> Module -> IO ExecutionEngine+getTheEngine = createExecutionEngineForModule True++newtype EngineAccess a = EA (MR.ReaderT ExecutionEngine IO a)+ deriving (Functor, Applicative, Monad, MonadIO)++-- |The LLVM execution engine is encapsulated so it cannot be accessed directly.+-- The reason is that (currently) there must only ever be one engine,+-- so access to it is wrapped in a monad.+runEngineAccess :: EngineAccess a -> IO a+runEngineAccess (EA body) = do+ MR.runReaderT body =<< getTheEngine FFI.kindEither =<< createModule "__empty__"++runEngineAccessWithModule :: Module -> EngineAccess a -> IO a+runEngineAccessWithModule m (EA body) = do+ MR.runReaderT body =<< getTheEngine FFI.kindEither m++runEngineAccessInterpreterWithModule :: Module -> EngineAccess a -> IO a+runEngineAccessInterpreterWithModule m (EA body) = do+ MR.runReaderT body =<< getTheEngine FFI.kindInterpreter m+++getEngine :: EngineAccess ExecutionEngine+getEngine = EA MR.ask++accessEngine :: (FFI.ExecutionEngineRef -> IO a) -> EngineAccess a+accessEngine act = do+ engine <- getEngine+ liftIO $ withEngine engine act++getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef+getExecutionEngineTargetData =+ accessEngine FFI.getExecutionEngineTargetData++{- |+In contrast to 'generateFunction' this compiles a function once.+Thus it is faster for many calls to the same function.+See @examples\/Vector.hs@.++If the function calls back into Haskell code,+you also have to set the function addresses+using 'addFunctionValue' or 'addGlobalMappings'.++You must keep the execution engine alive+as long as you want to call the function.+Better use 'getExecutionFunction' which handles this for you.+-}+getPointerToFunction :: Function f -> EngineAccess (FunPtr f)+getPointerToFunction (Value f) =+ accessEngine $ \eePtr -> FFI.getPointerToFunction eePtr f++class ExecutionFunction f where+ keepAlive :: ExecutionEngine -> f -> f++instance ExecutionFunction (IO a) where+ keepAlive engine act = do+ a <- act+ touchForeignPtr (fromEngine engine)+ return a++instance ExecutionFunction f => ExecutionFunction (a -> f) where+ keepAlive engine act = keepAlive engine . act++type Importer f = FunPtr f -> f++getExecutionFunction ::+ (ExecutionFunction f) => Importer f -> Function f -> EngineAccess f+getExecutionFunction importer (Value f) = do+ engine <- getEngine+ liftIO $ withEngine engine $ \eePtr ->+ keepAlive engine . importer <$> FFI.getPointerToFunction eePtr f++{- |+Tell LLVM the address of an external function+if it cannot resolve a name automatically.+Alternatively you may declare the function+with 'staticFunction' instead of 'externFunction'.+-}+addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()+addFunctionValue (Value g) f =+ accessEngine $ \eePtr -> FFI.addFunctionMapping eePtr g f++{- |+Pass a list of global mappings to LLVM+that can be obtained from 'LLVM.Core.getGlobalMappings'.+-}+addGlobalMappings :: GlobalMappings -> EngineAccess ()+addGlobalMappings (GlobalMappings gms) = accessEngine gms++addModule :: Module -> EngineAccess ()+addModule m =+ accessEngine $ \eePtr -> U.withModule m $ FFI.addModule eePtr+++--------------------------------------++newtype GenericValue = GenericValue {+ fromGenericValue :: ForeignPtr FFI.GenericValue+ }++withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a+withGenericValue = withForeignPtr . fromGenericValue++createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue+createGenericValueWith f = do+ ptr <- f+ liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr++withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a+withAll ps a = go [] ps+ where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs+ go ptrs _ = withArrayLen (reverse ptrs) a++runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue+runFunction func args =+ liftIO =<< getRunFunction <*> pure func <*> pure args++getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)+getRunFunction = do+ engine <- getEngine+ return $ \ func args ->+ withAll args $ \argLen argPtr ->+ withEngine engine $ \eePtr ->+ createGenericValueWith $ FFI.runFunction eePtr func+ (fromIntegral argLen) argPtr++class Generic a where+ toGeneric :: a -> GenericValue+ fromGeneric :: GenericValue -> a++instance Generic () where+ toGeneric _ = error "toGeneric ()"+ fromGeneric _ = ()++toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue+toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ do+ typ <- typeRef $ Proxy.fromValue val+ FFI.createGenericValueOfInt+ typ (fromIntegral val) (FFI.consBool signed)++fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a+fromGenericInt signed val = unsafePerformIO $+ withGenericValue val $ \ref ->+ fmap fromIntegral $ FFI.genericValueToInt ref (FFI.consBool signed)++--instance Generic Bool where+-- toGeneric = toGenericInt False . FFI.consBool+-- fromGeneric = toBool . fromGenericInt False++instance Generic Int where+ toGeneric = toGenericInt True+ fromGeneric = fromGenericInt True++instance Generic Int8 where+ toGeneric = toGenericInt True+ fromGeneric = fromGenericInt True++instance Generic Int16 where+ toGeneric = toGenericInt True+ fromGeneric = fromGenericInt True++instance Generic Int32 where+ toGeneric = toGenericInt True+ fromGeneric = fromGenericInt True++instance Generic Int64 where+ toGeneric = toGenericInt True+ fromGeneric = fromGenericInt True++instance Generic Word where+ toGeneric = toGenericInt False+ fromGeneric = fromGenericInt False++instance Generic Word8 where+ toGeneric = toGenericInt False+ fromGeneric = fromGenericInt False++instance Generic Word16 where+ toGeneric = toGenericInt False+ fromGeneric = fromGenericInt False++instance Generic Word32 where+ toGeneric = toGenericInt False+ fromGeneric = fromGenericInt False++instance Generic Word64 where+ toGeneric = toGenericInt False+ fromGeneric = fromGenericInt False++toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue+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 -> do+ typ <- typeRef (Proxy :: Proxy a)+ fmap realToFrac $ FFI.genericValueToFloat typ ref++instance Generic Float where+ toGeneric = toGenericReal+ fromGeneric = fromGenericReal++instance Generic Double where+ toGeneric = toGenericReal+ fromGeneric = fromGenericReal++instance Generic (Data.Ptr a) where+ toGeneric =+ unsafePerformIO . createGenericValueWith .+ FFI.createGenericValueOfPointer . Data.uncheckedToPtr+ fromGeneric val =+ Data.uncheckedFromPtr . unsafePerformIO . withGenericValue val $+ FFI.genericValueToPointer++instance Generic (Ptr a) where+ toGeneric =+ unsafePerformIO . createGenericValueWith .+ FFI.createGenericValueOfPointer+ fromGeneric val =+ unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer++instance Generic (StablePtr a) where+ toGeneric =+ unsafePerformIO . createGenericValueWith .+ FFI.createGenericValueOfPointer . castStablePtrToPtr+ fromGeneric val =+ unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $+ FFI.genericValueToPointer
+ private/LLVM/ExecutionEngine/Marshal.hs view
@@ -0,0 +1,455 @@+module LLVM.ExecutionEngine.Marshal (+ Marshal(..),+ MarshalVector(..),+ sizeOf,+ alignment,+ StructFields,+ sizeOfArray,+ pokeList,++ with,+ alloca,++ Stored(..),+ castToStoredPtr,+ castFromStoredPtr,++ -- * for testing+ expandBits,+ gatherBits,+ adjustSign,+ chop,+ cut,+ split,+ merge,+ ) where++import qualified LLVM.Core.Vector as Vector ()+import qualified LLVM.Core.Data as Data+import qualified LLVM.Core.Type as Type+import qualified LLVM.Core.Proxy as LP+import qualified LLVM.ExecutionEngine.Target as Target+import LLVM.ExecutionEngine.Target (TargetData)+import LLVM.Core.Data (Ptr)++import qualified LLVM.Target.Native as Native+import qualified LLVM.FFI.Core as FFI++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy))++import qualified Foreign.Storable as Store+import qualified Foreign+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (FunPtr)++import System.IO.Unsafe (unsafePerformIO)++import qualified Control.Monad.Trans.State as MS+import Control.Applicative (liftA2, pure, (<$>))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.List.HT as ListHT+import Data.Bits (shiftL, shiftR, testBit, (.&.))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)++++targetData :: TargetData+targetData =+ unsafePerformIO $ Native.initializeNativeTarget >> Target.getTargetData+++sizeOf :: (Type.IsType a) => LP.Proxy a -> Int+sizeOf = Target.storeSizeOfType targetData . Type.unsafeTypeRef++alignment :: (Type.IsType a) => LP.Proxy a -> Int+alignment = Target.abiAlignmentOfType targetData . Type.unsafeTypeRef++sizeOfArray :: (Type.IsType a) => LP.Proxy a -> Int -> Int+sizeOfArray proxy n =+ Target.abiSizeOfType targetData (Type.unsafeTypeRef proxy) * n+++{- |+Exchange data via memory in a format that is compatible with LLVM's data layout.+Prominent differences to 'Foreign.Storable' are:++* LLVM's @i1@ requires a byte in memory,+ whereas Haskell's 'Bool' occupies a 32-bit word with 'Foreign.poke'.++* LLVM's @<4 x i8>@ orders vector elements depending on machine endianess,+ whereas 'Foreign.poke' uses ascending order+ which is compatible with arrays.++This class also supports 'Data.Struct', 'Data.Vector', 'Data.Array'.+-}+class (Type.IsType a) => Marshal a where+ peek :: Ptr a -> IO a+ poke :: Ptr a -> a -> IO ()++peekPrimitive :: (Type.Storable a) => Ptr a -> IO a+peekPrimitive = Store.peek . Type.toPtr++pokePrimitive :: (Type.Storable a) => Ptr a -> a -> IO ()+pokePrimitive = Store.poke . Type.toPtr++instance Marshal Float where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Double where+ peek = peekPrimitive; poke = pokePrimitive++instance Marshal Int where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int8 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int16 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int32 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Int64 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word8 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word16 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word32 where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal Word64 where+ peek = peekPrimitive; poke = pokePrimitive+instance (Store.Storable a) => Marshal (Foreign.Ptr a) where+ peek = peekPrimitive; poke = pokePrimitive+instance (Type.IsType a) => Marshal (Ptr a) where+ peek = peekPrimitive; poke = pokePrimitive+instance (Type.IsFunction a) => Marshal (FunPtr a) where+ peek = peekPrimitive; poke = pokePrimitive+instance Marshal (StablePtr a) where+ peek = peekPrimitive; poke = pokePrimitive++instance (Type.Positive d) => Marshal (Data.WordN d) where+ peek ptr =+ fmap (Data.WordN . merge 8 . map toInteger . word8s) $+ peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)+ poke ptr (Data.WordN a) =+ pokeVectorGen ptr . word8s . map fromInteger .+ take (sizeOf (proxyFromPtr ptr)) . split 8 $ a++instance (Type.Positive d) => Marshal (Data.IntN d) where+ peek ptr =+ fmap (consIntN Proxy . merge 8 . map toInteger . word8s) $+ peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)+ poke ptr a =+ pokeVectorGen ptr . word8s . map fromInteger .+ take (sizeOf (proxyFromPtr ptr)) . split 8 $ deconsIntN Proxy a++cut :: Int -> Integer -> Integer+cut n w = (shiftL 1 n - 1) .&. w++split :: Int -> Integer -> [Integer]+split n = map (cut n) . iterate (flip shiftR n)++merge :: Int -> [Integer] -> Integer+merge m xs = sum $ zipWith shiftL xs $ iterate (m+) 0++instance Marshal Bool where+ peek = fmap (/= 0) . Store.peek . castBoolPtr+ poke ptr a = Store.poke (castBoolPtr ptr) (fromIntegral $ fromEnum a)++castBoolPtr :: Ptr Bool -> Foreign.Ptr Word8+castBoolPtr = Foreign.castPtr . Data.uncheckedToPtr++instance+ (Type.Natural n, Marshal a, Type.IsSized a) =>+ Marshal (Data.Array n a) where+ peek = peekArray Proxy LP.Proxy+ poke = pokeArray Fold.toList++peekArray ::+ (Type.Natural n, Marshal a) =>+ Proxy n -> LP.Proxy a ->+ Ptr (Data.Array n a) -> IO (Data.Array n a)+peekArray n proxy =+ let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+ in \ptr ->+ fmap Data.Array $ mapM peek $+ take (Dec.integralFromProxy n) $+ iterate (flip plusPtr step) (castElemPtr ptr)++pokeArray :: (Marshal a) => (f a -> [a]) -> Ptr (f a) -> f a -> IO ()+pokeArray toList ptr = pokeList (castElemPtr ptr) . toList++pokeList :: (Marshal a) => Ptr a -> [a] -> IO ()+pokeList = pokeListAux LP.Proxy++pokeListAux :: (Marshal a) => LP.Proxy a -> Ptr a -> [a] -> IO ()+pokeListAux proxy =+ let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy+ in \ptr -> sequence_ . zipWith poke (iterate (flip plusPtr step) ptr)++castElemPtr :: Ptr (f a) -> Ptr a+castElemPtr = Data.uncheckedFromPtr . Foreign.castPtr . Data.uncheckedToPtr+++instance+ (Type.Positive n, MarshalVector a) =>+ Marshal (Data.Vector n a) where+ peek = peekVector+ poke = pokeVector++class (Type.IsPrimitive a) => MarshalVector a where+ peekVector ::+ (Type.Positive n) =>+ Ptr (Data.Vector n a) -> IO (Data.Vector n a)+ pokeVector ::+ (Type.Positive n) =>+ Ptr (Data.Vector n a) -> Data.Vector n a -> IO ()++instance MarshalVector Bool where+ peekVector ptr =+ fmap (vectorFromList . expandBits) $+ peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)+ pokeVector ptr = pokeVectorGen ptr . gatherBits . Fold.toList++expandBits :: [Word8] -> [Bool]+expandBits = concatMap (\byte -> map (testBit byte) [0..7])++vectorFromList :: (Type.Positive n) => [a] -> Data.Vector n a+vectorFromList =+ MS.evalState $ Trav.sequence $ pure $ MS.state $ \(y:ys) -> (y,ys)++gatherBits :: [Bool] -> [Word8]+gatherBits =+ map (sum . zipWith (flip shiftL) [0..] . map (fromIntegral . fromEnum)) .+ ListHT.sliceVertical 8+++instance (Type.Positive d) => MarshalVector (Data.WordN d) where+ peekVector ptr = fmap Data.WordN <$> peekNVector Proxy ptr+ pokeVector ptr = pokeNVector Proxy ptr . fmap (\(Data.WordN x) -> x)++instance (Type.Positive d) => MarshalVector (Data.IntN d) where+ peekVector ptr = fmap (consIntN Proxy) <$> peekNVector Proxy ptr+ pokeVector ptr = pokeNVector Proxy ptr . fmap (deconsIntN Proxy)++consIntN :: (Type.Positive d) => Proxy d -> Integer -> Data.IntN d+consIntN proxy = Data.IntN . adjustSign (Dec.integralFromProxy proxy)++deconsIntN :: (Type.Positive d) => Proxy d -> Data.IntN d -> Integer+deconsIntN proxy (Data.IntN a) = cut (Dec.integralFromProxy proxy) a++adjustSign :: Int -> Integer -> Integer+adjustSign d =+ let range = shiftL 1 d+ in \a -> if a < div range 2 then a else a-range++peekNVector ::+ (Type.Positive n, Type.Positive d, Type.IsPrimitive (intn d)) =>+ Proxy d -> Ptr (Data.Vector n (intn d)) -> IO (Data.Vector n Integer)+peekNVector proxy ptr =+ fmap (vectorFromList . chop 8 (Dec.integralFromProxy proxy) .+ map toInteger . word8s) $+ peekVectorGen ptr $ sizeOf (proxyFromPtr ptr)++pokeNVector ::+ (Type.Positive n, Type.Positive d, Type.IsPrimitive (intn d)) =>+ Proxy d ->+ Ptr (Data.Vector n (intn d)) -> Data.Vector n Integer -> IO ()+pokeNVector proxy ptr =+ pokeVectorGen ptr . take (sizeOf (proxyFromPtr ptr)) . word8s .+ map fromInteger . chop (Dec.integralFromProxy proxy) 8 . Fold.toList++word8s :: [Word8] -> [Word8]+word8s = id++proxyFromPtr :: Ptr a -> LP.Proxy a+proxyFromPtr _ = LP.Proxy++chop :: Int -> Int -> [Integer] -> [Integer]+chop m n =+ concat . snd .+ Trav.mapAccumL+ (\(valid,acc) x ->+ let newAcc = acc + cut n (shiftL x valid)+ nextValid = valid+m+ in if nextValid<n+ then ((nextValid, newAcc), [])+ else+ case divMod nextValid n of+ (chunks,remd) ->+ ((remd, shiftR x (m-remd)),+ (newAcc :) $+ map (cut n . shiftR x) $+ take (chunks-1) $ iterate (n+) (n-valid)))+ (0,0) .+ (++ repeat 0)+++instance MarshalVector Float where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Double where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word8 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word16 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word32 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Word64 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int8 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int16 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int32 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList++instance MarshalVector Int64 where+ peekVector = peekVectorAuto Proxy+ pokeVector ptr = pokeVectorGen ptr . Fold.toList+++peekVectorAuto ::+ (Type.Positive n, Type.IsPrimitive a, Store.Storable a) =>+ Proxy n -> Ptr (Data.Vector n a) -> IO (Data.Vector n a)+peekVectorAuto proxy ptr =+ fmap vectorFromList $ peekVectorGen ptr $ Dec.integralFromProxy proxy++peekVectorGen ::+ (Type.IsType b, Store.Storable chunk) =>+ Ptr b -> Int -> IO [chunk]+peekVectorGen = peekVectorAux LP.Proxy (error "vector")++peekVectorAux ::+ (Type.IsType b, Store.Storable chunk) =>+ LP.Proxy b -> chunk -> Ptr b -> Int -> IO [chunk]+peekVectorAux proxy dummyChunk =+ let (offset,step) = arrayParams proxy dummyChunk+ in \ptr n ->+ mapM (Store.peekByteOff (Data.uncheckedToPtr ptr)) $+ take n $ iterate (step+) offset++pokeVectorGen ::+ (Type.IsType b, Store.Storable chunk) =>+ Ptr b -> [chunk] -> IO ()+pokeVectorGen = pokeVectorAux LP.Proxy (error "vector")++pokeVectorAux ::+ (Type.IsType b, Store.Storable chunk) =>+ LP.Proxy b -> chunk -> Ptr b -> [chunk] -> IO ()+pokeVectorAux proxy dummyChunk =+ let (offset,step) = arrayParams proxy dummyChunk+ in \ptr xs ->+ sequence_ $+ zipWith (Store.pokeByteOff (Data.uncheckedToPtr ptr))+ (iterate (step+) offset) xs++arrayParams ::+ (Type.IsType b, Store.Storable chunk) =>+ LP.Proxy b -> chunk -> (Int,Int)+arrayParams proxy dummyChunk =+ let chunkSize = Store.sizeOf dummyChunk+ in if Target.littleEndian targetData+ then (0, chunkSize)+ else (sizeOf proxy - chunkSize, -chunkSize)+++instance (StructFields fields) => Marshal (Data.Struct fields) where+ peek = withPtrProxy $ \proxy ->+ let typeRef = Type.unsafeTypeRef proxy+ in fmap Data.Struct . peekStruct typeRef 0+ poke = withPtrProxy $ \proxy ->+ let typeRef = Type.unsafeTypeRef proxy+ pokePlain = pokeStruct typeRef 0+ in \ptr (Data.Struct as) -> pokePlain ptr as++withPtrProxy :: (LP.Proxy a -> Ptr a -> b) -> Ptr a -> b+withPtrProxy act = act LP.Proxy++class (Type.StructFields fields) => StructFields fields where+ peekStruct :: FFI.TypeRef -> Int -> Ptr struct -> IO fields+ pokeStruct :: FFI.TypeRef -> Int -> Ptr struct -> fields -> IO ()++instance+ (Marshal a, Type.IsSized a, StructFields as) =>+ StructFields (a,as) where+ peekStruct typeRef i =+ let offset = Target.offsetOfElement targetData typeRef i+ peekIs = peekStruct typeRef (i+1)+ in \ptr -> liftA2 (,) (peek $ plusPtr ptr offset) (peekIs ptr)+ pokeStruct typeRef i =+ let offset = Target.offsetOfElement targetData typeRef i+ pokeIs = pokeStruct typeRef (i+1)+ in \ptr (a,as) -> poke (plusPtr ptr offset) a >> pokeIs ptr as++instance StructFields () where+ peekStruct _type _i _ptr = return ()+ pokeStruct _type _i _ptr () = return ()++plusPtr :: Ptr a -> Int -> Ptr b+plusPtr ptr offset =+ Data.uncheckedFromPtr $ Foreign.plusPtr (Data.uncheckedToPtr ptr) offset+++with :: (Marshal a) => a -> (Ptr a -> IO b) -> IO b+with a act = alloca $ \ptr -> poke ptr a >> act ptr++alloca :: (Type.IsType a) => (Ptr a -> IO b) -> IO b+alloca = allocaAux LP.Proxy++allocaAux :: (Type.IsType a) => LP.Proxy a -> (Ptr a -> IO b) -> IO b+allocaAux proxy f =+ Foreign.allocaBytes (sizeOf proxy) (f . Data.uncheckedFromPtr)+++{- |+Provide @Marshal@ functionality through Haskell's 'Storable' interface.+Thus, @'Ptr' a@ is equivalent to @'Foreign.Ptr' ('Stored' a)@.+You may e.g. use a @'Foreign.ForeignPtr' ('Stored' a)@+to manage LLVM data with Haskell's garbage collector.+-}+newtype Stored a = Stored {getStored :: a}++castToStoredPtr :: Ptr a -> Foreign.Ptr (Stored a)+castToStoredPtr = Foreign.castPtr . Data.uncheckedToPtr++castFromStoredPtr :: Foreign.Ptr (Stored a) -> Ptr a+castFromStoredPtr = Data.uncheckedFromPtr . Foreign.castPtr+++instance (Marshal a) => Store.Storable (Stored a) where+ sizeOf = sizeOf . proxyFromStored+ alignment = alignment . proxyFromStored+ peek = fmap Stored . peek . castFromStoredPtr+ poke ptr = poke (castFromStoredPtr ptr) . getStored++proxyFromStored :: Stored a -> LP.Proxy a+proxyFromStored _ = LP.Proxy
+ private/LLVM/ExecutionEngine/Target.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+module LLVM.ExecutionEngine.Target (+ TargetData,+ dataLayoutStr,+ abiAlignmentOfType,+ abiSizeOfType,+ littleEndian,+ callFrameAlignmentOfType,+ intPtrType,+ offsetOfElement,+ pointerSize,+ preferredAlignmentOfType,+ sizeOfTypeInBits,+ storeSizeOfType,+ getTargetData,+ targetDataFromString,+ withIntPtrType,+ ) where++import qualified LLVM.ExecutionEngine.Engine as EE+import LLVM.Core.Data (WordN)++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.Target as FFI++import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy)++import Foreign.ForeignPtr+ (ForeignPtr,+ newForeignPtr, withForeignPtr, touchForeignPtr, castForeignPtr)+import Foreign.C.String (withCString, peekCString)++import Control.Monad (liftM2, (<=<))+import Control.Applicative ((<$>))+import Data.Maybe (fromMaybe)+import System.IO.Unsafe (unsafePerformIO)+++type Type = FFI.TypeRef++data TargetDataOwner++data TargetData = TargetData (ForeignPtr TargetDataOwner) FFI.TargetDataRef++dataLayoutStr :: TargetData -> String+dataLayoutStr td = unsafeIO td $ peekCString <=< FFI.copyStringRepOfTargetData++abiAlignmentOfType :: TargetData -> Type -> Int+abiAlignmentOfType td = unsafeIntIO td . flip FFI.abiAlignmentOfType++abiSizeOfType :: TargetData -> Type -> Int+abiSizeOfType td = unsafeIntIO td . flip FFI.abiSizeOfType++littleEndian :: TargetData -> Bool+littleEndian td = FFI.bigEndian /= unsafeIO td FFI.byteOrder++callFrameAlignmentOfType :: TargetData -> Type -> Int+callFrameAlignmentOfType td = unsafeIntIO td . flip FFI.callFrameAlignmentOfType++-- elementAtOffset :: TargetData -> Type -> Word64 -> Int++intPtrType :: TargetData -> Type+intPtrType td = unsafeIO td FFI.intPtrType++offsetOfElement :: TargetData -> Type -> Int -> Int+offsetOfElement td ty k =+ unsafeIntIO td $ \r -> FFI.offsetOfElement r ty (fromIntegral k)++pointerSize :: TargetData -> Int+pointerSize td = unsafeIntIO td FFI.pointerSize++-- preferredAlignmentOfGlobal :: TargetData -> Value a -> Int++preferredAlignmentOfType :: TargetData -> Type -> Int+preferredAlignmentOfType td = unsafeIntIO td . flip FFI.preferredAlignmentOfType++sizeOfTypeInBits :: TargetData -> Type -> Int+sizeOfTypeInBits td = unsafeIntIO td . flip FFI.sizeOfTypeInBits++storeSizeOfType :: TargetData -> Type -> Int+storeSizeOfType td = unsafeIntIO td . flip FFI.storeSizeOfType+++withIntPtrType :: (forall n . (Dec.Positive n) => WordN n -> a) -> a+withIntPtrType f =+ fromMaybe (error "withIntPtrType: pointer size must be non-negative") $+ Dec.reifyPositive (fromIntegral sz) (\ n -> f (g n))+ where g :: Proxy n -> WordN n+ g _ = error "withIntPtrType: argument used"+ sz = pointerSize $ unsafePerformIO getTargetData+++unsafeIO :: TargetData -> (FFI.TargetDataRef -> IO a) -> a+unsafeIO (TargetData fptr td) act =+ unsafePerformIO $ do x <- act td; touchForeignPtr fptr; return x++unsafeIntIO ::+ (Integral i, Num j) => TargetData -> (FFI.TargetDataRef -> IO i) -> j+unsafeIntIO td act = fromIntegral $ unsafeIO td act++-- Normally the TargetDataRef never changes,+-- so the operation are really functions.+-- The ForeignPtr can point to TargetData or to ExecutionEngine.+makeTargetData :: ForeignPtr a -> FFI.TargetDataRef -> TargetData+makeTargetData = TargetData . castForeignPtr++-- Gets the target data for the JIT target.+getTargetData :: IO TargetData+getTargetData =+ EE.runEngineAccess $+ liftM2 makeTargetData+ (EE.fromEngine <$> EE.getEngine)+ EE.getExecutionEngineTargetData++createTargetData :: String -> IO (ForeignPtr FFI.TargetData)+createTargetData s =+ newForeignPtr FFI.ptrDisposeTargetData =<<+ withCString s FFI.createTargetData++targetDataFromString :: String -> TargetData+targetDataFromString s = unsafePerformIO $ do+ td <- createTargetData s+ withForeignPtr td $ return . makeTargetData td
src/LLVM/Core.hs view
@@ -31,7 +31,9 @@ Target.initializeNativeTarget, -- * Modules Module, newModule, newNamedModule, defineModule, destroyModule, createModule,+ getModule, setTarget, FFI.hostTriple,+ setDataLayout, PassManager, createPassManager, createFunctionPassManager, writeBitcodeToFile, readBitcodeFromFile, getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue,@@ -51,11 +53,12 @@ constVector, constArray, constCyclicVector, constCyclicArray, constStruct, constPackedStruct,- toVector, fromVector, vector, cyclicVector,+ toVector, fromVector, vector, cyclicVector, consVector, -- * Code generation CodeGenFunction, CodeGenModule, -- * Functions- Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,+ Function, newFunction, newNamedFunction, defineFunction,+ createFunction, createNamedFunction, setFuncCallConv, functionParameter, TFunction, liftCodeGenModule, getParams, -- * Global variable creation Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal,@@ -83,7 +86,7 @@ import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) import LLVM.Core.CodeGen import LLVM.Core.CodeGenMonad- (CodeGenFunction, CodeGenModule, liftCodeGenModule,+ (CodeGenFunction, CodeGenModule, liftCodeGenModule, getModule, GlobalMappings, getGlobalMappings) import LLVM.Core.Data import LLVM.Core.Instructions
− src/LLVM/Core/CodeGen.hs
@@ -1,681 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module LLVM.Core.CodeGen(- -- * Module creation- newModule, newNamedModule, defineModule, createModule,- getModuleValues, ModuleValue, castModuleValue, setTarget,- -- * Globals- Linkage(..),- Visibility(..),- -- * Function creation- Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,- addAttributes,- FFI.AttributeIndex(..), Attribute(..),- externFunction, staticFunction, staticNamedFunction,- FunctionArgs, FunctionCodeGen, FunctionResult,- TFunction,- -- * Global variable creation- Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal,- externGlobal, staticGlobal,- -- * Values- Value(..), ConstValue(..),- IsConst(..), valueOf, value,- IsConstFields,- zero, allOnes, undef,- createString, createStringNul,- withString, withStringNul,- constVector, constArray, constStruct, constPackedStruct,- constCyclicVector, constCyclicArray,- -- * Basic blocks- BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,- fromLabel, toLabel,- -- * Misc- 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--import qualified LLVM.FFI.Core.Attribute as Attr-import qualified LLVM.FFI.Core as FFI-import LLVM.FFI.Core(Linkage(..), Visibility(..))--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.C.String (withCString, withCStringLen)-import Foreign.StablePtr (StablePtr, castStablePtrToPtr)-import Foreign.Ptr (Ptr, minusPtr, nullPtr, FunPtr, castFunPtrToPtr)-import System.IO.Unsafe (unsafePerformIO)--import Control.Monad.IO.Class (liftIO)-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.Tuple.HT (mapSnd)-import Data.Maybe.HT (toMaybe)-import Data.Maybe (fromMaybe)--import Text.Printf (printf)-------------------------------------------- | Create a new module.-newModule :: IO U.Module-newModule = newNamedModule "_module" -- XXX should generate a name---- | Create a new explicitely named module.-newNamedModule :: String -- ^ module name- -> IO U.Module-newNamedModule = U.createModule---- | Give the body for a module.-defineModule :: U.Module -- ^ module that is defined- -> CodeGenModule a -- ^ module body- -> IO a-defineModule = runCodeGenModule---- | Create a new module with the given body.-createModule :: CodeGenModule a -- ^ module body- -> IO a-createModule cgm = newModule >>= \ m -> defineModule m cgm--setTarget :: String -> CodeGenModule ()-setTarget triple = do- modul <- getModule- liftIO $ U.withModule modul $ \m -> withCString triple $ FFI.setTarget m-------------------------------------------newtype ModuleValue = ModuleValue FFI.ValueRef- deriving (Show, Typeable)--getModuleValues :: U.Module -> IO [(String, ModuleValue)]-getModuleValues =- liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues--castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a)-castModuleValue (ModuleValue f) =- toMaybe (U.valueHasType f (unsafeTypeRef (LP.Proxy :: LP.Proxy a))) (Value f)------------------------------------------newtype Value a = Value { unValue :: FFI.ValueRef }- deriving (Show, Typeable)--newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef }- deriving (Show, Typeable)---- XXX merge with IsArithmetic?-class IsConst a where- constOf :: a -> ConstValue a--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-instance IsConst Word32 where constOf = constI-instance IsConst Word64 where constOf = constI-instance IsConst Int8 where constOf = constI-instance IsConst Int16 where constOf = constI-instance IsConst Int32 where constOf = constI-instance IsConst Int64 where constOf = constI-instance IsConst Float where constOf = constF-instance IsConst Double where constOf = constF---instance IsConst FP128 where constOf = constF--instance (Dec.Positive n) => IsConst (WordN n) where- constOf (WordN i) = constInteger i-instance (Dec.Positive n) => IsConst (IntN n) where- constOf (IntN i) = constInteger i--constOfPtr :: (IsType ptr) =>- ptr -> Ptr b -> ConstValue ptr-constOfPtr proto p =- let ip = p `minusPtr` nullPtr- inttoptrC :: ConstValue int -> ConstValue ptr- 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- inttoptrC $ constOf (fromIntegral ip :: Word64)- else- error "constOf Ptr: pointer size not 4 or 8"---- This instance doesn't belong here, but mutually recursive modules are painful.-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, Dec.Positive n) => IsConst (Vector n a) where- constOf (Vector x) = constVectorGen constOf x--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) =- unsafeConstValue $ U.constStruct (constFieldsOf a) False-instance (IsConstFields a) => IsConst (PackedStruct a) where- constOf (PackedStruct a) =- unsafeConstValue $ U.constStruct (constFieldsOf a) True--class IsConstFields a where- constFieldsOf :: a -> [FFI.ValueRef]--instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where- constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as-instance IsConstFields () where- constFieldsOf _ = []---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) FFI.false--{--ToDo:-Passes a BigInt as decimal number string.-Not very efficient but quite generic.-Maybe Hex is better?--}-constInteger :: (IsType (intN n)) => Integer -> ConstValue (intN n)-constInteger i =- unsafeWithConstValue $ \typ ->- withCString (show i) $ \cstr ->- FFI.constIntOfString typ cstr 10--constI :: (IsInteger a, Integral a) => a -> ConstValue a-constI i =- unsafeWithConstValue $ \typ ->- FFI.constInt typ (fromIntegral i) (FFI.consBool $ isSigned $ LP.fromValue i)--constF :: (IsFloating a, Real a) => a -> ConstValue a-constF i =- unsafeWithConstValue $ \typ -> FFI.constReal typ (realToFrac i)--valueOf :: (IsConst a) => a -> Value a-valueOf = value . constOf--value :: ConstValue a -> Value a-value (ConstValue a) = Value a--zero :: forall a . (IsType a) => ConstValue a-zero = unsafeWithConstValue FFI.constNull--allOnes :: forall a . (IsInteger a) => ConstValue a-allOnes = unsafeWithConstValue FFI.constAllOnes--undef :: forall a . (IsType a) => ConstValue a-undef = unsafeWithConstValue FFI.getUndef--{--createString :: String -> ConstValue (DynamicArray Word8)-createString = ConstValue . U.constString--constStringNul :: String -> ConstValue (DynamicArray Word8)-constStringNul = ConstValue . U.constStringNul--}--------------------------------------------- |A function is simply a pointer to the function.-type Function a = Value (FunPtr a)---- | Create a new named function.-newNamedFunction :: forall a . (IsFunction a)- => Linkage- -> String -- ^ Function name- -> CodeGenModule (Function a)-newNamedFunction linkage name = do- modul <- getModule- 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--- it needs a known name.-newFunction :: forall a . (IsFunction a)- => Linkage- -> CodeGenModule (Function a)-newFunction linkage = genMSym "fun" >>= newNamedFunction linkage--defineFunctionParam ::- Function f -- ^ Function to define (created by 'newFunction').- -> Parameterized r f -- ^ Function body.- -> CodeGenModule ()-defineFunctionParam fn p = do- bld <- liftIO $ U.createBuilder- let body' = do- newBasicBlock >>= defineBasicBlock- defineParameterized fn p- runCodeGenFunction bld (unValue fn) body'---- | Define a function body. The basic block returned by the function is the function entry point.-defineFunction :: forall f . (FunctionArgs f)- => Function f -- ^ Function to define (created by 'newFunction').- -> FunctionCodeGen f -- ^ Function body.- -> CodeGenModule ()-defineFunction fn body =- defineFunctionParam fn $ paramFunc body---- | Create a new function with the given body.-createFunction :: (FunctionArgs f)- => Linkage- -> FunctionCodeGen f -- ^ Function body.- -> CodeGenModule (Function f)-createFunction linkage body = do- f <- newFunction linkage- defineFunction f body- return f---- | Create a new function with the given body.-createNamedFunction :: (FunctionArgs f)- => Linkage- -> String- -> FunctionCodeGen f -- ^ Function body.- -> CodeGenModule (Function f)-createNamedFunction linkage name body = do- f <- newNamedFunction linkage name- defineFunction f body- return f---- | Set the calling convention of a function. By default it is the--- C calling convention.-setFuncCallConv :: Function a- -> FFI.CallingConvention- -> CodeGenModule ()-setFuncCallConv (Value f) cc = do- liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc)--data Attribute = Attribute Attr.Name Word64---- | Add attributes to a value. Beware, what attributes are allowed depends on--- what kind of value it is.-addAttributes ::- Value a -> FFI.AttributeIndex -> [Attribute] -> CodeGenFunction r ()-addAttributes (Value f) i as =- liftIO $ do- context <- FFI.getGlobalContext- Fold.forM_ as $ \(Attribute (Attr.Name name) val) -> do- attrKind <-- withCStringLen name $- uncurry FFI.getEnumAttributeKindForName .- mapSnd fromIntegral- attr <- FFI.createEnumAttribute context attrKind val- FFI.addCallSiteAttribute f i attr---- Convert a function of type f = t1->t2->...-> IO r to--- g = Value t1 -> Value t2 -> ... CodeGenFunction r ()-class IsFunction f => FunctionArgs f where- type FunctionCodeGen f :: *- type FunctionResult f :: *- paramFunc :: FunctionCodeGen f -> Parameterized (FunctionResult f) f--instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where- type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b- type FunctionResult (a -> b) = FunctionResult b- paramFunc f = param $ \x -> paramFunc (f x)--instance IsFirstClass a => FunctionArgs (IO a) where- type FunctionCodeGen (IO a) = CodeGenFunction a ()- type FunctionResult (IO a) = a- paramFunc = parameterized---newtype- Parameterized r f =- Parameterized (Int -> FFI.ValueRef -> CodeGenFunction r ())--parameterized :: CodeGenFunction r () -> Parameterized r (IO r)-parameterized code = Parameterized (const $ const code)--param :: (Value a -> Parameterized r b) -> Parameterized r (a -> b)-param pf =- Parameterized $ \n f ->- case pf $ Value $ U.getParam f n of- Parameterized p -> p (n+1) f--defineParameterized :: Function f -> Parameterized r f -> CodeGenFunction r ()-defineParameterized f (Parameterized p) = p 0 $ unValue f--------------------------------------------- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction.-newtype BasicBlock = BasicBlock FFI.BasicBlockRef- deriving (Show, Typeable)--createBasicBlock :: CodeGenFunction r BasicBlock-createBasicBlock = do- b <- newBasicBlock- defineBasicBlock b- return b--newBasicBlock :: CodeGenFunction r BasicBlock-newBasicBlock = genFSym >>= newNamedBasicBlock--newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock-newNamedBasicBlock name = do- fn <- getFunction- liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name--defineBasicBlock :: BasicBlock -> CodeGenFunction r ()-defineBasicBlock (BasicBlock l) = do- bld <- getBuilder- liftIO $ U.positionAtEnd bld l--getCurrentBasicBlock :: CodeGenFunction r BasicBlock-getCurrentBasicBlock = do- bld <- getBuilder- liftIO $ liftM BasicBlock $ U.getInsertBlock bld--toLabel :: BasicBlock -> Value Label-toLabel (BasicBlock ptr) =- Value (unsafePerformIO $ FFI.basicBlockAsValue ptr)--fromLabel :: Value Label -> BasicBlock-fromLabel (Value ptr) =- BasicBlock (unsafePerformIO $ FFI.valueAsBasicBlock ptr)--------------------------------------------- XXX: the functions in this section (and addGlobalMapping) don't actually use any--- Function state so should really be in the CodeGenModule monad---- | 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---- | 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--externCore ::- String -> (String -> CodeGenModule FFI.ValueRef) ->- CodeGenFunction r (Value ptr)-externCore name act = do- es <- getExterns- case lookup name es of- Just f -> return $ Value f- Nothing -> do- f <- liftCodeGenModule $ act name- putExterns ((name, f) : es)- return $ Value f--{- |-Make an external C function with a fixed address callable from LLVM code.-This callback function can also be a Haskell function,-that was imported like--> foreign import ccall "&nextElement"-> nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)--See @examples\/List.hs@.--When you only use 'externFunction', then LLVM cannot resolve the name.-(However, I do not know why.)-Thus 'staticFunction' manages a list of static functions.-This list is automatically installed by 'ExecutionEngine.simpleFunction'-and can be manually obtained by 'getGlobalMappings'-and installed by 'ExecutionEngine.addGlobalMappings'.-\"Installing\" means calling LLVM's @addGlobalMapping@ according to-<http://old.nabble.com/jit-with-external-functions-td7769793.html>.--}-staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f)-staticFunction = staticNamedFunction ""--{- |-Due to <https://llvm.org/bugs/show_bug.cgi?id=20656>-this will fail with MCJIT of LLVM-3.6.--}-staticNamedFunction :: forall f r. (IsFunction f) => String -> FunPtr f -> CodeGenFunction r (Function f)-staticNamedFunction name func = liftCodeGenModule $ do- val <- newNamedFunction ExternalLinkage name- 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)) gbl- return val------------------------------------------withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a-withCurrentBuilder body = do- bld <- getBuilder- liftIO $ U.withBuilder bld body-------------------------------------------- Mark all block terminating instructions. Not used yet.---data Terminate = Terminate------------------------------------------type Global a = Value (Ptr a)---- | Create a new named global variable.-newNamedGlobal :: forall a . (IsType a)- => Bool -- ^Constant?- -> Linkage -- ^Visibility- -> String -- ^Name- -> TGlobal a-newNamedGlobal isConst linkage name = do- modul <- getModule- typ <- liftIO $ typeRef (LP.Proxy :: LP.Proxy a)- liftIO $ liftM Value $ do- g <- U.addGlobal modul linkage name typ- when isConst $ FFI.setGlobalConstant g FFI.true- return g---- | Create a new global variable.-newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a-newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage---- | Give a global variable a (constant) value.-defineGlobal :: Global a -> ConstValue a -> CodeGenModule ()-defineGlobal (Value g) (ConstValue v) =- liftIO $ FFI.setInitializer g v---- | Create and define a global variable.-createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a-createGlobal isConst linkage con = do- g <- newGlobal isConst linkage- defineGlobal g con- return g---- | Create and define a named global variable.-createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a-createNamedGlobal isConst linkage name con = do- g <- newNamedGlobal isConst linkage name- defineGlobal g con- return g--type TFunction a = CodeGenModule (Function a)-type TGlobal a = CodeGenModule (Global a)---- Special string creators-{-# DEPRECATED createString "use withString instead" #-}-createString :: String -> TGlobal (Array n Word8)-createString s = string (length s) (U.constString s)--{-# DEPRECATED createStringNul "use withStringNul instead" #-}-createStringNul :: String -> TGlobal (Array n Word8)-createStringNul s = string (length s + 1) (U.constStringNul s)--withString ::- String ->- (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") $- Dec.reifyNatural (fromIntegral n) (\tn ->- do arr <- string n (U.constString s)- act (fixArraySize tn arr))--withStringNul ::- String ->- (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") $- Dec.reifyNatural (fromIntegral n) (\tn ->- do arr <- string n (U.constStringNul s)- act (fixArraySize tn arr))--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"- 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 FFI.true- FFI.setInitializer g s- return g-------------------------------------------- |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--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.fromFixedList 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- let m = length xs- n = Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton n)- when (m /= n) $- error $- printf "LLVM.constArray: number of array elements (%d) mismatches typed array length (%d)"- m n- 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 struct =- unsafeConstValue $ U.constStruct (constValueFieldsOf struct) False---- |Make a constant packed struct.-constPackedStruct ::- (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c))-constPackedStruct struct =- unsafeConstValue $ U.constStruct (constValueFieldsOf struct) True--class IsConstStruct c where- type ConstStructOf c :: *- constValueFieldsOf :: c -> [FFI.ValueRef]--instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where- type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs)- constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as-instance IsConstStruct () where- type ConstStructOf () = ()- constValueFieldsOf _ = []
− src/LLVM/Core/CodeGenMonad.hs
@@ -1,181 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.Core.CodeGenMonad(- -- * Module code generation- CodeGenModule, runCodeGenModule, genMSym, getModule,- GlobalMappings(..), addGlobalMapping, getGlobalMappings,- addFunctionMapping,- -- * Function code generation- CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns,- ) where--import LLVM.Core.Util (Module, Builder, Function, getValueNameU, withModule, )--import qualified LLVM.FFI.Core as FFI-import qualified LLVM.FFI.ExecutionEngine as EE--import Foreign.C.String (withCString, )-import Foreign.Ptr (FunPtr, Ptr, nullPtr, )--import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, )-import Control.Monad.IO.Class (MonadIO, liftIO, )-import Control.Monad (when, )-import Control.Applicative (Applicative, )-import Data.Monoid (Monoid, mempty, mappend, )-import Data.Semigroup (Semigroup, (<>), )--import Data.Typeable (Typeable)------------------------------------------data CGMState = CGMState {- cgm_module :: Module,- cgm_externs :: [(String, Function)],- cgm_global_mappings :: GlobalMappings,- cgm_next :: !Int- }- deriving (Show, Typeable)-newtype CodeGenModule a = CGM (StateT CGMState IO a)- deriving (Functor, Applicative, Monad, MonadIO, Typeable)--genMSym :: String -> CodeGenModule String-genMSym prefix = do- s <- CGM get- let n = cgm_next s- CGM $ put (s { cgm_next = n + 1 })- return $ "_" ++ prefix ++ show n--getModule :: CodeGenModule Module-getModule = CGM $ gets cgm_module--runCodeGenModule :: Module -> CodeGenModule a -> IO a-runCodeGenModule m (CGM body) =- evalStateT body $- CGMState {- cgm_module = m, cgm_next = 1,- cgm_externs = [], cgm_global_mappings = mempty- }------------------------------------------data CGFState r = CGFState {- cgf_module :: CGMState,- cgf_builder :: Builder,- cgf_function :: Function,- cgf_next :: !Int- }- deriving (Show, Typeable)-newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)- deriving (Functor, Applicative, Monad, MonadIO, Typeable)--genFSym :: CodeGenFunction a String-genFSym = do- s <- CGF get- let n = cgf_next s- CGF $ put (s { cgf_next = n + 1 })- return $ "_L" ++ show n--getFunction :: CodeGenFunction a Function-getFunction = CGF $ gets cgf_function--getBuilder :: CodeGenFunction a Builder-getBuilder = CGF $ gets cgf_builder--getFunctionModule :: CodeGenFunction a Module-getFunctionModule = CGF $ gets (cgm_module . cgf_module)--getExterns :: CodeGenFunction a [(String, Function)]-getExterns = CGF $ gets (cgm_externs . cgf_module)--putExterns :: [(String, Function)] -> CodeGenFunction a ()-putExterns es = do- cgf <- CGF get- let cgm' = (cgf_module cgf) { cgm_externs = es }- CGF $ put (cgf { cgf_module = cgm' })---type Value = FFI.ValueRef--addGlobalMapping ::- Value -> Ptr a -> CodeGenModule ()-addGlobalMapping value func = CGM $ do- addMappingToState $- GlobalMappings (\ee -> EE.addGlobalMapping ee value func)--addFunctionMapping ::- Function -> FunPtr f -> CodeGenModule ()-addFunctionMapping value func = CGM $ do- {-- We need to fetch the name from the value- since it might have been disambiguized after adding.- -}- name <- liftIO $ getValueNameU value- modul <- gets cgm_module- addMappingToState $- GlobalMappings $ \ee -> do- {-- Between adding and application- the program may have been restructured by optimization passes.- I have not seen that the optimizer alters a Function Value pointer,- but the optimizer can remove an unused function.- That would render the original value invalid.- -}- currentValue <-- liftIO $- withCString name $ \cname ->- withModule modul $ \cmodule ->- FFI.getNamedFunction cmodule cname- -- the optimizer could have removed the function- when (currentValue/=nullPtr) $- EE.addFunctionMapping ee currentValue func--addMappingToState :: GlobalMappings -> StateT CGMState IO ()-addMappingToState gm =- modify $ \cgm ->- cgm { cgm_global_mappings = cgm_global_mappings cgm <> gm }--newtype GlobalMappings =- GlobalMappings (EE.ExecutionEngineRef -> IO ())--instance Show GlobalMappings where- show _ = "GlobalMappings"--instance Semigroup GlobalMappings where- GlobalMappings x <> GlobalMappings y =- GlobalMappings (\ee -> x ee >> y ee)--instance Monoid GlobalMappings where- mempty = GlobalMappings $ const $ return ()- mappend = (<>)---{- |-Get a list created by calls to 'staticFunction'-that must be passed to the execution engine-via 'LLVM.ExecutionEngine.addGlobalMappings'.--}-getGlobalMappings ::- CodeGenModule GlobalMappings-getGlobalMappings =- CGM $ gets cgm_global_mappings--runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a-runCodeGenFunction bld fn (CGF body) = do- cgm <- CGM get- let cgf = CGFState { cgf_module = cgm,- cgf_builder = bld,- cgf_function = fn,- cgf_next = 1 }- (a, cgf') <- liftIO $ runStateT body cgf- CGM $ put (cgf_module cgf')- return a-------------------------------------------- | Allows you to define part of a module while in the middle of defining a function.-liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a-liftCodeGenModule (CGM act) = do- cgf <- CGF get- (a, cgm') <- liftIO $ runStateT act (cgf_module cgf)- CGF $ put (cgf { cgf_module = cgm' })- return a
− src/LLVM/Core/Data.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-module LLVM.Core.Data (- IntN(..), WordN(..), FP128(..),- Array(..), Vector(..), Label, Struct(..), PackedStruct(..),- FixedList,- ) where--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 Type.Base.Proxy (Proxy(Proxy))--import qualified Data.Foldable as Fold-import qualified Data.Bits as Bits--import Data.Typeable (Typeable)----- TODO:--- Make instances IntN, WordN to actually do the right thing.--- Make FP128 do the right thing--- Make Array functions.---- |Variable sized signed integer.--- The /n/ parameter should belong to @PosI@.-newtype IntN n = IntN Integer- deriving (Show, Eq, Ord, Typeable)--instance (Dec.Positive n) => Bounded (IntN n) where- minBound =- withBitSize $- IntN . negate . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy- maxBound =- withBitSize $- IntN . subtract 1 . Bits.shiftL 1 . subtract 1 . Dec.integralFromProxy---- |Variable sized unsigned integer.--- The /n/ parameter should belong to @PosI@.-newtype WordN n = WordN Integer- deriving (Show, Eq, Ord, Typeable)--instance (Dec.Positive n) => Bounded (WordN n) where- minBound = WordN 0- maxBound =- withBitSize $ WordN . subtract 1 . Bits.shiftL 1 . Dec.integralFromProxy--withBitSize :: (Proxy n -> f n) -> f n-withBitSize f = f Proxy---- |128 bit floating point.-newtype FP128 = FP128 Rational- 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 (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.fromFixedList xs- :: UnaryVector.T (Dec.ToUnary n) a))---- |Label type, produced by a basic block.-data Label- deriving (Typeable)---- |Struct types; a list (nested tuple) of component types.-newtype Struct a = Struct a- deriving (Show, Typeable)-newtype PackedStruct a = PackedStruct a- deriving (Show, Typeable)
− src/LLVM/Core/Instructions.hs
@@ -1,1251 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module LLVM.Core.Instructions(- -- * ADT representation of IR- BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,- -- * Terminator instructions- ret,- condBr,- br,- switch,- invoke, invokeWithConv,- invokeFromFunction, invokeWithConvFromFunction,- unreachable,- -- * Arithmetic binary operations- -- | Arithmetic operations with the normal semantics.- -- The u instructions are unsigned, the s instructions are signed.- add, sub, mul, neg,- iadd, isub, imul, ineg,- iaddNoWrap, isubNoWrap, imulNoWrap, inegNoWrap,- fadd, fsub, fmul, fneg,- idiv, irem,- udiv, sdiv, fdiv, urem, srem, frem,- -- * Logical binary operations- -- |Logical instructions with the normal semantics.- shl, shr, lshr, ashr, and, or, xor, inv,- -- * Vector operations- extractelement,- insertelement,- shufflevector,- -- * Aggregate operation- extractvalue,- insertvalue,- -- * Memory access- malloc, arrayMalloc,- alloca, arrayAlloca,- free,- load,- store,- getElementPtr, getElementPtr0,- -- * Conversions- ValueCons,- trunc, zext, sext, ext, zadapt, sadapt, adapt,- fptrunc, fpext,- fptoui, fptosi, fptoint,- uitofp, sitofp, inttofp,- ptrtoint, inttoptr,- bitcast,- -- * Comparison- CmpPredicate(..), IntPredicate(..), FPPredicate(..),- CmpRet, CmpResult, CmpValueResult,- cmp, pcmp, icmp, fcmp,- select,- -- * Fast math- setHasNoNaNs,- setHasNoInfs,- setHasNoSignedZeros,- setHasAllowReciprocal,- setFastMath,- -- * Other- phi, addPhiInputs,- call, callWithConv,- callFromFunction, callWithConvFromFunction,- Call, applyCall, runCall,-- -- * Classes and types- ValueCons2, BinOpValue,- Terminate, Ret, CallArgs,- CodeGen.FunctionArgs, CodeGen.FunctionCodeGen, CodeGen.FunctionResult,- AllocArg,- GetElementPtr, ElementPtrType, IsIndexArg, IsIndexType,- GetValue, ValueType,- GetField, FieldType,- ) where--import qualified LLVM.Core.Util as U-import qualified LLVM.Util.Proxy as LP-import qualified LLVM.Core.CodeGen as CodeGen-import LLVM.Core.Instructions.Private- (ValueCons, unValue, convert, unop,- FFIBinOp, FFIConstBinOp,- GetField, FieldType, GetElementPtr, ElementPtrType,- IsIndexArg, IsIndexType, getIxList, getArg,- CmpPredicate(..),- uintFromCmpPredicate, sintFromCmpPredicate, fpFromCmpPredicate)-import LLVM.Core.Data-import LLVM.Core.Type-import LLVM.Core.CodeGenMonad-import LLVM.Core.CodeGen- (BasicBlock(BasicBlock), Function, withCurrentBuilder,- ConstValue(ConstValue), zero,- Value(Value), value, valueOf)--import qualified LLVM.FFI.Core as FFI-import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))--import qualified Type.Data.Num.Decimal.Number as Dec-import Type.Data.Num.Decimal.Literal (d1)-import Type.Data.Num.Decimal.Number ((:<:), (:>:))-import Type.Base.Proxy (Proxy)--import Foreign.Ptr (Ptr, FunPtr, )-import Foreign.C (CUInt, CInt)--import Control.Monad.IO.Class (liftIO)-import Control.Monad (liftM)--import qualified Data.Map as Map-import Data.Map (Map)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word8, Word16, Word32, Word64)--import Prelude hiding (and, or)----- TODO:--- Add vector version of arithmetic--- Add rest of instructions--- Use Terminate to ensure bb termination (how?)--- more intrinsics are needed to, e.g., create an empty vector--data ArgDesc = AV String | AI Int | AL String | AE--instance Show ArgDesc where- -- show (AV s) = "V_" ++ s- -- show (AI i) = "I_" ++ show i- -- show (AL l) = "L_" ++ l- show (AV s) = s- show (AI i) = show i- show (AL l) = l- show AE = "voidarg?"--data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd- | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub- | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul- | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem- | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor- deriving Show---- FIXME: complete definitions for unimplemented instructions-data InstrDesc =- -- terminators- IDRet TypeDesc ArgDesc | IDRetVoid- | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc- | IDSwitch [(ArgDesc, ArgDesc)]- | IDIndirectBr- | IDInvoke- | IDUnwind- | IDUnreachable- -- binary operators (including bitwise)- | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc- -- memory access and addressing- | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc- | IDGetElementPtr TypeDesc [ArgDesc]- -- conversion- | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc- | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc- | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc- | IDSItoFP TypeDesc TypeDesc ArgDesc- | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc- | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc- | IDBitcast TypeDesc TypeDesc ArgDesc- -- other- | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc- | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]- | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg- -- vector operators- | IDExtractElement | IDInsertElement | IDShuffleVector- -- aggregate operators- | IDExtractValue | IDInsertValue- -- invalid- | IDInvalidOp- deriving Show---- TODO: overflow support for binary operations (add/sub/mul)-getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)-getInstrDesc v = do- valueName <- U.getValueNameU v- opcode <- FFI.instGetOpcode v- t <- FFI.typeOf v >>= typeDesc2- -- FIXME: sizeof() does not work for types!- --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral- tsize <- return 1- ovs <- U.getOperands v- os <- mapM getArgDesc ovs- os0 <- return $ case os of {o:_ -> o; _ -> AE}- os1 <- return $ case os of {_:o:_ -> o; _ -> AE}- instr <-- case Map.lookup opcode binOpMap of -- binary arithmetic- Just op -> return $ IDBinOp op t os0 os1- Nothing ->- case Map.lookup opcode convOpMap of- Just op -> do- t2 <-- case ovs of- (_name,ov):_ -> FFI.typeOf ov >>= typeDesc2- _ -> return TDVoid- return $ op t2 t os0- Nothing ->- case opcode of- 1 -> return $ if null os then IDRetVoid else IDRet t os0- 2 -> return $ if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1- 3 -> return $ IDSwitch $ toPairs os- -- TODO (can skip for now)- -- 4 -> return IndirectBr ; 5 -> return Invoke- 6 -> return IDUnwind; 7 -> return IDUnreachable- 26 -> return $ IDAlloca (getPtrType t) tsize (getImmInt os0)- 27 -> return $ IDLoad t os0; 28 -> return $ IDStore t os0 os1- 29 -> return $ IDGetElementPtr t os- 42 -> do- pInt <- FFI.cmpInstGetIntPredicate v- return $ IDICmp (FFI.toIntPredicate pInt) os0 os1- 43 -> do- pFloat <- FFI.cmpInstGetRealPredicate v- return $ IDFCmp (FFI.toRealPredicate pFloat) os0 os1- 44 -> return $ IDPhi t $ toPairs os- -- FIXME: getelementptr arguments are not handled- 45 -> return $ IDCall t (last os) (init os)- 46 -> return $ IDSelect t os0 os1- -- TODO (can skip for now)- -- 47 -> return UserOp1 ; 48 -> return UserOp2 ; 49 -> return VAArg- -- 50 -> return ExtractElement ; 51 -> return InsertElement ; 52 -> return ShuffleVector- -- 53 -> return ExtractValue ; 54 -> return InsertValue- _ -> return IDInvalidOp- return (valueName, instr)- --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode- where toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))- stride _ [] = []- stride n (x:xs) = x : stride n (drop (n-1) xs)- getPtrType (TDPtr t) = t- getPtrType _ = TDVoid- getImmInt (AI i) = i- getImmInt _ = 0--binOpMap :: Map CInt BinOpDesc-binOpMap =- Map.fromList- [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),- (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),- (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),- (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),- (24, BOOr), (25, BOXor)]--convOpMap :: Map CInt (TypeDesc -> TypeDesc -> ArgDesc -> InstrDesc)-convOpMap =- Map.fromList- [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),- (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),- (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)]---- TODO: fix for non-int constants-getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc-getArgDesc (vname, v) = do- isC <- U.isConstant v- t <- FFI.typeOf v >>= typeDesc2- if isC- then case t of- TDInt _ _ -> do- cV <- FFI.constIntGetSExtValue v- return $ AI $ fromIntegral cV- _ -> return AE- else case t of- TDLabel -> return $ AL vname- _ -> return $ AV vname------------------------------------------type Terminate = ()-terminate :: Terminate-terminate = ()-------------------------------------------- |Acceptable arguments to the 'ret' instruction.-class Ret a r where- ret' :: a -> CodeGenFunction r Terminate---- | Return from the current function with the given value. Use () as the return value for what would be a void function in C.-ret :: (Ret a r) => a -> CodeGenFunction r Terminate-ret = ret'---- overlaps with Ret () ()!-{--instance (IsFirstClass a, IsConst a) => Ret a a where- ret' = ret . valueOf--}--instance Ret (Value a) a where- ret' (Value a) = do- withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a- return terminate--instance Ret () () where- ret' _ = do- withCurrentBuilder_ $ FFI.buildRetVoid- return terminate--withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r ()-withCurrentBuilder_ p = withCurrentBuilder p >> return ()-------------------------------------------- | Branch to the first basic block if the boolean is true, otherwise to the second basic block.-condBr :: Value Bool -- ^ Boolean to branch upon.- -> BasicBlock -- ^ Target for true.- -> BasicBlock -- ^ Target for false.- -> CodeGenFunction r Terminate-condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do- withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2- return terminate-------------------------------------------- | Unconditionally branch to the given basic block.-br :: BasicBlock -- ^ Branch target.- -> CodeGenFunction r Terminate-br (BasicBlock t) = do- withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t- return terminate-------------------------------------------- | Branch table instruction.-switch :: (IsInteger a)- => Value a -- ^ Value to branch upon.- -> BasicBlock -- ^ Default branch target.- -> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets.- -> CodeGenFunction r Terminate-switch (Value val) (BasicBlock dflt) arms = do- withCurrentBuilder_ $ \ bldPtr -> do- inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms)- sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ]- return terminate-------------------------------------------- |Inform the code generator that this code can never be reached.-unreachable :: CodeGenFunction r Terminate-unreachable = do- withCurrentBuilder_ FFI.buildUnreachable- return terminate-------------------------------------------withArithmeticType ::- (IsArithmetic c) =>- (ArithmeticType c -> a -> CodeGenFunction r (v c)) ->- (a -> CodeGenFunction r (v c))-withArithmeticType f = f arithmeticType---class (ValueCons value0, ValueCons value1) => ValueCons2 value0 value1 where- type BinOpValue (value0 :: * -> *) (value1 :: * -> *) :: * -> *- binop ::- FFIConstBinOp -> FFIBinOp ->- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)--instance ValueCons2 Value Value where- type BinOpValue Value Value = Value- binop _ op (Value a1) (Value a2) = buildBinOp op a1 a2--instance ValueCons2 Value ConstValue where- type BinOpValue Value ConstValue = Value- binop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2--instance ValueCons2 ConstValue Value where- type BinOpValue ConstValue Value = Value- binop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2--instance ValueCons2 ConstValue ConstValue where- type BinOpValue ConstValue ConstValue = ConstValue- binop cop _ (ConstValue a1) (ConstValue a2) =- liftIO $ fmap ConstValue $ cop a1 a2---add, sub, mul ::- (ValueCons2 value0 value1, IsArithmetic a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-add =- curry $ withArithmeticType $ \typ -> uncurry $ case typ of- IntegerType -> binop FFI.constAdd FFI.buildAdd- FloatingType -> binop FFI.constFAdd FFI.buildFAdd--sub =- curry $ withArithmeticType $ \typ -> uncurry $ case typ of- IntegerType -> binop FFI.constSub FFI.buildSub- FloatingType -> binop FFI.constFSub FFI.buildFSub--mul =- curry $ withArithmeticType $ \typ -> uncurry $ case typ of- IntegerType -> binop FFI.constMul FFI.buildMul- FloatingType -> binop FFI.constFMul FFI.buildFMul--iadd, isub, imul ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-iadd = binop FFI.constAdd FFI.buildAdd-isub = binop FFI.constSub FFI.buildSub-imul = binop FFI.constMul FFI.buildMul--iaddNoWrap, isubNoWrap, imulNoWrap ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-iaddNoWrap =- sbinop FFI.constNSWAdd FFI.buildNSWAdd FFI.constNUWAdd FFI.buildNUWAdd-isubNoWrap =- sbinop FFI.constNSWSub FFI.buildNSWSub FFI.constNUWSub FFI.buildNUWSub-imulNoWrap =- sbinop FFI.constNSWMul FFI.buildNSWMul FFI.constNUWMul FFI.buildNUWMul---- | signed or unsigned integer division depending on the type-idiv ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-idiv = sbinop FFI.constSDiv FFI.buildSDiv FFI.constUDiv FFI.buildUDiv--- | signed or unsigned remainder depending on the type-irem ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-irem = sbinop FFI.constSRem FFI.buildSRem FFI.constURem FFI.buildURem--{-# DEPRECATED udiv "use idiv instead" #-}-{-# DEPRECATED sdiv "use idiv instead" #-}-{-# DEPRECATED urem "use irem instead" #-}-{-# DEPRECATED srem "use irem instead" #-}-udiv, sdiv, urem, srem ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-udiv = binop FFI.constUDiv FFI.buildUDiv-sdiv = binop FFI.constSDiv FFI.buildSDiv-urem = binop FFI.constURem FFI.buildURem-srem = binop FFI.constSRem FFI.buildSRem--fadd, fsub, fmul ::- (ValueCons2 value0 value1, IsFloating a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-fadd = binop FFI.constFAdd FFI.buildFAdd-fsub = binop FFI.constFSub FFI.buildFSub-fmul = binop FFI.constFMul FFI.buildFMul---- | Floating point division.-fdiv ::- (ValueCons2 value0 value1, IsFloating a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-fdiv = binop FFI.constFDiv FFI.buildFDiv--- | Floating point remainder.-frem ::- (ValueCons2 value0 value1, IsFloating a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-frem = binop FFI.constFRem FFI.buildFRem--shl, lshr, ashr, and, or, xor ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-shl = binop FFI.constShl FFI.buildShl-lshr = binop FFI.constLShr FFI.buildLShr-ashr = binop FFI.constAShr FFI.buildAShr-and = binop FFI.constAnd FFI.buildAnd-or = binop FFI.constOr FFI.buildOr-xor = binop FFI.constXor FFI.buildXor--shr ::- (ValueCons2 value0 value1, IsInteger a) =>- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 a)-shr = sbinop FFI.constAShr FFI.buildAShr FFI.constLShr FFI.buildLShr--sbinop ::- forall value0 value1 a b r.- (ValueCons2 value0 value1, IsInteger a) =>- FFIConstBinOp -> FFIBinOp ->- FFIConstBinOp -> FFIBinOp ->- value0 a -> value1 a -> CodeGenFunction r (BinOpValue value0 value1 b)-sbinop scop sop ucop uop =- if isSigned (LP.Proxy :: LP.Proxy a)- then binop scop sop- else binop ucop uop---buildBinOp ::- FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)-buildBinOp op a1 a2 =- liftM Value $- withCurrentBuilder $ \ bld ->- U.withEmptyCString $ op bld a1 a2--neg ::- (ValueCons value, IsArithmetic a) =>- value a -> CodeGenFunction r (value a)-neg =- withArithmeticType $ \typ -> case typ of- IntegerType -> unop FFI.constNeg FFI.buildNeg- FloatingType -> unop FFI.constFNeg FFI.buildFNeg--ineg ::- (ValueCons value, IsInteger a) =>- value a -> CodeGenFunction r (value a)-ineg = unop FFI.constNeg FFI.buildNeg--inegNoWrap ::- forall value a r.- (ValueCons value, IsInteger a) =>- value a -> CodeGenFunction r (value a)-inegNoWrap =- if isSigned (LP.Proxy :: LP.Proxy a)- then unop FFI.constNSWNeg FFI.buildNSWNeg- else unop FFI.constNUWNeg FFI.buildNUWNeg--fneg ::- (ValueCons value, IsFloating a) =>- value a -> CodeGenFunction r (value a)-fneg = unop FFI.constFNeg FFI.buildFNeg--inv ::- (ValueCons value, IsInteger a) =>- value a -> CodeGenFunction r (value a)-inv = unop FFI.constNot FFI.buildNot-------------------------------------------- | Get a value from a vector.-extractelement :: (Dec.Positive n, IsPrimitive a)- => Value (Vector n a) -- ^ Vector- -> Value Word32 -- ^ Index into the vector- -> CodeGenFunction r (Value a)-extractelement (Value vec) (Value i) =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i---- | Insert a value into a vector, nondestructive.-insertelement :: (Dec.Positive n, IsPrimitive a)- => Value (Vector n a) -- ^ Vector- -> Value a -- ^ Value to insert- -> Value Word32 -- ^ Index into the vector- -> CodeGenFunction r (Value (Vector n a))-insertelement (Value vec) (Value e) (Value i) =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i---- | Permute vector.-shufflevector :: (Dec.Positive n, Dec.Positive m, IsPrimitive a)- => Value (Vector n a)- -> Value (Vector n a)- -> ConstValue (Vector m Word32)- -> CodeGenFunction r (Value (Vector m a))-shufflevector (Value a) (Value b) (ConstValue mask) =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask----- |Acceptable arguments to 'extractvalue' and 'insertvalue'.-class GetValue agg ix where- type ValueType agg ix :: *- getIx :: LP.Proxy agg -> ix -> CUInt--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, Dec.Natural n) => GetValue (Array n a) Word32 where- type ValueType (Array n a) Word32 = a- getIx _ n = fromIntegral n--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, 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.-extractvalue :: forall r agg i.- GetValue agg i- => Value agg -- ^ Aggregate- -> i -- ^ Index into the aggregate- -> CodeGenFunction r (Value (ValueType agg i))-extractvalue (Value agg) i =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $- FFI.buildExtractValue bldPtr agg (getIx (LP.Proxy :: LP.Proxy agg) i)---- | Insert a value into an aggregate, nondestructive.-insertvalue :: forall r agg i.- GetValue agg i- => Value agg -- ^ Aggregate- -> Value (ValueType agg i) -- ^ Value to insert- -> i -- ^ Index into the aggregate- -> CodeGenFunction r (Value agg)-insertvalue (Value agg) (Value e) i =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $- FFI.buildInsertValue bldPtr agg e (getIx (LP.Proxy :: LP.Proxy agg) i)--------------------------------------------- | Truncate a value to a shorter bit width.-trunc :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)- => value a -> CodeGenFunction r (value b)-trunc = convert FFI.constTrunc FFI.buildTrunc---- | Zero extend a value to a wider width.--- If possible, use 'ext' that chooses the right padding according to the types-zext :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)- => value a -> CodeGenFunction r (value b)-zext = convert FFI.constZExt FFI.buildZExt---- | Sign extend a value to wider width.--- If possible, use 'ext' that chooses the right padding according to the types-sext :: (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)- => value a -> CodeGenFunction r (value b)-sext = convert FFI.constSExt 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 value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)- => value a -> CodeGenFunction r (value b)-ext =- if isSigned (LP.Proxy :: LP.Proxy b)- then convert FFI.constSExt FFI.buildSExt- else convert FFI.constZExt FFI.buildZExt---- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.-zadapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b)- => value a -> CodeGenFunction r (value b)-zadapt =- case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))- (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of- LT -> convert FFI.constZExt FFI.buildZExt- EQ -> convert FFI.constBitCast FFI.buildBitCast- GT -> convert FFI.constTrunc FFI.buildTrunc---- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.-sadapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b)- => value a -> CodeGenFunction r (value b)-sadapt =- case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))- (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of- LT -> convert FFI.constSExt FFI.buildSExt- EQ -> convert FFI.constBitCast FFI.buildBitCast- GT -> convert FFI.constTrunc FFI.buildTrunc---- | It is 'sadapt' or 'zadapt' depending on the sign mode.-adapt :: forall value a b r. (ValueCons value, IsInteger a, IsInteger b, ShapeOf a ~ ShapeOf b, Signed a ~ Signed b)- => value a -> CodeGenFunction r (value b)-adapt =- case compare (sizeOf (typeDesc (LP.Proxy :: LP.Proxy a)))- (sizeOf (typeDesc (LP.Proxy :: LP.Proxy b))) of- LT ->- if isSigned (LP.Proxy :: LP.Proxy b)- then convert FFI.constSExt FFI.buildSExt- else convert FFI.constZExt FFI.buildZExt- EQ -> convert FFI.constBitCast FFI.buildBitCast- GT -> convert FFI.constTrunc FFI.buildTrunc---- | Truncate a floating point value.-fptrunc :: (ValueCons value, IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :>: SizeOf b)- => value a -> CodeGenFunction r (value b)-fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc---- | Extend a floating point value.-fpext :: (ValueCons value, IsFloating a, IsFloating b, ShapeOf a ~ ShapeOf b, IsSized a, IsSized b, SizeOf a :<: SizeOf b)- => value a -> CodeGenFunction r (value b)-fpext = convert FFI.constFPExt FFI.buildFPExt--{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-}--- | Convert a floating point value to an unsigned integer.-fptoui :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)-fptoui = convert FFI.constFPToUI FFI.buildFPToUI--{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-}--- | Convert a floating point value to a signed integer.-fptosi :: (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)-fptosi = convert FFI.constFPToSI FFI.buildFPToSI---- | Convert a floating point value to an integer.--- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.-fptoint :: forall value a b r. (ValueCons value, IsFloating a, IsInteger b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)-fptoint =- if isSigned (LP.Proxy :: LP.Proxy b)- then convert FFI.constFPToSI FFI.buildFPToSI- else convert FFI.constFPToUI FFI.buildFPToUI---{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -}--- | Convert an unsigned integer to a floating point value.--- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.-uitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)-uitofp = convert FFI.constUIToFP FFI.buildUIToFP--{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -}--- | Convert a signed integer to a floating point value.--- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.-sitofp :: (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)-sitofp = convert FFI.constSIToFP FFI.buildSIToFP---- | Convert an integer to a floating point value.--- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.-inttofp :: forall value a b r. (ValueCons value, IsInteger a, IsFloating b, ShapeOf a ~ ShapeOf b) => value a -> CodeGenFunction r (value b)-inttofp =- if isSigned (LP.Proxy :: LP.Proxy a)- then convert FFI.constSIToFP FFI.buildSIToFP- else convert FFI.constUIToFP FFI.buildUIToFP----- | Convert a pointer to an integer.-ptrtoint :: (ValueCons value, IsInteger b, IsPrimitive b) => value (Ptr a) -> CodeGenFunction r (value b)-ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt---- | Convert an integer to a pointer.-inttoptr :: (ValueCons value, IsInteger a, IsType b) => value a -> CodeGenFunction r (value (Ptr b))-inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr---- | Convert between to values of the same size by just copying the bit pattern.-bitcast :: (ValueCons value, IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)- => value a -> CodeGenFunction r (value b)-bitcast = convert FFI.constBitCast FFI.buildBitCast-------------------------------------------type CmpValueResult value0 value1 a = BinOpValue value0 value1 (CmpResult a)--type CmpResult c = ShapedType (ShapeOf c) Bool--class (IsFirstClass c) => CmpRet c where- cmpBld :: LP.Proxy c -> CmpPredicate -> FFIBinOp- cmpCnst :: LP.Proxy c -> CmpPredicate -> FFIConstBinOp--instance CmpRet Float where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst-instance CmpRet Double where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst-instance CmpRet FP128 where cmpBld _ = fcmpBld ; cmpCnst _ = fcmpCnst-instance CmpRet Bool where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst-instance CmpRet Word8 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst-instance CmpRet Word16 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst-instance CmpRet Word32 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst-instance CmpRet Word64 where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst-instance CmpRet Int8 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst-instance CmpRet Int16 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst-instance CmpRet Int32 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst-instance CmpRet Int64 where cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst-instance (IsType a) =>- CmpRet (Ptr a) where cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst--instance (Dec.Positive n) => CmpRet (WordN n) where- cmpBld _ = ucmpBld ; cmpCnst _ = ucmpCnst-instance (Dec.Positive n) => CmpRet (IntN n) where- cmpBld _ = scmpBld ; cmpCnst _ = scmpCnst--instance (CmpRet a, IsPrimitive a, Dec.Positive n) => CmpRet (Vector n a) where- cmpBld _ = cmpBld (LP.Proxy :: LP.Proxy a)- cmpCnst _ = cmpCnst (LP.Proxy :: LP.Proxy a)---{- |-Compare values of ordered types-and choose predicates according to the compared types.-Floating point numbers are compared in \"ordered\" mode,-that is @NaN@ operands yields 'False' as result.-Pointers are compared unsigned.-These choices are consistent with comparison in plain Haskell.--}-cmp :: forall value0 value1 a r.- (ValueCons2 value0 value1, CmpRet a) =>- CmpPredicate -> value0 a -> value1 a ->- CodeGenFunction r (CmpValueResult value0 value1 a)-cmp p =- binop- (cmpCnst (LP.Proxy :: LP.Proxy a) p)- (cmpBld (LP.Proxy :: LP.Proxy a) p)--ucmpBld :: CmpPredicate -> FFIBinOp-ucmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))--scmpBld :: CmpPredicate -> FFIBinOp-scmpBld p = flip FFI.buildICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))--fcmpBld :: CmpPredicate -> FFIBinOp-fcmpBld p = flip FFI.buildFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))---ucmpCnst :: CmpPredicate -> FFIConstBinOp-ucmpCnst p = FFI.constICmp (FFI.fromIntPredicate (uintFromCmpPredicate p))--scmpCnst :: CmpPredicate -> FFIConstBinOp-scmpCnst p = FFI.constICmp (FFI.fromIntPredicate (sintFromCmpPredicate p))--fcmpCnst :: CmpPredicate -> FFIConstBinOp-fcmpCnst p = FFI.constFCmp (FFI.fromRealPredicate (fpFromCmpPredicate p))---_ucmp ::- (ValueCons2 value0 value1, CmpRet a, IsInteger a) =>- CmpPredicate -> value0 a -> value1 a ->- CodeGenFunction r (CmpValueResult value0 value1 a)-_ucmp p = binop (ucmpCnst p) (ucmpBld p)--_scmp ::- (ValueCons2 value0 value1, CmpRet a, IsInteger a) =>- CmpPredicate -> value0 a -> value1 a ->- CodeGenFunction r (CmpValueResult value0 value1 a)-_scmp p = binop (scmpCnst p) (scmpBld p)--pcmp ::- (ValueCons2 value0 value1, IsType a) =>- IntPredicate -> value0 (Ptr a) -> value1 (Ptr a) ->- CodeGenFunction r (BinOpValue value0 value1 (Ptr a))-pcmp p =- binop- (FFI.constICmp (FFI.fromIntPredicate p))- (flip FFI.buildICmp (FFI.fromIntPredicate p))---{-# DEPRECATED icmp "use cmp or pcmp instead" #-}--- | Compare integers.-icmp ::- (ValueCons2 value0 value1, CmpRet a, IsIntegerOrPointer a) =>- IntPredicate -> value0 a -> value1 a ->- CodeGenFunction r (CmpValueResult value0 value1 a)-icmp p =- binop- (FFI.constICmp (FFI.fromIntPredicate p))- (flip FFI.buildICmp (FFI.fromIntPredicate p))---- | Compare floating point values.-fcmp ::- (ValueCons2 value0 value1, CmpRet a, IsFloating a) =>- FPPredicate -> value0 a -> value1 a ->- CodeGenFunction r (CmpValueResult value0 value1 a)-fcmp p =- binop- (FFI.constFCmp (FFI.fromRealPredicate p))- (flip FFI.buildFCmp (FFI.fromRealPredicate p))------------------------------------------setHasNoNaNs, setHasNoInfs, setHasNoSignedZeros, setHasAllowReciprocal,- setFastMath :: (IsFloating a) => Bool -> Value a -> CodeGenFunction r ()-setHasNoNaNs = fastMath FFI.setHasNoNaNs-setHasNoInfs = fastMath FFI.setHasNoInfs-setHasNoSignedZeros = fastMath FFI.setHasNoSignedZeros-setHasAllowReciprocal = fastMath FFI.setHasAllowReciprocal-setFastMath = fastMath FFI.setHasUnsafeAlgebra--fastMath ::- (IsFloating a) =>- (FFI.ValueRef -> FFI.Bool -> IO ()) ->- Bool -> Value a -> CodeGenFunction r ()-fastMath setter b (Value v) = liftIO $ setter v $ FFI.consBool b--------------------------------------------- XXX could do const song and dance--- | Select between two values depending on a boolean.-select :: (CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a)-select (Value cnd) (Value thn) (Value els) =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $- FFI.buildSelect bldPtr cnd thn els------------------------------------------type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef--{--Function (a -> b -> IO c)-Value a -> Value b -> CodeGenFunction r c--}---- |Acceptable arguments to 'call'.-class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>- CallArgs f g r where- type CalledFunction g :: *- type CallerResult g :: *- type CallerFunction f r :: *- doCall :: Call f -> g--instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where- type CalledFunction (Value a -> b') = a -> CalledFunction b'- type CallerResult (Value a -> b') = CallerResult b'- type CallerFunction (a -> b) r = Value a -> CallerFunction b r- doCall f a = doCall (applyCall f a)----instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where--- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (LP.Proxy :: LP.Proxy a))--instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where- type CalledFunction (CodeGenFunction r (Value a)) = IO a- type CallerResult (CodeGenFunction r (Value a)) = r- type CallerFunction (IO a) r = CodeGenFunction r (Value a)- doCall = runCall--doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a)-doCallDef mkCall args _ =- withCurrentBuilder $ \ bld ->- liftM Value $ mkCall bld (reverse args)---- | Call a function with the given arguments. The 'call' instruction is variadic, i.e., the number of arguments--- it takes depends on the type of /f/.-call :: (CallArgs f g r) => Function f -> g-call = doCall . callFromFunction--data Call a = Call Caller [FFI.ValueRef]--callFromFunction :: Function a -> Call a-callFromFunction (Value f) = Call (U.makeCall f) []---- like Applicative.<*>-infixl 4 `applyCall`--applyCall :: Call (a -> b) -> Value a -> Call b-applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args)--runCall :: Call (IO a) -> CodeGenFunction r (Value a)-runCall (Call mkCall args) = doCallDef mkCall args ()---invokeFromFunction ::- BasicBlock -- ^Normal return point.- -> BasicBlock -- ^Exception return point.- -> Function f -- ^Function to call.- -> Call f-invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) =- Call (U.makeInvoke norm expt f) []---- | Call a function with exception handling.-invoke :: (CallArgs f g r)- => BasicBlock -- ^Normal return point.- -> BasicBlock -- ^Exception return point.- -> Function f -- ^Function to call.- -> g-invoke norm expt f = doCall $ invokeFromFunction norm expt f--callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f-callWithConvFromFunction cc (Value f) =- Call (U.makeCallWithCc cc f) []---- | Call a function with the given arguments. The 'call' instruction--- is variadic, i.e., the number of arguments it takes depends on the--- type of /f/.--- This also sets the calling convention of the call to the function.--- As LLVM itself defines, if the calling conventions of the calling--- /instruction/ and the function being /called/ are different, undefined--- behavior results.-callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g-callWithConv cc f = doCall $ callWithConvFromFunction cc f--invokeWithConvFromFunction ::- FFI.CallingConvention -- ^Calling convention- -> BasicBlock -- ^Normal return point.- -> BasicBlock -- ^Exception return point.- -> Function f -- ^Function to call.- -> Call f-invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) =- Call (U.makeInvokeWithCc cc norm expt f) []---- | Call a function with exception handling.--- This also sets the calling convention of the call to the function.--- As LLVM itself defines, if the calling conventions of the calling--- /instruction/ and the function being /called/ are different, undefined--- behavior results.-invokeWithConv :: (CallArgs f g r)- => FFI.CallingConvention -- ^Calling convention- -> BasicBlock -- ^Normal return point.- -> BasicBlock -- ^Exception return point.- -> Function f -- ^Function to call.- -> g-invokeWithConv cc norm expt f =- doCall $ invokeWithConvFromFunction cc norm expt f-------------------------------------------- XXX could do const song and dance--- |Join several variables (virtual registers) from different basic blocks into one.--- All of the variables in the list are joined. See also 'addPhiInputs'.-phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)-phi incoming =- liftM Value $- withCurrentBuilder $ \ bldPtr -> do- inst <- U.buildEmptyPhi bldPtr =<< typeRef (LP.Proxy :: LP.Proxy a)- U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]- return inst---- |Add additional inputs to an existing phi node.--- The reason for this instruction is that sometimes the structure of the code--- makes it impossible to have all variables in scope at the point where you need the phi node.-addPhiInputs :: forall a r . (IsFirstClass a)- => Value a -- ^Must be a variable from a call to 'phi'.- -> [(Value a, BasicBlock)] -- ^Variables to add.- -> CodeGenFunction r ()-addPhiInputs (Value inst) incoming =- liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]--------------------------------------------- | Acceptable argument to array memory allocation.-class AllocArg a where- getAllocArg :: a -> Value Word32-instance AllocArg (Value Word32) where- getAllocArg = id-instance AllocArg (ConstValue Word32) where- getAllocArg = value-instance AllocArg Word32 where- getAllocArg = valueOf---- could be moved to Util.Memory--- FFI.buildMalloc deprecated since LLVM-2.7--- XXX What's the type returned by malloc--- | Allocate heap memory.-malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))-malloc = arrayMalloc (1::Word32)--{--I use a pointer type as size parameter of 'malloc'.-This way I hope that the parameter has always the correct size (32 or 64 bit).-A side effect is that we can convert the result of 'getelementptr' using 'bitcast',-that does not suffer from the slow assembly problem. (bug #8281)--}-foreign import ccall "&aligned_malloc_sizeptr"- alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))--foreign import ccall "&aligned_free"- alignedFree :: FunPtr (Ptr Word8 -> IO ())---{--There is a bug in LLVM-2.7 and LLVM-2.8-(http://llvm.org/bugs/show_bug.cgi?id=8281)-that causes huge assembly times for expressions like-ptrtoint(getelementptr(zero,..)).-If you break those expressions into two statements-at separate lines, everything is fine.-But the C interface is too clever,-and rewrites two separate statements into a functional expression on a single line.-Such code is generated whenever you call-buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.-One possible way is to write a getelementptr expression-containing a nullptr in a way-that hides the constant nature of nullptr.-- ptr <- alloca- store (value zero) ptr- z <- load ptr- size <- bitcast =<<- getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())--However, I found that bitcast on pointers causes no problems.-Thus I switched to using pointers for size quantities.-This still allows for optimizations involving pointers.--}---- XXX What's the type returned by arrayMalloc?--- | Allocate heap (array) memory.-arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>- s -> CodeGenFunction r (Value (Ptr a)) -- XXX-arrayMalloc s = do- func <- CodeGen.staticNamedFunction "alignedMalloc" alignedMalloc--- func <- externFunction "malloc"-- 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)))- size- alignment---- XXX What's the type returned by malloc--- | Allocate stack memory.-alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))-alloca =- liftM Value $- withCurrentBuilder $ \ bldPtr -> 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.-arrayAlloca :: forall a r s . (IsSized a, AllocArg s) =>- s -> CodeGenFunction r (Value (Ptr a))-arrayAlloca s =- liftM Value $- withCurrentBuilder $ \ bldPtr -> do- typ <- typeRef (LP.Proxy :: LP.Proxy a)- U.withEmptyCString $- 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?--- | Free heap memory.-free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()-free ptr = do- func <- CodeGen.staticNamedFunction "alignedFree" alignedFree--- func <- externFunction "free"- _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr- return ()----- | If we want to export that, then we should have a Size type--- This is the official implementation,--- but it suffers from the ptrtoint(gep) bug.-_sizeOf ::- forall a r.- (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word64)-_sizeOf a =- liftIO $ liftM Value $- FFI.sizeOf =<< typeRef a--_alignOf ::- forall a r.- (IsSized a) => LP.Proxy a -> CodeGenFunction r (Value Word64)-_alignOf a =- liftIO $ liftM Value $- FFI.alignOf =<< typeRef a----- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.--- see ConstantExpr::getSizeOf-sizeOfArray ::- forall a r . (IsSized a) =>- 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) =>- LP.Proxy a -> CodeGenFunction r (Value (Ptr Word8))-alignOf _ =- bitcast =<<- getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())----- | Load a value from memory.-load :: Value (Ptr a) -- ^ Address to load from.- -> CodeGenFunction r (Value a)-load (Value p) =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ FFI.buildLoad bldPtr p---- | Store a value in memory-store :: Value a -- ^ Value to store.- -> Value (Ptr a) -- ^ Address to store to.- -> CodeGenFunction r ()-store (Value v) (Value p) = do- withCurrentBuilder_ $ \ bldPtr ->- FFI.buildStore bldPtr v p- return ()---- | Address arithmetic. See LLVM description.--- (The type isn't as accurate as it should be.)-_getElementPtrDynamic :: (IsInteger i) =>- Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))-_getElementPtrDynamic (Value ptr) ixs =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->- U.withEmptyCString $- FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)---- | Address arithmetic. See LLVM description.--- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.--- (This is without a doubt the most confusing LLVM instruction, but the types help.)-getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) =>- Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))-getElementPtr (Value ptr) (a, ixs) =- let ixl = getArg a : getIxList (LP.Proxy :: LP.Proxy o) ixs in- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withArrayLen ixl $ \ idxLen idxPtr ->- U.withEmptyCString $- FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)---- | Like getElementPtr, but with an initial index that is 0.--- This is useful since any pointer first need to be indexed off the pointer, and then into--- its actual value. This first indexing is often with 0.-getElementPtr0 :: (GetElementPtr o i) =>- Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))-getElementPtr0 p i = getElementPtr p (0::Word32, i)--_getElementPtr :: forall value o i i0 r.- (ValueCons value, GetElementPtr o i, IsIndexType i0) =>- value (Ptr o) -> (value i0, i) ->- CodeGenFunction r (value (Ptr (ElementPtrType o i)))-_getElementPtr vptr (a, ixs) =- let withArgs act =- U.withArrayLen- (unValue a : getIxList (LP.Proxy :: LP.Proxy o) ixs) $- \ idxLen idxPtr ->- act idxPtr (fromIntegral idxLen)- in unop- (\ptr -> withArgs $ FFI.constGEP ptr)- (\bldPtr ptr cstr ->- withArgs $ \idxPtr idxLen ->- FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)- vptr-----------------------------------------{--instance (IsConst a) => Show (ConstValue a) -- XXX-instance (IsConst a) => Eq (ConstValue a)--{--instance (IsConst a) => Eq (ConstValue a) where- ConstValue x == ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOEQ) x y)- else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntEQ) x y)- ConstValue x /= ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPONE) x y)- else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntNE) x y)--instance (IsConst a) => Ord (ConstValue a) where- ConstValue x < ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOLT) x y)- else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLT) x y)- ConstValue x <= ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOLE) x y)- else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntLE) x y)- ConstValue x > ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOGT) x y)- else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGT) x y)- ConstValue x >= ConstValue y =- if isFloating x then ConstValue (FFI.constFCmp (FFI.fromRealPredicate FPOGE) x y)- else ConstValue (FFI.constICmp (FFI.fromIntPredicate IntGE) x y)--}--instance (Num a, IsConst a) => Num (ConstValue a) where- ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y)- ConstValue x - ConstValue y = ConstValue (FFI.constSub x y)- ConstValue x * ConstValue y = ConstValue (FFI.constMul x y)- negate (ConstValue x) = ConstValue (FFI.constNeg x)- fromInteger x = constOf (fromInteger x :: a)--}
− src/LLVM/Core/Instructions/Guided.hs
@@ -1,356 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE EmptyDataDecls #-}-{- |-This module provides some functions from the "LLVM.Core.Instructions" module-in a way that enables easier type handling.-E.g. 'trunc' on vectors requires you to prove-that reducing the bitsize of the elements-reduces the bitsize of the whole vector.-We solve the problem by adding a 'Guide' parameter.-It can be either 'scalar' or 'vector'.-We impose the bitsize constraint only on the element type,-but not on the size of the whole value (scalar or vector).--Another example:-If you call 'trunc' on a Vector input,-GHC cannot infer that the result must be a 'Data.Vector' of the same size.-Using the guide, it can.-However, in practice this is not as useful as I thought initially.--}-module LLVM.Core.Instructions.Guided (- Guide,- scalar,- vector,- getElementPtr,- getElementPtr0,- trunc,- ext,- extBool,- zadapt,- sadapt,- adapt,- fptrunc,- fpext,- fptoint,- inttofp,- ptrtoint,- inttoptr,- bitcast,- select,- cmp,- icmp,- pcmp,- fcmp,- ) where--import qualified LLVM.Core.Instructions.Private as Priv-import qualified LLVM.Core.Type as Type-import qualified LLVM.Core.Util as U-import qualified LLVM.Util.Proxy as LP-import LLVM.Core.Instructions.Private (ValueCons)-import LLVM.Core.CodeGenMonad (CodeGenFunction)-import LLVM.Core.CodeGen (ConstValue, zero)-import LLVM.Core.Type- (IsArithmetic, IsInteger, IsIntegerOrPointer, IsFloating,- IsFirstClass, IsPrimitive,- Signed, Positive, IsType, IsSized, SizeOf,- isFloating, sizeOf, typeDesc)--import qualified LLVM.FFI.Core as FFI--import Type.Data.Num.Decimal.Number ((:<:), (:>:))--import Foreign.Ptr (Ptr)--import qualified Control.Functor.HT as FuncHT--import Data.Word (Word32)---data Guide shape elem = Guide--instance Functor (Guide shape) where- fmap _ Guide = Guide--scalar :: Guide Type.ScalarShape a-scalar = Guide--vector :: (Positive n) => Guide (Type.VectorShape n) a-vector = Guide--proxyFromGuide :: Guide shape elem -> LP.Proxy elem-proxyFromGuide Guide = LP.Proxy---type Type shape a = Type.ShapedType shape a-type VT value shape a = value (Type shape a)--getElementPtr ::- (ValueCons value, Priv.GetElementPtr o i, Priv.IsIndexType i0) =>- Guide shape (Ptr o, i0) ->- VT value shape (Ptr o) ->- (VT value shape i0, i) ->- CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))-getElementPtr guide vptr (a, ixs) =- getElementPtrGen (fmap fst guide) vptr (Priv.unValue a, ixs)--getElementPtr0 ::- (ValueCons value, Priv.GetElementPtr o i) =>- Guide shape (Ptr o) ->- VT value shape (Ptr o) -> i ->- CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))-getElementPtr0 guide vptr ixs =- getElementPtrGen guide vptr- (Priv.unConst (zero :: ConstValue Word32), ixs)--getElementPtrGen ::- (ValueCons value, Priv.GetElementPtr o i) =>- Guide shape (Ptr o) ->- VT value shape (Ptr o) -> (FFI.ValueRef, i) ->- CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i)))-getElementPtrGen guide vptr (i0val,ixs) =- let withArgs act =- U.withArrayLen- (i0val : Priv.getIxList (LP.element (proxyFromGuide guide)) ixs) $- \ idxLen idxPtr ->- act idxPtr (fromIntegral idxLen)- in Priv.unop- (\ptr -> withArgs $ FFI.constGEP ptr)- (\bldPtr ptr cstr ->- withArgs $ \idxPtr idxLen ->- FFI.buildGEP bldPtr ptr idxPtr idxLen cstr)- vptr----- | Truncate a value to a shorter bit width.-trunc ::- (ValueCons value, IsInteger av, IsInteger bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,- IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-trunc = convert FFI.constTrunc FFI.buildTrunc--isSigned :: (IsArithmetic a) => Guide shape a -> Bool-isSigned = Type.isSigned . proxyFromGuide---- | Extend a value to wider width.--- If the target type is signed, then preserve the sign,--- If the target type is unsigned, then extended by zeros.-ext ::- (ValueCons value, IsInteger a, IsInteger b, IsType bv, Signed a ~ Signed b,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,- IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-ext guide =- if isSigned (fmap snd guide)- then convert FFI.constSExt FFI.buildSExt guide- else convert FFI.constZExt FFI.buildZExt guide--extBool ::- (ValueCons value, IsInteger b, IsType bv,- IsPrimitive b, Type shape Bool ~ av, Type shape b ~ bv) =>- Guide shape (Bool,b) -> value av -> CodeGenFunction r (value bv)-extBool guide =- if isSigned (fmap snd guide)- then convert FFI.constSExt FFI.buildSExt guide- else convert FFI.constZExt FFI.buildZExt guide---compareGuideSizes :: (IsType a, IsType b) => Guide shape (a,b) -> Ordering-compareGuideSizes guide =- case FuncHT.unzip $ proxyFromGuide guide of- (a,b) -> compare (sizeOf (typeDesc a)) (sizeOf (typeDesc b))---- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.-zadapt ::- (ValueCons value, IsInteger a, IsInteger b, IsType bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-zadapt guide =- case compareGuideSizes guide of- LT -> convert FFI.constZExt FFI.buildZExt guide- EQ -> convert FFI.constBitCast FFI.buildBitCast guide- GT -> convert FFI.constTrunc FFI.buildTrunc guide---- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.-sadapt ::- (ValueCons value, IsInteger a, IsInteger b, IsType bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-sadapt guide =- case compareGuideSizes guide of- LT -> convert FFI.constSExt FFI.buildSExt guide- EQ -> convert FFI.constBitCast FFI.buildBitCast guide- GT -> convert FFI.constTrunc FFI.buildTrunc guide---- | It is 'sadapt' or 'zadapt' depending on the sign mode.-adapt ::- (ValueCons value, IsInteger a, IsInteger b, IsType bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,- Signed a ~ Signed b) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-adapt guide =- case compareGuideSizes guide of- LT ->- if isSigned (fmap snd guide)- then convert FFI.constSExt FFI.buildSExt guide- else convert FFI.constZExt FFI.buildZExt guide- EQ -> convert FFI.constBitCast FFI.buildBitCast guide- GT -> convert FFI.constTrunc FFI.buildTrunc guide---- | Truncate a floating point value.-fptrunc ::- (ValueCons value, IsFloating av, IsFloating bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,- IsSized a, IsSized b, SizeOf a :>: SizeOf b) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-fptrunc = convert FFI.constFPTrunc FFI.buildFPTrunc---- | Extend a floating point value.-fpext ::- (ValueCons value, IsFloating av, IsFloating bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,- IsSized a, IsSized b, SizeOf a :<: SizeOf b) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-fpext = convert FFI.constFPExt FFI.buildFPExt---- | Convert a floating point value to an integer.--- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.-fptoint ::- (ValueCons value, IsFloating a, IsInteger b, IsType bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-fptoint guide =- if isSigned (fmap snd guide)- then convert FFI.constFPToSI FFI.buildFPToSI guide- else convert FFI.constFPToUI FFI.buildFPToUI guide----- | Convert an integer to a floating point value.--- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.-inttofp ::- (ValueCons value, IsInteger a, IsFloating b, IsType bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-inttofp guide =- if isSigned (fmap fst guide)- then convert FFI.constSIToFP FFI.buildSIToFP guide- else convert FFI.constUIToFP FFI.buildUIToFP guide----- | Convert a pointer to an integer.-ptrtoint ::- (ValueCons value, IsType a, IsInteger b, IsType bv,- IsPrimitive b, Type shape (Ptr a) ~ av, Type shape b ~ bv) =>- Guide shape (Ptr a, b) -> value av -> CodeGenFunction r (value bv)-ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt---- | Convert an integer to a pointer.-inttoptr ::- (ValueCons value, IsInteger a, IsType b, IsType bv,- IsPrimitive a, Type shape a ~ av, Type shape (Ptr b) ~ bv) =>- Guide shape (a, Ptr b) -> value av -> CodeGenFunction r (value bv)-inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr---- | Convert between to values of the same size by just copying the bit pattern.-bitcast ::- (ValueCons value, IsFirstClass a, IsFirstClass bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv,- IsSized a, IsSized b, SizeOf a ~ SizeOf b) =>- Guide shape (a,b) -> value av -> CodeGenFunction r (value bv)-bitcast = convert FFI.constBitCast FFI.buildBitCast---convert ::- (ValueCons value, IsType bv,- IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) =>- Priv.FFIConstConvert -> Priv.FFIConvert -> Guide shape (a,b) ->- value av -> CodeGenFunction r (value bv)-convert cnvConst cnv Guide = Priv.convert cnvConst cnv----select ::- (ValueCons value, IsPrimitive a,- Type shape a ~ av, Type shape Bool ~ bv) =>- Guide shape a ->- value bv -> value av -> value av -> CodeGenFunction r (value av)-select Guide = Priv.trinop FFI.constSelect FFI.buildSelect---cmp ::- (ValueCons value, IsArithmetic a, IsPrimitive a,- Type shape a ~ av, Type shape Bool ~ bv) =>- Guide shape a ->- Priv.CmpPredicate -> value av -> value av -> CodeGenFunction r (value bv)-cmp guide@Guide p =- let cmpop constCmp buildCmp predi =- Priv.binop (constCmp predi) (flip buildCmp predi)- in if isFloating (proxyFromGuide guide)- then- cmpop FFI.constFCmp FFI.buildFCmp $- FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p- else- cmpop FFI.constICmp FFI.buildICmp $- FFI.fromIntPredicate $- if isSigned guide- then Priv.sintFromCmpPredicate p- else Priv.uintFromCmpPredicate p--_cmp ::- (ValueCons value, IsArithmetic a, IsPrimitive a,- Type shape a ~ av, Type shape Bool ~ bv) =>- Guide shape a ->- Priv.CmpPredicate -> value av -> value av -> CodeGenFunction r (value bv)-_cmp guide@Guide p =- if isFloating (proxyFromGuide guide)- then- let predi = FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p- in Priv.binop- (FFI.constFCmp predi)- (flip FFI.buildFCmp predi)- else- let predi =- FFI.fromIntPredicate $- if isSigned guide- then Priv.sintFromCmpPredicate p- else Priv.uintFromCmpPredicate p- in Priv.binop- (FFI.constICmp predi)- (flip FFI.buildICmp predi)--{-# DEPRECATED icmp "use cmp or pcmp instead" #-}--- | Compare integers.-icmp ::- (ValueCons value, IsIntegerOrPointer a, IsPrimitive a,- Type shape a ~ av, Type shape Bool ~ bv) =>- Guide shape a ->- FFI.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)-icmp Guide p =- Priv.binop- (FFI.constICmp (FFI.fromIntPredicate p))- (flip FFI.buildICmp (FFI.fromIntPredicate p))---- | Compare pointers.-pcmp :: (ValueCons value, Type shape (Ptr a) ~ av, Type shape Bool ~ bv) =>- Guide shape (Ptr a) ->- FFI.IntPredicate -> value av -> value av -> CodeGenFunction r (value bv)-pcmp Guide p =- Priv.binop- (FFI.constICmp (FFI.fromIntPredicate p))- (flip FFI.buildICmp (FFI.fromIntPredicate p))---- | Compare floating point values.-fcmp ::- (ValueCons value, IsFloating a, IsPrimitive a,- Type shape a ~ av, Type shape Bool ~ bv) =>- Guide shape a ->- FFI.FPPredicate -> value av -> value av -> CodeGenFunction r (value bv)-fcmp Guide p =- Priv.binop- (FFI.constFCmp (FFI.fromRealPredicate p))- (flip FFI.buildFCmp (FFI.fromRealPredicate p))
− src/LLVM/Core/Instructions/Private.hs
@@ -1,291 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module LLVM.Core.Instructions.Private where--import qualified LLVM.Core.Util as U-import qualified LLVM.Util.Proxy as LP-import LLVM.Core.Type (IsType, IsPrimitive, typeRef)-import LLVM.Core.Data (Vector, Array, Struct, PackedStruct)-import LLVM.Core.CodeGenMonad (CodeGenFunction)-import LLVM.Core.CodeGen- (ConstValue(ConstValue), constOf, Value(Value), withCurrentBuilder)--import qualified LLVM.FFI.Core as FFI-import LLVM.FFI.Core (IntPredicate(..), FPPredicate(..))--import qualified Type.Data.Num.Decimal.Number as Dec-import Type.Data.Num.Decimal.Number (Pred)-import Type.Base.Proxy (Proxy)--import Control.Monad.IO.Class (liftIO)-import Control.Monad (liftM)--import Data.Typeable (Typeable)-import Data.Int (Int32, Int64)-import Data.Word (Word32, Word64)----type FFIConstConvert = FFI.ValueRef -> FFI.TypeRef -> IO FFI.ValueRef-type FFIConvert =- FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef ->- U.CString -> IO FFI.ValueRef--type FFIConstUnOp = FFI.ValueRef -> IO FFI.ValueRef-type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef--type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef-type FFIBinOp =- FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef ->- U.CString -> IO FFI.ValueRef--type FFIConstTrinOp =- FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef -> IO FFI.ValueRef-type FFITrinOp =- FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef ->- U.CString -> IO FFI.ValueRef---class ValueCons value where- switchValueCons :: f ConstValue -> f Value -> f value--instance ValueCons ConstValue where- switchValueCons f _ = f--instance ValueCons Value where- switchValueCons _ f = f---convert :: (ValueCons value, IsType b) =>- FFIConstConvert -> FFIConvert -> value a -> CodeGenFunction r (value b)-convert cop op =- getUnOp $- switchValueCons- (UnOp $ convertConstValue LP.Proxy cop)- (UnOp $ convertValue LP.Proxy op)--convertConstValue ::- (IsType b) =>- LP.Proxy b -> FFIConstConvert ->- ConstValue a -> CodeGenFunction r (ConstValue b)-convertConstValue proxy conv (ConstValue a) =- liftM ConstValue $ liftIO $ conv a =<< typeRef proxy--convertValue ::- (IsType b) =>- LP.Proxy b -> FFIConvert -> Value a -> CodeGenFunction r (Value b)-convertValue proxy conv (Value a) =- liftM Value $- withCurrentBuilder $ \ bldPtr -> do- typ <- typeRef proxy- U.withEmptyCString $ conv bldPtr a typ---newtype UnValue a value = UnValue {getUnValue :: value a -> FFI.ValueRef}--unValue :: (ValueCons value) => value a -> FFI.ValueRef-unValue =- getUnValue $- switchValueCons- (UnValue $ \(ConstValue a) -> a)- (UnValue $ \(Value a) -> a)--newtype UnOp a b r value =- UnOp {getUnOp :: value a -> CodeGenFunction r (value b)}--unop ::- (ValueCons value) =>- FFIConstUnOp -> FFIUnOp -> value a -> CodeGenFunction r (value b)-unop cop op =- getUnOp $- switchValueCons- (UnOp $ \(ConstValue a) -> liftIO $ fmap ConstValue $ cop a)- (UnOp $ \(Value a) ->- liftM Value $- withCurrentBuilder $ \ bld ->- U.withEmptyCString $ op bld a)--newtype BinOp a b c r value =- BinOp {getBinOp :: value a -> value b -> CodeGenFunction r (value c)}--binop ::- (ValueCons value) =>- FFIConstBinOp -> FFIBinOp ->- value a -> value b -> CodeGenFunction r (value c)-binop cop op =- getBinOp $- switchValueCons- (BinOp $ \(ConstValue a) (ConstValue b) ->- liftIO $ fmap ConstValue $ cop a b)- (BinOp $ \(Value a) (Value b) ->- liftM Value $- withCurrentBuilder $ \ bld ->- U.withEmptyCString $ op bld a b)--newtype TrinOp a b c d r value =- TrinOp {- getTrinOp ::- value a -> value b -> value c -> CodeGenFunction r (value d)- }--trinop ::- (ValueCons value) =>- FFIConstTrinOp -> FFITrinOp ->- value a -> value b -> value c -> CodeGenFunction r (value d)-trinop cop op =- getTrinOp $- switchValueCons- (TrinOp $ \(ConstValue a) (ConstValue b) (ConstValue c) ->- liftIO $ fmap ConstValue $ cop a b c)- (TrinOp $ \(Value a) (Value b) (Value c) ->- liftM Value $- withCurrentBuilder $ \ bld ->- U.withEmptyCString $ op bld a b c)------ | Acceptable arguments to 'getElementPointer'.-class GetElementPtr optr ixs where- type ElementPtrType optr ixs :: *- getIxList :: LP.Proxy optr -> ixs -> [FFI.ValueRef]---- | Acceptable single index to 'getElementPointer'.-class IsIndexArg a where- getArg :: a -> FFI.ValueRef--{- |-In principle we do not need the getValueArg method,-because we could just use 'unValue'.-However, we want to prevent users-from defining their own (disfunctional) IsIndexType instances.--}-class (IsPrimitive i) => IsIndexType i where- getValueArg :: (ValueCons value) => value i -> FFI.ValueRef--instance IsIndexType Word32 where- getValueArg = unValue--instance IsIndexType Word64 where- getValueArg = unValue--instance IsIndexType Int32 where- getValueArg = unValue--instance IsIndexType Int64 where- getValueArg = unValue--instance IsIndexType i => IsIndexArg (ConstValue i) where- getArg = getValueArg--instance IsIndexType i => IsIndexArg (Value i) where- getArg = getValueArg--instance IsIndexArg Word32 where- getArg = unConst . constOf--instance IsIndexArg Word64 where- getArg = unConst . constOf--instance IsIndexArg Int32 where- getArg = unConst . constOf--instance IsIndexArg Int64 where- getArg = unConst . constOf--unConst :: ConstValue a -> FFI.ValueRef-unConst (ConstValue v) = v---- End of indexing-instance GetElementPtr a () where- type ElementPtrType a () = a- getIxList LP.Proxy () = []---- Index in Array-instance- (GetElementPtr o i, IsIndexArg a, Dec.Natural k) =>- GetElementPtr (Array k o) (a, i) where- type ElementPtrType (Array k o) (a, i) = ElementPtrType o i- getIxList proxy (v, i) = getArg v : getIxList (LP.element proxy) i---- Index in Vector-instance- (GetElementPtr o i, IsIndexArg a, Dec.Positive k) =>- GetElementPtr (Vector k o) (a, i) where- type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i- getIxList proxy (v, i) = getArg v : getIxList (LP.element proxy) i--fieldProxy :: LP.Proxy (struct fs) -> Proxy a -> LP.Proxy (FieldType fs a)-fieldProxy LP.Proxy _proxy = LP.Proxy---- Index in Struct and PackedStruct.--- The index has to be a type level integer to statically determine the record field type-instance- (GetElementPtr (FieldType fs a) i, Dec.Natural a) =>- GetElementPtr (Struct fs) (Proxy a, i) where- type ElementPtrType (Struct fs) (Proxy a, i) =- ElementPtrType (FieldType fs a) i- getIxList proxy (a, i) =- unConst (constOf (Dec.integralFromProxy a :: Word32)) :- getIxList (fieldProxy proxy a) i-instance- (GetElementPtr (FieldType fs a) i, Dec.Natural a) =>- GetElementPtr (PackedStruct fs) (Proxy a, i) where- type ElementPtrType (PackedStruct fs) (Proxy a, i) =- ElementPtrType (FieldType fs a) i- getIxList proxy (a, i) =- unConst (constOf (Dec.integralFromProxy a :: Word32)) :- getIxList (fieldProxy proxy a) i--class GetField as i where type FieldType as i :: *-instance GetField (a, as) Dec.Zero where- type FieldType (a, as) Dec.Zero = a-instance- (GetField as (Pred (Dec.Pos i0 i1))) =>- GetField (a, as) (Dec.Pos i0 i1) where- type FieldType (a,as) (Dec.Pos i0 i1) = FieldType as (Pred (Dec.Pos i0 i1))----data CmpPredicate =- CmpEQ -- ^ equal- | CmpNE -- ^ not equal- | CmpGT -- ^ greater than- | CmpGE -- ^ greater or equal- | CmpLT -- ^ less than- | CmpLE -- ^ less or equal- deriving (Eq, Ord, Enum, Show, Typeable)--uintFromCmpPredicate :: CmpPredicate -> IntPredicate-uintFromCmpPredicate p =- case p of- CmpEQ -> IntEQ- CmpNE -> IntNE- CmpGT -> IntUGT- CmpGE -> IntUGE- CmpLT -> IntULT- CmpLE -> IntULE--sintFromCmpPredicate :: CmpPredicate -> IntPredicate-sintFromCmpPredicate p =- case p of- CmpEQ -> IntEQ- CmpNE -> IntNE- CmpGT -> IntSGT- CmpGE -> IntSGE- CmpLT -> IntSLT- CmpLE -> IntSLE--fpFromCmpPredicate :: CmpPredicate -> FPPredicate-fpFromCmpPredicate p =- case p of- CmpEQ -> FPOEQ- CmpNE -> FPONE- CmpGT -> FPOGT- CmpGE -> FPOGE- CmpLT -> FPOLT- CmpLE -> FPOLE
− src/LLVM/Core/Type.hs
@@ -1,627 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}--- |The LLVM type system is captured with a number of Haskell type classes.--- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type.--- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for--- those types that are LLVM first class types (passable as arguments etc).--- All valid LLVM types belong to the 'IsType' class.-module LLVM.Core.Type(- -- * Type classifier- IsType(..),- -- ** Special type classifiers- Dec.Natural,- Dec.Positive,- IsArithmetic(arithmeticType),- ArithmeticType(IntegerType,FloatingType),- IsInteger, Signed,- IsIntegerOrPointer,- IsFloating,- IsPrimitive,- IsFirstClass,- IsSized, SizeOf, sizeOf,- IsFunction,- -- ** Others- IsScalarOrVector,- ShapeOf, ScalarShape, VectorShape,- Shape, ShapedType,- StructFields,- UnknownSize, -- needed for arrays of structs- -- ** Structs- CurryStruct(..), consStruct,- UncurryStruct(uncurryStruct), Curried,- (:&), (&),- -- ** Type tests- TypeDesc(..),- isFloating,- isSigned,- typeRef,- unsafeTypeRef,- typeName,- intrinsicTypeName,- typeDesc2,- VarArgs, CastVarArgs,- ) where--import qualified LLVM.FFI.Core as FFI--import LLVM.Core.Util (functionType, structType)-import LLVM.Core.Data- (IntN, WordN, Vector, Array, FP128,- Struct(Struct), PackedStruct(PackedStruct), Label)-import LLVM.Util.Proxy (Proxy(Proxy))--import qualified Type.Data.Num.Decimal.Number as Dec-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)-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word8, Word16, Word32, Word64)---#include "MachDeps.h"---- TODO:--- Move IntN, WordN to a special module that implements those types--- properly in Haskell.--- 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 :: Proxy a -> TypeDesc--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) = 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) = withCode structType (mapM code ts) packed- code TDInvalidType = error "typeRef TDInvalidType"--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"- code TDFP128 = "f128"- code TDVoid = "void"- code (TDInt _ n) = "i" ++ show n- code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"- code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"- code (TDPtr a) = code a ++ "*"- code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"- code TDLabel = "label"- code (TDStruct as packed) = (if packed then "<{" else "{") ++- intercalate "," (map code as) ++- (if packed then "}>" else "}")- code TDInvalidType = error "typeName TDInvalidType"--intrinsicTypeName :: (IsType a) => Proxy a -> String-intrinsicTypeName = code . typeDesc- where code TDFloat = "f32"- code TDDouble = "f64"- code TDFP128 = "f128"- code (TDInt _ n) = "i" ++ show n- code (TDVector n a) = "v" ++ show n ++ code a- code _ = error "intrinsicTypeName: type not supported in intrinsics"--typeDesc2 :: FFI.TypeRef -> IO TypeDesc-typeDesc2 t = do- tk <- FFI.getTypeKind t- case tk of- FFI.VoidTypeKind -> return TDVoid- FFI.FloatTypeKind -> return TDFloat- FFI.DoubleTypeKind -> return TDDouble- -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80"- FFI.FP128TypeKind -> return TDFP128- -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128"- FFI.LabelTypeKind -> return TDLabel- FFI.IntegerTypeKind -> do- n <- FFI.getIntTypeWidth t- return $ TDInt False (fromIntegral n)- -- FIXME: FFI.FunctionTypeKind- -- FIXME: FFI.StructTypeKind -> return "(Struct ...)"- FFI.ArrayTypeKind -> do- n <- FFI.getArrayLength t- et <- FFI.getElementType t- etd <- typeDesc2 et- return $ TDArray (fromIntegral n) etd- FFI.PointerTypeKind -> do- et <- FFI.getElementType t- etd <- typeDesc2 et- return $ TDPtr etd- -- FIXME: FFI.OpaqueTypeKind -> return "Opaque"- FFI.VectorTypeKind -> do- n <- FFI.getVectorSize t- et <- FFI.getElementType t- etd <- typeDesc2 et- return $ TDVector (fromIntegral n) etd- -- FIXME: LLVMMetadataTypeKind, /**< Metadata */- -- FIXME: LLVMX86_MMXTypeKind /**< X86 MMX */- _ -> return TDInvalidType---- |Type descriptor, used to convey type information through the LLVM API.-data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer- | TDArray Integer TypeDesc | TDVector Integer TypeDesc- | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel- | TDStruct [TypeDesc] Bool | TDInvalidType- deriving (Eq, Ord, Show, Typeable)---- XXX isFloating and typeName could be extracted from typeRef--- Usage:--- superclass of IsConst--- add, sub, mul, neg context--- used to get type name to call intrinsic--- |Arithmetic types, i.e., integral and floating types.-class IsFirstClass a => IsArithmetic a where- arithmeticType :: ArithmeticType a--data ArithmeticType a = IntegerType | FloatingType--instance Functor ArithmeticType where- 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--- used to find signedness in Arithmetic--- |Integral types.-class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where- type Signed a :: *---- Usage:--- icmp--- |Integral or pointer type.-class IsIntegerOrPointer a--isSigned :: (IsArithmetic a) => Proxy a -> Bool-isSigned = is . typeDesc- where is (TDInt s _) = s- is (TDVector _ a) = is a- is TDFloat = True- is TDDouble = True- is TDFP128 = True- is _ = error "isSigned got impossible input"---- Usage:--- constF--- many instructions--- |Floating types.-class IsArithmetic a => IsFloating a--isFloating :: (IsArithmetic a) => Proxy a -> Bool-isFloating = is . typeDesc- where is TDFloat = True- is TDDouble = True- is TDFP128 = True- is (TDVector _ a) = is a- is _ = False---- Usage:--- Precondition for Vector--- |Primitive types.--- class (IsType a) => IsPrimitive a-class (IsScalarOrVector a, ShapeOf a ~ ScalarShape) => IsPrimitive a--data ScalarShape-data VectorShape n--class Shape shape where- type ShapedType shape a :: *--instance Shape ScalarShape where- type ShapedType ScalarShape a = a--instance Shape (VectorShape n) where- type ShapedType (VectorShape n) a = Vector n a---- |Number of elements for instructions that handle both primitive and vector types-class (IsFirstClass a) => IsScalarOrVector a where- type ShapeOf a :: *----- Usage:--- Precondition for function args and result.--- Used by some instructions, like ret and phi.--- XXX IsSized as precondition?--- |First class types, i.e., the types that can be passed as arguments, etc.-class IsType a => IsFirstClass a---- Usage:--- Context for Array being a type--- thus, allocation instructions--- |Types with a fixed size.-class (IsType a, Dec.Natural (SizeOf a)) => IsSized a where- type SizeOf a :: *--sizeOf :: TypeDesc -> Integer-sizeOf TDFloat = 32-sizeOf TDDouble = 64-sizeOf TDFP128 = 128-sizeOf (TDInt _ bits) = bits-sizeOf (TDArray n typ) = n * sizeOf typ-sizeOf (TDVector n typ) = n * sizeOf typ-sizeOf (TDStruct ts _packed) = sum (map sizeOf ts)-sizeOf _ = error "type has no size"---- |Function type.-class (IsType a) => IsFunction a where- funcType :: [TypeDesc] -> Proxy a -> TypeDesc---- Only make instances for types that make sense in Haskell--- (i.e., some floating types are excluded).---- Floating point types.-instance IsType Float where typeDesc _ = TDFloat-instance IsType Double where typeDesc _ = TDDouble-instance IsType FP128 where typeDesc _ = TDFP128---- Void type-instance IsType () where typeDesc _ = TDVoid---- Label type-instance IsType Label where typeDesc _ = TDLabel---- Variable size integer types-instance (Dec.Positive n) => IsType (IntN n)- where typeDesc _ =- TDInt True- (Dec.integralFromSingleton (Dec.singleton :: Dec.Singleton 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-instance IsType Word8 where typeDesc _ = TDInt False 8-instance IsType Word16 where typeDesc _ = TDInt False 16-instance IsType Word32 where typeDesc _ = TDInt False 32-instance IsType Word64 where typeDesc _ = TDInt False 64-instance IsType Int8 where typeDesc _ = TDInt True 8-instance IsType Int16 where typeDesc _ = TDInt True 16-instance IsType Int32 where typeDesc _ = TDInt True 32-instance IsType Int64 where typeDesc _ = TDInt True 64---- Sequence types-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 (Proxy :: Proxy a))--instance (IsFunction f) => IsType (FunPtr f) where- typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy f))--instance IsType (StablePtr a) where- typeDesc _ = TDPtr (typeDesc (Proxy :: Proxy Int8))-{-- typeDesc _ = TDPtr TDVoid--List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed.--}----- Functions.-instance (IsFirstClass a, IsFunction b) => IsType (a->b) where- typeDesc = funcType []---- Function base type, always IO.-instance (IsFirstClass a) => IsType (IO a) where- typeDesc = funcType []---- Struct types, basically a list of component types.-instance (StructFields a) => IsType (Struct a) where- typeDesc p = TDStruct (fieldTypes $ fmap (\(Struct a) -> a) p) False--instance (StructFields a) => IsType (PackedStruct a) where- typeDesc p = TDStruct (fieldTypes $ fmap (\(PackedStruct a) -> a) p) True---- Use a nested tuples for struct fields.-class StructFields as where- fieldTypes :: Proxy as -> [TypeDesc]--instance (IsSized a, StructFields as) => StructFields (a :& as) where- fieldTypes p = typeDesc (fmap fst p) : fieldTypes (fmap snd p)-instance StructFields () where- fieldTypes Proxy = []----- Simplifies construction, pattern matching and conversion to and from records-class CurryStruct f where- type UncurriedArgument f- type UncurriedResult f- curryStruct :: (Struct (UncurriedArgument f) -> UncurriedResult f) -> f--instance CurryStruct (Struct a) where- type UncurriedArgument (Struct a) = ()- type UncurriedResult (Struct a) = Struct a- curryStruct g = g $ Struct ()--instance (CurryStruct f) => CurryStruct (a->f) where- type UncurriedArgument (a->f) = (a, UncurriedArgument f)- type UncurriedResult (a->f) = UncurriedResult f- curryStruct g a = curryStruct (\(Struct r) -> g $ Struct (a,r))--consStruct ::- (CurryStruct f, UncurriedResult f ~ Struct (UncurriedArgument f)) => f-consStruct = curryStruct id--class UncurryStruct a where- type Curried a b- curryStruct' :: (Struct a -> b) -> Curried a b- uncurryStruct :: Curried a b -> Struct a -> b--instance UncurryStruct () where- type Curried () b = b- curryStruct' f = f $ Struct ()- uncurryStruct f (Struct ()) = f--instance (UncurryStruct r) => UncurryStruct (a,r) where- type Curried (a,r) b = a -> Curried r b- curryStruct' f a = curryStruct' (\(Struct r) -> f $ Struct (a,r))- uncurryStruct f (Struct (a,r)) = uncurryStruct (f a) $ Struct r---- An alias for pairs to make structs look nicer-infixr :&-type (:&) a as = (a, as)-infixr &-(&) :: a -> as -> a :& as-a & as = (a, as)------ Instances to classify types-instance IsArithmetic Float where arithmeticType = FloatingType-instance IsArithmetic Double where arithmeticType = FloatingType-instance IsArithmetic FP128 where arithmeticType = FloatingType-instance (Dec.Positive n) => IsArithmetic (IntN n) where arithmeticType = IntegerType-instance (Dec.Positive n) => IsArithmetic (WordN n) where arithmeticType = IntegerType-{--This instance is more dangerous than useful.-E.g. 'inv' can be mixed up with 'neg'.-For arithmetic on i1 you might better use @IntN D1@ or @WordN D1@.--}-instance IsArithmetic Bool where arithmeticType = IntegerType-instance IsArithmetic Int8 where arithmeticType = IntegerType-instance IsArithmetic Int16 where arithmeticType = IntegerType-instance IsArithmetic Int32 where arithmeticType = IntegerType-instance IsArithmetic Int64 where arithmeticType = IntegerType-instance IsArithmetic Word8 where arithmeticType = IntegerType-instance IsArithmetic Word16 where arithmeticType = IntegerType-instance IsArithmetic Word32 where arithmeticType = IntegerType-instance IsArithmetic Word64 where arithmeticType = IntegerType-instance (Dec.Positive n, IsPrimitive a, IsArithmetic a) =>- IsArithmetic (Vector n a) where- arithmeticType = vectorArithmeticType arithmeticType--- arithmeticType = fmap (pure :: a -> Vector n a) arithmeticType--instance IsFloating Float-instance IsFloating Double-instance IsFloating FP128-instance (Dec.Positive n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)--data NotANumber--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-instance IsInteger Int32 where type Signed Int32 = True-instance IsInteger Int64 where type Signed Int64 = True-instance IsInteger Word8 where type Signed Word8 = False-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 (Dec.Positive n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)- where type Signed (Vector n a) = Signed a--instance (Dec.Positive n) => IsIntegerOrPointer (IntN n)-instance (Dec.Positive n) => IsIntegerOrPointer (WordN n)-instance IsIntegerOrPointer Bool-instance IsIntegerOrPointer Int8-instance IsIntegerOrPointer Int16-instance IsIntegerOrPointer Int32-instance IsIntegerOrPointer Int64-instance IsIntegerOrPointer Word8-instance IsIntegerOrPointer Word16-instance IsIntegerOrPointer Word32-instance IsIntegerOrPointer Word64-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 (Dec.Positive n) => IsFirstClass (IntN n)-instance (Dec.Positive n) => IsFirstClass (WordN n)-instance IsFirstClass Bool-instance IsFirstClass Int8-instance IsFirstClass Int16-instance IsFirstClass Int32-instance IsFirstClass Int64-instance IsFirstClass Word8-instance IsFirstClass Word16-instance IsFirstClass Word32-instance IsFirstClass Word64-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 (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-instance IsSized Bool where type SizeOf Bool = D1-instance IsSized Int8 where type SizeOf Int8 = D8-instance IsSized Int16 where type SizeOf Int16 = D16-instance IsSized Int32 where type SizeOf Int32 = D32-instance IsSized Int64 where type SizeOf Int64 = D64-instance IsSized Word8 where type SizeOf Word8 = D8-instance IsSized Word16 where type SizeOf Word16 = D16-instance IsSized Word32 where type SizeOf Word32 = D32-instance IsSized Word64 where type SizeOf Word64 = D64-{--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- (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 :(-instance (StructFields as) => IsSized (Struct as) where- type SizeOf (Struct as) = UnknownSize-instance (StructFields as) => IsSized (PackedStruct as) where- type SizeOf (PackedStruct as) = UnknownSize--type UnknownSize = D99 -- XXX this is wrong!--#if WORD_SIZE_IN_BITS == 32-type PtrSize = D32-#elif WORD_SIZE_IN_BITS == 64-type PtrSize = D64-#else-#error cannot determine type of PtrSize-#endif--instance IsPrimitive Float-instance IsPrimitive Double-instance IsPrimitive FP128-instance (Dec.Positive n) => IsPrimitive (IntN n)-instance (Dec.Positive n) => IsPrimitive (WordN n)-instance IsPrimitive Bool-instance IsPrimitive Int8-instance IsPrimitive Int16-instance IsPrimitive Int32-instance IsPrimitive Int64-instance IsPrimitive Word8-instance IsPrimitive Word16-instance IsPrimitive Word32-instance IsPrimitive Word64-instance IsPrimitive Label-instance IsPrimitive ()-instance (IsType a) => IsPrimitive (Ptr a)---instance (Dec.Positive n) =>- IsScalarOrVector (IntN n) where type ShapeOf (IntN n) = ScalarShape-instance (Dec.Positive n) =>- IsScalarOrVector (WordN n) where type ShapeOf (WordN n) = ScalarShape-instance IsScalarOrVector Float where type ShapeOf Float = ScalarShape-instance IsScalarOrVector Double where type ShapeOf Double = ScalarShape-instance IsScalarOrVector FP128 where type ShapeOf FP128 = ScalarShape-instance IsScalarOrVector Bool where type ShapeOf Bool = ScalarShape-instance IsScalarOrVector Int8 where type ShapeOf Int8 = ScalarShape-instance IsScalarOrVector Int16 where type ShapeOf Int16 = ScalarShape-instance IsScalarOrVector Int32 where type ShapeOf Int32 = ScalarShape-instance IsScalarOrVector Int64 where type ShapeOf Int64 = ScalarShape-instance IsScalarOrVector Word8 where type ShapeOf Word8 = ScalarShape-instance IsScalarOrVector Word16 where type ShapeOf Word16 = ScalarShape-instance IsScalarOrVector Word32 where type ShapeOf Word32 = ScalarShape-instance IsScalarOrVector Word64 where type ShapeOf Word64 = ScalarShape-instance IsScalarOrVector Label where type ShapeOf Label = ScalarShape-instance IsScalarOrVector () where type ShapeOf () = ScalarShape-instance (IsType a) =>- IsScalarOrVector (Ptr a) where type ShapeOf (Ptr a) = ScalarShape--instance (Dec.Positive n, IsPrimitive a) =>- IsScalarOrVector (Vector n a) where- type ShapeOf (Vector n a) = VectorShape n----- Functions.-instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where- 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 (Proxy :: Proxy a))-instance (IsFirstClass a) => IsFunction (VarArgs a) where- 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'.-data VarArgs a- deriving (Typeable)-instance IsType (VarArgs a) where- typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly"---- |Define what vararg types are permissible.-class CastVarArgs a b-instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c)-instance CastVarArgs (VarArgs a) (IO a)-instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c)------- XXX Structures not implemented. Tuples is probably an easy way.-
− src/LLVM/Core/UnaryVector.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module LLVM.Core.UnaryVector (- T, vector, cyclicVector,- FixedLength.fromFixedList, FixedLength.toFixedList, FixedLength.head,- FixedList, Length,- FixedLength.Curried, FixedLength.uncurry,- ) where--import qualified Type.Data.Num.Unary as Unary--import qualified Data.FixedLength as FixedLength-import Data.FixedLength (T, List, Length, end, (!:))--import qualified Data.NonEmpty as NonEmpty--import Prelude hiding (head)---type FixedList n = List n---vector :: (Unary.Natural n, n ~ Length (List n)) => List n a -> T n a-vector = FixedLength.fromFixedList--cyclicVector :: (Unary.Natural n) => NonEmpty.T [] a -> T n a-cyclicVector xt@(NonEmpty.Cons x xs) =- runOp0 $- Unary.switchNat- (Op0 end)- (Op0 $ x !: cyclicVectorAppend xt xs)--cyclicVectorAppend :: (Unary.Natural n) => NonEmpty.T [] a -> [a] -> T n a-cyclicVectorAppend ys xt =- runOp0 $- Unary.switchNat- (Op0 end)- (Op0 $- case xt of- [] -> cyclicVector ys- x:xs -> x !: cyclicVectorAppend ys xs)--newtype Op0 a n = Op0 {runOp0 :: T n a}
− src/LLVM/Core/Util.hs
@@ -1,480 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.Core.Util(- -- * Module handling- Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,- getModuleValues, getFunctions, getGlobalVariables, valueHasType,- -- * Pass manager handling- PassManager(..), withPassManager, createPassManager, createFunctionPassManager,- runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager,- -- * Instruction builder- Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock,- -- * Basic blocks- BasicBlock,- appendBasicBlock, getBasicBlocks,- -- * Functions- Function,- addFunction, getParam, getParams,- -- * Structs- structType,- -- * Globals- addGlobal,- constString, constStringNul, constVector, constArray, constStruct,- -- * Instructions- makeCall, makeInvoke,- makeCallWithCc, makeInvokeWithCc,- withValue, getInstructions, getOperands,- -- * Uses and Users- hasUsers, getUsers, getUses, getUser, isChildOf, getDep,- -- * Misc- CString, withArrayLen,- withEmptyCString,- functionType, buildEmptyPhi, addPhiIns,- showTypeOf, getValueNameU, getObjList, annotateValueList,- isConstant, isIntrinsic,- -- * Transformation passes- addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,- addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,- ) where--import qualified LLVM.FFI.Core as FFI-import qualified LLVM.FFI.BitWriter as FFI-import qualified LLVM.FFI.BitReader as FFI-import qualified LLVM.FFI.Transforms.Scalar as FFI--import Foreign.C.String (withCString, withCStringLen, CString, peekCString)-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray)-import Foreign.Marshal.Alloc (alloca)-import Foreign.Storable (Storable(..))-import System.IO.Unsafe (unsafePerformIO)--import Data.Typeable (Typeable)-import Data.List (intercalate)-import Control.Monad (liftM, when)---type Type = FFI.TypeRef--functionType :: Bool -> Type -> [Type] -> IO Type-functionType varargs retType paramTypes =- withArrayLen paramTypes $ \ len ptr ->- FFI.functionType retType ptr (fromIntegral len) (FFI.consBool varargs)--structType :: [Type] -> Bool -> IO Type-structType types packed =- withArrayLen types $ \ len ptr ->- FFI.structType ptr (fromIntegral len) (FFI.consBool packed)------------------------------------------- Handle modules---- Don't use a finalizer for the module, but instead provide an--- explicit destructor. This is because handing a module to--- a module provider changes ownership of the module to the provider,--- and we don't want to free it by mistake.---- | Type of top level modules.-newtype Module = Module {- fromModule :: FFI.ModuleRef- }- deriving (Show, Typeable)--withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a-withModule modul f = f (fromModule modul)--createModule :: String -> IO Module-createModule name =- withCString name $ \ namePtr -> do- liftM Module $ FFI.moduleCreateWithName namePtr---- | Free all storage related to a module. *Note*, this is a dangerous call, since referring--- to the module after this call is an error. The reason for the explicit call to free--- the module instead of an automatic lifetime management is that modules have a--- somewhat complicated ownership. Handing a module to a module provider changes--- the ownership of the module, and the module provider will free the module when necessary.-destroyModule :: Module -> IO ()-destroyModule = FFI.disposeModule . fromModule---- |Write a module to a file.-writeBitcodeToFile :: String -> Module -> IO ()-writeBitcodeToFile name mdl =- withCString name $ \ namePtr ->- withModule mdl $ \ mdlPtr -> do- rc <- FFI.writeBitcodeToFile mdlPtr namePtr- when (rc /= 0) $- ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc---- |Read a module from a file.-readBitcodeFromFile :: String -> IO Module-readBitcodeFromFile name =- withCString name $ \ namePtr ->- alloca $ \ bufPtr ->- alloca $ \ modPtr ->- alloca $ \ errStr -> do- rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr- if FFI.deconsBool rrc then do- msg <- peek errStr >>= peekCString- ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg- else do- buf <- peek bufPtr- prc <- FFI.parseBitcode buf modPtr errStr- if FFI.deconsBool prc then do- msg <- peek errStr >>= peekCString- ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg- else do- ptr <- peek modPtr- return $ Module ptr-{-- liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr--}--getModuleValues :: Module -> IO [(String, Value)]-getModuleValues mdl = do- fs <- getFunctions mdl- gs <- getGlobalVariables mdl- return (fs ++ gs)--getFunctions :: Module -> IO [(String, Value)]-getFunctions mdl =- getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl- >>= annotateValueList--getGlobalVariables :: Module -> IO [(String, Value)]-getGlobalVariables mdl =- getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl- >>= annotateValueList---- This is safe because we just ask for the type of a value.-valueHasType :: Value -> Type -> Bool-valueHasType v t = unsafePerformIO $ do- vt <- FFI.typeOf v- return $ vt == t -- LLVM uses hash consing for types, so pointer equality works.--showTypeOf :: Value -> IO String-showTypeOf v = FFI.typeOf v >>= showType'--showType' :: Type -> IO String-showType' p = do- pk <- FFI.getTypeKind p- case pk of- FFI.VoidTypeKind -> return "()"- FFI.FloatTypeKind -> return "Float"- FFI.DoubleTypeKind -> return "Double"- FFI.X86_FP80TypeKind -> return "X86_FP80"- FFI.FP128TypeKind -> return "FP128"- FFI.PPC_FP128TypeKind -> return "PPC_FP128"- FFI.LabelTypeKind -> return "Label"- FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"- FFI.FunctionTypeKind -> do- r <- FFI.getReturnType p- c <- FFI.countParamTypes p- let n = fromIntegral c- as <- allocaArray n $ \ args -> do- FFI.getParamTypes p args- peekArray n args- ts <- mapM showType' (as ++ [r])- return $ "(" ++ intercalate " -> " ts ++ ")"- FFI.StructTypeKind -> return "(Struct ...)"- FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"- FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"- FFI.OpaqueTypeKind -> return "Opaque"- FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")"------------------------------------------- Handle instruction builders--newtype Builder = Builder {- fromBuilder :: ForeignPtr FFI.Builder- }- deriving (Show, Typeable)--withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a-withBuilder = withForeignPtr . fromBuilder--createBuilder :: IO Builder-createBuilder = do- ptr <- FFI.createBuilder- liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr--positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO ()-positionAtEnd bld bblk =- withBuilder bld $ \ bldPtr ->- FFI.positionAtEnd bldPtr bblk--getInsertBlock :: Builder -> IO FFI.BasicBlockRef-getInsertBlock bld =- withBuilder bld $ \ bldPtr ->- FFI.getInsertBlock bldPtr------------------------------------------type BasicBlock = FFI.BasicBlockRef--appendBasicBlock :: Function -> String -> IO BasicBlock-appendBasicBlock func name =- withCString name $ \ namePtr ->- FFI.appendBasicBlock func namePtr--getBasicBlocks :: Value -> IO [(String, BasicBlock)]-getBasicBlocks v =- getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v- >>= annotateBasicBlockList------------------------------------------type Function = FFI.ValueRef--addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function-addFunction modul linkage name typ =- withModule modul $ \ modulPtr ->- withCString name $ \ namePtr -> do- f <- FFI.addFunction modulPtr namePtr typ- FFI.setLinkage f (FFI.fromLinkage linkage)- return f--getParam :: Function -> Int -> Value-getParam f = unsafePerformIO . FFI.getParam f . fromIntegral--getParams :: Value -> IO [(String, Value)]-getParams v =- getObjList withValue FFI.getFirstParam FFI.getNextParam v- >>= annotateValueList------------------------------------------addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value-addGlobal modul linkage name typ =- withModule modul $ \ modulPtr ->- withCString name $ \ namePtr -> do- v <- FFI.addGlobal modulPtr typ namePtr- FFI.setLinkage v (FFI.fromLinkage linkage)- return v---- unsafePerformIO is safe because it's only used for the withCStringLen conversion-constStringInternal :: Bool -> String -> Value-constStringInternal nulTerm s = unsafePerformIO $- withCStringLen s $ \(sPtr, sLen) ->- FFI.constString sPtr (fromIntegral sLen) (FFI.consBool (not nulTerm))--constString :: String -> Value-constString = constStringInternal False--constStringNul :: String -> Value-constStringNul = constStringInternal True------------------------------------------type Value = FFI.ValueRef--withValue :: Value -> (Value -> IO a) -> IO a-withValue v f = f v--withBasicBlock :: FFI.BasicBlockRef -> (FFI.BasicBlockRef -> IO a) -> IO a-withBasicBlock v f = f v--makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value-makeCall = makeCallWithCc FFI.C--makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value-makeCallWithCc cc func bldPtr args = do-{-- print "makeCall"- FFI.dumpValue func- mapM_ FFI.dumpValue args- print "----------------------"--}- withArrayLen args $ \ argLen argPtr ->- withEmptyCString $ \cstr -> do- i <- FFI.buildCall bldPtr func argPtr- (fromIntegral argLen) cstr- FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)- return i--makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->- [Value] -> IO Value-makeInvoke = makeInvokeWithCc FFI.C--makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->- [Value] -> IO Value-makeInvokeWithCc cc norm expt func bldPtr args =- withArrayLen args $ \ argLen argPtr ->- withEmptyCString $ \cstr -> do- i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr- FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)- return i--getInstructions :: BasicBlock -> IO [(String, Value)]-getInstructions bb =- getObjList withBasicBlock FFI.getFirstInstruction FFI.getNextInstruction bb- >>= annotateValueList--getOperands :: Value -> IO [(String, Value)]-getOperands ii = geto ii >>= annotateValueList- where geto i = do- num <- FFI.getNumOperands i- let oloop instr number total = if number >= total then return [] else do- o <- FFI.getOperand instr number- os <- oloop instr (number + 1) total- return (o : os)- oloop i 0 num------------------------------------------buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value-buildEmptyPhi bldPtr typ = do- withEmptyCString $ FFI.buildPhi bldPtr typ--withEmptyCString :: (CString -> IO a) -> IO a-withEmptyCString = withCString ""--addPhiIns :: Value -> [(Value, BasicBlock)] -> IO ()-addPhiIns inst incoming = do- let (vals, bblks) = unzip incoming- withArrayLen vals $ \ count valPtr ->- withArray bblks $ \ bblkPtr ->- FFI.addIncoming inst valPtr bblkPtr (fromIntegral count)-------------------------------------------- | Manage compile passes.-newtype PassManager = PassManager {- fromPassManager :: ForeignPtr FFI.PassManager- }- deriving (Show, Typeable)--withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)- -> IO a-withPassManager = withForeignPtr . fromPassManager---- | Create a pass manager.-createPassManager :: IO PassManager-createPassManager = do- ptr <- FFI.createPassManager- liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr---- | Create a pass manager for a module.-createFunctionPassManager :: Module -> IO PassManager-createFunctionPassManager modul =- withModule modul $ \modulPtr -> do- ptr <- FFI.createFunctionPassManagerForModule modulPtr- liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr---- | Add a control flow graph simplification pass to the manager.-addCFGSimplificationPass :: PassManager -> IO ()-addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass---- | Add a constant propagation pass to the manager.-addConstantPropagationPass :: PassManager -> IO ()-addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass--addDemoteMemoryToRegisterPass :: PassManager -> IO ()-addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass---- | Add a global value numbering pass to the manager.-addGVNPass :: PassManager -> IO ()-addGVNPass pm = withPassManager pm FFI.addGVNPass--addInstructionCombiningPass :: PassManager -> IO ()-addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass--addPromoteMemoryToRegisterPass :: PassManager -> IO ()-addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass--addReassociatePass :: PassManager -> IO ()-addReassociatePass pm = withPassManager pm FFI.addReassociatePass--runFunctionPassManager :: PassManager -> Function -> IO FFI.Bool-runFunctionPassManager pm fcn = withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn--initializeFunctionPassManager :: PassManager -> IO FFI.Bool-initializeFunctionPassManager pm = withPassManager pm FFI.initializeFunctionPassManager--finalizeFunctionPassManager :: PassManager -> IO FFI.Bool-finalizeFunctionPassManager pm = withPassManager pm FFI.finalizeFunctionPassManager------------------------------------------constVector :: [Value] -> IO Value-constVector xs = do- withArrayLen xs $ \ len ptr ->- FFI.constVector ptr (fromIntegral len)--constArray :: Type -> [Value] -> IO Value-constArray t xs = do- withArrayLen xs $ \ len ptr ->- FFI.constArray t ptr (fromIntegral len)--constStruct :: [Value] -> Bool -> IO Value-constStruct xs packed = do- withArrayLen xs $ \ len ptr ->- FFI.constStruct ptr (fromIntegral len) (FFI.consBool packed)------------------------------------------getValueNameU :: Value -> IO String-getValueNameU a = do- -- sometimes void values need explicit names too- str <- peekCString =<< FFI.getValueName a- if str == "" then return (show a) else return str--getBasicBlockNameU :: BasicBlock -> IO String-getBasicBlockNameU a = do- str <- peekCString =<< FFI.getBasicBlockName a- if str == "" then return (show a) else return str--getObjList ::- (obj -> (objPtr -> IO [Ptr a]) -> io) -> (objPtr -> IO (Ptr a)) ->- (Ptr a -> IO (Ptr a)) -> obj -> io-getObjList withF firstF nextF obj =- withF obj $ \ objPtr -> do- let oloop p =- if p == nullPtr- then return []- else fmap (p:) $ oloop =<< nextF p- oloop =<< firstF objPtr--annotateValueList :: [Value] -> IO [(String, Value)]-annotateValueList vs = do- names <- mapM getValueNameU vs- return $ zip names vs--annotateBasicBlockList :: [BasicBlock] -> IO [(String, BasicBlock)]-annotateBasicBlockList vs = do- names <- mapM getBasicBlockNameU vs- return $ zip names vs--isConstant :: Value -> IO Bool-isConstant v = fmap FFI.deconsBool $ FFI.isConstant v--isIntrinsic :: Value -> IO Bool-isIntrinsic v = fmap (/=0) $ FFI.getIntrinsicID v------------------------------------------type Use = FFI.UseRef--hasUsers :: Value -> IO Bool-hasUsers v = fmap (>0) $ FFI.getNumUses v--getUses :: Value -> IO [Use]-getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse--getUsers :: [Use] -> IO [(String, Value)]-getUsers us = mapM FFI.getUser us >>= annotateValueList--getUser :: Use -> IO Value-getUser = FFI.getUser--isChildOf :: BasicBlock -> Value -> IO Bool-isChildOf bb v = do- bb2 <- FFI.getInstructionParent v- return $ bb == bb2--getDep :: Use -> IO (String, String)-getDep u = do- producer <- FFI.getUsedValue u >>= getValueNameU- consumer <- FFI.getUser u >>= getValueNameU- return (producer, consumer)
− src/LLVM/Core/Vector.hs
@@ -1,277 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-}-module LLVM.Core.Vector (MkVector(..), vector, cyclicVector, ) where--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 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 qualified Foreign.Storable.Traversable as Store-import Foreign.Storable (Storable(..))--import qualified Test.QuickCheck as QC--import qualified Control.Monad.Trans.State as MS-import Control.Applicative (Applicative, pure, liftA2, (<*>))-import Control.Functor.HT (unzip, outerProduct)--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, uncurry)----- XXX Should these really be here?-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 D2 a where- type Tuple D2 a = (a,a)- toVector (a1, a2) = vector (a1 !: a2 !: Empty.Cons)- fromVector = uncurry $ \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 !: Empty.Cons)- fromVector = uncurry $ \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 !: Empty.Cons)- fromVector =- uncurry $ \a1 a2 a3 a4 a5 a6 a7 a8 ->- (a1, a2, a3, a4, a5, a6, a7, a8)---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.fromFixedList xs--decimalFromUnaryVector :: UnaryVector.T (Dec.ToUnary n) a -> Vector n a-decimalFromUnaryVector = Vector . UnaryVector.toFixedList---type Curried n a b = UnaryVector.Curried (Dec.ToUnary n) a b--uncurry ::- (Dec.Natural n) =>- Curried n a b -> Vector n a -> b-uncurry f =- withNatDict1 $ \dict v ->- case dict of- DecProof.UnaryNat ->- UnaryVector.uncurry 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 :: Target.TargetData-ourTargetData = unsafePerformIO Target.getTargetData------------------------------------------{- 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--}--vector ::- (Dec.Positive n) =>- FixedList (Dec.ToUnary n) a -> Vector n a-vector = Vector--{- |-Make a constant vector. Replicates or truncates the list to get length /n/.-This behaviour is consistent uncurry that of 'LLVM.Core.CodeGen.constCyclicVector'.-May be abused for constructing vectors from lists uncurry statically unknown size.--}-cyclicVector :: (Dec.Positive n) => NonEmpty.T [] a -> Vector n a-cyclicVector xs =- withUnaryDecVector (UnaryVector.cyclicVector xs)---replicate :: (Dec.Positive n) => a -> Vector n a-replicate a = withUnaryDecVector (pure a)---instance (Dec.Positive n) => Functor (Vector n) where- fmap f a =- withUnaryDecVector (fmap f $ unaryFromDecimalVector a)--instance (Dec.Positive n) => Applicative (Vector n) where- pure = replicate- f <*> a =- withUnaryDecVector- (unaryFromDecimalVector f <*> unaryFromDecimalVector a)--instance (Dec.Positive n) => Foldable (Vector n) where- foldMap = foldMapDefault--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 = pure . toEnum--instance (Real a, Dec.Positive n) => Real (Vector n a) where- toRational = error "Vector toRational"--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, Dec.Positive n) => Fractional (Vector n a) where- (/) = liftA2 (/)- fromRational = pure . fromRational--instance (RealFrac a, Dec.Positive n) => RealFrac (Vector n a) where- properFraction = error "Vector properFraction"--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, 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- scaleFloat 0 x = x- scaleFloat _ _ = error "Vector scaleFloat"- isNaN = error "Vector isNaN"- isInfinite = error "Vector isInfinite"- isDenormalized = error "Vector isDenormalized"- isNegativeZero = error "Vector isNegativeZero"- isIEEE = isIEEE . head---indices :: (Dec.Positive n) => Vector n Int-indices =- flip MS.evalState 0 $ Trav.sequenceA $ replicate $ MS.state (\k -> (k,k+1))--instance (Dec.Positive n, QC.Arbitrary a) => QC.Arbitrary (Vector n a) where- arbitrary = Trav.sequenceA $ replicate QC.arbitrary- shrink v =- case indices of- ixs ->- concatMap- (Trav.sequenceA .- liftA2- (\x doShrink ->- if doShrink then QC.shrink x else [x]) v) $- outerProduct (==) (Fold.toList ixs) ixs
src/LLVM/ExecutionEngine.hs view
@@ -9,6 +9,7 @@ runEngineAccessWithModule, addModule, ExecutionFunction,+ Importer, getExecutionFunction, getPointerToFunction, addFunctionValue,@@ -26,11 +27,17 @@ module LLVM.ExecutionEngine.Target, -- * Exchange data with JIT code in memory Marshal.Marshal(..),+ Marshal.MarshalVector(..), Marshal.sizeOf, Marshal.alignment, Marshal.StructFields, Marshal.sizeOfArray, Marshal.pokeList,+ Marshal.with,+ Marshal.alloca,+ Marshal.Stored(..),+ Marshal.castToStoredPtr,+ Marshal.castFromStoredPtr, ) where import qualified LLVM.ExecutionEngine.Marshal as Marshal
− src/LLVM/ExecutionEngine/Engine.hs
@@ -1,297 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.ExecutionEngine.Engine(- EngineAccess,- ExecutionEngine(..),- getEngine,- runEngineAccess, runEngineAccessWithModule,- runEngineAccessInterpreterWithModule,- getExecutionEngineTargetData,- ExecutionFunction,- getExecutionFunction,- getPointerToFunction,- addModule,- addFunctionValue, addGlobalMappings,- runFunction, getRunFunction,- 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, withModule, createModule)-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 (consBool, deconsBool, )--import qualified Control.Monad.Trans.Reader as MR-import Control.Monad.IO.Class (MonadIO, liftIO, )-import Control.Monad (liftM, )-import Control.Applicative (Applicative, pure, (<*>), (<$>), )--import qualified Data.EnumBitSet as EnumSet-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, touchForeignPtr)-import Foreign.C.String (peekCString)-import Foreign.Ptr (Ptr, FunPtr, )-import Foreign.Storable (peek)-import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )-import System.IO.Unsafe (unsafePerformIO)---newtype- ExecutionEngine = ExecutionEngine {- fromEngine :: ForeignPtr FFI.ExecutionEngine- }--withEngine :: ExecutionEngine -> (FFI.ExecutionEngineRef -> IO a) -> IO a-withEngine = withForeignPtr . fromEngine--createExecutionEngineForModule ::- Bool -> FFI.EngineKindSet -> Module -> IO ExecutionEngine-createExecutionEngineForModule hostCPU kind m =- alloca $ \eePtr ->- alloca $ \errPtr -> do- success <-- withModule m $ \mPtr ->- if hostCPU- then- FFI.createExecutionEngineKindForModuleCPU- eePtr kind mPtr errPtr- else- if EnumSet.get FFI.JIT kind- then FFI.createExecutionEngineForModule eePtr mPtr errPtr- else FFI.createInterpreterForModule eePtr mPtr errPtr- if FFI.deconsBool success- then do- err <- peek errPtr- errStr <- peekCString err- free err- ioError . userError $ errStr- else- liftM ExecutionEngine $- newForeignPtr FFI.ptrDisposeExecutionEngine =<<- peek eePtr--getTheEngine :: FFI.EngineKindSet -> Module -> IO ExecutionEngine-getTheEngine = createExecutionEngineForModule True--newtype EngineAccess a = EA (MR.ReaderT ExecutionEngine IO a)- deriving (Functor, Applicative, Monad, MonadIO)---- |The LLVM execution engine is encapsulated so it cannot be accessed directly.--- The reason is that (currently) there must only ever be one engine,--- so access to it is wrapped in a monad.-runEngineAccess :: EngineAccess a -> IO a-runEngineAccess (EA body) = do- MR.runReaderT body =<< getTheEngine FFI.kindEither =<< createModule "__empty__"--runEngineAccessWithModule :: Module -> EngineAccess a -> IO a-runEngineAccessWithModule m (EA body) = do- MR.runReaderT body =<< getTheEngine FFI.kindEither m--runEngineAccessInterpreterWithModule :: Module -> EngineAccess a -> IO a-runEngineAccessInterpreterWithModule m (EA body) = do- MR.runReaderT body =<< getTheEngine FFI.kindInterpreter m---getEngine :: EngineAccess ExecutionEngine-getEngine = EA MR.ask--accessEngine :: (FFI.ExecutionEngineRef -> IO a) -> EngineAccess a-accessEngine act = do- engine <- getEngine- liftIO $ withEngine engine act--getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef-getExecutionEngineTargetData =- accessEngine FFI.getExecutionEngineTargetData--{- |-In contrast to 'generateFunction' this compiles a function once.-Thus it is faster for many calls to the same function.-See @examples\/Vector.hs@.--If the function calls back into Haskell code,-you also have to set the function addresses-using 'addFunctionValue' or 'addGlobalMappings'.--You must keep the execution engine alive-as long as you want to call the function.-Better use 'getExecutionFunction' which handles this for you.--}-getPointerToFunction :: Function f -> EngineAccess (FunPtr f)-getPointerToFunction (Value f) =- accessEngine $ \eePtr -> FFI.getPointerToFunction eePtr f--class ExecutionFunction f where- keepAlive :: ExecutionEngine -> f -> f--instance ExecutionFunction (IO a) where- keepAlive engine act = do- a <- act- touchForeignPtr (fromEngine engine)- return a--instance ExecutionFunction f => ExecutionFunction (a -> f) where- keepAlive engine act = keepAlive engine . act--getExecutionFunction ::- (ExecutionFunction f) => (FunPtr f -> f) -> Function f -> EngineAccess f-getExecutionFunction importer (Value f) = do- engine <- getEngine- liftIO $ withEngine engine $ \eePtr ->- keepAlive engine . importer <$> FFI.getPointerToFunction eePtr f--{- |-Tell LLVM the address of an external function-if it cannot resolve a name automatically.-Alternatively you may declare the function-with 'staticFunction' instead of 'externFunction'.--}-addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()-addFunctionValue (Value g) f =- accessEngine $ \eePtr -> FFI.addFunctionMapping eePtr g f--{- |-Pass a list of global mappings to LLVM-that can be obtained from 'LLVM.Core.getGlobalMappings'.--}-addGlobalMappings :: GlobalMappings -> EngineAccess ()-addGlobalMappings (GlobalMappings gms) = accessEngine gms--addModule :: Module -> EngineAccess ()-addModule m =- accessEngine $ \eePtr -> U.withModule m $ FFI.addModule eePtr-------------------------------------------newtype GenericValue = GenericValue {- fromGenericValue :: ForeignPtr FFI.GenericValue- }--withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a-withGenericValue = withForeignPtr . fromGenericValue--createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue-createGenericValueWith f = do- ptr <- f- liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr--withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a-withAll ps a = go [] ps- where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs- go ptrs _ = withArrayLen (reverse ptrs) a--runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue-runFunction func args =- liftIO =<< getRunFunction <*> pure func <*> pure args--getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)-getRunFunction = do- engine <- getEngine- return $ \ func args ->- withAll args $ \argLen argPtr ->- withEngine engine $ \eePtr ->- createGenericValueWith $ FFI.runFunction eePtr func- (fromIntegral argLen) argPtr--class Generic a where- toGeneric :: a -> GenericValue- fromGeneric :: GenericValue -> a--instance Generic () where- toGeneric _ = error "toGeneric ()"- fromGeneric _ = ()--toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue-toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ do- typ <- typeRef $ Proxy.fromValue val- FFI.createGenericValueOfInt- typ (fromIntegral val) (FFI.consBool signed)--fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a-fromGenericInt signed val = unsafePerformIO $- withGenericValue val $ \ref ->- fmap fromIntegral $ FFI.genericValueToInt ref (FFI.consBool signed)----instance Generic Bool where--- toGeneric = toGenericInt False . FFI.consBool--- fromGeneric = toBool . fromGenericInt False--instance Generic Int8 where- toGeneric = toGenericInt True- fromGeneric = fromGenericInt True--instance Generic Int16 where- toGeneric = toGenericInt True- fromGeneric = fromGenericInt True--instance Generic Int32 where- toGeneric = toGenericInt True- fromGeneric = fromGenericInt True--{--instance Generic Int where- toGeneric = toGenericInt True- fromGeneric = fromGenericInt True--}--instance Generic Int64 where- toGeneric = toGenericInt True- fromGeneric = fromGenericInt True--instance Generic Word8 where- toGeneric = toGenericInt False- fromGeneric = fromGenericInt False--instance Generic Word16 where- toGeneric = toGenericInt False- fromGeneric = fromGenericInt False--instance Generic Word32 where- toGeneric = toGenericInt False- fromGeneric = fromGenericInt False--instance Generic Word64 where- toGeneric = toGenericInt False- fromGeneric = fromGenericInt False--toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue-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 -> do- typ <- typeRef (Proxy :: Proxy a)- fmap realToFrac $ FFI.genericValueToFloat typ ref--instance Generic Float where- toGeneric = toGenericReal- fromGeneric = fromGenericReal--instance Generic Double where- toGeneric = toGenericReal- fromGeneric = fromGenericReal--instance Generic (Ptr a) where- toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer- fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer--instance Generic (StablePtr a) where- toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr- fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer
− src/LLVM/ExecutionEngine/Marshal.hs
@@ -1,186 +0,0 @@-{- |-A 'Marshal' class that is compatible with LLVM's data layout.-Most prominent difference is that LLVM's @i1@ requires a byte in memory,-whereas Haskell's 'Bool' occupies a 32-bit word.-Additionally this class supports 'Data.Struct', 'Data.Vector', 'Data.Array'.--}-module LLVM.ExecutionEngine.Marshal (- Marshal(..),- sizeOf,- alignment,- StructFields,- sizeOfArray,- pokeList,- ) where--import qualified LLVM.Core.Vector as Vector ()-import qualified LLVM.Core.Data as Data-import qualified LLVM.Core.Type as Type-import qualified LLVM.Util.Proxy as LP-import qualified LLVM.ExecutionEngine.Target as Target-import LLVM.ExecutionEngine.Target (TargetData)--import qualified LLVM.FFI.Core as FFI--import qualified Type.Data.Num.Decimal.Number as Dec-import Type.Base.Proxy (Proxy(Proxy))--import qualified Foreign.Storable as Store-import Foreign.StablePtr (StablePtr)-import Foreign.Ptr (Ptr, FunPtr, castPtr, plusPtr)--import System.IO.Unsafe (unsafePerformIO)--import qualified Control.Monad.Trans.State as MS-import Control.Applicative (liftA2, pure)--import qualified Data.Traversable as Trav-import qualified Data.Foldable as Fold-import Data.Int (Int8, Int16, Int32, Int64)-import Data.Word (Word8, Word16, Word32, Word64)----targetData :: TargetData-targetData = unsafePerformIO Target.getTargetData---sizeOf :: (Type.IsType a) => LP.Proxy a -> Int-sizeOf = Target.storeSizeOfType targetData . Type.unsafeTypeRef--alignment :: (Type.IsType a) => LP.Proxy a -> Int-alignment = Target.abiAlignmentOfType targetData . Type.unsafeTypeRef--sizeOfArray :: (Type.IsType a) => LP.Proxy a -> Int -> Int-sizeOfArray proxy n =- Target.abiSizeOfType targetData (Type.unsafeTypeRef proxy) * n---class (Type.IsType a) => Marshal a where- peek :: Ptr a -> IO a- poke :: Ptr a -> a -> IO ()--peekPrimitive :: (Store.Storable a) => Ptr a -> IO a-peekPrimitive = Store.peek--pokePrimitive :: (Store.Storable a) => Ptr a -> a -> IO ()-pokePrimitive = Store.poke--instance Marshal Float where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Double where- peek = peekPrimitive; poke = pokePrimitive--instance Marshal Int8 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Int16 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Int32 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Int64 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Word8 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Word16 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Word32 where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal Word64 where- peek = peekPrimitive; poke = pokePrimitive-instance (Type.IsType a) => Marshal (Ptr a) where- peek = peekPrimitive; poke = pokePrimitive-instance (Type.IsFunction a) => Marshal (FunPtr a) where- peek = peekPrimitive; poke = pokePrimitive-instance Marshal (StablePtr a) where- peek = peekPrimitive; poke = pokePrimitive--instance Marshal Bool where- peek = fmap (/= 0) . Store.peek . castBoolPtr- poke ptr a = Store.poke (castBoolPtr ptr) (fromIntegral $ fromEnum a)--castBoolPtr :: Ptr Bool -> Ptr Word8-castBoolPtr = castPtr--instance- (Type.Natural n, Marshal a, Type.IsSized a) =>- Marshal (Data.Array n a) where- peek = peekArray Proxy LP.Proxy- poke = pokeArray (\(Data.Array as) -> as)--instance- (Type.Positive n, Marshal a, Type.IsPrimitive a) =>- Marshal (Data.Vector n a) where- peek = peekVector Proxy LP.Proxy- poke = pokeArray Fold.toList--peekArray ::- (Type.Natural n, Marshal a) =>- Proxy n -> LP.Proxy a ->- Ptr (Data.Array n a) -> IO (Data.Array n a)-peekArray n proxy =- let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy- in \ptr ->- fmap Data.Array $ mapM peek $- take (Dec.integralFromProxy n) $- iterate (flip plusPtr step) (castElemPtr ptr)--peekVector ::- (Type.Positive n, Marshal a) =>- Proxy n -> LP.Proxy a ->- Ptr (Data.Vector n a) -> IO (Data.Vector n a)-peekVector _n proxy =- let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy- in \ptr ->- flip MS.evalStateT (castElemPtr ptr) $- Trav.traverse- (\() -> MS.StateT $ \ptri -> do- a <- peek ptri- return (a, plusPtr ptri step))- (pure ())--pokeArray :: (Marshal a) => (f a -> [a]) -> Ptr (f a) -> f a -> IO ()-pokeArray toList ptr = pokeList (castElemPtr ptr) . toList--pokeList :: (Marshal a) => Ptr a -> [a] -> IO ()-pokeList = pokeListAux LP.Proxy--pokeListAux :: (Marshal a) => LP.Proxy a -> Ptr a -> [a] -> IO ()-pokeListAux proxy =- let step = Target.abiSizeOfType targetData $ Type.unsafeTypeRef proxy- in \ptr -> sequence_ . zipWith poke (iterate (flip plusPtr step) ptr)--castElemPtr :: Ptr (f a) -> Ptr a-castElemPtr = castPtr---instance (StructFields fields) => Marshal (Data.Struct fields) where- peek = withPtrProxy $ \proxy ->- let typeRef = Type.unsafeTypeRef proxy- in fmap Data.Struct . peekStruct typeRef 0- poke = withPtrProxy $ \proxy ->- let typeRef = Type.unsafeTypeRef proxy- pokePlain = pokeStruct typeRef 0- in \ptr (Data.Struct as) -> pokePlain ptr as--withPtrProxy :: (LP.Proxy a -> Ptr a -> b) -> Ptr a -> b-withPtrProxy act = act LP.Proxy--class (Type.StructFields fields) => StructFields fields where- peekStruct :: FFI.TypeRef -> Int -> Ptr struct -> IO fields- pokeStruct :: FFI.TypeRef -> Int -> Ptr struct -> fields -> IO ()--instance- (Marshal a, Type.IsSized a, StructFields as) =>- StructFields (a,as) where- peekStruct typeRef i =- let offset = Target.offsetOfElement targetData typeRef i- peekIs = peekStruct typeRef (i+1)- in \ptr -> liftA2 (,) (peek $ plusPtr ptr offset) (peekIs ptr)- pokeStruct typeRef i =- let offset = Target.offsetOfElement targetData typeRef i- pokeIs = pokeStruct typeRef (i+1)- in \ptr (a,as) -> poke (plusPtr ptr offset) a >> pokeIs ptr as--instance StructFields () where- peekStruct _type _i _ptr = return ()- pokeStruct _type _i _ptr () = return ()
− src/LLVM/ExecutionEngine/Target.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where--import qualified LLVM.ExecutionEngine.Engine as EE-import LLVM.Core.Data (WordN)--import qualified LLVM.FFI.Core as FFI-import qualified LLVM.FFI.Target as FFI--import qualified Type.Data.Num.Decimal.Number as Dec-import Type.Base.Proxy (Proxy)--import Foreign.ForeignPtr- (ForeignPtr, newForeignPtr, withForeignPtr, touchForeignPtr)-import Foreign.C.String (withCString)--import Control.Monad (liftM2)-import Control.Applicative ((<$>))-import Data.Typeable (Typeable)-import Data.Maybe (fromMaybe)-import System.IO.Unsafe (unsafePerformIO)---type Type = FFI.TypeRef--data TargetData = TargetData {- abiAlignmentOfType :: Type -> Int,- abiSizeOfType :: Type -> Int,- littleEndian :: Bool,- callFrameAlignmentOfType :: Type -> Int,--- elementAtOffset :: Type -> Word64 -> Int,- intPtrType :: Type,- offsetOfElement :: Type -> Int -> Int,- pointerSize :: Int,--- preferredAlignmentOfGlobal :: Value a -> Int,- preferredAlignmentOfType :: Type -> Int,- sizeOfTypeInBits :: Type -> Int,- storeSizeOfType :: Type -> Int- }- deriving (Typeable)--withIntPtrType :: (forall n . (Dec.Positive n) => WordN n -> a) -> a-withIntPtrType f =- fromMaybe (error "withIntPtrType: pointer size must be non-negative") $- Dec.reifyPositive (fromIntegral sz) (\ n -> f (g n))- where g :: Proxy n -> WordN n- g _ = error "withIntPtrType: argument used"- sz = pointerSize $ unsafePerformIO getTargetData---unsafeIO :: ForeignPtr a -> IO b -> b-unsafeIO fptr act =- unsafePerformIO $ do x <- act; touchForeignPtr fptr; return x--unsafeIntIO :: (Integral i, Num j) => ForeignPtr a -> IO i -> j-unsafeIntIO fptr = fromIntegral . unsafeIO fptr---- Normally the TargetDataRef never changes, so the operation--- are really pure functions.-makeTargetData :: ForeignPtr a -> FFI.TargetDataRef -> TargetData-makeTargetData fptr r = TargetData {- abiAlignmentOfType = unsafeIntIO fptr . FFI.abiAlignmentOfType r,- abiSizeOfType = unsafeIntIO fptr . FFI.abiSizeOfType r,- littleEndian = unsafeIO fptr (FFI.byteOrder r) /= FFI.bigEndian,- callFrameAlignmentOfType = unsafeIntIO fptr . FFI.callFrameAlignmentOfType r,- intPtrType = unsafeIO fptr $ FFI.intPtrType r,- offsetOfElement = \ty k ->- unsafeIntIO fptr $ FFI.offsetOfElement r ty (fromIntegral k),- pointerSize = unsafeIntIO fptr $ FFI.pointerSize r,- preferredAlignmentOfType = unsafeIntIO fptr . FFI.preferredAlignmentOfType r,- sizeOfTypeInBits = unsafeIntIO fptr . FFI.sizeOfTypeInBits r,- storeSizeOfType = unsafeIntIO fptr . FFI.storeSizeOfType r- }---- Gets the target data for the JIT target.-getTargetData :: IO TargetData-getTargetData =- EE.runEngineAccess $- liftM2 makeTargetData- (EE.fromEngine <$> EE.getEngine)- EE.getExecutionEngineTargetData--createTargetData :: String -> IO (ForeignPtr FFI.TargetData)-createTargetData s =- newForeignPtr FFI.ptrDisposeTargetData =<<- withCString s FFI.createTargetData--targetDataFromString :: String -> TargetData-targetDataFromString s = unsafePerformIO $ do- td <- createTargetData s- withForeignPtr td $ return . makeTargetData td
src/LLVM/Util/Arithmetic.hs view
@@ -2,10 +2,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} module LLVM.Util.Arithmetic( TValue,@@ -13,7 +11,7 @@ (%&&), (%||), (?), (??), retrn, set,- ArithFunction, arithFunction,+ ArithFunction, arithFunction, Return, ToArithFunction, toArithFunction, recursiveFunction, CallIntrinsic, ) where@@ -21,6 +19,7 @@ import qualified LLVM.Util.Intrinsic as Intrinsic import qualified LLVM.Core as LLVM import LLVM.Util.Loop (mapVector, mapVector2)+import LLVM.Core.CodeGen (UnValue, CodeValue, CodeResult) import LLVM.Core import qualified Type.Data.Num.Decimal.Number as Dec@@ -79,19 +78,21 @@ select c' t' f' -- | Return a value from an 'arithFunction'.-retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r ()+retrn :: TValue a a -> CodeGenFunction a () retrn x = x >>= ret -- | Use @x <- set $ ...@ to make a binding. set :: TValue r a -> CodeGenFunction r (TValue r a) set x = do x' <- x; return (return x') -instance Eq (TValue r a) where+instance Eq (CodeGenFunction r av) where (==) = error "CodeGenFunction Value: (==)"-instance Ord (TValue r a) where+instance Ord (CodeGenFunction r av) where compare = error "CodeGenFunction Value: compare" -instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where+instance+ (IsArithmetic a, CmpRet a, Num a, IsConst a, Value a ~ av) =>+ Num (CodeGenFunction r av) where (+) = binop add (-) = binop sub (*) = binop mul@@ -100,29 +101,41 @@ signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0)) fromInteger = return . valueOf . fromInteger -instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Enum (TValue r a) where+instance+ (IsArithmetic a, CmpRet a, Num a, IsConst a, Value a ~ av) =>+ Enum (CodeGenFunction r av) where succ x = x + 1 pred x = x - 1 fromEnum _ = error "CodeGenFunction Value: fromEnum" toEnum = fromIntegral -instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Real (TValue r a) where+instance+ (IsArithmetic a, CmpRet a, Num a, IsConst a, Value a ~ av) =>+ Real (CodeGenFunction r av) where toRational _ = error "CodeGenFunction Value: toRational" -instance (CmpRet a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where+instance+ (CmpRet a, Num a, IsConst a, IsInteger a, Value a ~ av) =>+ Integral (CodeGenFunction r av) where quot = binop idiv rem = binop irem quotRem x y = (quot x y, rem x y) toInteger _ = error "CodeGenFunction Value: toInteger" -instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where+instance+ (CmpRet a, Fractional a, IsConst a, IsFloating a, Value a ~ av) =>+ Fractional (CodeGenFunction r av) where (/) = binop fdiv fromRational = return . valueOf . fromRational -instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where+instance+ (CmpRet a, Fractional a, IsConst a, IsFloating a, Value a ~ av) =>+ RealFrac (CodeGenFunction r av) where properFraction _ = error "CodeGenFunction Value: properFraction" -instance (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where+instance+ (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a, Value a ~ av) =>+ Floating (CodeGenFunction r av) where pi = return $ valueOf pi sqrt = callIntrinsic1 "sqrt" sin = callIntrinsic1 "sin"@@ -141,7 +154,9 @@ acosh x = log (x + sqrt (x*x - 1)) atanh x = (log (1 + x) - log (1 - x)) / 2 -instance (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where+instance+ (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a, Value a ~ av) =>+ RealFloat (CodeGenFunction r av) where floatRadix _ = floatRadix (undefined :: a) floatDigits _ = floatDigits (undefined :: a) floatRange _ = floatRange (undefined :: a)@@ -165,58 +180,94 @@ ------------------------------------------- -class ArithFunction r z a b | a -> b r z, b r z -> a where+{- |+Turn+@(a -> b -> CodeGenFunction r c)@+into+@(a -> b -> CodeGenFunction r ())@+for @r ~ Result c@+-}+class (RetB a ~ b, CodeValue a ~ z, RetA z b ~ a) => Return z a b where+ type RetA z b+ type RetB a+ addRet :: a -> b++instance+ (Ret z, Result z ~ r, r ~ ra, r ~ rb, z ~ a, unit ~ ()) =>+ Return z (CodeGenFunction ra a) (CodeGenFunction rb unit) where+ type RetA z (CodeGenFunction rb unit) = CodeGenFunction (Result z) z+ type RetB (CodeGenFunction ra a) = CodeGenFunction ra ()+ addRet code = ret =<< code++instance (Return z b0 b1, a0 ~ a1) => Return z (a0 -> b0) (a1 -> b1) where+ type RetA z (a1 -> b1) = a1 -> RetA z b1+ type RetB (a0 -> b0) = a0 -> RetB b0+ addRet f = addRet . f+++class (FunA r b ~ a, FunB a ~ b, CodeResult a ~ r) => ArithFunction r a b where+ type FunA r b+ type FunB a arithFunction' :: a -> b instance- (Ret a r) =>- ArithFunction r a (CodeGenFunction r a) (CodeGenFunction r ()) where- arithFunction' x = x >>= ret+ (r ~ ra, r ~ rb, a ~ b) =>+ ArithFunction r (CodeGenFunction ra a) (CodeGenFunction rb b) where+ type FunA r (CodeGenFunction rb b) = CodeGenFunction r b+ type FunB (CodeGenFunction ra a) = CodeGenFunction ra a+ arithFunction' x = x instance- (ArithFunction r z b0 b1) =>- ArithFunction r z (CodeGenFunction r a -> b0) (a -> b1) where+ (ArithFunction r b0 b1, a0 ~ CodeGenFunction r a1) =>+ ArithFunction r (a0 -> b0) (a1 -> b1) where+ type FunA r (a1 -> b1) = CodeGenFunction r a1 -> FunA r b1+ type FunB (a0 -> b0) = CodeValue a0 -> FunB b0 arithFunction' f = arithFunction' . f . return -- |Unlift a function with @TValue@ to have @Value@ arguments.-arithFunction :: ArithFunction r z a b => a -> b-arithFunction = arithFunction'+arithFunction :: (ArithFunction r a b, r ~ Result z, Return z b c) => a -> c+arithFunction = addRet . arithFunction' -class ToArithFunction r a b | a r -> b, b -> a r where+class+ (TFunB r a ~ b, TFunA b ~ a, CodeResult b ~ r) =>+ ToArithFunction r a b where+ type TFunA b+ type TFunB r a toArithFunction' :: CodeGenFunction r (Call a) -> b -instance ToArithFunction r (IO b) (CodeGenFunction r (Value b)) where- toArithFunction' cl = cl >>= runCall+instance (Value a ~ b) => ToArithFunction r (IO a) (CodeGenFunction r b) where+ type TFunA (CodeGenFunction r b) = IO (UnValue b)+ type TFunB r (IO a) = CodeGenFunction r (Value a)+ toArithFunction' cl = runCall =<< cl instance- ToArithFunction r b0 b1 =>- ToArithFunction r (a -> b0) (CodeGenFunction r (Value a) -> b1) where+ (ToArithFunction r b0 b1, CodeGenFunction r (Value a0) ~ a1) =>+ ToArithFunction r (a0 -> b0) (a1 -> b1) where+ type TFunA (a1 -> b1) = UnValue (CodeValue a1) -> TFunA b1+ type TFunB r (a0 -> b0) = CodeGenFunction r (Value a0) -> TFunB r b0 toArithFunction' cl x = toArithFunction' (liftM2 applyCall cl x) _toArithFunction2 ::- Function (a -> b -> IO c) -> TValue r a -> TValue r b -> TValue r c+ Function (a -> b -> IO c) -> TValue r a -> TValue r b -> TValue r c _toArithFunction2 f tx ty = do x <- tx y <- ty runCall $ callFromFunction f `applyCall` x `applyCall` y -- |Lift a function from having @Value@ arguments to having @TValue@ arguments.-toArithFunction ::- (ToArithFunction r f g) =>- Function f -> g-toArithFunction f =- toArithFunction' $ return $ callFromFunction f+toArithFunction :: (ToArithFunction r f g) => Function f -> g+toArithFunction = toArithFunction' . return . callFromFunction ------------------------------------------- -- |Define a recursive 'arithFunction', gets passed itself as the first argument. recursiveFunction :: (IsFunction f, FunctionArgs f, code ~ FunctionCodeGen f,- ArithFunction r1 z arith code,- ToArithFunction r0 f g) =>+ ArithFunction r arith open, r ~ Result z, Return z open code,+ ToArithFunction r f g) => (g -> arith) -> CodeGenModule (Function f) recursiveFunction af = do f <- newFunction ExternalLinkage
src/LLVM/Util/Foreign.hs view
@@ -3,28 +3,35 @@ -- The functions in Foreign.* do not obey the required alignment. module LLVM.Util.Foreign where +import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+ import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Marshal.Array (allocaArray, pokeArray)-import Foreign.Storable (Storable(poke, sizeOf, alignment))-import Foreign.Ptr (alignPtr, Ptr)+import Foreign.Ptr (alignPtr) -with :: Storable a => a -> (Ptr a -> IO b) -> IO b+with :: (EE.Marshal a) => a -> (LLVM.Ptr a -> IO b) -> IO b with x act = alloca $ \ p -> do- poke p x+ EE.poke p x act p -alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b+alloca :: forall a b. (EE.Marshal a) => (LLVM.Ptr a -> IO b) -> IO b alloca act =- allocaBytes (2 * sizeOf (undefined :: a)) $ \ p ->- act $ alignPtr p (alignment (undefined :: a))+ allocaBytes (2 * EE.sizeOf (LP.Proxy :: LP.Proxy a)) $ \ p ->+ act $ LLVM.uncheckedFromPtr $+ alignPtr p (EE.alignment (LP.Proxy :: LP.Proxy a)) -withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen :: (EE.Marshal a) => [a] -> (Int -> LLVM.Ptr a -> IO b) -> IO b withArrayLen xs act = let l = length xs in- allocaArray (l+1) $ \ p -> do- let p' = alignPtr p (alignment (head xs))- pokeArray p' xs+ allocaBytes ((l+1) * EE.sizeOf (proxyFromList xs)) $ \ p -> do+ let p' =+ LLVM.uncheckedFromPtr $+ alignPtr p $ EE.alignment $ proxyFromList xs+ EE.pokeList p' xs act l p' +proxyFromList :: [a] -> LP.Proxy a+proxyFromList _ = LP.Proxy
src/LLVM/Util/Intrinsic.hs view
@@ -6,7 +6,7 @@ call1, call2, ) where -import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core.Proxy as LP import qualified LLVM.Core as LLVM import LLVM.Core (CodeGenFunction, Value, IsType, IsFirstClass,
src/LLVM/Util/Memory.hs view
@@ -6,17 +6,17 @@ IsLengthType, ) where -import LLVM.Util.Proxy (Proxy(Proxy))+import LLVM.Core.Proxy (Proxy(Proxy)) import LLVM.Core -import Foreign.Ptr (Ptr, )-import Data.Word (Word8, Word32, Word64, )+import Data.Word (Word8, Word32, Word64, Word) import Control.Functor.HT (void, ) class IsFirstClass len => IsLengthType len where +instance IsLengthType Word where instance IsLengthType Word32 where instance IsLengthType Word64 where
src/LLVM/Util/Optimize.hs view
@@ -11,6 +11,15 @@ {- | Result tells whether the module was modified by any of the passes.++It is very important that you set target triple and target data layout+before optimizing.+Otherwise the optimizer will make wrong assumptions+and e.g. corrupt your record offsets.+See e.g. example/Array for how this can be achieved.++In the future I might enforce via types+that you set target parameters before optimization. -} optimizeModule :: Int -> Module -> IO Bool optimizeModule optLevel mdl =
src/LLVM/Util/Proxy.hs view
@@ -1,19 +1,5 @@-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+module LLVM.Util.Proxy (+ module LLVM.Core.Proxy,+ ) where -element :: Proxy (f a) -> Proxy a-element Proxy = Proxy+import LLVM.Core.Proxy
+ test/Main.hs view
@@ -0,0 +1,21 @@+module Main where++import qualified Test.Marshal as Marshal+import qualified Test.Chop as Chop++import qualified LLVM.Core as LLVM++import Data.Tuple.HT (mapPair, mapFst)++import qualified Test.QuickCheck as QC+++main :: IO ()+main = do+ LLVM.initializeNativeTarget++ mapM_ (\(msg,prop) -> putStr (msg++": ") >> prop >>= QC.quickCheck) $+ map (mapPair (("Chop."++),return)) Chop.tests +++ map (mapPair (("Marshal."++),return)) Marshal.testsRoundTrip +++ map (mapFst ("Marshal."++)) Marshal.testsExtract +++ []
− test/Makefile
@@ -1,16 +0,0 @@-ghc := ghc-ghcflags := -Wall -Werror-tests := TestType TestValue--all: $(tests:%=%.out)--%.out: %.test- ./$< > $@ 2>&1; s=$$?; cat $@; \- if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi--.PRECIOUS: %.test-%.test: %.hs- $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<--clean:- -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out)
+ test/Test/Chop.hs view
@@ -0,0 +1,63 @@+module Test.Chop where++import qualified LLVM.ExecutionEngine.Marshal as Marshal++import Data.Bits (shiftL)+import Data.Word (Word8)++import qualified Test.QuickCheck as QC+++divUp :: Integral a => a -> a -> a+divUp a b = - div (-a) b++expandBits :: [Word8] -> Bool+expandBits xs = xs == Marshal.gatherBits (Marshal.expandBits xs)++gatherBits :: [Bool] -> Bool+gatherBits xs =+ Marshal.gatherBits xs+ ==+ (take (divUp (length xs) 8) $ map fromIntegral $+ Marshal.chop 1 8 $ map (toInteger . fromEnum) xs)++forAllBitWidth :: (Int -> QC.Property) -> QC.Property+forAllBitWidth = QC.forAll (QC.choose (1,100))++chopBig :: QC.NonNegative Int -> QC.Property+chopBig (QC.NonNegative k) =+ forAllBitWidth $ \m ->+ forAllBitWidth $ \n ->+ QC.forAll (QC.listOf $ QC.choose (0, shiftL 1 m - 1)) $ \xs ->+ take k (Marshal.chop m n xs)+ ==+ take k (Marshal.split n $ Marshal.merge m xs)++chop :: QC.NonNegative Int -> QC.Property+chop (QC.NonNegative k) =+ forAllBitWidth $ \m ->+ forAllBitWidth $ \n ->+ QC.forAll (QC.listOf $ QC.choose (0, shiftL 1 m - 1)) $ \xs ->+ take k (Marshal.chop n m $ Marshal.chop m n xs)+ ==+ take k (xs ++ repeat 0)++chopSigned :: QC.NonNegative Int -> QC.Property+chopSigned (QC.NonNegative k) =+ forAllBitWidth $ \m ->+ forAllBitWidth $ \n ->+ QC.forAll (QC.listOf $ QC.choose (- shiftL 1 m, shiftL 1 m - 1)) $ \xs ->+ take k (map (Marshal.adjustSign (m+1)) $ Marshal.chop n (m+1) $+ Marshal.chop (m+1) n $ map (Marshal.cut (m+1)) xs)+ ==+ take k (xs ++ repeat 0)+++tests :: [(String, QC.Property)]+tests =+ ("expandBits", QC.property expandBits) :+ ("gatherBits", QC.property gatherBits) :+ ("chopBig", QC.property chopBig) :+ ("chop", QC.property chop) :+ ("chopSigned", QC.property chopSigned) :+ []
+ test/Test/Marshal.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+module Test.Marshal (testsRoundTrip, testsExtract) where++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Optimize as Opt+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy(Proxy))++import Foreign.Ptr (FunPtr, Ptr, nullPtr, plusPtr, castPtr)++import qualified Data.Foldable as Fold+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Tuple.HT (mapPair, mapFst)++import qualified Test.QuickCheck.Monadic as QCMon+import qualified Test.QuickCheck as QC++import Control.Monad (liftM2, void, (<=<))++++type RoundTrip a = a -> QC.Property+type RoundTripVec n a = RoundTrip (LLVM.Vector n a)++roundTrip :: (EE.Marshal a, Eq a) => RoundTrip a+roundTrip x =+ QCMon.monadicIO $ do+ y <- QCMon.run $ EE.with x EE.peek+ QCMon.assert $ x==y++testsRoundTrip :: [(String, QC.Property)]+testsRoundTrip =+ map (mapFst ("RoundTrip." ++)) $+ ("f32", QC.property (roundTrip :: RoundTrip Float)) :+ ("f64", QC.property (roundTrip :: RoundTrip Double)) :+ ("i1", QC.property (roundTrip :: RoundTrip Bool)) :+ ("i2", QC.property (roundTrip :: RoundTrip Int2)) :+ ("i3", QC.property (roundTrip :: RoundTrip Int3)) :+ ("i24", QC.property (roundTrip :: RoundTrip Int24)) :+ ("i64", QC.property (roundTrip :: RoundTrip Int64)) :+ ("i2", QC.property (roundTrip :: RoundTrip Word2)) :+ ("i3", QC.property (roundTrip :: RoundTrip Word3)) :+ ("i17", QC.property (roundTrip :: RoundTrip Word17)) :+ ("i32", QC.property (roundTrip :: RoundTrip Word32)) :+ ("ptr", QC.property ((roundTrip :: RoundTrip (Ptr Word8)) . plusPtr nullPtr)) :+ ("()", QC.property (roundTrip :: RoundTrip (LLVM.Struct ()))) :+ ("struct-i8",+ QC.property (roundTrip :: RoundTrip (LLVM.Struct (Word8,())))) :+ ("struct-i8-i24",+ QC.property (roundTrip :: RoundTrip (LLVM.Struct (Word8,(Int24,()))))) :+ ("struct-i3-f32",+ QC.property (roundTrip :: RoundTrip (LLVM.Struct (Int3,(Float,()))))) :+ ("struct-i16-i1-i64",+ QC.property+ (roundTrip :: RoundTrip (LLVM.Struct (Int16,(Bool,(Word64,())))))) :+ ("v8f32", QC.property (roundTrip :: RoundTripVec TypeNum.D8 Float)) :+ ("v5f64", QC.property (roundTrip :: RoundTripVec TypeNum.D5 Double)) :+ ("v7i1", QC.property (roundTrip :: RoundTripVec TypeNum.D7 Bool)) :+ ("v13i1", QC.property (roundTrip :: RoundTripVec TypeNum.D13 Bool)) :+ ("v4i2", QC.property (roundTrip :: RoundTripVec TypeNum.D4 Int2)) :+ ("v10i2", QC.property (roundTrip :: RoundTripVec TypeNum.D10 Word2)) :+ ("v7i3", QC.property (roundTrip :: RoundTripVec TypeNum.D7 Int3)) :+ ("v5i3", QC.property (roundTrip :: RoundTripVec TypeNum.D5 Word3)) :+ ("v9i24", QC.property (roundTrip :: RoundTripVec TypeNum.D9 Int24)) :+ ("v3i17", QC.property (roundTrip :: RoundTripVec TypeNum.D3 Word17)) :+ ("v5i8", QC.property (roundTrip :: RoundTripVec TypeNum.D5 Word8)) :+ ("v3i16", QC.property (roundTrip :: RoundTripVec TypeNum.D3 Word16)) :+ ("v4i8", QC.property (roundTrip :: RoundTripVec TypeNum.D4 Int8)) :+ ("v7i32", QC.property (roundTrip :: RoundTripVec TypeNum.D7 Int32)) :+ []+++type Importer func = FunPtr func -> func++generateFunction ::+ EE.ExecutionFunction f =>+ Importer f -> LLVM.CodeGenModule (LLVM.Function f) -> IO f+generateFunction imprt code = do+ td <- EE.getTargetData+ (m,func) <-+ LLVM.createModule $ do+ LLVM.setTarget LLVM.hostTriple+ LLVM.setDataLayout $ EE.dataLayoutStr td+ liftM2 (,) LLVM.getModule code+ LLVM.writeBitcodeToFile "Test.bc" m+ void $ Opt.optimizeModule 3 m+ LLVM.writeBitcodeToFile "TestOpt.bc" m+ EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func+++foreign import ccall safe "dynamic" derefTestCasePtr ::+ Importer (LLVM.Ptr inp -> LLVM.Ptr out -> IO ())++modul ::+ (LLVM.IsType inp, LLVM.IsType out) =>+ (LLVM.Value inp -> LLVM.CodeGenFunction () (LLVM.Value out)) ->+ LLVM.CodeGenModule (LLVM.Function (LLVM.Ptr inp -> LLVM.Ptr out -> IO ()))+modul codegen =+ LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do+ flip LLVM.store yPtr =<< codegen =<< LLVM.load xPtr+ LLVM.ret ()++run ::+ (Show inp, EE.Marshal inp, EE.Marshal out) =>+ QC.Gen inp ->+ (LLVM.Value inp -> LLVM.CodeGenFunction () (LLVM.Value out)) ->+ (inp -> out -> Bool) ->+ IO QC.Property+run qcgen codegen predicate = do+ funIO <- generateFunction derefTestCasePtr $ modul codegen+ return $ QC.forAll qcgen $ \x ->+ QCMon.monadicIO $ do+ y <-+ QCMon.run $+ EE.with x $ \xPtr ->+ EE.alloca $ \yPtr -> do+ funIO xPtr yPtr+ EE.peek yPtr+ QCMon.assert $ predicate x y+++type Extract n a = QC.Gen (LLVM.Vector n a, Word32)++extractElem ::+ (TypeNum.Positive n,+ (n TypeNum.:*: LLVM.SizeOf a) ~ size, TypeNum.Natural size,+ Show a, Eq a,+ EE.MarshalVector a, EE.Marshal a, LLVM.IsSized a, LLVM.IsPrimitive a) =>+ Extract n a -> IO QC.Property+extractElem qcgen =+ run+ (fmap (uncurry LLVM.consStruct) qcgen)+ (\vi -> do+ v <- LLVM.extractvalue vi TypeNum.d0+ i <- LLVM.extractvalue vi TypeNum.d1+ LLVM.extractelement v i)+ (LLVM.uncurryStruct $ \v i a ->+ a == Fold.toList v !! fromIntegral i)+++vectorSize :: LLVM.Vector n a -> Proxy n+vectorSize _ = Proxy++genVector :: (TypeNum.Positive n, QC.Arbitrary a) => Extract n a+genVector = do+ v <- QC.arbitrary+ i <- QC.choose (0, TypeNum.integralFromProxy (vectorSize v) - 1)+ return (v,i)+++type Int2 = LLVM.IntN TypeNum.D2+type Int3 = LLVM.IntN TypeNum.D3+type Word2 = LLVM.WordN TypeNum.D2+type Word3 = LLVM.WordN TypeNum.D3+type Int24 = LLVM.IntN TypeNum.D24+type Word17 = LLVM.IntN TypeNum.D17+++testsVector :: [(String, IO QC.Property)]+testsVector =+ map (mapFst ("Vector." ++)) $+ ("v8f32", extractElem (genVector :: Extract TypeNum.D8 Float)) :+ ("v5f64", extractElem (genVector :: Extract TypeNum.D5 Double)) :+ ("v7i1", extractElem (genVector :: Extract TypeNum.D7 Bool)) :+ ("v13i1", extractElem (genVector :: Extract TypeNum.D13 Bool)) :+ ("v4i2", extractElem (genVector :: Extract TypeNum.D4 Int2)) :+ ("v10i2", extractElem (genVector :: Extract TypeNum.D10 Word2)) :+ -- ToDo: broken on LLVM<=9: https://bugs.llvm.org/show_bug.cgi?id=44915+ ("v7i3", extractElem (genVector :: Extract TypeNum.D7 Int3)) :+ ("v5i3", extractElem (genVector :: Extract TypeNum.D5 Word3)) :+ ("v9i24", extractElem (genVector :: Extract TypeNum.D9 Int24)) :+ ("v3i17", extractElem (genVector :: Extract TypeNum.D3 Word17)) :+ ("v5i8", extractElem (genVector :: Extract TypeNum.D5 Word8)) :+ ("v3i16", extractElem (genVector :: Extract TypeNum.D3 Word16)) :+ ("v4i8", extractElem (genVector :: Extract TypeNum.D4 Int8)) :+ ("v7i32", extractElem (genVector :: Extract TypeNum.D7 Int32)) :+ []+++{-+Conversion from a Ptr Word8 triggers improper optimization+if target data layout is not set for module prior to optimization.+-}+runViaBytePtr ::+ (Show inp, EE.Marshal inp, EE.Marshal out) =>+ QC.Gen inp ->+ (LLVM.Value inp -> LLVM.CodeGenFunction () (LLVM.Value out)) ->+ (inp -> out -> Bool) ->+ IO QC.Property+runViaBytePtr qcgen codegen predicate = do+ funIO <-+ generateFunction derefTestCasePtr $+ LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do+ flip LLVM.store yPtr =<< codegen =<< LLVM.load =<< LLVM.bitcast xPtr+ LLVM.ret ()+ return $ QC.forAll qcgen $ \x ->+ QCMon.monadicIO $ do+ y <-+ QCMon.run $+ EE.with x $ \xPtr ->+ EE.alloca $ \yPtr -> do+ funIO (castToBytePtr xPtr) yPtr+ EE.peek yPtr+ QCMon.assert $ predicate x y++castToBytePtr :: LLVM.Ptr a -> LLVM.Ptr Word8+castToBytePtr = LLVM.fromPtr . castPtr . LLVM.uncheckedToPtr++extractValue ::+ (QC.Arbitrary s, Show s, EE.Marshal s, EE.Marshal a, Eq a) =>+ LP.Proxy s ->+ (s -> a) ->+ (forall r. LLVM.Value s -> LLVM.CodeGenFunction r (LLVM.Value a)) ->+ Bool ->+ IO QC.Property+extractValue LP.Proxy select extract viaBytePtr =+ (if viaBytePtr then runViaBytePtr else run)+ QC.arbitrary extract (\s x -> select s == x)++type Pair a b = LLVM.Struct (a,(b,()))+type Triple a b c = LLVM.Struct (a,(b,(c,())))++sfst :: LLVM.Struct (a,z) -> a+sfst (LLVM.Struct (a,_)) = a+ssnd :: LLVM.Struct (a,(b,z)) -> b+ssnd (LLVM.Struct (_,(b,_))) = b+sthd :: LLVM.Struct (a,(b,(c,z))) -> c+sthd (LLVM.Struct (_,(_,(c,_)))) = c++exv ::+ (LLVM.GetField s i, TypeNum.Natural i, LLVM.FieldType s i ~ a) =>+ Proxy i ->+ LLVM.Value (LLVM.Struct s) -> LLVM.CodeGenFunction r (LLVM.Value a)+exv = flip LLVM.extractvalue++proxyA :: LP.Proxy (Triple Int16 Bool Word64)+proxyA = LP.Proxy++proxyB :: LP.Proxy (Triple Bool Bool Int8)+proxyB = LP.Proxy++proxyC :: LP.Proxy (Pair Bool (Pair Float Word64))+proxyC = LP.Proxy++testsStruct :: [(String, Bool -> IO QC.Property)]+testsStruct =+ ("{i16,i1,i64} 0",+ extractValue proxyA sfst (exv TypeNum.d0)) :+ ("{i16,i1,i64} 1",+ extractValue proxyA ssnd (exv TypeNum.d1)) :+ ("{i16,i1,i64} 2",+ extractValue proxyA sthd (exv TypeNum.d2)) :+ ("{i1,i1,i8} 0",+ extractValue proxyB sfst (exv TypeNum.d0)) :+ ("{i1,i1,i8} 1",+ extractValue proxyB ssnd (exv TypeNum.d1)) :+ ("{i1,i1,i8} 2",+ extractValue proxyB sthd (exv TypeNum.d2)) :+ ("{i1,{float,i64}} 0",+ extractValue proxyC sfst (exv TypeNum.d0)) :+ ("{i1,{float,i64}} 1 0",+ extractValue proxyC (sfst.ssnd) (exv TypeNum.d0 <=< exv TypeNum.d1)) :+ ("{i1,{float,i64}} 1 1",+ extractValue proxyC (ssnd.ssnd) (exv TypeNum.d1 <=< exv TypeNum.d1)) :+ []+++testsExtract :: [(String, IO QC.Property)]+testsExtract =+ map (mapFst ("Extract." ++)) $+ testsVector +++ map (mapPair (("Struct." ++), ($False))) testsStruct +++ map (mapPair (("StructByte." ++), ($True))) testsStruct
− test/TestValue.hs
@@ -1,69 +0,0 @@-module TestValue (main) where- -import qualified LLVM.Core as Core-import qualified LLVM.Core.Type as T-import qualified LLVM.Core.Value as V- -testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v)- => T.Module -> String -> IO (V.Function r p)-testArguments m name = do- func <- Core.addFunction m name (T.function undefined undefined)- V.dumpValue func- let arg = V.params func- V.dumpValue arg- return func- -voidArguments :: T.Module -> IO ()-voidArguments m = do- func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ())- V.dumpValue func- return () --type F a = V.Function a a-type P a = V.Function (T.Pointer a) (T.Pointer a)-type V a = V.Function (T.Vector a) (T.Vector a)--arguments :: T.Module -> IO ()-arguments m = do- voidArguments m-- testArguments m "int1" :: IO (F T.Int1)- testArguments m "int8" :: IO (F T.Int8)- testArguments m "int16" :: IO (F T.Int16)- testArguments m "int32" :: IO (F T.Int32)- testArguments m "int64" :: IO (F T.Int64)- testArguments m "float" :: IO (F T.Float)- testArguments m "double" :: IO (F T.Double)- testArguments m "float128" :: IO (F T.Float128)- testArguments m "x86Float80" :: IO (F T.X86Float80)- testArguments m "ppcFloat128" :: IO (F T.PPCFloat128)-- testArguments m "ptrInt1" :: IO (P T.Int1)- testArguments m "ptrInt8" :: IO (P T.Int8)- testArguments m "ptrInt16" :: IO (P T.Int16)- testArguments m "ptrInt32" :: IO (P T.Int32)- testArguments m "ptrInt64" :: IO (P T.Int64)- testArguments m "ptrFloat" :: IO (P T.Float)- testArguments m "ptrDouble" :: IO (P T.Double)- testArguments m "ptrFloat128" :: IO (P T.Float128)- testArguments m "ptrX86Float80" :: IO (P T.X86Float80)- testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128)-- testArguments m "vecInt1" :: IO (V T.Int1)- testArguments m "vecInt8" :: IO (V T.Int8)- testArguments m "vecInt16" :: IO (V T.Int16)- testArguments m "vecInt32" :: IO (V T.Int32)- testArguments m "vecInt64" :: IO (V T.Int64)- testArguments m "vecFloat" :: IO (V T.Float)- testArguments m "vecDouble" :: IO (V T.Double)- testArguments m "vecFloat128" :: IO (V T.Float128)- testArguments m "vecX86Float80" :: IO (V T.X86Float80)- testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128)-- return ()--main :: IO ()-main = do- m <- Core.createModule "m"- arguments m- return ()