llvm 0.6.6.0 → 0.6.7.0

raw patch · 21 files changed

+250/−133 lines, 21 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• LLVM/Core.hs +1/−0
• LLVM/Core/CodeGen.hs +43/−16
• LLVM/Core/CodeGenMonad.hs +6/−3
• LLVM/Core/Data.hs +16/−7
• LLVM/Core/Instructions.hs +23/−5
• LLVM/Core/Type.hs +42/−5
• LLVM/Core/Util.hs +21/−5
• LLVM/Core/Vector.hs +4/−8
• LLVM/ExecutionEngine/Engine.hs +3/−1
• LLVM/ExecutionEngine/Target.hs +25/−21
• LLVM/FFI/Core.hsc +17/−9
• LLVM/FFI/ExecutionEngine.hsc +4/−2
• LLVM/FFI/Target.hsc +15/−13
• LLVM/Util/Arithmetic.hs +3/−3
• examples/Align.hs +6/−4
• examples/Arith.hs +6/−10
• examples/BrainF.hs +2/−7
• examples/DotProd.hs +2/−7
• examples/HelloJIT.hs +1/−1
• examples/Makefile +8/−5
• llvm.cabal +2/−1

@@ -43,6 +43,7 @@     Value, ConstValue, valueOf, constOf, value,     zero, allOnes, undef,     createString, createStringNul,+    --constString, constStringNul,     constVector, constArray,     toVector, fromVector,     -- * Code generation

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, FlexibleContexts, ScopedTypeVariables, DeriveDataTypeable #-} module LLVM.Core.CodeGen(     -- * Module creation     newModule, newNamedModule, defineModule, createModule,@@ -26,10 +26,13 @@     -- * Misc     withCurrentBuilder     ) where+import Data.Typeable import Control.Monad(liftM, when) import Data.Int import Data.Word-import Data.TypeLevel hiding (Bool, Eq, (+))+import Foreign.Ptr(minusPtr, nullPtr)+import Foreign.Storable(sizeOf)+import Data.TypeLevel hiding (Bool, Eq, (+), (==)) import LLVM.Core.CodeGenMonad import qualified LLVM.FFI.Core as FFI import qualified LLVM.Core.Util as U@@ -61,7 +64,7 @@ --------------------------------------  newtype ModuleValue = ModuleValue FFI.ValueRef-    deriving (Show)+    deriving (Show, Typeable)  getModuleValues :: U.Module -> IO [(String, ModuleValue)] getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues@@ -73,13 +76,13 @@ --------------------------------------  newtype Value a = Value { unValue :: FFI.ValueRef }-    deriving (Show)+    deriving (Show, Typeable) -newtype ConstValue a = ConstValue FFI.ValueRef-    deriving (Show)+newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef }+    deriving (Show, Typeable)  -- XXX merge with IsArithmetic?-class (IsArithmetic a) => IsConst a where+class IsConst a where     constOf :: a -> ConstValue a  instance IsConst Bool   where constOf = constEnum (typeRef True)@@ -96,13 +99,37 @@ instance IsConst Double where constOf = constF --instance IsConst FP128  where constOf = constF -{--instance IsConst (Array n a) where-    constOf (Array xs) = -      withArrayLen xs $ \ len ptr ->-        constArray (typeRef (undefined :: a)) ??? len--}+-- This instance doesn't belong here, but mutually recursive modules are painful.+instance (IsType a) => IsConst (Ptr a) where+    constOf p =+        let ip = p `minusPtr` nullPtr+            inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef (undefined :: Ptr a))+        in  if sizeOf p == 4 then+                inttoptrC $ constOf (fromIntegral ip :: Word32)+            else if sizeOf p == 8 then+                inttoptrC $ constOf (fromIntegral ip :: Word64)+            else+                error "constOf Ptr: pointer size not 4 or 8" +instance (IsPrimitive a, IsConst a, IsPowerOf2 n) => IsConst (Vector n a) where+    constOf (Vector xs) = constVector (map constOf xs)++instance (IsConst a, IsSized a s, Nat n) => IsConst (Array n a) where+    constOf (Array xs) = constArray (map constOf xs)++instance (IsConstFields a) => IsConst (Struct a) where+    constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False+instance (IsConstFields a) => IsConst (PackedStruct a) where+    constOf (PackedStruct a) = ConstValue $ 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 _ = []+ constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 @@ -245,7 +272,7 @@  -- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction. newtype BasicBlock = BasicBlock FFI.BasicBlockRef-    deriving (Show)+    deriving (Show, Typeable)  createBasicBlock :: CodeGenFunction r BasicBlock createBasicBlock = do@@ -378,7 +405,7 @@     | DLLExportLinkage    -- ^Function to be accessible from DLL     | ExternalWeakLinkage -- ^ExternalWeak linkage description     | GhostLinkage        -- ^Stand-in functions for streaming fns from BC files    -    deriving (Show, Eq, Ord, Enum)+    deriving (Show, Eq, Ord, Enum, Typeable)  {- -- |An enumeration for the kinds of visibility of global values.@@ -399,4 +426,4 @@ -- |Make a constant array.  Replicates or truncates the list to get length /n/. constArray :: forall a n s . (IsSized a s, Nat n) => [ConstValue a] -> ConstValue (Array n a) constArray xs =-    ConstValue $ U.constArray (typeRef (undefined :: Array n a)) (toNum (undefined :: n)) [ v | ConstValue v <- xs ]+    ConstValue $ U.constArray (typeRef (undefined :: a)) (toNum (undefined :: n)) [ v | ConstValue v <- xs ]

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module LLVM.Core.CodeGenMonad(     -- * Module code generation     CodeGenModule, runCodeGenModule, genMSym, getModule,@@ -7,6 +7,7 @@     -- * Reexport     liftIO     ) where+import Data.Typeable import Control.Monad.State  import LLVM.Core.Util(Module, Builder, Function)@@ -18,8 +19,9 @@     cgm_externs :: [(String, Function)],     cgm_next :: !Int     }+    deriving (Show, Typeable) newtype CodeGenModule a = CGM (StateT CGMState IO a)-    deriving (Functor, Monad, MonadState CGMState, MonadIO)+    deriving (Functor, Monad, MonadState CGMState, MonadIO, Typeable)  genMSym :: String -> CodeGenModule String genMSym prefix = do@@ -44,8 +46,9 @@     cgf_function :: Function,     cgf_next :: !Int     }+    deriving (Show, Typeable) newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)-    deriving (Functor, Monad, MonadState (CGFState r), MonadIO)+    deriving (Functor, Monad, MonadState (CGFState r), MonadIO, Typeable)  genFSym :: CodeGenFunction a String genFSym = do

