diff --git a/LLVM/Core.hs b/LLVM/Core.hs --- a/LLVM/Core.hs +++ b/LLVM/Core.hs @@ -46,6 +46,7 @@ zero, allOnes, undef, createString, createStringNul, withString, withStringNul, + withModule, Module(..), --constString, constStringNul, constVector, constArray, constStruct, constPackedStruct, @@ -64,7 +65,7 @@ -- * Globals Linkage(..), -- * Basic blocks - BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, createNamedBasicBlock, getCurrentBasicBlock, getBasicBlocks, fromLabel, toLabel, getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, @@ -72,8 +73,10 @@ addAttributes, Attribute(..), castVarArgs, -- * Debugging - dumpValue, dumpType, getValueName, annotateValueList + dumpValue, dumpType, annotateValueList, + getValueName, setValueName, setValueName_ ) where + import qualified LLVM.FFI.Core as FFI import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) import LLVM.Core.CodeGen @@ -95,6 +98,14 @@ -- |Get the name of a 'Value'. getValueName :: Value a -> IO String getValueName (Value a) = getValueNameU a + +-- |Set the name of a 'Value'. +setValueName :: String -> Value a -> IO (Value a) +setValueName str v@(Value a) = setValueNameU str a >> return v + +-- |Set the name of a 'Value'. +setValueName_ :: String -> Value a -> IO () +setValueName_ str (Value a) = setValueNameU str a -- |Convert a varargs function to a regular function. castVarArgs :: (CastVarArgs a b) => Function a -> Function b diff --git a/LLVM/Core/CodeGen.hs b/LLVM/Core/CodeGen.hs --- a/LLVM/Core/CodeGen.hs +++ b/LLVM/Core/CodeGen.hs @@ -24,7 +24,7 @@ withString, withStringNul, constVector, constArray, constStruct, constPackedStruct, -- * Basic blocks - BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, createNamedBasicBlock, getCurrentBasicBlock, fromLabel, toLabel, -- * Misc withCurrentBuilder @@ -143,10 +143,10 @@ constFieldsOf _ = [] constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a -constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 +constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) False constI :: (IsInteger a, Integral a) => a -> ConstValue a -constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i) +constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (isSigned i) constF :: (IsFloating a, Real a) => a -> ConstValue a constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i) @@ -303,6 +303,12 @@ defineBasicBlock b return b +createNamedBasicBlock :: String -> CodeGenFunction r BasicBlock +createNamedBasicBlock name = do + b <- newNamedBasicBlock name + defineBasicBlock b + return b + newBasicBlock :: CodeGenFunction r BasicBlock newBasicBlock = genFSym >>= newNamedBasicBlock @@ -409,7 +415,7 @@ modul <- getModule let typ = typeRef (undefined :: a) liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ - when isConst $ FFI.setGlobalConstant g 1 + when isConst $ FFI.setGlobalConstant g True return g -- | Create a new global variable. @@ -490,7 +496,7 @@ name <- genMSym "str" let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n) liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ - FFI.setGlobalConstant g 1 + FFI.setGlobalConstant g True FFI.setInitializer g s return g diff --git a/LLVM/Core/Instructions.hs b/LLVM/Core/Instructions.hs --- a/LLVM/Core/Instructions.hs +++ b/LLVM/Core/Instructions.hs @@ -35,7 +35,7 @@ free, load, store, - getElementPtr, getElementPtr0, + getElementPtr, getElementPtr0, unsafeGetElementPtr, -- * Conversions trunc, zext, sext, fptrunc, fpext, @@ -45,12 +45,13 @@ bitcast, bitcastUnify, -- * Comparison CmpPredicate(..), IntPredicate(..), FPPredicate(..), - CmpRet, + CmpRet(..), cmp, pcmp, icmp, fcmp, select, -- * Other phi, addPhiInputs, call, callWithConv, + sizeOf, alignOf, -- * Classes and types Terminate, @@ -65,10 +66,18 @@ import Data.Word import Data.Map(fromList, (!)) import Foreign.Ptr (FunPtr, ) -import Foreign.C(CInt, CUInt) +import Foreign.C(CUInt) import Data.TypeLevel((:<:), (:>:), (:==:), (:*), D0, D1, D2, D3, D4, D5, D6, D7, D8, D9, d1, toNum, Succ) import qualified LLVM.FFI.Core as FFI +import LLVM.FFI.Core + ( IntPredicate(..) + , toIntPredicate + , fromIntPredicate + , FPPredicate(..) + , toFPPredicate + , fromFPPredicate + ) import LLVM.Core.Data import LLVM.Core.Type import LLVM.Core.CodeGenMonad @@ -688,51 +697,6 @@ CmpLT -> FPOLT CmpLE -> FPOLE - -data IntPredicate = - IntEQ -- ^ equal - | IntNE -- ^ not equal - | IntUGT -- ^ unsigned greater than - | IntUGE -- ^ unsigned greater or equal - | IntULT -- ^ unsigned less than - | IntULE -- ^ unsigned less or equal - | IntSGT -- ^ signed greater than - | IntSGE -- ^ signed greater or equal - | IntSLT -- ^ signed less than - | IntSLE -- ^ signed less or equal - deriving (Eq, Ord, Enum, Show, Typeable) - -fromIntPredicate :: IntPredicate -> CInt -fromIntPredicate p = fromIntegral (fromEnum p + 32) - -toIntPredicate :: Int -> IntPredicate -toIntPredicate p = toEnum $ fromIntegral p - 32 - -data FPPredicate = - FPFalse -- ^ Always false (always folded) - | FPOEQ -- ^ True if ordered and equal - | FPOGT -- ^ True if ordered and greater than - | FPOGE -- ^ True if ordered and greater than or equal - | FPOLT -- ^ True if ordered and less than - | FPOLE -- ^ True if ordered and less than or equal - | FPONE -- ^ True if ordered and operands are unequal - | FPORD -- ^ True if ordered (no nans) - | FPUNO -- ^ True if unordered: isnan(X) | isnan(Y) - | FPUEQ -- ^ True if unordered or equal - | FPUGT -- ^ True if unordered or greater than - | FPUGE -- ^ True if unordered, greater than, or equal - | FPULT -- ^ True if unordered or less than - | 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, Typeable) - -fromFPPredicate :: FPPredicate -> CInt -fromFPPredicate p = fromIntegral (fromEnum p) - -toFPPredicate :: Int -> FPPredicate -toFPPredicate p = toEnum $ fromIntegral p - -- |Acceptable operands to comparison instructions. class CmpOp a b c d | a b -> c where cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value d) @@ -1014,8 +978,8 @@ -- | 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 s . (IsSized a s) => a -> CodeGenFunction r (Value Word64) -_sizeOf a = +sizeOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value Word64) +sizeOf a = liftIO $ liftM Value $ FFI.sizeOf (typeRef a) @@ -1145,13 +1109,9 @@ -- (This is without a doubt the most confusing LLVM instruction, but the types help.) getElementPtr :: forall a o i n r . (GetElementPtr o i n, IsIndexArg a) => Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr n)) -getElementPtr (Value ptr) (a, ixs) = +getElementPtr val (a, ixs) = let ixl = getArg a : getIxList (undefined :: o) ixs in - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withArrayLen ixl $ \ idxLen idxPtr -> - U.withEmptyCString $ - FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) + getElementPtrFromValues val ixl -- | 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 @@ -1159,6 +1119,26 @@ getElementPtr0 :: (GetElementPtr o i n) => Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr n)) getElementPtr0 p i = getElementPtr p (0::Word32, i) + +-- | Call getelementptr directly with a list of indexes. +-- This is should be used only if the runtime type is not yet known. +-- If the indexes and return type are incorrect this function may segfault +-- in LLVMBuildGEP, or assert if debug assertions are enabled. +unsafeGetElementPtr :: forall o i n r . IsIndexArg i => + Value (Ptr o) -> [i] -> CodeGenFunction r (Value (Ptr n)) +unsafeGetElementPtr val i = + let ixl = map getArg i in + getElementPtrFromValues val ixl + +-- | Internal function for emitting a GEP +getElementPtrFromValues :: forall o n r . + Value (Ptr o) -> [FFI.ValueRef] -> CodeGenFunction r (Value n) +getElementPtrFromValues (Value ptr) ixl = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withArrayLen ixl $ \ idxLen idxPtr -> + U.withEmptyCString $ + FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) -------------------------------------- {- diff --git a/LLVM/Core/Type.hs b/LLVM/Core/Type.hs --- a/LLVM/Core/Type.hs +++ b/LLVM/Core/Type.hs @@ -38,7 +38,7 @@ typeDesc2, VarArgs, CastVarArgs, ) where -import Data.Typeable +import Data.Data import Data.List(intercalate) import Data.Int import Data.Word @@ -133,7 +133,7 @@ | TDArray Integer TypeDesc | TDVector Integer TypeDesc | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel | TDStruct [TypeDesc] Bool | TDInvalidType - deriving (Eq, Ord, Show, Typeable) + deriving (Eq, Ord, Show, Typeable, Data) -- XXX isFloating and typeName could be extracted from typeRef -- Usage: diff --git a/LLVM/Core/Util.hs b/LLVM/Core/Util.hs --- a/LLVM/Core/Util.hs +++ b/LLVM/Core/Util.hs @@ -31,7 +31,7 @@ CString, withArrayLen, withEmptyCString, functionType, buildEmptyPhi, addPhiIns, - showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant, + showTypeOf, getValueNameU, setValueNameU, getObjList, annotateValueList, isConstant, -- * Transformation passes addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, @@ -46,7 +46,6 @@ 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 @@ -61,14 +60,13 @@ functionType :: Bool -> Type -> [Type] -> Type functionType varargs retType paramTypes = unsafePerformIO $ withArrayLen paramTypes $ \ len ptr -> - return $ FFI.functionType retType ptr (fromIntegral len) - (fromBool varargs) + return $ FFI.functionType retType ptr (fromIntegral len) 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) + return $ FFI.structType ptr (fromIntegral len) packed -------------------------------------- -- Handle modules @@ -106,7 +104,7 @@ withCString name $ \ namePtr -> withModule mdl $ \ mdlPtr -> do rc <- FFI.writeBitcodeToFile mdlPtr namePtr - when (rc /= 0) $ + when (rc /= False) $ ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc return () @@ -118,13 +116,13 @@ alloca $ \ modPtr -> alloca $ \ errStr -> do rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr - if rrc /= 0 then do + if rrc /= False 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 + if prc /= False then do msg <- peek errStr >>= peekCString ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg else do @@ -160,11 +158,14 @@ pk <- FFI.getTypeKind p case pk of FFI.VoidTypeKind -> return "()" + FFI.HalfTypeKind -> return "Half" 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.X86_MMXTypeKind -> return "X86_MMX" + FFI.MetadataTypeKind -> return "Metadata" FFI.LabelTypeKind -> return "Label" FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")" FFI.FunctionTypeKind -> do @@ -179,7 +180,6 @@ 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 ++ ")" -------------------------------------- @@ -274,7 +274,7 @@ constStringInternal :: Bool -> String -> (Value, Int) constStringInternal nulTerm s = unsafePerformIO $ withCStringLen s $ \(sPtr, sLen) -> - return (FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm)), sLen) + return (FFI.constString sPtr (fromIntegral sLen) (not nulTerm), sLen) constString :: String -> (Value, Int) constString = constStringInternal False @@ -403,14 +403,14 @@ addTargetData :: FFI.TargetDataRef -> PassManager -> IO () addTargetData td pm = withPassManager pm $ FFI.addTargetData td -runFunctionPassManager :: PassManager -> Function -> IO Int -runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn +runFunctionPassManager :: PassManager -> Function -> IO Bool +runFunctionPassManager pm fcn = withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn -initializeFunctionPassManager :: PassManager -> IO Int -initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager +initializeFunctionPassManager :: PassManager -> IO Bool +initializeFunctionPassManager pm = withPassManager pm FFI.initializeFunctionPassManager -finalizeFunctionPassManager :: PassManager -> IO Int -finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager +finalizeFunctionPassManager :: PassManager -> IO Bool +finalizeFunctionPassManager pm = withPassManager pm FFI.finalizeFunctionPassManager -------------------------------------- @@ -432,7 +432,7 @@ 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) + return $ FFI.constStruct ptr (fromIntegral len) packed -------------------------------------- @@ -443,6 +443,11 @@ str <- peekCString cs if str == "" then return (show a) else return str +setValueNameU :: String -> Value -> IO () +setValueNameU str a = do + withCString str $ \ strPtr -> + FFI.setValueName a strPtr + getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a)) -> (Ptr a -> IO (Ptr a)) -> t1 -> t getObjList withF firstF nextF obj = do @@ -460,9 +465,7 @@ return $ zip names vs isConstant :: Value -> IO Bool -isConstant v = do - isC <- FFI.isConstant v - if isC == 0 then return False else return True +isConstant = FFI.isConstant isIntrinsic :: Value -> IO Bool isIntrinsic v = do diff --git a/LLVM/ExecutionEngine.hs b/LLVM/ExecutionEngine.hs --- a/LLVM/ExecutionEngine.hs +++ b/LLVM/ExecutionEngine.hs @@ -16,7 +16,7 @@ getFreePointers, FreePointers, -- * Translation Translatable, Generic, - generateFunction, + generateFunction, generateFunctionFromRef, -- * Unsafe type conversion Unsafe, unsafePurify, @@ -54,7 +54,10 @@ -- then you should better use 'getPointerToFunction'. generateFunction :: (Translatable f) => Value (Ptr f) -> EngineAccess f -generateFunction (Value f) = do +generateFunction (Value f) = generateFunctionFromRef f + +generateFunctionFromRef :: (Translatable f) => ValueRef -> EngineAccess f +generateFunctionFromRef f = do run <- getRunFunction return $ translate run [] f diff --git a/LLVM/Util/Optimize.hs b/LLVM/Util/Optimize.hs --- a/LLVM/Util/Optimize.hs +++ b/LLVM/Util/Optimize.hs @@ -75,9 +75,7 @@ moduleModified <- FFI.runPassManager passes m - return $ - toEnum (fromIntegral moduleModified) || - toEnum (fromIntegral functionsModified) + return $ moduleModified || functionsModified -- tools/opt/opt.cpp: AddOptimizationPasses addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO () diff --git a/examples/List.hs b/examples/List.hs --- a/examples/List.hs +++ b/examples/List.hs @@ -4,7 +4,7 @@ import LLVM.Util.Loop (Phi, phis, addPhis, ) import LLVM.ExecutionEngine (simpleFunction, ) -import LLVM.Core +import LLVM.Core hiding ( sizeOf ) import qualified System.IO as IO import Data.Word (Word32, ) diff --git a/llvm.cabal b/llvm.cabal --- a/llvm.cabal +++ b/llvm.cabal @@ -1,11 +1,13 @@ name: llvm -version: 3.0.1.0 +version: 3.2.0.0 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit. description: High-level bindings to the LLVM compiler toolkit. . + * New in 3.2.0.0: Builds against LLVM 3.2 + . * New in 3.0.0.0: The low-level bindings have been split into the llvm-base package. . @@ -42,7 +44,7 @@ base >= 3 && < 5, bytestring >= 0.9, directory, - llvm-base >= 3.0.0.1 && < 4, + llvm-base >= 3.2.0.0 && < 4, mtl, process, type-level,