llvm 0.4.2.0 → 0.4.4.1
raw patch · 18 files changed
+651/−48 lines, 18 files
Files
- LLVM/Core.hs +12/−10
- LLVM/Core/CodeGen.hs +33/−6
- LLVM/Core/Data.hs +3/−6
- LLVM/Core/Instructions.hs +2/−2
- LLVM/Core/Type.hs +4/−2
- LLVM/Core/Util.hs +94/−4
- LLVM/Core/Vector.hs +42/−0
- LLVM/ExecutionEngine.hs +5/−1
- LLVM/ExecutionEngine/Engine.hs +27/−4
- LLVM/FFI/Core.hsc +45/−8
- LLVM/FFI/ExecutionEngine.hsc +8/−2
- examples/Array.hs +58/−0
- examples/DotProd.hs +95/−0
- examples/Loop.hs +83/−0
- examples/Makefile +5/−1
- examples/Vector.hs +114/−0
- examples/mainfib.c +12/−0
- llvm.cabal +9/−2
LLVM/Core.hs view
@@ -31,7 +31,8 @@ Module, newModule, newNamedModule, defineModule, destroyModule, createModule, ModuleProvider, createModuleProviderForExistingModule, PassManager, createPassManager, createFunctionPassManager,- writeBitcodeToFile,+ writeBitcodeToFile, readBitcodeFromFile,+ getModuleValues, ModuleValue, castModuleValue, -- * Instructions module LLVM.Core.Instructions, -- * Types classification@@ -43,41 +44,42 @@ zero, allOnes, undef, createString, createStringNul, constVector, constArray,+ mkVector, -- * Code generation CodeGenFunction, CodeGenModule, -- * Functions- Function, newFunction, newNamedFunction, defineFunction, createFunction,+ Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, TFunction, -- * Global variable creation- Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal,+ Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal, -- * Globals Linkage(..), -- * Basic blocks BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, -- * Debugging- dumpValue,+ dumpValue, dumpType, -- * Transformations addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, addTargetData ) where import qualified LLVM.FFI.Core as FFI-import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray)+import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, getModuleValues, valueHasType) import LLVM.Core.CodeGen import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule)-import LLVM.Core.Data+import LLVM.Core.Data hiding (Vector, Array)+import LLVM.Core.Data(Vector, Array) import LLVM.Core.Instructions import LLVM.Core.Type+import LLVM.Core.Vector -- |Print a value. dumpValue :: Value a -> IO () dumpValue (Value v) = FFI.dumpValue v -{--dumpType :: forall a . (IsType a) => Value a -> IO ()-dumpType _ = FFI.dumpValue (typeRef (undefined :: a))--}+dumpType :: Value a -> IO ()+dumpType (Value v) = showTypeOf v >>= putStrLn -- TODO for types: -- Enforce free is only called on malloc memory. (Enforce only one free?)
LLVM/Core/CodeGen.hs view
@@ -1,15 +1,16 @@-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, FlexibleContexts, ScopedTypeVariables #-} module LLVM.Core.CodeGen( -- * Module creation newModule, newNamedModule, defineModule, createModule,+ getModuleValues, ModuleValue, castModuleValue, -- * Globals Linkage(..), -- * Function creation- Function, newFunction, newNamedFunction, defineFunction, createFunction,+ Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, FunctionArgs, TFunction, -- * Global variable creation- Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, TGlobal,+ Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal, -- * Values Value(..), ConstValue(..), IsConst(..), valueOf, value,@@ -55,6 +56,17 @@ -------------------------------------- +newtype ModuleValue = ModuleValue FFI.ValueRef++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) =+ if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing++--------------------------------------+ newtype Value a = Value { unValue :: FFI.ValueRef } newtype ConstValue a = ConstValue FFI.ValueRef@@ -101,15 +113,12 @@ value :: ConstValue a -> Value a value (ConstValue a) = Value a --- Not unsafe, just generates a constant. zero :: forall a . (IsType a) => ConstValue a zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a) --- Not unsafe, just generates a constant. allOnes :: forall a . (IsInteger a) => ConstValue a allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a) --- Not unsafe, just generates a constant. undef :: forall a . (IsType a) => ConstValue a undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a) @@ -169,6 +178,17 @@ defineFunction f body return f +-- | Create a new function with the given body.+createNamedFunction :: (IsFunction f, FunctionArgs f g (CodeGenFunction r ()))+ => Linkage+ -> String+ -> g -- ^ Function body.+ -> CodeGenModule (Function f)+createNamedFunction linkage name body = do+ f <- newNamedFunction linkage name+ defineFunction f body+ return f+ -- XXX This is ugly, it must be possible to make it simpler -- Convert a function of type f = t1->t2->...-> IO r to -- g = Value t1 -> Value t2 -> ... CodeGenFunction r ()@@ -277,6 +297,13 @@ 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
LLVM/Core/Data.hs view
@@ -1,5 +1,6 @@ module LLVM.Core.Data(IntN(..), WordN(..), FP128(..),- Array(..), Vector(..), Ptr(..)) where+ Array(..), Vector(..), Ptr) where+import Foreign.Ptr(Ptr) import Data.TypeNumbers -- TODO:@@ -25,11 +26,7 @@ newtype (IsTypeNumber n) => Array n a = Array [a] deriving (Show) --- XXX Power of 2 size constraint not enforced -- |Fixed sized vector, the array size is encoded in the /n/ parameter.-newtype Vector n a = Vector (Array n a)+newtype Vector n a = Vector [a] deriving (Show) --- |Pointer type.-newtype Ptr a = Ptr a- deriving (Show)
LLVM/Core/Instructions.hs view
@@ -590,11 +590,11 @@ -- Index in Array instance (GetElementPtr o i n, IsIndexArg a) => GetElementPtr (Array k o) (a, i) n where- getIxList ~(Array (a:_)) (v, i) = getArg v : getIxList a i+ getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i -- Index in Vector instance (GetElementPtr o i n, IsIndexArg a) => GetElementPtr (Vector k o) (a, i) n where- getIxList ~(Vector (Array (a:_))) (v, i) = getArg v : getIxList a i+ getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i -- | Address arithmetic. See LLVM description. -- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.
LLVM/Core/Type.hs view
@@ -16,7 +16,9 @@ IsSized, IsFunction, -- IsFunctionRet,- IsSequence+ IsSequence,+ -- ** Others+ IsPowerOf2 ) where import Data.Int import Data.Word@@ -118,7 +120,7 @@ (typeNumber (undefined :: n)) instance (IsType a) => IsType (Ptr a) where- typeRef ~(Ptr a) = FFI.pointerType (typeRef a) 0+ typeRef _ = FFI.pointerType (typeRef (undefined :: a)) 0 -- Functions. instance (IsFirstClass a, IsFunction b) => IsType (a->b) where
LLVM/Core/Util.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} module LLVM.Core.Util( -- * Module handling- Module(..), withModule, createModule, destroyModule, writeBitcodeToFile,+ Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,+ getModuleValues, valueHasType, -- * Module provider handling ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule, -- * Pass manager handling@@ -24,21 +25,27 @@ CString, withArrayLen, withEmptyCString, functionType, buildEmptyPhi, addPhiIns,+ showTypeOf, -- * Transformation passes addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, addTargetData ) where+import Data.List(intercalate) import Control.Monad(liftM, when)-import Foreign.C.String (withCString, withCStringLen, CString)+import Foreign.C.String (withCString, withCStringLen, CString, peekCString) import Foreign.ForeignPtr (ForeignPtr, FinalizerPtr, newForeignPtr, withForeignPtr)-import Foreign.Marshal.Array (withArrayLen, withArray)+import Foreign.Ptr (nullPtr)+import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (Storable(..)) import Foreign.Marshal.Utils (fromBool) import System.IO.Unsafe (unsafePerformIO) import qualified LLVM.FFI.Core as FFI import qualified LLVM.FFI.Target as FFI import qualified LLVM.FFI.BitWriter as FFI+import qualified LLVM.FFI.BitReader as FFI import qualified LLVM.FFI.Transforms.Scalar as FFI type Type = FFI.TypeRef@@ -108,6 +115,88 @@ ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc return () +-- |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 rrc /= 0 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 prc /= 0 then do+ msg <- peek errStr >>= peekCString+ ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg+ else do+ ptr <- peek modPtr+ return $ Module ptr+{-+ final <- h2c_module FFI.disposeModule+ liftM Module $ newForeignPtr final ptr+-}++getModuleValues :: Module -> IO [(String, Value)]+getModuleValues mdl = do+ withModule mdl $ \ mdlPtr -> do+ ffst <- FFI.getFirstFunction mdlPtr+ let floop p = if p == nullPtr then return [] else do+ n <- FFI.getNextFunction p+ ps <- floop n+ sptr <- FFI.getValueName p+ s <- peekCString sptr+ return ((s, p) : ps)+ fs <- floop ffst+ gfst <- FFI.getFirstGlobal mdlPtr+ let gloop p = if p == nullPtr then return [] else do+ n <- FFI.getNextGlobal p+ ps <- gloop n+ sptr <- FFI.getValueName p+ s <- peekCString sptr+ return ((s, p) : ps)+ gs <- gloop gfst+ return (fs ++ gs)++-- 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 module providers @@ -327,3 +416,4 @@ let xs' = take n (cycle xs) withArrayLen xs' $ \ len ptr -> return $ FFI.constArray t ptr (fromIntegral len)+
+ LLVM/Core/Vector.hs view
@@ -0,0 +1,42 @@+{- # OPTIONS_GHC -fno-warn-orphan-instance # -}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables #-}+module LLVM.Core.Vector(MkVector(..)) where+import Data.TypeNumbers+import LLVM.Core.Type+import LLVM.Core.Data+import LLVM.Core.CodeGen(IsConst(..), ConstValue(..), Value)+import LLVM.FFI.Core(constVector)+import Foreign.Ptr(Ptr, castPtr)+import Foreign.Storable(Storable(..))+import Foreign.Marshal.Array(peekArray, pokeArray, withArrayLen)+import System.IO.Unsafe(unsafePerformIO)++-- XXX Should these really be here?+class (IsPowerOf2 n, IsPrimitive a) => MkVector va n a | va -> n a, n a -> va where+ mkVector :: va -> Vector n a++{-+instance (IsPrimitive a) => MkVector (Value a) (D1 End) (Value a) where+ mkVector a = Vector [a]+-}++instance (IsPrimitive a) => MkVector (a, a) (D2 End) a where+ mkVector (a1, a2) = Vector [a1, a2]++instance (IsPrimitive a) => MkVector (a, a, a, a) (D4 End) a where+ mkVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]++instance (IsPrimitive a) => MkVector (a, a, a, a, a, a, a, a) (D8 End) a where+ mkVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]++instance (Storable a, IsTypeNumber n) => Storable (Vector n a) where+ sizeOf _ = sizeOf (undefined :: a) * typeNumber (undefined :: n)+ alignment _ = alignment (undefined :: a) * typeNumber (undefined :: n)+ peek p = fmap Vector $ peekArray (typeNumber (undefined :: n)) (castPtr p :: Ptr a)+ poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs++instance (IsPowerOf2 n, IsPrimitive a, IsConst a) => IsConst (Vector n a) where+ constOf (Vector vs) =+ unsafePerformIO $+ withArrayLen [ c | v <- vs, let ConstValue c = constOf v ] $ \ len ptr ->+ return $ ConstValue $ constVector ptr (fromIntegral len)
LLVM/ExecutionEngine.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. module LLVM.ExecutionEngine( -- * Execution engine ExecutionEngine, createExecutionEngine,+ addModuleProvider, runStaticConstructors, runStaticDestructors,+#if HAS_GETPOINTERTOGLOBAL+ getPointerToFunction,+#endif -- * Translation Translatable, Generic, generateFunction,
LLVM/ExecutionEngine/Engine.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables #-} module LLVM.ExecutionEngine.Engine( ExecutionEngine,- createExecutionEngine, runStaticConstructors, runStaticDestructors,+ createExecutionEngine, addModuleProvider, runStaticConstructors, runStaticDestructors, getExecutionEngineTargetData,+#if HAS_GETPOINTERTOGLOBAL+ getPointerToFunction,+#endif runFunction, GenericValue, Generic(..) ) where@@ -15,14 +18,15 @@ withForeignPtr) import Foreign.Marshal.Utils (fromBool) import Foreign.C.String (peekCString)-import Foreign.Ptr (Ptr)+import Foreign.Ptr (Ptr, FunPtr) import Foreign.Storable (peek) import System.IO.Unsafe (unsafePerformIO) import LLVM.Core.Util(ModuleProvider, withModuleProvider) import qualified LLVM.FFI.ExecutionEngine as FFI import qualified LLVM.FFI.Target as FFI-import LLVM.Core.Util(Function)+import qualified LLVM.Core.Util(Function)+import LLVM.Core.CodeGen(Value(..), Function) import LLVM.Core.Type(IsFirstClass, IsType(..)) -- |The type of the JITer.@@ -35,6 +39,7 @@ withExecutionEngine = withForeignPtr . fromExecutionEngine -- |Create an execution engine for a module provider.+-- Warning, do not call this function more than once. createExecutionEngine :: ModuleProvider -> IO ExecutionEngine createExecutionEngine prov = withModuleProvider prov $ \provPtr ->@@ -53,6 +58,12 @@ foreign import ccall "wrapper" h2c_ee :: (Ptr FFI.ExecutionEngine -> IO ()) -> IO (FinalizerPtr a) +addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO ()+addModuleProvider ee prov =+ withExecutionEngine ee $ \ eePtr ->+ withModuleProvider prov $ \ provPtr ->+ FFI.addModuleProvider eePtr provPtr+ runStaticConstructors :: ExecutionEngine -> IO () runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors @@ -62,6 +73,13 @@ getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData +#if HAS_GETPOINTERTOGLOBAL+getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f)+getPointerToFunction ee (Value f) =+ withExecutionEngine ee $ \ eePtr ->+ FFI.getPointerToGlobal eePtr f+#endif+ -------------------------------------- newtype GenericValue = GenericValue {@@ -168,3 +186,8 @@ 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+
LLVM/FFI/Core.hsc view
@@ -38,6 +38,7 @@ , deleteTypeName , getTypeKind+ , TypeKind(..) -- ** Integer types , int1Type@@ -429,15 +430,15 @@ -- | Indicate whether a function takes varargs. foreign import ccall unsafe "LLVMIsFunctionVarArg" isFunctionVarArg- :: TypeRef -> CInt+ :: TypeRef -> IO CInt -- | Give a function's return type. foreign import ccall unsafe "LLVMGetReturnType" getReturnType- :: TypeRef -> TypeRef+ :: TypeRef -> IO TypeRef -- | Give the number of fixed parameters that a function takes. foreign import ccall unsafe "LLVMCountParamTypes" countParamTypes- :: TypeRef -> CUInt+ :: TypeRef -> IO CUInt -- | Fill out an array with the types of a function's fixed -- parameters.@@ -465,9 +466,9 @@ foreign import ccall unsafe "LLVMDeleteTypeName" deleteTypeName :: ModuleRef -> CString -> IO () --- | Give the type of a sequential type's elements.+-- | Get the type of a sequential type's elements. foreign import ccall unsafe "LLVMGetElementType" getElementType- :: TypeRef -> TypeRef+ :: TypeRef -> IO TypeRef data Value@@ -965,8 +966,26 @@ data TypeHandle type TypeHandleRef = Ptr TypeHandle -type TypeKind = CUInt+data TypeKind+ = VoidTypeKind+ | FloatTypeKind+ | DoubleTypeKind+ | X86_FP80TypeKind+ | FP128TypeKind+ | PPC_FP128TypeKind+ | LabelTypeKind+ | IntegerTypeKind+ | FunctionTypeKind+ | StructTypeKind+ | ArrayTypeKind+ | PointerTypeKind+ | OpaqueTypeKind+ | VectorTypeKind+ deriving (Eq, Ord, Enum, Bounded, Show, Read) +getTypeKind :: TypeRef -> IO TypeKind+getTypeKind = fmap (toEnum . fromIntegral) . getTypeKindCUInt+ foreign import ccall unsafe "LLVMCreateMemoryBufferWithContentsOfFile" createMemoryBufferWithContentsOfFile :: CString -> Ptr MemoryBufferRef -> Ptr CString -> IO CInt foreign import ccall unsafe "LLVMCreateMemoryBufferWithSTDIN" createMemoryBufferWithSTDIN@@ -987,8 +1006,8 @@ :: TypeRef -> IO CUInt foreign import ccall unsafe "LLVMGetTarget" getTarget :: ModuleRef -> IO CString-foreign import ccall unsafe "LLVMGetTypeKind" getTypeKind- :: TypeRef -> IO TypeKind+foreign import ccall unsafe "LLVMGetTypeKind" getTypeKindCUInt+ :: TypeRef -> IO CUInt foreign import ccall unsafe "LLVMGetVectorSize" getVectorSize :: TypeRef -> IO CUInt foreign import ccall unsafe "LLVMRefineType" refineType@@ -1110,3 +1129,21 @@ :: ValueRef -> CUInt -> Attribute -> IO () foreign import ccall unsafe "LLVMSetTailCall" setTailCall :: ValueRef -> CInt -> IO ()+{-+foreign import ccall unsafe "LLVMAddAlias" addAlias+ :: ModuleRef -> TypeRef -> ValueRef -> CString -> IO ValueRef+foreign import ccall unsafe "LLVMBuildExtractValue" buildExtractValue+ :: BuilderRef -> ValueRef -> CUInt -> CString -> IO ValueRef+foreign import ccall unsafe "LLVMBuildInsertValue" buildInsertValue+ :: BuilderRef -> ValueRef -> ValueRef -> CUInt -> CString -> IO ValueRef+foreign import ccall unsafe "LLVMClearInsertionPosition" clearInsertionPosition+ :: BuilderRef -> IO ()+foreign import ccall unsafe "LLVMConstExtractValue" constExtractValue+ :: ValueRef -> Ptr CUInt -> CUInt -> IO ValueRef+foreign import ccall unsafe "LLVMConstInlineAsm" constInlineAsm+ :: TypeRef -> CString -> CString -> CInt -> IO ValueRef+foreign import ccall unsafe "LLVMConstInsertValue" constInsertValue+ :: ValueRef -> ValueRef -> Ptr CUInt -> IO ValueRef+foreign import ccall unsafe "LLVMInsertIntoBuilder" insertIntoBuilder+ :: BuilderRef -> ValueRef -> IO ()+-}
LLVM/FFI/ExecutionEngine.hsc view
@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-} module LLVM.FFI.ExecutionEngine (@@ -18,6 +18,7 @@ , runFunctionAsMain , getExecutionEngineTargetData , addGlobalMapping+ , getPointerToGlobal -- * Generic values , GenericValue@@ -34,7 +35,7 @@ import Foreign.C.String (CString) import Foreign.C.Types (CDouble, CInt, CUInt, CULLong)-import Foreign.Ptr (Ptr)+import Foreign.Ptr (Ptr, FunPtr) import LLVM.FFI.Core (ModuleRef, ModuleProviderRef, TypeRef, ValueRef) import LLVM.FFI.Target(TargetDataRef)@@ -108,3 +109,8 @@ :: ExecutionEngineRef -> IO TargetDataRef foreign import ccall unsafe "LLVMAddGlobalMapping" addGlobalMapping :: ExecutionEngineRef -> ValueRef -> Ptr () -> IO ()++#if HAS_GETPOINTERTOGLOBAL+foreign import ccall unsafe "LLVMGetPointerToGlobal" getPointerToGlobal+ :: ExecutionEngineRef -> ValueRef -> IO (FunPtr a)+#endif
+ examples/Array.hs view
@@ -0,0 +1,58 @@+module Array where+import Data.Word++import LLVM.Core+--import LLVM.ExecutionEngine++import Loop++cg :: CodeGenModule (Function (Double -> IO (Ptr Double)))+cg = do+ dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do+ r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do+ ai <- mul aStride i+ bi <- mul bStride i+ ap <- getElementPtr aPtr (ai, ())+ bp <- getElementPtr bPtr (bi, ())+ a <- load ap+ b <- load bp+ ab <- mul a b+ add (s :: Value Double) ab+ ret r+ let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double)++ -- multiply a:[n x m], b:[m x l]+ matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do+ forLoop (valueOf 0) n () $ \ ni () -> do+ forLoop (valueOf 0) l () $ \ li () -> do+ ni' <- mul ni m+ row <- getElementPtr aPtr (ni', ())+ col <- getElementPtr bPtr (li, ())+ x <- call dotProd m row (valueOf 1) col m+ j <- add ni' li+ p <- getElementPtr cPtr (j, ())+ store x p+ return ()+ ret ()+ let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ())++ let fillArray _ [] = return ()+ fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs++ test <- createNamedFunction ExternalLinkage "test" $ \ x -> do+ a <- arrayMalloc (4 :: Word32)+ fillArray a $ map valueOf [1,2,3,4]+ b <- arrayMalloc (4 :: Word32)+ fillArray b [x,x,x,x]+ c <- arrayMalloc (4 :: Word32)+ call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c+ ret c+ let _ = test :: Function (Double -> IO (Ptr Double))++ return test++main :: IO ()+main = do+ m <- newModule+ _f <- defineModule m cg+ writeBitcodeToFile "Arr.bc" m
+ examples/DotProd.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}+module DotProd where+import Data.Word+import Data.TypeNumbers+import Foreign.Marshal.Array(allocaArray, pokeArray)+import Foreign.Ptr+import Foreign.Storable+import LLVM.Core+import LLVM.ExecutionEngine++import Loop++mDotProd :: forall n a . (IsPowerOf2 n, IsTypeNumber n,+ IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a,+ FunctionArgs (IO a) (CodeGenFunction a ()) (CodeGenFunction 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++ ap <- getElementPtr aPtr (i, ()) -- index into aPtr+ bp <- getElementPtr bPtr (i, ()) -- index into bPtr+ a <- load ap -- load element from a vector+ b <- load bp -- load element from b vector+ ab <- mul a b -- multiply them+ add s ab -- accumulate sum++ r <- forLoop (valueOf (0::Word32)) (valueOf (typeNumber (undefined :: n)))+ (valueOf 0) $ \ i r -> do+ ri <- extractelement s i+ add r ri+ ret (r :: Value a)++type R = Float+type T = Vector (D4 End) R++main :: IO ()+main = do+ let mDotProd' = mDotProd+ writeFunction "DotProd.bc" mDotProd'++ ioDotProd <- simpleFunction mDotProd'+ let dotProd :: [T] -> [T] -> R+ dotProd a b =+ unsafePurify $+ withArrayLen a $ \ aLen aPtr ->+ withArrayLen b $ \ bLen bPtr ->+-- XXX something weird is going on here. Without that putStr the result is wrong.+ putStr "" >>+ ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr+++ let a = [1 .. 8]+ b = [4 .. 11]+ print $ dotProd (vectorize 0 a) (vectorize 0 b)+ print $ sum $ zipWith (*) a b++writeFunction :: String -> CodeGenModule a -> IO ()+writeFunction name f = do+ m <- newModule+ defineModule m f+ writeBitcodeToFile name m++withArrayLen :: (Storable a) => [a] -> (Int -> 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+ act l p'++class Vectorize n a where+ vectorize :: a -> [a] -> [Vector n a]++{-+instance (IsPrimitive a) => Vectorize (D1 End) a where+ vectorize _ [] = []+ vectorize x (x1:xs) = mkVector x1 : vectorize x xs+-}++instance (IsPrimitive a) => Vectorize (D2 End) a where+ vectorize _ [] = []+ vectorize x (x1:x2:xs) = mkVector (x1, x2) : vectorize x xs+ vectorize x xs = vectorize x $ xs ++ [x]++instance (IsPrimitive a) => Vectorize (D4 End) a where+ vectorize _ [] = []+ vectorize x (x1:x2:x3:x4:xs) = mkVector (x1, x2, x3, x4) : vectorize x xs+ vectorize x xs = vectorize x $ xs ++ [x]++instance (IsPrimitive a) => Vectorize (D8 End) a where+ vectorize _ [] = []+ vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = mkVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs+ vectorize x xs = vectorize x $ xs ++ [x]
+ examples/Loop.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeOperators #-}+module Loop(Phi, (:*)(..), forLoop) where+import LLVM.Core++class Phi a where+ phis :: BasicBlock -> a -> CodeGenFunction r a+ addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()++infixr 1 :*+-- XXX should use HList if it was packaged in a nice way.+data a :* b = a :* b+ deriving (Eq, Ord, Show, Read)++instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where+ phis bb (a :* b) = do+ a' <- phi [(a, bb)]+ b' <- phis bb b+ return (a' :* b')+ addPhis bb (a :* b) (a' :* b') = do+ addPhiInputs a [(a', bb)]+ addPhis bb b b'++instance Phi () where+ phis _ _ = return ()+ addPhis _ _ _ = return ()++instance (IsFirstClass a) => Phi (Value a) where+ phis bb a = do+ a' <- phi [(a, bb)]+ return a'+ addPhis bb a a' = do+ addPhiInputs a [(a', bb)]++instance (Phi a, Phi b) => Phi (a, b) where+ phis bb (a, b) = do+ a' <- phis bb a+ b' <- phis bb b+ return (a', b')+ addPhis bb (a, b) (a', b') = do+ addPhis bb a a'+ addPhis bb b b'++instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where+ phis bb (a, b, c) = do+ a' <- phis bb a+ b' <- phis bb b+ c' <- phis bb c+ return (a', b', c')+ addPhis bb (a, b, c) (a', b', c') = do+ addPhis bb a a'+ addPhis bb b b'+ addPhis bb c c'++-- Loop the index variable from low to high. The state in the loop starts as start, and is modified+-- by incr in each iteration.+forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i) =>+ Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a+forLoop low high start incr = do+ top <- getCurrentBasicBlock+ loop <- newBasicBlock+ body <- newBasicBlock+ exit <- newBasicBlock++ br loop++ defineBasicBlock loop+ i <- phi [(low, top)]+ vars <- phis top start+ t <- icmp IntNE i high+ condBr t body exit++ defineBasicBlock body++ vars' <- incr i vars+ i' <- add i (valueOf 1 :: Value i)++ body' <- getCurrentBasicBlock+ addPhis body' vars vars'+ addPhiInputs i [(i', body')]+ br loop+ defineBasicBlock exit++ return vars
examples/Makefile view
@@ -1,8 +1,12 @@ ghc := ghc ghcflags := -Wall -optl -w-examples := HelloJIT Fibonacci BrainF Vector+# -DHAS_GETPOINTERTOGLOBAL=1+examples := HelloJIT Fibonacci BrainF Vector Array DotProd all: $(examples)++Vector: Loop.hs Convert.hs+Array: Loop.hs %: %.hs $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<
+ examples/Vector.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE CPP #-}+module Vector where+import System.Process(system)+--import Control.Monad.Trans(liftIO)+import Data.TypeNumbers+import Data.Word++import LLVM.Core+import LLVM.ExecutionEngine++import Loop+import Convert++-- Type of vector elements.+type T = Float++-- Number of vector elements.+type N = D1 (D6 End)++cgvec :: CodeGenModule (Function (T -> IO T))+cgvec = do+ -- A global variable that vectest messes with.+ acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T))++ -- Return the global variable.+ retAcc <- createNamedFunction ExternalLinkage "retacc" $ do+ vacc <- load acc+ ret vacc+ let _ = retAcc :: Function (IO T) -- Force the type of retAcc.++ -- A function that tests vector opreations.+ f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do++ let v = value (zero :: ConstValue (Vector N T))+ n = typeNumber (undefined :: N) :: Word32++ -- Fill the vector with x, x+1, x+2, ...+ (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do+ x1' <- add x1 (1::T)+ v1' <- insertelement v1 x1 i+ return (x1', v1')++ -- Elementwise cubing of the vector.+ vsq <- mul v1 v1+ vcb <- mul vsq v1++ -- Sum the elements of the vector.+ s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do+ y <- extractelement vcb i+ s' <- add s (y :: Value T)+ return s'++ -- Update the global variable.+ vacc <- load acc+ vacc' <- add vacc s+ store vacc' acc++ ret (s :: Value T)++-- liftIO $ dumpValue f+ return f++-- Run LLVM optimizer at standard level.+optimize :: String -> IO ()+optimize name = do+ _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name+ return ()++-- Optimize the module by writing the bit code to file, running the optimizer, and then reading the file back in.+-- XXX With a working pass manager it wouldn't be necessary to go via a file.+main :: IO ()+main = do+ -- First run standard code.+ m <- newModule+ iovec <- defineModule m cgvec++ ee <- createModuleProviderForExistingModule m >>= createExecutionEngine++#if HAS_GETPOINTERTOGLOBAL+ fptr <- getPointerToFunction ee iovec+ let fvec = convert fptr++ fvec 10 >>= print+#endif++ let vec = generateFunction ee iovec++ vec 10 >>= print++ -- And then optimize and run.+ let name = "Vec.bc"+ writeBitcodeToFile name m+ optimize name+ m' <- readBitcodeFromFile name++ funcs <- getModuleValues m'+ print $ map fst funcs++ let iovec' :: Function (T -> IO T)+ Just iovec' = castModuleValue =<< lookup "vectest" funcs+ ioretacc' :: Function (IO T)+ Just ioretacc' = castModuleValue =<< lookup "retacc" funcs+ createModuleProviderForExistingModule m' >>= addModuleProvider ee+ let vec' = generateFunction ee iovec'+ retacc' = generateFunction ee ioretacc'++ dumpValue iovec'++ vec' 10 >>= print+ vec' 0 >>= print+ retacc' >>= print+++
+ examples/mainfib.c view
@@ -0,0 +1,12 @@+#include <stdio.h>+#include <stdlib.h>++extern unsigned int fib(unsigned int);++int+main(int argc, char **argv)+{+ int n = argc > 1 ? atoi(argv[1]) : 10;+ printf("fib %d = %d\n", n, fib(n));+ exit(0);+}
llvm.cabal view
@@ -1,12 +1,12 @@ name: llvm-version: 0.4.2.0+version: 0.4.4.1 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit description: Bindings to the LLVM compiler toolkit author: Bryan O'Sullivan, Lennart Augustsson maintainer: Bryan O'Sullivan <bos@serpentine.com>, Lennart Augustsson <lennart@augustsson.net>-homepage: http://www.serpentine.com/llvm/+homepage: http://darcs.serpentine.com/llvm/ stability: experimental category: Compilers/Interpreters, Code Generation tested-with: GHC == 6.8.2, GHC == 6.10.1@@ -20,10 +20,15 @@ README.txt configure configure.ac+ examples/Array.hs examples/BrainF.hs+ examples/DotProd.hs examples/Fibonacci.hs examples/HelloJIT.hs+ examples/Loop.hs+ examples/Vector.hs examples/Makefile+ examples/mainfib.c tests/Makefile tests/TestValue.hs tools/Makefile@@ -51,6 +56,7 @@ build-depends: base < 2.0 || >= 2.2, bytestring >= 0.9, mtl ghc-options: -Wall+-- cpp-options: -DHAS_GETPOINTERTOGLOBAL=1 exposed-modules: Data.TypeNumbers@@ -71,4 +77,5 @@ LLVM.Core.Instructions LLVM.Core.Type LLVM.Core.Util+ LLVM.Core.Vector LLVM.ExecutionEngine.Engine