@@ -1,6 +1,7 @@-{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE EmptyDataDecls, DeriveDataTypeable #-} module LLVM.Core.Data(IntN(..), WordN(..), FP128(..),-       		      Array(..), Vector(..), Ptr, Label) where+       		      Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where+import Data.Typeable import Foreign.Ptr(Ptr) import Data.TypeLevel @@ -12,24 +13,32 @@ -- |Variable sized signed integer. -- The /n/ parameter should belong to @PosI@. newtype (Pos n) => IntN n = IntN Integer-    deriving (Show)+    deriving (Show, Typeable)  -- |Variable sized unsigned integer. -- The /n/ parameter should belong to @PosI@. newtype (Pos n) => WordN n = WordN Integer-    deriving (Show)+    deriving (Show, Typeable)  -- |128 bit floating point. newtype FP128 = FP128 Rational-    deriving (Show)+    deriving (Show, Typeable)  -- |Fixed sized arrays, the array size is encoded in the /n/ parameter. newtype (Nat n) => Array n a = Array [a]-    deriving (Show)+    deriving (Show, Typeable)  -- |Fixed sized vector, the array size is encoded in the /n/ parameter. newtype Vector n a = Vector [a]-    deriving (Show)+    deriving (Show, Typeable)  -- |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)+

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, FlexibleContexts, TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, FlexibleContexts, TypeOperators, DeriveDataTypeable #-} module LLVM.Core.Instructions(     -- * Terminator instructions     ret,@@ -26,7 +26,7 @@     free,     load,     store,-    getElementPtr,+    getElementPtr, getElementPtr0,     -- * Conversions     trunc, zext, sext,     fptrunc, fpext,@@ -49,11 +49,12 @@     GetElementPtr, IsIndexArg     ) where import Prelude hiding (and, or)+import Data.Typeable import Control.Monad(liftM) import Data.Int import Data.Word import Foreign.C(CInt)-import Data.TypeLevel((:<:), (:>:), (:==:))+import Data.TypeLevel((:<:), (:>:), (:==:), D0, toNum, Succ, Nat) import qualified LLVM.FFI.Core as FFI import LLVM.Core.Data import LLVM.Core.Type@@ -344,7 +345,7 @@   | IntSGE                      -- ^ signed greater or equal   | IntSLT                      -- ^ signed less than   | IntSLE                      -- ^ signed less or equal-    deriving (Eq, Ord, Enum, Show)+    deriving (Eq, Ord, Enum, Show, Typeable)  fromIntPredicate :: IntPredicate -> CInt fromIntPredicate p = fromIntegral (fromEnum p + 32)@@ -366,7 +367,7 @@   | FPULE             -- ^ True if unordered, less than, or equal   | FPUNE             -- ^ True if unordered or not equal   | FPT               -- ^ Always true (always folded)-    deriving (Eq, Ord, Enum, Show)+    deriving (Eq, Ord, Enum, Show, Typeable)  fromFPPredicate :: FPPredicate -> CInt fromFPPredicate p = fromIntegral (fromEnum p)@@ -626,6 +627,17 @@ instance (GetElementPtr o i n, IsIndexArg a) => GetElementPtr (Vector k o) (a, i) n where     getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i +-- Index in Struct and PackedStruct.+-- The index has to be a type level integer to statically determine the record field type+instance (GetElementPtr o i n, GetField fs a o, Nat a) => GetElementPtr (Struct fs) (a, i) n where+    getIxList _ (v, i) = unConst (constOf (toNum v :: Word32)) : getIxList (undefined :: o) i+instance (GetElementPtr o i n, GetField fs a o, Nat a) => GetElementPtr (PackedStruct fs) (a, i) n where+    getIxList _ (v, i) = unConst (constOf (toNum v :: Word32)) : getIxList (undefined :: o) i++class GetField as i a | as i -> a+instance GetField (a, as) D0 a+instance (GetField as i b, Succ i i') => GetField (a, as) i' b+ -- | 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.)@@ -639,6 +651,12 @@         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 n) =>+                  Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr n))+getElementPtr0 p i = getElementPtr p (0::Word32, i)  -------------------------------------- {-

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, IncoherentInstances #-}+{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, IncoherentInstances, TypeOperators, DeriveDataTypeable #-} -- |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@@ -18,25 +18,28 @@     IsFunction,     -- ** Others     IsPowerOf2,+    -- ** Structs+    (:&), (&),     -- ** Type tests     TypeDesc(..),     isFloating,     isSigned,     typeRef,     typeName,-    VarArgs, CastVarArgs+    VarArgs, CastVarArgs,     ) where+import Data.Typeable import Data.List(intercalate) import Data.Int import Data.Word import Data.TypeLevel hiding (Bool, Eq)-import LLVM.Core.Util(functionType)+import LLVM.Core.Util(functionType, structType) import LLVM.Core.Data import qualified LLVM.FFI.Core as FFI  -- Usage: vector precondition class (Pos n) => IsPowerOf2 n-instance (LogBaseF D2 n l True, Pos n) => IsPowerOf2 n+instance (LogBase D2 n l, ExpBase D2 l n) => IsPowerOf2 n  -- TODO: -- Move IntN, WordN to a special module that implements those types@@ -61,6 +64,7 @@ 	code (TDPtr a) = FFI.pointerType (code a) 0 	code (TDFunction va as b) = functionType va (code b) (map code as) 	code TDLabel = FFI.labelType+        code (TDStruct ts packed) = structType (map code ts) packed  typeName :: (IsType a) => a -> String typeName = code . typeDesc@@ -74,12 +78,16 @@ 	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 "}")  -- |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-    deriving (Eq, Ord, Show)+              | TDStruct [TypeDesc] Bool+    deriving (Eq, Ord, Show, Typeable)  -- XXX isFloating and typeName could be extracted from typeRef -- Usage:@@ -195,6 +203,29 @@ 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 ~(Struct a) = TDStruct (fieldTypes a) False++instance (StructFields a) => IsType (PackedStruct a) where+    typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True++-- Use a nested tuples for struct fields.+class StructFields as where+    fieldTypes :: as -> [TypeDesc]++instance (IsSized a sa, StructFields as) => StructFields (a :& as) where+    fieldTypes ~(a, as) = typeDesc a : fieldTypes as+instance StructFields () where+    fieldTypes _ = []++-- 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 instance IsArithmetic Double@@ -262,6 +293,7 @@ instance (IsType a) => IsFirstClass (Ptr a) instance IsFirstClass Label instance IsFirstClass () -- XXX This isn't right, but () can be returned+instance (StructFields as) => IsFirstClass (Struct as)  instance IsSized Float D32 instance IsSized Double D64@@ -281,7 +313,11 @@ instance (IsPowerOf2 n, IsPrimitive a, IsSized a s, Mul n s ns, Pos ns) => IsSized (Vector n a) ns instance (IsType a) => IsSized (Ptr a) PtrSize -- instance IsSized Label PtrSize -- labels are not quite first classed+-- We cannot compute the sizes statically :(+instance (StructFields as) => IsSized (Struct as) UnknownSize+instance (StructFields as) => IsSized (PackedStruct as) UnknownSize +type UnknownSize = D99   -- XXX this is wrong! type PtrSize = D32   -- XXX this is wrong!  instance IsPrimitive Float@@ -312,6 +348,7 @@ -- |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" 

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, DeriveDataTypeable #-} module LLVM.Core.Util(     -- * Module handling     Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,@@ -16,9 +16,11 @@     -- * Functions     Function,     addFunction, getParam,+    -- * Structs+    structType,     -- * Globals     addGlobal,-    constString, constStringNul, constVector, constArray,+    constString, constStringNul, constVector, constArray, constStruct,     -- * Instructions     makeCall, makeInvoke,     -- * Misc@@ -31,6 +33,7 @@     addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,     addTargetData     ) where+import Data.Typeable import Data.List(intercalate) import Control.Monad(liftM, when) import Foreign.C.String (withCString, withCStringLen, CString, peekCString)@@ -57,6 +60,12 @@         return $ FFI.functionType retType ptr (fromIntegral len) 	       	 		  (fromBool varargs) +-- unsafePerformIO just to wrap the non-effecting withArrayLen call+structType :: [Type] -> Bool -> Type+structType types packed = unsafePerformIO $+    withArrayLen types $ \ len ptr ->+        return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0)+ -------------------------------------- -- Handle modules @@ -69,7 +78,7 @@ newtype Module = Module {       fromModule :: FFI.ModuleRef     }-    deriving (Show)+    deriving (Show, Typeable)  withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a withModule modul f = f (fromModule modul)@@ -185,6 +194,7 @@ newtype ModuleProvider = ModuleProvider {       fromModuleProvider :: ForeignPtr FFI.ModuleProvider     }+    deriving (Show, Typeable)  withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a)                    -> IO a@@ -205,7 +215,7 @@ newtype Builder = Builder {       fromBuilder :: ForeignPtr FFI.Builder     }-    deriving (Show)+    deriving (Show, Typeable)  withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a withBuilder = withForeignPtr . fromBuilder@@ -317,7 +327,7 @@ newtype PassManager = PassManager {       fromPassManager :: ForeignPtr FFI.PassManager     }-    deriving (Show)+    deriving (Show, Typeable)  withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)                    -> IO a@@ -387,6 +397,12 @@     let xs' = take n (cycle xs)      withArrayLen xs' $ \ len ptr ->         return $ FFI.constArray t ptr (fromIntegral len)++-- The unsafePerformIO is just for the non-effecting withArrayLen+constStruct :: [Value] -> Bool -> Value+constStruct xs packed = unsafePerformIO $ do+    withArrayLen xs $ \ len ptr ->+        return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0)  -------------------------------------- 

@@ -5,12 +5,10 @@ import Data.TypeLevel hiding (Eq, (+), (==), (-), (*), succ, pred, div, mod, divMod, logBase) import LLVM.Core.Type import LLVM.Core.Data-import LLVM.Core.CodeGen(IsConst(..), ConstValue(..))-import LLVM.FFI.Core(constVector) import LLVM.ExecutionEngine.Target import Foreign.Ptr(Ptr, castPtr) import Foreign.Storable(Storable(..))-import Foreign.Marshal.Array(peekArray, pokeArray, withArrayLen)+import Foreign.Marshal.Array(peekArray, pokeArray) import System.IO.Unsafe(unsafePerformIO)  -- XXX Should these really be here?@@ -44,11 +42,9 @@     peek p = fmap Vector $ peekArray (toNum (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)+-- XXX The JITer target data.  This isn't really right.+ourTargetData :: TargetData+ourTargetData = unsafePerformIO getTargetData  -------------------------------------- 

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module LLVM.ExecutionEngine.Engine(        EngineAccess,        runEngineAccess,@@ -14,6 +14,7 @@        ) where import Control.Monad.State import Control.Concurrent.MVar+import Data.Typeable import Data.Int import Data.Word import Foreign.Marshal.Alloc (alloca, free)@@ -118,6 +119,7 @@     ea_engine :: Ptr FFI.ExecutionEngine,     ea_providers :: [ModuleProvider]     }+    deriving (Show, Typeable)  newtype EngineAccess a = EA (StateT EAState IO a)     deriving (Functor, Monad, MonadState EAState, MonadIO)

@@ -1,9 +1,11 @@-module LLVM.ExecutionEngine.Target(TargetData(..), ourTargetData, targetDataFromString) where---import Data.Word+{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}+module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where+import Data.Typeable+import Data.TypeLevel(Nat, reifyIntegral) import Foreign.C.String import System.IO.Unsafe(unsafePerformIO) ---import LLVM.Core+import LLVM.Core.Data(WordN) import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData)  import qualified LLVM.FFI.Core as FFI@@ -25,33 +27,35 @@     sizeOfTypeInBits           :: Type -> Int,     storeSizeOfType            :: Type -> Int     }+    deriving (Typeable) -un :: IO a -> a-un = unsafePerformIO+withIntPtrType :: (forall n . (Nat n) => WordN n -> a) -> a+withIntPtrType f = reifyIntegral sz (\ n -> f (g n))+  where g :: n -> WordN n+        g _ = error "withIntPtrType: argument used"+        sz = pointerSize $ unsafePerformIO getTargetData  -- Gets the target data for the JIT target.--- This is really constant, so unsafePerformIO is safe.-ourEngineTargetDataRef :: FFI.TargetDataRef-ourEngineTargetDataRef = un $-    runEngineAccess getExecutionEngineTargetData+getEngineTargetDataRef :: IO FFI.TargetDataRef+getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData  -- Normally the TargetDataRef never changes, so the operation -- are really pure functions. makeTargetData :: FFI.TargetDataRef -> TargetData makeTargetData r = TargetData {-    aBIAlignmentOfType       = fromIntegral . un . FFI.aBIAlignmentOfType r,-    aBISizeOfType            = fromIntegral . un . FFI.aBISizeOfType r,-    littleEndian             = un (FFI.byteOrder r) /= 0,-    callFrameAlignmentOfType = fromIntegral . un . FFI.callFrameAlignmentOfType r,-    intPtrType               = un $ FFI.intPtrType r,-    pointerSize              = fromIntegral $ un $ FFI.pointerSize r,-    preferredAlignmentOfType = fromIntegral . un . FFI.preferredAlignmentOfType r,-    sizeOfTypeInBits         = fromIntegral . un . FFI.sizeOfTypeInBits r,-    storeSizeOfType          = fromIntegral . un . FFI.storeSizeOfType r+    aBIAlignmentOfType       = fromIntegral . FFI.aBIAlignmentOfType r,+    aBISizeOfType            = fromIntegral . FFI.aBISizeOfType r,+    littleEndian             = FFI.byteOrder r /= 0,+    callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r,+    intPtrType               = FFI.intPtrType r,+    pointerSize              = fromIntegral $ FFI.pointerSize r,+    preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r,+    sizeOfTypeInBits         = fromIntegral . FFI.sizeOfTypeInBits r,+    storeSizeOfType          = fromIntegral . FFI.storeSizeOfType r     } -ourTargetData :: TargetData-ourTargetData = makeTargetData ourEngineTargetDataRef+getTargetData :: IO TargetData+getTargetData = fmap makeTargetData getEngineTargetDataRef  targetDataFromString :: String -> TargetData-targetDataFromString s = makeTargetData $ un $ withCString s FFI.createTargetData+targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-}  -- | -- Module:      LLVM.FFI.Core@@ -360,7 +360,7 @@      , dumpModule     ) where-+import Data.Typeable(Typeable) import Foreign.C.String (CString) import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) import Foreign.Ptr (Ptr, FunPtr)@@ -368,6 +368,7 @@ #include <llvm-c/Core.h>  data Module+    deriving (Typeable) type ModuleRef = Ptr Module  foreign import ccall unsafe "LLVMModuleCreateWithName" moduleCreateWithName@@ -387,6 +388,7 @@   data ModuleProvider+    deriving (Typeable) type ModuleProviderRef = Ptr ModuleProvider  foreign import ccall unsafe "LLVMCreateModuleProviderForExistingModule"@@ -398,6 +400,7 @@   data Type+    deriving (Typeable) type TypeRef = Ptr Type  foreign import ccall unsafe "LLVMInt1Type" int1Type :: TypeRef@@ -479,6 +482,7 @@   data Value+    deriving (Typeable) type ValueRef = Ptr Value  foreign import ccall unsafe "LLVMAddGlobal" addGlobal@@ -579,7 +583,7 @@                        | Cold                        | X86StdCall                        | X86FastCall-                         deriving (Show, Eq, Ord, Enum, Bounded)+                         deriving (Show, Eq, Ord, Enum, Bounded, Typeable)  fromCallingConvention :: CallingConvention -> CUInt fromCallingConvention C = (#const LLVMCCallConv)@@ -807,6 +811,7 @@     :: BasicBlockRef -> IO ()  data Builder+    deriving (Typeable) type BuilderRef = Ptr Builder  foreign import ccall unsafe "LLVMCreateBuilder" createBuilder@@ -959,18 +964,20 @@     :: ValueRef -> CUInt -> IO ()  foreign import ccall unsafe "LLVMStructType" structType-    :: (Ptr TypeRef) -> CUInt -> CInt -> IO TypeRef+    :: Ptr TypeRef -> CUInt -> CInt -> TypeRef foreign import ccall unsafe "LLVMCountStructElementTypes"-    countStructElementTypes :: TypeRef -> IO CUInt+    countStructElementTypes :: TypeRef -> CUInt foreign import ccall unsafe "LLVMGetStructElementTypes" getStructElementTypes-    :: TypeRef -> (Ptr TypeRef) -> IO ()+    :: TypeRef -> Ptr TypeRef -> IO () foreign import ccall unsafe "LLVMIsPackedStruct" isPackedStruct-    :: TypeRef -> IO CInt+    :: TypeRef -> CInt  data MemoryBuffer+    deriving (Typeable) type MemoryBufferRef = Ptr MemoryBuffer  data TypeHandle+    deriving (Typeable) type TypeHandleRef = Ptr TypeHandle  data TypeKind@@ -988,7 +995,7 @@     | PointerTypeKind     | OpaqueTypeKind     | VectorTypeKind-    deriving (Eq, Ord, Enum, Bounded, Show, Read)+    deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable)  getTypeKind :: TypeRef -> IO TypeKind getTypeKind = fmap (toEnum . fromIntegral) . getTypeKindCUInt@@ -1038,7 +1045,7 @@     | NestAttribute     | ReadNoneAttribute     | ReadOnlyAttribute-    deriving (Show, Eq, Ord, Enum, Bounded)+    deriving (Show, Eq, Ord, Enum, Bounded, Typeable)  fromAttribute :: Attribute -> CAttribute fromAttribute ZExtAttribute = (#const LLVMZExtAttribute)@@ -1070,6 +1077,7 @@ type CAttribute = CInt  data PassManager+    deriving (Typeable) type PassManagerRef = Ptr PassManager  foreign import ccall unsafe "LLVMConstRealOfString" constRealOfString

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-}  module LLVM.FFI.ExecutionEngine     (@@ -32,7 +32,7 @@     , genericValueToPointer     , ptrDisposeGenericValue     ) where-+import Data.Typeable import Foreign.C.String (CString) import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) import Foreign.Ptr (Ptr, FunPtr)@@ -41,6 +41,7 @@ import LLVM.FFI.Target(TargetDataRef)  data ExecutionEngine+    deriving (Typeable) type ExecutionEngineRef = Ptr ExecutionEngine  foreign import ccall unsafe "LLVMCreateExecutionEngine" createExecutionEngine@@ -58,6 +59,7 @@   data GenericValue+    deriving (Typeable) type GenericValueRef = Ptr GenericValue  foreign import ccall unsafe "LLVMCreateGenericValueOfInt"

@@ -1,6 +1,7 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable #-}  module LLVM.FFI.Target where+import Data.Typeable import Foreign.C.String (CString) import Foreign.C.Types (CInt, CUInt, CULLong) import Foreign.Ptr (Ptr)@@ -11,18 +12,19 @@ type ByteOrdering = CInt  data TargetData+    deriving (Typeable) type TargetDataRef = Ptr TargetData  foreign import ccall unsafe "LLVMABIAlignmentOfType" aBIAlignmentOfType-    :: TargetDataRef -> TypeRef -> IO CUInt+    :: TargetDataRef -> TypeRef -> CUInt foreign import ccall unsafe "LLVMABISizeOfType" aBISizeOfType-    :: TargetDataRef -> TypeRef -> IO CULLong+    :: TargetDataRef -> TypeRef -> CULLong foreign import ccall unsafe "LLVMAddTargetData" addTargetData     :: TargetDataRef -> PassManagerRef -> IO () foreign import ccall unsafe "LLVMByteOrder" byteOrder-    :: TargetDataRef -> IO ByteOrdering+    :: TargetDataRef -> ByteOrdering foreign import ccall unsafe "LLVMCallFrameAlignmentOfType" callFrameAlignmentOfType-    :: TargetDataRef -> TypeRef -> IO CUInt+    :: TargetDataRef -> TypeRef -> CUInt foreign import ccall unsafe "LLVMCopyStringRepOfTargetData" copyStringRepOfTargetData     :: TargetDataRef -> IO CString foreign import ccall unsafe "LLVMCreateTargetData" createTargetData@@ -30,21 +32,21 @@ foreign import ccall unsafe "LLVMDisposeTargetData" disposeTargetData     :: TargetDataRef -> IO () foreign import ccall unsafe "LLVMElementAtOffset" elementAtOffset-    :: TargetDataRef -> TypeRef -> CULLong -> IO CUInt+    :: TargetDataRef -> TypeRef -> CULLong -> CUInt foreign import ccall unsafe "LLVMIntPtrType" intPtrType-    :: TargetDataRef -> IO TypeRef+    :: TargetDataRef -> TypeRef foreign import ccall unsafe "LLVMInvalidateStructLayout" invalidateStructLayout     :: TargetDataRef -> TypeRef -> IO () foreign import ccall unsafe "LLVMOffsetOfElement" offsetOfElement-    :: TargetDataRef -> TypeRef -> CUInt -> IO CULLong+    :: TargetDataRef -> TypeRef -> CUInt -> CULLong foreign import ccall unsafe "LLVMPointerSize" pointerSize-    :: TargetDataRef -> IO CUInt+    :: TargetDataRef -> CUInt foreign import ccall unsafe "LLVMPreferredAlignmentOfGlobal" preferredAlignmentOfGlobal-    :: TargetDataRef -> ValueRef -> IO CUInt+    :: TargetDataRef -> ValueRef -> CUInt foreign import ccall unsafe "LLVMPreferredAlignmentOfType" preferredAlignmentOfType-    :: TargetDataRef -> TypeRef -> IO CUInt+    :: TargetDataRef -> TypeRef -> CUInt foreign import ccall unsafe "LLVMSizeOfTypeInBits" sizeOfTypeInBits-    :: TargetDataRef -> TypeRef -> IO CULLong+    :: TargetDataRef -> TypeRef -> CULLong foreign import ccall unsafe "LLVMStoreSizeOfType" storeSizeOfType-    :: TargetDataRef -> TypeRef -> IO CULLong+    :: TargetDataRef -> TypeRef -> CULLong 

@@ -132,7 +132,7 @@ instance (Eq (TValue r a)) instance (Ord (TValue r a)) -instance (Cmp a b, Num a, IsConst a) => Num (TValue r a) where+instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Num (TValue r a) where     (+) = binop add     (-) = binop sub     (*) = binop mul@@ -141,13 +141,13 @@     signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0))     fromInteger = return . valueOf . fromInteger -instance (Cmp a b, Num a, IsConst a) => Enum (TValue r a) where+instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Enum (TValue r a) where     succ x = x + 1     pred x = x - 1     fromEnum _ = error "CodeGenFunction Value: fromEnum"     toEnum = fromIntegral -instance (Cmp a b, Num a, IsConst a) => Real (TValue r a) where+instance (IsArithmetic a, Cmp a b, Num a, IsConst a) => Real (TValue r a) where     toRational _ = error "CodeGenFunction Value: toRational"  instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where

@@ -1,5 +1,5 @@ module Align (main) where-import Data.TypeLevel(D4)+import Data.TypeLevel(D1, D2, D4) import Data.Word  import LLVM.Core@@ -7,10 +7,12 @@  main :: IO () main = do-    let td = ourTargetData+    td <- getTargetData     print (littleEndian td,            aBIAlignmentOfType td $ typeRef (undefined :: Word32),-	   aBIAlignmentOfType td $ typeRef (undefined :: Double),+           aBIAlignmentOfType td $ typeRef (undefined :: Word64), 	   aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float),-	   storeSizeOfType td $ typeRef (undefined :: Vector D4 Float)+	   aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double),+	   storeSizeOfType td $ typeRef (undefined :: Vector D4 Float),+           intPtrType td 	   )

@@ -7,6 +7,7 @@ import LLVM.ExecutionEngine import LLVM.Util.Arithmetic import LLVM.Util.Foreign as F+import LLVM.Util.File(writeCodeGenModule)  import Foreign.Storable {-@@ -38,13 +39,7 @@      vectorToPtr fn -writeFunction :: String -> CodeGenModule a -> IO ()-writeFunction name f = do-    m <- newModule-    defineModule m f-    writeBitcodeToFile name m - main :: IO () main = do @@ -53,24 +48,25 @@     let someFn :: Double -> Double         someFn = unsafePurify ioSomeFn -    writeFunction "Arith.bc" mSomeFn'+    writeCodeGenModule "Arith.bc" mSomeFn'      print (someFn 10)     print (someFn 2) -    writeFunction "ArithFib.bc" mFib+    writeCodeGenModule "ArithFib.bc" mFib      fib <- simpleFunction mFib     fib 22 >>= print --    writeFunction "VArith.bc" mVFun+{-+    writeCodeGenModule "VArith.bc" mVFun      ioVFun <- simpleFunction mVFun     let v = toVector (1,2,3,4)      r <- vectorPtrWrap ioVFun v     print r+-}  vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) vectorToPtr f =

@@ -19,6 +19,7 @@ import System.Environment(getArgs)  import LLVM.Core+import LLVM.Util.File(writeCodeGenModule) import LLVM.ExecutionEngine  main :: IO ()@@ -36,18 +37,12 @@     prog <- if length args == 1 then readFile (head args) else return text      when (debug) $-        writeFunction "BrainF.bc" $ brainCompile debug prog 65536+        writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536      bfprog <- simpleFunction $ brainCompile debug prog 65536     when (prog == text) $         putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:"     bfprog--writeFunction :: String -> CodeGenModule a -> IO ()-writeFunction name f = do-    m <- newModule-    defineModule m f-    writeBitcodeToFile name m  brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) brainCompile _debug instrs wmemtotal = do

@@ -5,6 +5,7 @@ import LLVM.Core import LLVM.ExecutionEngine import LLVM.Util.Loop+import LLVM.Util.File(writeCodeGenModule) import LLVM.Util.Foreign  mDotProd :: forall n a . (IsPowerOf2 n,@@ -35,7 +36,7 @@ main :: IO () main = do     let mDotProd' = mDotProd-    writeFunction "DotProd.bc" mDotProd'+    writeCodeGenModule "DotProd.bc" mDotProd'      ioDotProd <- simpleFunction mDotProd'     let dotProd :: [T] -> [T] -> R@@ -50,12 +51,6 @@         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  class Vectorize n a where     vectorize :: a -> [a] -> [Vector n a]

@@ -10,7 +10,7 @@     puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32)     greetz <- createStringNul "Hello, JIT!"     func <- createFunction ExternalLinkage $ do-      tmp <- getElementPtr greetz (0::Word32, (0::Word32, ()))+      tmp <- getElementPtr0 greetz (0::Word32, ())       call puts tmp -- Throw away return value.       ret ()     return func

@@ -1,16 +1,19 @@ ghc := ghc ghcflags := -Wall -optl -w # -DHAS_GETPOINTERTOGLOBAL=1-examples := HelloJIT Fibonacci BrainF Vector Array DotProd Arith Align+examples := HelloJIT Fibonacci BrainF Vector Array DotProd Arith Align Struct -all: $(examples)+all: $(examples:%=%.exe)  Vector:	Convert.hs -%: %.hs-	$(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<+%.exe: %.hs+	$(ghc) $(ghcflags) --make -o $(basename $<).exe -main-is $(basename $<).main $< -%.run: %+Struct.exe:	Struct.hs structCheck.c+	$(ghc) $(ghcflags) --make -o Struct.exe -main-is Struct.main Struct.hs structCheck.c++%.run: %.exe 	./$<  run:	$(examples:%=%.run)

@@ -1,9 +1,10 @@ name: llvm-version: 0.6.6.0+version: 0.6.7.0 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit. description: Bindings to the LLVM compiler toolkit.+             New in 0.6.7.0: Struct types;              New in 0.6.6.0: Bug fixes; 	     New in 0.6.5.0: Adapted to LLVM 2.5; author: Bryan O'Sullivan, Lennart Augustsson