diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -22,7 +22,7 @@ -- without checking they're already defined and so causes warnings. uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] -llvmVersion = Version [3,4] [] +llvmVersion = Version [3,5] [] llvmConfigNames = [ "llvm-config-" ++ (intercalate "." . map show . versionBranch $ llvmVersion), @@ -111,7 +111,7 @@ "3.2" -> "LLVM-3.2svn" x -> "LLVM-" ++ x staticLibs <- liftM (map (fromJust . stripPrefix "-l") . words) $ llvmConfig ["--libs"] - externLibs <- liftM (mapMaybe (stripPrefix "-l") . words) $ llvmConfig ["--ldflags"] + systemLibs <- liftM (map (fromJust . stripPrefix "-l") . words) $ llvmConfig ["--system-libs"] let genericPackageDescription' = genericPackageDescription { condLibrary = do @@ -123,8 +123,8 @@ condTreeComponents = condTreeComponents libraryCondTree ++ [ ( Var (Flag (FlagName "shared-llvm")), - CondNode (mempty { libBuildInfo = mempty { extraLibs = [sharedLib] ++ externLibs } }) [] [], - Just (CondNode (mempty { libBuildInfo = mempty { extraLibs = staticLibs ++ externLibs } }) [] []) + CondNode (mempty { libBuildInfo = mempty { extraLibs = [sharedLib] ++ systemLibs } }) [] [], + Just (CondNode (mempty { libBuildInfo = mempty { extraLibs = staticLibs ++ systemLibs } }) [] []) ) ] } diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,5 +0,0 @@ --*-change-log-*- - -3.4.5.3 Benjamin S. Scarlet 2015-04-11 - * Clean up warnings with ghc-7.10 - * Start changelog diff --git a/llvm-general.cabal b/llvm-general.cabal --- a/llvm-general.cabal +++ b/llvm-general.cabal @@ -1,5 +1,5 @@ name: llvm-general -version: 3.4.6.0 +version: 3.5.0.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -16,11 +16,13 @@ handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell. extra-source-files: - changelog src/LLVM/General/Internal/FFI/Analysis.h + src/LLVM/General/Internal/FFI/Attribute.h + src/LLVM/General/Internal/FFI/AttributeC.hpp src/LLVM/General/Internal/FFI/BinaryOperator.h + src/LLVM/General/Internal/FFI/CallingConvention.h + src/LLVM/General/Internal/FFI/CallingConventionC.hpp src/LLVM/General/Internal/FFI/Constant.h - src/LLVM/General/Internal/FFI/Function.h src/LLVM/General/Internal/FFI/GlobalValue.h src/LLVM/General/Internal/FFI/InlineAssembly.h src/LLVM/General/Internal/FFI/Instruction.h @@ -35,12 +37,6 @@ type: git location: git://github.com/bscarlet/llvm-general.git -source-repository this - type: git - location: git://github.com/bscarlet/llvm-general.git - branch: llvm-3.4 - tag: v3.4.6.0 - flag shared-llvm description: link against llvm shared rather than static library default: False @@ -52,6 +48,7 @@ library build-tools: llvm-config ghc-options: -fwarn-unused-imports + cc-options: -std=c++11 build-depends: base >= 4.6 && < 5, utf8-string >= 0.3.7, @@ -64,7 +61,7 @@ parsec >= 3.1.3, array >= 0.4.0.0, setenv >= 0.1.0, - llvm-general-pure == 3.4.5.4 + llvm-general-pure == 3.5.0.0 extra-libraries: stdc++ hs-source-dirs: src extensions: @@ -131,11 +128,13 @@ LLVM.General.Internal.RawOStream LLVM.General.Internal.RMWOperation LLVM.General.Internal.String + LLVM.General.Internal.TailCallKind LLVM.General.Internal.Target LLVM.General.Internal.Threading LLVM.General.Internal.Type LLVM.General.Internal.Value LLVM.General.Internal.FFI.Analysis + LLVM.General.Internal.FFI.Attribute LLVM.General.Internal.FFI.Assembly LLVM.General.Internal.FFI.BasicBlock LLVM.General.Internal.FFI.BinaryOperator @@ -174,6 +173,7 @@ include-dirs: src c-sources: src/LLVM/General/Internal/FFI/AssemblyC.cpp + src/LLVM/General/Internal/FFI/AttributeC.cpp src/LLVM/General/Internal/FFI/BitcodeC.cpp src/LLVM/General/Internal/FFI/BuilderC.cpp src/LLVM/General/Internal/FFI/ConstantC.cpp @@ -205,8 +205,8 @@ HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1, - llvm-general == 3.4.6.0, - llvm-general-pure == 3.4.5.4, + llvm-general == 3.5.0.0, + llvm-general-pure == 3.5.0.0, containers >= 0.4.2.1, mtl >= 2.1, transformers >= 0.3.0.0, @@ -219,6 +219,7 @@ main-is: Test.hs other-modules: LLVM.General.Test.Analysis + LLVM.General.Test.CallingConvention LLVM.General.Test.Constants LLVM.General.Test.DataLayout LLVM.General.Test.ExecutionEngine diff --git a/src/LLVM/General/Internal/Atomicity.hs b/src/LLVM/General/Internal/Atomicity.hs --- a/src/LLVM/General/Internal/Atomicity.hs +++ b/src/LLVM/General/Internal/Atomicity.hs @@ -23,16 +23,27 @@ (FFI.memoryOrderingSequentiallyConsistent, Just A.SequentiallyConsistent) ] -instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.LLVMBool, FFI.MemoryOrdering) where +genCodingInstance [t| A.SynchronizationScope |] ''FFI.SynchronizationScope [ + (FFI.synchronizationScopeSingleThread, A.SingleThread), + (FFI.synchronizationScopeCrossThread, A.CrossThread) + ] + +instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.SynchronizationScope, FFI.MemoryOrdering) where encodeM a = - return (,) `ap` encodeM (maybe False A.crossThread a) `ap` encodeM (liftM A.memoryOrdering a) + return (,) `ap` encodeM (maybe A.SingleThread fst a) `ap` encodeM (liftM snd a) -instance Monad m => DecodeM m (Maybe A.Atomicity) (FFI.LLVMBool, FFI.MemoryOrdering) where - decodeM (ss, ao) = return (liftM . A.Atomicity) `ap` decodeM ss `ap` decodeM ao +instance Monad m => DecodeM m (Maybe A.Atomicity) (FFI.SynchronizationScope, FFI.MemoryOrdering) where + decodeM (ss, ao) = return (liftM . (,)) `ap` decodeM ss `ap` decodeM ao -instance Monad m => EncodeM m A.Atomicity (FFI.LLVMBool, FFI.MemoryOrdering) where +instance Monad m => EncodeM m A.Atomicity (FFI.SynchronizationScope, FFI.MemoryOrdering) where encodeM = encodeM . Just -instance Monad m => DecodeM m A.Atomicity (FFI.LLVMBool, FFI.MemoryOrdering) where +instance Monad m => DecodeM m A.Atomicity (FFI.SynchronizationScope, FFI.MemoryOrdering) where + decodeM = liftM fromJust . decodeM + +instance Monad m => EncodeM m A.MemoryOrdering FFI.MemoryOrdering where + encodeM = encodeM . Just + +instance Monad m => DecodeM m A.MemoryOrdering FFI.MemoryOrdering where decodeM = liftM fromJust . decodeM diff --git a/src/LLVM/General/Internal/Attribute.hs b/src/LLVM/General/Internal/Attribute.hs --- a/src/LLVM/General/Internal/Attribute.hs +++ b/src/LLVM/General/Internal/Attribute.hs @@ -1,154 +1,235 @@ {-# LANGUAGE - TemplateHaskell, MultiParamTypeClasses, - ConstraintKinds + ConstraintKinds, + QuasiQuotes, + UndecidableInstances, + RankNTypes #-} module LLVM.General.Internal.Attribute where import LLVM.General.Prelude -import LLVM.General.TH -import Language.Haskell.TH.Quote - -import Data.List (genericSplitAt) +import Control.Monad.AnyCont +import Control.Monad.Exceptable +import Control.Monad.State (gets) -import Data.Bits +import Foreign.C (CUInt) +import Foreign.Ptr +import Data.Either +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified LLVM.General.Internal.FFI.Attribute as FFI import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI +import LLVM.General.Internal.FFI.LLVMCTypes (parameterAttributeKindP, functionAttributeKindP) -import qualified LLVM.General.AST.Attribute as A.A +import qualified LLVM.General.AST.ParameterAttribute as A.PA +import qualified LLVM.General.AST.FunctionAttribute as A.FA import LLVM.General.Internal.Coding +import LLVM.General.Internal.Context +import LLVM.General.Internal.EncodeAST +import LLVM.General.Internal.DecodeAST -$(do - let - -- build an instance of the Coding class for lists of some kind of attribute - genAttributeListCoding :: (Data a, Bits a) => TypeQ -> Name -> [(a, String)] -> DecsQ - genAttributeListCoding type' ctn attributeData = do - let - lowZeroes :: Bits b => b -> Int - lowZeroes b | testBit b 0 = 0 - lowZeroes b = 1 + lowZeroes (shiftR b 1) - field :: Bits b => b -> (Int, Int) - field b = - let s = lowZeroes b - w = lowZeroes (complement (shiftR b s)) - in - (s,w) - attributeData' = [(mkName n, b, s,w) | (b,n) <- attributeData, let (s,w) = field b ] - let m = varT . mkName $ "m" - TyConI (NewtypeD _ _ _ (NormalC ctcn _) _) <- reify ctn - let zero = [| $(conE ctcn) 0 |] - sequence [ - instanceD (sequence [appT (conT ''Monad) m]) [t| EncodeM $(m) [$(type')] $(conT ctn) |] [ - funD (mkName "encodeM") [ - clause [] (normalB [| return . ( - let - encodeAlignment a | popCount a == 1 = 1 + popCount (a - 1) - encodeAlignment _ = error "Cannot encode alignment which is not a power of two" - encodeAttribute a = $( - caseE [| a |] $ flip map attributeData' $ \(n, b, s, w) -> - let bQ = (dataToExpQ (const Nothing) b) - in - case w of - 1 -> match (conP n []) (normalB bQ) [] - _ -> do - a <- newName "a" - match - (conP n [varP a]) - (normalB [| ($(conE ctcn) (fromIntegral (encodeAlignment $(varE a)) `shiftL` s)) .&. $(bQ) |]) - [] - ) - in - foldl (.|.) $(zero) . map encodeAttribute - ) |]) [] - ] - ], - - -- build a decoder which uses bit masking for multiple fields at once - -- to eliminate multiple absent attributes in fewer tests - instanceD (sequence [appT (conT ''Monad) m]) [t| DecodeM $(m) [$(type')] $(conT ctn) |] [ - funD (mkName "decodeM") [ - do - bits <- newName "bits" - clause [varP bits] (normalB - (let - code :: (Data a, Bits a) => [ (Name, a, Int, Int) ] -- attrs to handle - -> Int -- length (attrs), passed in to avoid recomputation - -> (a, ExpQ) -- (, ) - code [(n, b, s, w)] _ = ( - b, - case w of - 1 -> [| [ $(conE n) | testBit $(varE bits) s ] |] - _-> [| - [ - $(do - i' <- newName "i'" - letE - [valD (conP ctcn [varP i']) (normalB [| i |]) []] - [| $(conE n) (bit ((fromIntegral $(varE i')) - 1)) |]) - | let i = ($(varE bits) .&. $(dataToExpQ (const Nothing) b)) `shiftR` s, - i /= $(zero) - ] - |] - ) - code attrs nAttrs = - let (nEarlyAttrs, nLateAttrs) = (nAttrs `div` 2, nAttrs - nEarlyAttrs) - (earlyAttrs, lateAttrs) = genericSplitAt nEarlyAttrs attrs - (earlyAttrBits, earlyAttrCode) = code earlyAttrs nEarlyAttrs - (lateAttrBits, lateAttrCode) = code lateAttrs nLateAttrs - attrBits = earlyAttrBits .|. lateAttrBits - in - ( - attrBits, - [| - if ($(varE bits) .&. $(dataToExpQ (const Nothing) attrBits) /= $(zero)) then - ($earlyAttrCode ++ $lateAttrCode) - else - [] - |] - ) - in - [| return $(snd $ code attributeData' (length attributeData')) |] - ) - ) [] - ] - ] - ] +instance Monad m => EncodeM m A.PA.ParameterAttribute (Ptr FFI.ParameterAttrBuilder -> EncodeAST ()) where + encodeM a = return $ \b -> liftIO $ case a of + A.PA.Alignment v -> FFI.attrBuilderAddAlignment b v + A.PA.Dereferenceable v -> FFI.attrBuilderAddDereferenceable b v + _ -> FFI.attrBuilderAddParameterAttributeKind b $ case a of + A.PA.ZeroExt -> FFI.parameterAttributeKindZExt + A.PA.SignExt -> FFI.parameterAttributeKindSExt + A.PA.InReg -> FFI.parameterAttributeKindInReg + A.PA.SRet -> FFI.parameterAttributeKindStructRet + A.PA.NoAlias -> FFI.parameterAttributeKindNoAlias + A.PA.ByVal -> FFI.parameterAttributeKindByVal + A.PA.NoCapture -> FFI.parameterAttributeKindNoCapture + A.PA.Nest -> FFI.parameterAttributeKindNest + A.PA.ReadOnly -> FFI.parameterAttributeKindReadOnly + A.PA.ReadNone -> FFI.parameterAttributeKindReadNone + A.PA.InAlloca -> FFI.parameterAttributeKindInAlloca + A.PA.NonNull -> FFI.parameterAttributeKindNonNull + A.PA.Returned -> FFI.parameterAttributeKindReturned - pi <- genAttributeListCoding [t| A.A.ParameterAttribute |] ''FFI.ParamAttr [ - (FFI.paramAttrZExt, "A.A.ZeroExt"), - (FFI.paramAttrSExt, "A.A.SignExt"), - (FFI.paramAttrInReg, "A.A.InReg"), - (FFI.paramAttrStructRet, "A.A.SRet"), - (FFI.paramAttrAlignment, "A.A.Alignment"), - (FFI.paramAttrNoAlias, "A.A.NoAlias"), - (FFI.paramAttrByVal, "A.A.ByVal"), - (FFI.paramAttrNoCapture, "A.A.NoCapture"), - (FFI.paramAttrNest, "A.A.Nest") - ] +instance Monad m => EncodeM m A.FA.FunctionAttribute (Ptr FFI.FunctionAttrBuilder -> EncodeAST ()) where + encodeM (A.FA.StringAttribute kind value) = return $ \b -> do + (kindP, kindLen) <- encodeM kind + (valueP, valueLen) <- encodeM value + liftIO $ FFI.attrBuilderAddStringAttribute b kindP kindLen valueP valueLen + encodeM a = return $ \b -> liftIO $ case a of + A.FA.StackAlignment v -> FFI.attrBuilderAddStackAlignment b v + _ -> FFI.attrBuilderAddFunctionAttributeKind b $ case a of + A.FA.NoReturn -> FFI.functionAttributeKindNoReturn + A.FA.NoUnwind -> FFI.functionAttributeKindNoUnwind + A.FA.ReadNone -> FFI.functionAttributeKindReadNone + A.FA.ReadOnly -> FFI.functionAttributeKindReadOnly + A.FA.NoInline -> FFI.functionAttributeKindNoInline + A.FA.AlwaysInline -> FFI.functionAttributeKindAlwaysInline + A.FA.MinimizeSize -> FFI.functionAttributeKindMinSize + A.FA.OptimizeForSize -> FFI.functionAttributeKindOptimizeForSize + A.FA.OptimizeNone -> FFI.functionAttributeKindOptimizeForSize + A.FA.StackProtect -> FFI.functionAttributeKindStackProtect + A.FA.StackProtectReq -> FFI.functionAttributeKindStackProtectReq + A.FA.StackProtectStrong -> FFI.functionAttributeKindStackProtectStrong + A.FA.NoRedZone -> FFI.functionAttributeKindNoRedZone + A.FA.NoImplicitFloat -> FFI.functionAttributeKindNoImplicitFloat + A.FA.Naked -> FFI.functionAttributeKindNaked + A.FA.InlineHint -> FFI.functionAttributeKindInlineHint + A.FA.ReturnsTwice -> FFI.functionAttributeKindReturnsTwice + A.FA.UWTable -> FFI.functionAttributeKindUWTable + A.FA.NonLazyBind -> FFI.functionAttributeKindNonLazyBind + A.FA.Builtin -> FFI.functionAttributeKindBuiltin + A.FA.NoBuiltin -> FFI.functionAttributeKindNoBuiltin + A.FA.Cold -> FFI.functionAttributeKindCold + A.FA.JumpTable -> FFI.functionAttributeKindJumpTable + A.FA.NoDuplicate -> FFI.functionAttributeKindNoDuplicate + A.FA.SanitizeAddress -> FFI.functionAttributeKindSanitizeAddress + A.FA.SanitizeThread -> FFI.functionAttributeKindSanitizeThread + A.FA.SanitizeMemory -> FFI.functionAttributeKindSanitizeMemory - fi <- genAttributeListCoding [t| A.A.FunctionAttribute |] ''FFI.FunctionAttr [ - (FFI.functionAttrNoReturn, "A.A.NoReturn"), - (FFI.functionAttrNoUnwind, "A.A.NoUnwind"), - (FFI.functionAttrReadNone, "A.A.ReadNone"), - (FFI.functionAttrReadOnly, "A.A.ReadOnly"), - (FFI.functionAttrNoInline, "A.A.NoInline"), - (FFI.functionAttrAlwaysInline, "A.A.AlwaysInline"), - (FFI.functionAttrOptimizeForSize, "A.A.OptimizeForSize"), - (FFI.functionAttrStackProtect, "A.A.StackProtect"), - (FFI.functionAttrStackProtectReq, "A.A.StackProtectReq"), - (FFI.functionAttrNoRedZone, "A.A.NoRedZone"), - (FFI.functionAttrNoImplicitFloat, "A.A.NoImplicitFloat"), - (FFI.functionAttrNaked, "A.A.Naked"), - (FFI.functionAttrInlineHint, "A.A.InlineHint"), - (FFI.functionAttrStackAlignment, "A.A.StackAlignment"), - (FFI.functionAttrReturnsTwice, "A.A.ReturnsTwice"), - (FFI.functionAttrUWTable, "A.A.UWTable"), - (FFI.functionAttrNonLazyBind, "A.A.NonLazyBind") - ] - return (pi ++ fi) - ) +instance DecodeM DecodeAST A.PA.ParameterAttribute FFI.ParameterAttribute where + decodeM a = do + enum <- liftIO $ FFI.parameterAttributeKindAsEnum a + case enum of + [parameterAttributeKindP|ZExt|] -> return A.PA.ZeroExt + [parameterAttributeKindP|SExt|] -> return A.PA.SignExt + [parameterAttributeKindP|InReg|] -> return A.PA.InReg + [parameterAttributeKindP|StructRet|] -> return A.PA.SRet + [parameterAttributeKindP|Alignment|] -> return A.PA.Alignment `ap` (liftIO $ FFI.attributeValueAsInt a) + [parameterAttributeKindP|NoAlias|] -> return A.PA.NoAlias + [parameterAttributeKindP|ByVal|] -> return A.PA.ByVal + [parameterAttributeKindP|NoCapture|] -> return A.PA.NoCapture + [parameterAttributeKindP|Nest|] -> return A.PA.Nest + [parameterAttributeKindP|ReadOnly|] -> return A.PA.ReadOnly + [parameterAttributeKindP|ReadNone|] -> return A.PA.ReadNone + [parameterAttributeKindP|InAlloca|] -> return A.PA.InAlloca + [parameterAttributeKindP|NonNull|] -> return A.PA.NonNull + [parameterAttributeKindP|Dereferenceable|] -> return A.PA.Dereferenceable `ap` (liftIO $ FFI.attributeValueAsInt a) + [parameterAttributeKindP|Returned|] -> return A.PA.Returned + _ -> error $ "unhandled parameter attribute enum value: " ++ show enum +instance DecodeM DecodeAST A.FA.FunctionAttribute FFI.FunctionAttribute where + decodeM a = do + isString <- decodeM =<< (liftIO $ FFI.isStringAttribute a) + if isString + then + return A.FA.StringAttribute + `ap` (decodeM $ FFI.attributeKindAsString a) + `ap` (decodeM $ FFI.attributeValueAsString a) + else do + enum <- liftIO $ FFI.functionAttributeKindAsEnum a + case enum of + [functionAttributeKindP|NoReturn|] -> return A.FA.NoReturn + [functionAttributeKindP|NoUnwind|] -> return A.FA.NoUnwind + [functionAttributeKindP|ReadNone|] -> return A.FA.ReadNone + [functionAttributeKindP|ReadOnly|] -> return A.FA.ReadOnly + [functionAttributeKindP|NoInline|] -> return A.FA.NoInline + [functionAttributeKindP|AlwaysInline|] -> return A.FA.AlwaysInline + [functionAttributeKindP|MinSize|] -> return A.FA.MinimizeSize + [functionAttributeKindP|OptimizeForSize|] -> return A.FA.OptimizeForSize + [functionAttributeKindP|OptimizeNone|] -> return A.FA.OptimizeForSize + [functionAttributeKindP|StackProtect|] -> return A.FA.StackProtect + [functionAttributeKindP|StackProtectReq|] -> return A.FA.StackProtectReq + [functionAttributeKindP|StackProtectStrong|] -> return A.FA.StackProtectStrong + [functionAttributeKindP|NoRedZone|] -> return A.FA.NoRedZone + [functionAttributeKindP|NoImplicitFloat|] -> return A.FA.NoImplicitFloat + [functionAttributeKindP|Naked|] -> return A.FA.Naked + [functionAttributeKindP|InlineHint|] -> return A.FA.InlineHint + [functionAttributeKindP|StackAlignment|] -> return A.FA.StackAlignment `ap` (liftIO $ FFI.attributeValueAsInt a) + [functionAttributeKindP|ReturnsTwice|] -> return A.FA.ReturnsTwice + [functionAttributeKindP|UWTable|] -> return A.FA.UWTable + [functionAttributeKindP|NonLazyBind|] -> return A.FA.NonLazyBind + [functionAttributeKindP|Builtin|] -> return A.FA.Builtin + [functionAttributeKindP|NoBuiltin|] -> return A.FA.NoBuiltin + [functionAttributeKindP|Cold|] -> return A.FA.Cold + [functionAttributeKindP|JumpTable|] -> return A.FA.JumpTable + [functionAttributeKindP|NoDuplicate|] -> return A.FA.NoDuplicate + [functionAttributeKindP|SanitizeAddress|] -> return A.FA.SanitizeAddress + [functionAttributeKindP|SanitizeThread|] -> return A.FA.SanitizeThread + [functionAttributeKindP|SanitizeMemory|] -> return A.FA.SanitizeMemory + _ -> error $ "unhandled function attribute enum value: " ++ show enum + +allocaAttrBuilder :: (Monad m, MonadAnyCont IO m) => m (Ptr (FFI.AttrBuilder a)) +allocaAttrBuilder = do + p <- allocaArray FFI.getAttrBuilderSize + anyContToM $ \f -> do + ab <- FFI.constructAttrBuilder p + r <- f ab + FFI.destroyAttrBuilder ab + return r +instance EncodeM EncodeAST a (Ptr (FFI.AttrBuilder b) -> EncodeAST ()) => EncodeM EncodeAST (FFI.Index, [a]) (FFI.AttributeSet b) where + encodeM (index, as) = scopeAnyCont $ do + ab <- allocaAttrBuilder + builds <- mapM encodeM as + forM builds ($ ab) :: EncodeAST [()] + Context context <- gets encodeStateContext + liftIO $ FFI.getAttributeSet context index ab + +instance EncodeM EncodeAST [A.FA.FunctionAttribute] FFI.FunctionAttributeSet where + encodeM fas = encodeM (FFI.functionIndex, fas) + +instance DecodeM DecodeAST a (FFI.Attribute b) => DecodeM DecodeAST [a] (FFI.AttributeSet b) where + decodeM as = do + np <- alloca + as <- liftIO $ FFI.attributeSetGetAttributes as 0 np + n <- peek np + decodeM (n, as) + +data MixedAttributeSet = MixedAttributeSet { + functionAttributes :: [Either A.FA.GroupID A.FA.FunctionAttribute], + returnAttributes :: [A.PA.ParameterAttribute], + parameterAttributes :: Map CUInt [A.PA.ParameterAttribute] + } + deriving (Eq, Show) + +data PreSlot + = IndirectFunctionAttributes A.FA.GroupID + | DirectFunctionAttributes [A.FA.FunctionAttribute] + | ReturnAttributes [A.PA.ParameterAttribute] + | ParameterAttributes CUInt [A.PA.ParameterAttribute] + +instance EncodeM EncodeAST PreSlot FFI.MixedAttributeSet where + encodeM preSlot = do + let forget = liftM FFI.forgetAttributeType + case preSlot of + IndirectFunctionAttributes gid -> forget (referAttributeGroup gid) + DirectFunctionAttributes fas -> forget (encodeM fas :: EncodeAST FFI.FunctionAttributeSet) + ReturnAttributes as -> forget (encodeM (FFI.returnIndex, as) :: EncodeAST FFI.ParameterAttributeSet) + ParameterAttributes i as -> forget (encodeM (fromIntegral (i + 1) :: FFI.Index, as) :: EncodeAST FFI.ParameterAttributeSet) + +instance EncodeM EncodeAST MixedAttributeSet FFI.MixedAttributeSet where + encodeM (MixedAttributeSet fAttrs rAttrs pAttrs) = do + let directP = DirectFunctionAttributes (rights fAttrs) + indirectPs = map IndirectFunctionAttributes (lefts fAttrs) + returnP = ReturnAttributes rAttrs + paramPs = [ ParameterAttributes x as | (x, as) <- Map.toList pAttrs ] + (nAttrs, attrs) <- encodeM ([directP, returnP] ++ indirectPs ++ paramPs) + Context context <- gets encodeStateContext + liftIO $ FFI.mixAttributeSets context attrs nAttrs + +instance DecodeM DecodeAST MixedAttributeSet FFI.MixedAttributeSet where + decodeM mas = do + numSlots <- if mas == nullPtr then return 0 else liftIO $ FFI.attributeSetNumSlots mas + slotIndexes <- forM (take (fromIntegral numSlots) [0..]) $ \s -> do + i <- liftIO $ FFI.attributeSetSlotIndex mas s + return (i, s) + let separate :: Ord k => k -> Map k a -> (Maybe a, Map k a) + separate = Map.updateLookupWithKey (\_ _ -> Nothing) + indexedSlots = Map.fromList slotIndexes + unless (Map.size indexedSlots == length slotIndexes) $ + fail "unexpected slot index collision decoding mixed AttributeSet" + let (functionSlot, otherSlots) = separate FFI.functionIndex (Map.fromList slotIndexes) + functionAnnotation <- for (maybeToList functionSlot) $ \slot -> do + a <- liftIO $ FFI.attributeSetSlotAttributes mas slot + getAttributeGroupID a + otherAttributeSets <- for otherSlots $ \slot -> do + a <- liftIO $ FFI.attributeSetSlotAttributes mas slot + decodeM (a :: FFI.ParameterAttributeSet) + let (returnAttributeSet, shiftedParameterAttributeSets) = separate FFI.returnIndex otherAttributeSets + return $ MixedAttributeSet { + functionAttributes = fmap Left functionAnnotation, + returnAttributes = join . maybeToList $ returnAttributeSet, + parameterAttributes = Map.mapKeysMonotonic (\x -> fromIntegral x - 1) shiftedParameterAttributeSets + } diff --git a/src/LLVM/General/Internal/CallingConvention.hs b/src/LLVM/General/Internal/CallingConvention.hs --- a/src/LLVM/General/Internal/CallingConvention.hs +++ b/src/LLVM/General/Internal/CallingConvention.hs @@ -11,23 +11,61 @@ import Foreign.C.Types (CUInt(..)) import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI -import LLVM.General.Internal.FFI.LLVMCTypes (callConvP) +import LLVM.General.Internal.FFI.LLVMCTypes (callingConventionP) import qualified LLVM.General.AST.CallingConvention as A.CC -instance Monad m => EncodeM m A.CC.CallingConvention FFI.CallConv where +instance Monad m => EncodeM m A.CC.CallingConvention FFI.CallingConvention where encodeM cc = return $ case cc of - A.CC.C -> FFI.callConvC - A.CC.Fast -> FFI.callConvFast - A.CC.Cold -> FFI.callConvCold - A.CC.GHC -> FFI.CallConv 10 - A.CC.Numbered cc' -> FFI.CallConv (fromIntegral cc') + A.CC.C -> FFI.callingConventionC + A.CC.Fast -> FFI.callingConventionFast + A.CC.Cold -> FFI.callingConventionCold + A.CC.GHC -> FFI.callingConventionGHC + A.CC.HiPE -> FFI.callingConventionHiPE + A.CC.WebKit_JS -> FFI.callingConventionWebKit_JS + A.CC.AnyReg -> FFI.callingConventionAnyReg + A.CC.PreserveMost -> FFI.callingConventionPreserveMost + A.CC.PreserveAll -> FFI.callingConventionPreserveAll + A.CC.X86_StdCall -> FFI.callingConventionX86_StdCall + A.CC.X86_FastCall -> FFI.callingConventionX86_FastCall + A.CC.ARM_APCS -> FFI.callingConventionARM_APCS + A.CC.ARM_AAPCS -> FFI.callingConventionARM_AAPCS + A.CC.ARM_AAPCS_VFP -> FFI.callingConventionARM_AAPCS_VFP + A.CC.MSP430_INTR -> FFI.callingConventionMSP430_INTR + A.CC.X86_ThisCall -> FFI.callingConventionX86_ThisCall + A.CC.PTX_Kernel -> FFI.callingConventionPTX_Kernel + A.CC.PTX_Device -> FFI.callingConventionPTX_Device + A.CC.SPIR_FUNC -> FFI.callingConventionSPIR_FUNC + A.CC.SPIR_KERNEL -> FFI.callingConventionSPIR_KERNEL + A.CC.Intel_OCL_BI -> FFI.callingConventionIntel_OCL_BI + A.CC.X86_64_SysV -> FFI.callingConventionX86_64_SysV + A.CC.X86_64_Win64 -> FFI.callingConventionX86_64_Win64 + A.CC.Numbered cc' -> FFI.CallingConvention (fromIntegral cc') -instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallConv where +instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallingConvention where decodeM cc = return $ case cc of - [callConvP|C|] -> A.CC.C - [callConvP|Fast|] -> A.CC.Fast - [callConvP|Cold|] -> A.CC.Cold - FFI.CallConv (CUInt 10) -> A.CC.GHC - FFI.CallConv (CUInt ci) | ci >= 64 -> A.CC.Numbered (fromIntegral ci) + [callingConventionP|C|] -> A.CC.C + [callingConventionP|Fast|] -> A.CC.Fast + [callingConventionP|Cold|] -> A.CC.Cold + [callingConventionP|GHC|] -> A.CC.GHC + [callingConventionP|HiPE|] -> A.CC.HiPE + [callingConventionP|WebKit_JS|] -> A.CC.WebKit_JS + [callingConventionP|AnyReg|] -> A.CC.AnyReg + [callingConventionP|PreserveMost|] -> A.CC.PreserveMost + [callingConventionP|PreserveAll|] -> A.CC.PreserveAll + [callingConventionP|X86_StdCall|] -> A.CC.X86_StdCall + [callingConventionP|X86_FastCall|] -> A.CC.X86_FastCall + [callingConventionP|ARM_APCS|] -> A.CC.ARM_APCS + [callingConventionP|ARM_AAPCS|] -> A.CC.ARM_AAPCS + [callingConventionP|ARM_AAPCS_VFP|] -> A.CC.ARM_AAPCS_VFP + [callingConventionP|MSP430_INTR|] -> A.CC.MSP430_INTR + [callingConventionP|X86_ThisCall|] -> A.CC.X86_ThisCall + [callingConventionP|PTX_Kernel|] -> A.CC.PTX_Kernel + [callingConventionP|PTX_Device|] -> A.CC.PTX_Device + [callingConventionP|SPIR_FUNC|] -> A.CC.SPIR_FUNC + [callingConventionP|SPIR_KERNEL|] -> A.CC.SPIR_KERNEL + [callingConventionP|Intel_OCL_BI|] -> A.CC.Intel_OCL_BI + [callingConventionP|X86_64_SysV|] -> A.CC.X86_64_SysV + [callingConventionP|X86_64_Win64|] -> A.CC.X86_64_Win64 + FFI.CallingConvention (CUInt ci) | ci >= 64 -> A.CC.Numbered (fromIntegral ci) diff --git a/src/LLVM/General/Internal/DecodeAST.hs b/src/LLVM/General/Internal/DecodeAST.hs --- a/src/LLVM/General/Internal/DecodeAST.hs +++ b/src/LLVM/General/Internal/DecodeAST.hs @@ -20,12 +20,16 @@ import Data.Array (Array) import qualified Data.Array as Array +import qualified LLVM.General.Internal.FFI.Attribute as FFI +import qualified LLVM.General.Internal.FFI.GlobalValue as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.Value as FFI import qualified LLVM.General.Internal.FFI.Type as FFI import qualified LLVM.General.AST.Name as A import qualified LLVM.General.AST.Operand as A (MetadataNodeID(..)) +import qualified LLVM.General.AST.Attribute as A.A +import qualified LLVM.General.AST.COMDAT as A.COMDAT import LLVM.General.Internal.Coding import LLVM.General.Internal.String () @@ -40,7 +44,10 @@ typesToDefine :: Seq (Ptr FFI.Type), metadataNodesToDefine :: Seq (A.MetadataNodeID, Ptr FFI.MDNode), metadataNodes :: Map (Ptr FFI.MDNode) A.MetadataNodeID, - metadataKinds :: Array Word String + metadataKinds :: Array Word String, + parameterAttributeSets :: Map FFI.ParameterAttributeSet [A.A.ParameterAttribute], + functionAttributeSetIDs :: Map FFI.FunctionAttributeSet A.A.GroupID, + comdats :: Map (Ptr FFI.COMDAT) (String, A.COMDAT.SelectionKind) } initialDecode = DecodeState { globalVarNum = Map.empty, @@ -50,7 +57,10 @@ typesToDefine = Seq.empty, metadataNodesToDefine = Seq.empty, metadataNodes = Map.empty, - metadataKinds = Array.listArray (1,0) [] + metadataKinds = Array.listArray (1,0) [], + parameterAttributeSets = Map.empty, + functionAttributeSetIDs = Map.empty, + comdats = Map.empty } newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a } deriving ( @@ -150,3 +160,13 @@ instance DecodeM DecodeAST A.Name (Ptr FFI.BasicBlock) where decodeM = getLocalName + +getAttributeGroupID :: FFI.FunctionAttributeSet -> DecodeAST A.A.GroupID +getAttributeGroupID p = do + ids <- gets functionAttributeSetIDs + case Map.lookup p ids of + Just r -> return r + Nothing -> do + let r = A.A.GroupID (fromIntegral (Map.size ids)) + modify $ \s -> s { functionAttributeSetIDs = Map.insert p r (functionAttributeSetIDs s) } + return r diff --git a/src/LLVM/General/Internal/EncodeAST.hs b/src/LLVM/General/Internal/EncodeAST.hs --- a/src/LLVM/General/Internal/EncodeAST.hs +++ b/src/LLVM/General/Internal/EncodeAST.hs @@ -18,11 +18,14 @@ import Data.Map (Map) import qualified Data.Map as Map -import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.General.Internal.FFI.Attribute as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI +import qualified LLVM.General.Internal.FFI.GlobalValue as FFI +import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.Value as FFI import qualified LLVM.General.AST as A +import qualified LLVM.General.AST.Attribute as A.A import LLVM.General.Internal.Context import LLVM.General.Internal.Coding @@ -40,7 +43,9 @@ encodeStateAllBlocks :: Map (A.Name, A.Name) (Ptr FFI.BasicBlock), encodeStateBlocks :: Map A.Name (Ptr FFI.BasicBlock), encodeStateMDNodes :: Map A.MetadataNodeID (Ptr FFI.MDNode), - encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type) + encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type), + encodeStateAttributeGroups :: Map A.A.GroupID FFI.FunctionAttributeSet, + encodeStateCOMDATs :: Map String (Ptr FFI.COMDAT) } newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ExceptableT String (StateT EncodeState IO)) a } @@ -74,7 +79,9 @@ encodeStateAllBlocks = Map.empty, encodeStateBlocks = Map.empty, encodeStateMDNodes = Map.empty, - encodeStateNamedTypes = Map.empty + encodeStateNamedTypes = Map.empty, + encodeStateAttributeGroups = Map.empty, + encodeStateCOMDATs = Map.empty } flip evalStateT initEncodeState . runExceptableT . flip runAnyContT return $ a @@ -115,6 +122,12 @@ defineMDNode :: A.MetadataNodeID -> Ptr FFI.MDNode -> EncodeAST () defineMDNode n v = modify $ \b -> b { encodeStateMDNodes = Map.insert n (FFI.upCast v) (encodeStateMDNodes b) } +defineAttributeGroup :: A.A.GroupID -> FFI.FunctionAttributeSet -> EncodeAST () +defineAttributeGroup gid attrs = modify $ \b -> b { encodeStateAttributeGroups = Map.insert gid attrs (encodeStateAttributeGroups b) } + +defineCOMDAT :: String -> Ptr FFI.COMDAT -> EncodeAST () +defineCOMDAT name cd = modify $ \b -> b { encodeStateCOMDATs = Map.insert name cd (encodeStateCOMDATs b) } + refer :: (Show n, Ord n) => (EncodeState -> Map n v) -> n -> EncodeAST v -> EncodeAST v refer r n f = do mop <- gets $ Map.lookup n . r @@ -123,11 +136,13 @@ undefinedReference :: Show n => String -> n -> EncodeAST a undefinedReference m n = throwError $ "reference to undefined " ++ m ++ ": " ++ show n -referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n (Ptr p)) -> String -> n -> EncodeAST (Ptr p) +referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n v) -> String -> n -> EncodeAST v referOrThrow r m n = refer r n $ undefinedReference m n referGlobal = referOrThrow encodeStateGlobals "global" referMDNode = referOrThrow encodeStateMDNodes "metadata node" +referAttributeGroup = referOrThrow encodeStateAttributeGroups "attribute group" +referCOMDAT = referOrThrow encodeStateCOMDATs "COMDAT" defineBasicBlock :: A.Name -> A.Name -> Ptr FFI.BasicBlock -> EncodeAST () defineBasicBlock fn n b = modify $ \s -> s { diff --git a/src/LLVM/General/Internal/FFI/AssemblyC.cpp b/src/LLVM/General/Internal/FFI/AssemblyC.cpp --- a/src/LLVM/General/Internal/FFI/AssemblyC.cpp +++ b/src/LLVM/General/Internal/FFI/AssemblyC.cpp @@ -1,8 +1,7 @@ #define __STDC_LIMIT_MACROS #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Module.h" -#include "llvm/Assembly/Parser.h" -#include "llvm/Assembly/PrintModulePass.h" +#include "llvm/AsmParser/Parser.h" #include "llvm/Pass.h" #include "llvm/Support/SourceMgr.h" #include "llvm/Support/raw_ostream.h" diff --git a/src/LLVM/General/Internal/FFI/Attribute.h b/src/LLVM/General/Internal/FFI/Attribute.h new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/FFI/Attribute.h @@ -0,0 +1,55 @@ +#ifndef __LLVM_GENERAL_INTERNAL_FFI__ATTRIBUTES__H__ +#define __LLVM_GENERAL_INTERNAL_FFI__ATTRIBUTES__H__ + +#define LLVM_GENERAL_FOR_EACH_ATTRIBUTE_KIND(macro) \ + macro(None,F,F,F) \ + macro(Alignment,T,F,F) \ + macro(AlwaysInline,F,F,T) \ + macro(Builtin,F,F,T) \ + macro(ByVal,T,F,F) \ + macro(InAlloca,T,F,F) \ + macro(Cold,F,F,T) \ + macro(InlineHint,F,F,T) \ + macro(InReg,T,T,F) \ + macro(JumpTable,F,F,T) \ + macro(MinSize,F,F,T) \ + macro(Naked,F,F,T) \ + macro(Nest,T,F,F) \ + macro(NoAlias,T,T,F) \ + macro(NoBuiltin,F,F,T) \ + macro(NoCapture,T,F,F) \ + macro(NoDuplicate,F,F,T) \ + macro(NoImplicitFloat,F,F,T) \ + macro(NoInline,F,F,T) \ + macro(NonLazyBind,F,F,T) \ + macro(NonNull,T,T,F) \ + macro(Dereferenceable,T,T,F) \ + macro(NoRedZone,F,F,T) \ + macro(NoReturn,F,F,T) \ + macro(NoUnwind,F,F,T) \ + macro(OptimizeForSize,F,F,T) \ + macro(OptimizeNone,F,F,T) \ + macro(ReadNone,T,F,T) \ + macro(ReadOnly,T,F,T) \ + macro(Returned,T,F,F) \ + macro(ReturnsTwice,F,F,T) \ + macro(SExt,T,T,F) \ + macro(StackAlignment,F,F,T) \ + macro(StackProtect,F,F,T) \ + macro(StackProtectReq,F,F,T) \ + macro(StackProtectStrong,F,F,T) \ + macro(StructRet,T,F,F) \ + macro(SanitizeAddress,F,F,T) \ + macro(SanitizeThread,F,F,T) \ + macro(SanitizeMemory,F,F,T) \ + macro(UWTable,F,F,T) \ + macro(ZExt,T,T,F) \ + macro(EndAttrKinds,F,F,F) + +typedef enum { +#define ENUM_CASE(x,p,r,f) LLVM_General_AttributeKind_ ## x, +LLVM_GENERAL_FOR_EACH_ATTRIBUTE_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_General_AttributeKind; + +#endif diff --git a/src/LLVM/General/Internal/FFI/Attribute.hs b/src/LLVM/General/Internal/FFI/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/FFI/Attribute.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.General.Internal.FFI.Attribute where + +import LLVM.General.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.General.Internal.FFI.Context +import LLVM.General.Internal.FFI.LLVMCTypes + +type Index = CInt +type Slot = CUInt +type IntValue = Word64 + +{- +Data model: +llvm::Attribute is one function or parameter attribute + +llvm::AttributeSet is a mess. +It's used to represent, at different times: +a) the set of parameter attributes on a parameter +b) the set of parameter attributes for a functions return value +c) the set of function attributes for a function +d) All of the above + +It is only possible to enumerate the attributes in an attribute set +given a "slot". + +Encode path: +Use AttrBuilder on the C++ side only, to implement [Attribute] -> AttributeSet +AttributeSets -> whole AttributeSet + +Decode strategy: +Store maps of AttributeSetImpl (Mess | Parameter | Function), +keyed by raw pointer. Expect Parameter and Function AttributeSetImpls +to have only one slot. Use the per-slot iterators to decode them +-} + +data MixedAttributeType +data FunctionAttributeType +data ParameterAttributeType +data AttributeImpl a +data AttributeSetImpl a + +type Attribute a = Ptr (AttributeImpl a) +type FunctionAttribute = Attribute FunctionAttributeType +type ParameterAttribute = Attribute ParameterAttributeType + +type AttributeSet a = Ptr (AttributeSetImpl a) +type MixedAttributeSet = AttributeSet MixedAttributeType +type FunctionAttributeSet = AttributeSet FunctionAttributeType +type ParameterAttributeSet = AttributeSet ParameterAttributeType + +forgetAttributeType :: AttributeSet a -> AttributeSet MixedAttributeType +forgetAttributeType = castPtr + +functionIndex :: Index +functionIndex = -1 +returnIndex :: Index +returnIndex = 0 + +foreign import ccall unsafe "LLVM_General_AttributeKindAsEnum" parameterAttributeKindAsEnum :: + ParameterAttribute -> IO ParameterAttributeKind + +foreign import ccall unsafe "LLVM_General_AttributeKindAsEnum" functionAttributeKindAsEnum :: + FunctionAttribute -> IO FunctionAttributeKind + +foreign import ccall unsafe "LLVM_General_IsStringAttribute" isStringAttribute :: + Attribute a -> IO LLVMBool + +foreign import ccall unsafe "LLVM_General_AttributeKindAsString" attributeKindAsString :: + Attribute a -> Ptr CSize -> IO (Ptr CChar) + +foreign import ccall unsafe "LLVM_General_AttributeValueAsString" attributeValueAsString :: + Attribute a -> Ptr CSize -> IO (Ptr CChar) + +foreign import ccall unsafe "LLVM_General_AttributeValueAsInt" attributeValueAsInt :: + Attribute a -> IO Word64 + +foreign import ccall unsafe "LLVM_General_AttributeSetNumSlots" attributeSetNumSlots :: + AttributeSet a -> IO Slot + +foreign import ccall unsafe "LLVM_General_AttributeSetSlotIndex" attributeSetSlotIndex :: + AttributeSet a -> Slot -> IO Index + +foreign import ccall unsafe "LLVM_General_AttributeSetSlotAttributes" attributeSetSlotAttributes :: + MixedAttributeSet -> Slot -> IO (AttributeSet a) + +foreign import ccall unsafe "LLVM_General_AttributeSetGetAttributes" attributeSetGetAttributes :: + AttributeSet a -> Slot -> Ptr CUInt -> IO (Ptr (Attribute a)) + +foreign import ccall unsafe "LLVM_General_GetAttributeSet" getAttributeSet :: + Ptr Context -> Index -> Ptr (AttrBuilder a) -> IO (AttributeSet a) + +foreign import ccall unsafe "LLVM_General_MixAttributeSets" mixAttributeSets :: + Ptr Context -> Ptr MixedAttributeSet -> CUInt -> IO MixedAttributeSet + +data AttrBuilder a +type FunctionAttrBuilder = AttrBuilder FunctionAttributeType +type ParameterAttrBuilder = AttrBuilder ParameterAttributeType + +foreign import ccall unsafe "LLVM_General_GetAttrBuilderSize" getAttrBuilderSize :: + CSize + +foreign import ccall unsafe "LLVM_General_ConstructAttrBuilder" constructAttrBuilder :: + Ptr Word8 -> IO (Ptr (AttrBuilder a)) + +foreign import ccall unsafe "LLVM_General_DestroyAttrBuilder" destroyAttrBuilder :: + Ptr (AttrBuilder a) -> IO () + +foreign import ccall unsafe "LLVM_General_AttrBuilderAddAttributeKind" attrBuilderAddFunctionAttributeKind :: + Ptr FunctionAttrBuilder -> FunctionAttributeKind -> IO () + +foreign import ccall unsafe "LLVM_General_AttrBuilderAddAttributeKind" attrBuilderAddParameterAttributeKind :: + Ptr ParameterAttrBuilder -> ParameterAttributeKind -> IO () + +foreign import ccall unsafe "LLVM_General_AttrBuilderAddStringAttribute" attrBuilderAddStringAttribute :: + Ptr FunctionAttrBuilder -> Ptr CChar -> CSize -> Ptr CChar -> CSize -> IO () + +foreign import ccall unsafe "LLVM_General_AttrBuilderAddAlignment" attrBuilderAddAlignment :: + Ptr ParameterAttrBuilder -> Word64 -> IO () + +foreign import ccall unsafe "LLVM_General_AttrBuilderAddStackAlignment" attrBuilderAddStackAlignment :: + Ptr FunctionAttrBuilder -> Word64 -> IO () + +foreign import ccall unsafe "LLVM_General_AttrBuilderAddDereferenceableAttr" attrBuilderAddDereferenceable :: + Ptr ParameterAttrBuilder -> Word64 -> IO () + diff --git a/src/LLVM/General/Internal/FFI/AttributeC.cpp b/src/LLVM/General/Internal/FFI/AttributeC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/FFI/AttributeC.cpp @@ -0,0 +1,120 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "LLVM/General/Internal/FFI/AttributeC.hpp" + +extern "C" { + +unsigned LLVM_General_AttributeSetNumSlots(const AttributeSetImpl *a) { + return unwrap(a).getNumSlots(); +} + +int LLVM_General_AttributeSetSlotIndex(const AttributeSetImpl *a, unsigned slot) { + return unwrap(a).getSlotIndex(slot); +} + +const AttributeSetImpl *LLVM_General_AttributeSetSlotAttributes(const AttributeSetImpl *a, unsigned slot) { + return wrap(unwrap(a).getSlotAttributes(slot)); +} + +const AttributeSetImpl *LLVM_General_GetSlotAttributeSet( + LLVMContextRef context, + unsigned index, + const AttributeImpl **attributes, + unsigned length +) { + AttrBuilder builder; + for (unsigned i = 0; i < length; i++) builder.addAttribute(unwrap(attributes[i])); + return wrap(AttributeSet::get(*unwrap(context), index, builder)); +} + +const AttributeImpl *const *LLVM_General_AttributeSetGetAttributes(AttributeSetImpl *asi, unsigned slot, unsigned *length) { + AttributeSet as = unwrap(asi); + ArrayRef::iterator b = as.begin(slot), e = as.end(slot); + *length = e - b; + return reinterpret_cast(b); +} + +inline void LLVM_General_AttributeEnumMatches() { +#define CHECK(name,p,r,f) \ + static_assert( \ + unsigned(llvm::Attribute::name) == unsigned(LLVM_General_AttributeKind_ ## name), \ + "LLVM_General_AttributeKind enum out of sync w/ llvm::Attribute::AttrKind for " #name \ + ); + LLVM_GENERAL_FOR_EACH_ATTRIBUTE_KIND(CHECK) +#undef CHECK +} + +unsigned LLVM_General_AttributeKindAsEnum(const AttributeImpl *a) { + LLVM_General_AttributeEnumMatches(); + return unwrap(a).getKindAsEnum(); +} + +uint64_t LLVM_General_AttributeValueAsInt(const AttributeImpl *a) { + return unwrap(a).getValueAsInt(); +} + +LLVMBool LLVM_General_IsStringAttribute(const AttributeImpl *a) { + return unwrap(a).isStringAttribute(); +} + +const char *LLVM_General_AttributeKindAsString(const AttributeImpl *a, size_t &l) { + const StringRef s = unwrap(a).getKindAsString(); + l = s.size(); + return s.data(); +} + +const char *LLVM_General_AttributeValueAsString(const AttributeImpl *a, size_t &l) { + const StringRef s = unwrap(a).getValueAsString(); + l = s.size(); + return s.data(); +} + +const AttributeSetImpl *LLVM_General_GetAttributeSet(LLVMContextRef context, unsigned index, const AttrBuilder &ab) { + return wrap(AttributeSet::get(*unwrap(context), index, ab)); +} + +const AttributeSetImpl *LLVM_General_MixAttributeSets( + LLVMContextRef context, const AttributeSetImpl **as, unsigned n +) { + return wrap( + AttributeSet::get( + *unwrap(context), + ArrayRef(reinterpret_cast(as), n) + ) + ); +} + +size_t LLVM_General_GetAttrBuilderSize() { return sizeof(AttrBuilder); } + +AttrBuilder *LLVM_General_ConstructAttrBuilder(char *p) { + return new(p) AttrBuilder(); +} + +void LLVM_General_DestroyAttrBuilder(AttrBuilder *a) { + a->~AttrBuilder(); +} + +void LLVM_General_AttrBuilderAddAttributeKind(AttrBuilder &ab, unsigned kind) { + LLVM_General_AttributeEnumMatches(); + ab.addAttribute(Attribute::AttrKind(kind)); +} + +void LLVM_General_AttrBuilderAddStringAttribute( + AttrBuilder &ab, const char *kind, size_t kind_len, const char *value, size_t value_len +) { + ab.addAttribute(StringRef(kind, kind_len), StringRef(value, value_len)); +} + +void LLVM_General_AttrBuilderAddAlignment(AttrBuilder &ab, uint64_t v) { + ab.addAlignmentAttr(v); +} + +void LLVM_General_AttrBuilderAddStackAlignment(AttrBuilder &ab, uint64_t v) { + ab.addStackAlignmentAttr(v); +} + +void LLVM_General_AttrBuilderAddDereferenceableAttr(AttrBuilder &ab, uint64_t v) { + ab.addDereferenceableAttr(v); +} + +} diff --git a/src/LLVM/General/Internal/FFI/AttributeC.hpp b/src/LLVM/General/Internal/FFI/AttributeC.hpp new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/FFI/AttributeC.hpp @@ -0,0 +1,42 @@ +#ifndef __LLVM_GENERAL_ATTRIBUTE_C_HPP__ +#define __LLVM_GENERAL_ATTRIBUTE_C_HPP__ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/Attributes.h" +#include "LLVM/General/Internal/FFI/Attribute.h" +using namespace llvm; + +inline void LLVM_General_AttributeSetMatches() { + static_assert( + sizeof(AttributeSet) == sizeof(AttributeSetImpl *), + "AttributeSet implementation has changed" + ); +} + +inline AttributeSet unwrap(const AttributeSetImpl *asi) { + LLVM_General_AttributeSetMatches(); + return *reinterpret_cast(&asi); +} + +inline const AttributeSetImpl *wrap(AttributeSet as) { + LLVM_General_AttributeSetMatches(); + return *reinterpret_cast(&as); +} + +inline void LLVM_General_AttributeMatches() { + static_assert( + sizeof(Attribute) == sizeof(AttributeImpl *), + "Attribute implementation has changed" + ); +} + +inline Attribute unwrap(const AttributeImpl *ai) { + LLVM_General_AttributeMatches(); + return *reinterpret_cast(&ai); +} + +inline const AttributeImpl *wrap(Attribute a) { + LLVM_General_AttributeMatches(); + return *reinterpret_cast(&a); +} + +#endif diff --git a/src/LLVM/General/Internal/FFI/BitcodeC.cpp b/src/LLVM/General/Internal/FFI/BitcodeC.cpp --- a/src/LLVM/General/Internal/FFI/BitcodeC.cpp +++ b/src/LLVM/General/Internal/FFI/BitcodeC.cpp @@ -1,5 +1,4 @@ #define __STDC_LIMIT_MACROS -//#include "llvm/Config/llvm-config.h" #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Module.h" #include "llvm-c/Core.h" @@ -17,9 +16,12 @@ char **error ) { std::string msg; - Module *m = ParseBitcodeFile(unwrap(mb), *unwrap(c), &msg); - if (m == 0) *error = strdup(msg.c_str()); - return wrap(m); + ErrorOr m = parseBitcodeFile(unwrap(mb), *unwrap(c)); + if (std::error_code ec = m.getError()) { + *error = strdup(ec.message().c_str()); + return 0; + } + return wrap(m.get()); } void LLVM_General_WriteBitcode(LLVMModuleRef m, raw_ostream &os) { diff --git a/src/LLVM/General/Internal/FFI/Builder.hs b/src/LLVM/General/Internal/FFI/Builder.hs --- a/src/LLVM/General/Internal/FFI/Builder.hs +++ b/src/LLVM/General/Internal/FFI/Builder.hs @@ -87,12 +87,12 @@ Ptr Builder -> Ptr Type -> Ptr Value -> CString -> IO (Ptr Instruction) foreign import ccall unsafe "LLVM_General_BuildLoad" buildLoad' :: - Ptr Builder -> LLVMBool -> Ptr Value -> MemoryOrdering -> LLVMBool -> CUInt -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) buildLoad builder vol a' (ss, mo) al s = buildLoad' builder vol a' mo ss al s foreign import ccall unsafe "LLVM_General_BuildStore" buildStore' :: - Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> MemoryOrdering -> LLVMBool -> CUInt -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) buildStore builder vol a' v' (ss, mo) al s = buildStore' builder vol a' v' mo ss al s @@ -107,17 +107,17 @@ buildGetElementPtr builder (LLVMBool 0) a (n, is) s = buildGetElementPtr' builder a is n s foreign import ccall unsafe "LLVM_General_BuildFence" buildFence' :: - Ptr Builder -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) + Ptr Builder -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) buildFence builder (ss, mo) s = buildFence' builder mo ss s foreign import ccall unsafe "LLVM_General_BuildAtomicCmpXchg" buildCmpXchg' :: - Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> MemoryOrdering -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) -buildCmpXchg builder vol a e r (ss, mo) s = buildCmpXchg' builder vol a e r mo ss s +buildCmpXchg builder vol a e r (ss, smo) fmo s = buildCmpXchg' builder vol a e r smo fmo ss s foreign import ccall unsafe "LLVM_General_BuildAtomicRMW" buildAtomicRMW' :: - Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) + Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) buildAtomicRMW builder vol rmwOp a v (ss, mo) s = buildAtomicRMW' builder vol rmwOp a v mo ss s diff --git a/src/LLVM/General/Internal/FFI/BuilderC.cpp b/src/LLVM/General/Internal/FFI/BuilderC.cpp --- a/src/LLVM/General/Internal/FFI/BuilderC.cpp +++ b/src/LLVM/General/Internal/FFI/BuilderC.cpp @@ -127,12 +127,13 @@ LLVMValueRef ptr, LLVMValueRef cmp, LLVMValueRef n, - LLVMAtomicOrdering lao, + LLVMAtomicOrdering successOrdering, + LLVMAtomicOrdering failureOrdering, LLVMSynchronizationScope lss, const char *name ) { AtomicCmpXchgInst *a = unwrap(b)->CreateAtomicCmpXchg( - unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(lao), unwrap(lss) + unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(successOrdering), unwrap(failureOrdering), unwrap(lss) ); a->setVolatile(v); a->setName(name); diff --git a/src/LLVM/General/Internal/FFI/CallingConvention.h b/src/LLVM/General/Internal/FFI/CallingConvention.h new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/FFI/CallingConvention.h @@ -0,0 +1,35 @@ +#ifndef __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION__H__ +#define __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION__H__ + +#define LLVM_GENERAL_FOR_EACH_CALLING_CONVENTION(macro) \ + macro(C, 0) \ + macro(Fast, 8) \ + macro(Cold, 9) \ + macro(GHC, 10) \ + macro(HiPE, 11) \ + macro(WebKit_JS, 12) \ + macro(AnyReg, 13) \ + macro(PreserveMost, 14) \ + macro(PreserveAll, 15) \ + macro(X86_StdCall, 64) \ + macro(X86_FastCall, 65) \ + macro(ARM_APCS, 66) \ + macro(ARM_AAPCS, 67) \ + macro(ARM_AAPCS_VFP, 68) \ + macro(MSP430_INTR, 69) \ + macro(X86_ThisCall, 70) \ + macro(PTX_Kernel, 71) \ + macro(PTX_Device, 72) \ + macro(SPIR_FUNC, 75) \ + macro(SPIR_KERNEL, 76) \ + macro(Intel_OCL_BI, 77) \ + macro(X86_64_SysV, 78) \ + macro(X86_64_Win64, 79) + +typedef enum { +#define ENUM_CASE(l,n) LLVM_General_CallingConvention_ ## l = n, + LLVM_GENERAL_FOR_EACH_CALLING_CONVENTION(ENUM_CASE) +#undef ENUM_CASE +} LLVM_General_CallingConvention; + +#endif diff --git a/src/LLVM/General/Internal/FFI/CallingConventionC.hpp b/src/LLVM/General/Internal/FFI/CallingConventionC.hpp new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/FFI/CallingConventionC.hpp @@ -0,0 +1,16 @@ +#ifndef __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION_C_HPP__ +#define __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION_C_HPP__ + +#include "LLVM/General/Internal/FFI/CallingConvention.h" + +inline void LLVM_General_CallingConventionEnumMatches() { +#define CHECK(l,n) \ + static_assert( \ + unsigned(llvm::CallingConv::l) == unsigned(LLVM_General_CallingConvention_ ## l), \ + "LLVM_General_CallingConvention enum out of sync w/ llvm::CallingConv::ID for " #l \ + ); + LLVM_GENERAL_FOR_EACH_CALLING_CONVENTION(CHECK) +#undef CHECK +} + +#endif diff --git a/src/LLVM/General/Internal/FFI/Function.h b/src/LLVM/General/Internal/FFI/Function.h deleted file mode 100644 --- a/src/LLVM/General/Internal/FFI/Function.h +++ /dev/null @@ -1,39 +0,0 @@ -#ifndef __LLVM_GENERAL_INTERNAL_FFI__FUNCTION__H__ -#define __LLVM_GENERAL_INTERNAL_FFI__FUNCTION__H__ - -#define LLVM_GENERAL_FOR_EACH_CALLCONV(macro) \ - macro(C) \ - macro(Fast) \ - macro(Cold) \ - -#define LLVM_GENERAL_FOR_EACH_PARAM_ATTR(macro) \ - macro(ZExt,Attribute) \ - macro(SExt,Attribute) \ - macro(InReg,Attribute) \ - macro(StructRet,Attribute) \ - macro(Alignment,) \ - macro(NoAlias,Attribute) \ - macro(ByVal,Attribute) \ - macro(NoCapture,Attribute) \ - macro(Nest,Attribute) - -#define LLVM_GENERAL_FOR_EACH_FUNCTION_ATTR(macro) \ - macro(NoReturn,Attribute) \ - macro(NoUnwind,Attribute) \ - macro(ReadNone,Attribute) \ - macro(ReadOnly,Attribute) \ - macro(NoInline,Attribute) \ - macro(AlwaysInline,Attribute) \ - macro(OptimizeForSize,Attribute) \ - macro(StackProtect,Attribute) \ - macro(StackProtectReq,Attribute) \ - macro(NoRedZone,Attribute) \ - macro(NoImplicitFloat,Attribute) \ - macro(Naked,Attribute) \ - macro(InlineHint,Attribute) \ - macro(StackAlignment,) \ - macro(ReturnsTwice,) \ - macro(UWTable,) \ - macro(NonLazyBind,) \ - -#endif diff --git a/src/LLVM/General/Internal/FFI/Function.hs b/src/LLVM/General/Internal/FFI/Function.hs --- a/src/LLVM/General/Internal/FFI/Function.hs +++ b/src/LLVM/General/Internal/FFI/Function.hs @@ -10,55 +10,54 @@ import Foreign.Ptr import Foreign.C +import LLVM.General.Internal.FFI.Attribute import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy -foreign import ccall unsafe "LLVMGetFunctionCallConv" getFunctionCallConv :: - Ptr Function -> IO CallConv +foreign import ccall unsafe "LLVM_General_GetFunctionCallingConvention" getFunctionCallingConvention :: + Ptr Function -> IO CallingConvention -foreign import ccall unsafe "LLVMSetFunctionCallConv" setFunctionCallConv :: - Ptr Function -> CallConv -> IO () +foreign import ccall unsafe "LLVM_General_SetFunctionCallingConvention" setFunctionCallingConvention :: + Ptr Function -> CallingConvention -> IO () -foreign import ccall unsafe "LLVMAddFunctionAttr" addFunctionAttr :: - Ptr Function -> FunctionAttr -> IO () +foreign import ccall unsafe "LLVM_General_GetFunctionMixedAttributeSet" getMixedAttributeSet :: + Ptr Function -> IO MixedAttributeSet -foreign import ccall unsafe "LLVMGetFunctionAttr" getFunctionAttr :: - Ptr Function -> IO FunctionAttr +foreign import ccall unsafe "LLVM_General_SetFunctionMixedAttributeSet" setMixedAttributeSet :: + Ptr Function -> MixedAttributeSet -> IO () foreign import ccall unsafe "LLVMGetFirstBasicBlock" getFirstBasicBlock :: - Ptr Function -> IO (Ptr BasicBlock) + Ptr Function -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMGetLastBasicBlock" getLastBasicBlock :: - Ptr Function -> IO (Ptr BasicBlock) + Ptr Function -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMGetNextBasicBlock" getNextBasicBlock :: - Ptr BasicBlock -> IO (Ptr BasicBlock) + Ptr BasicBlock -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMAppendBasicBlockInContext" appendBasicBlockInContext :: - Ptr Context -> Ptr Function -> CString -> IO (Ptr BasicBlock) + Ptr Context -> Ptr Function -> CString -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMCountParams" countParams :: - Ptr Function -> IO CUInt + Ptr Function -> IO CUInt foreign import ccall unsafe "LLVMGetParams" getParams :: - Ptr Function -> Ptr (Ptr Parameter) -> IO () - -foreign import ccall unsafe "LLVMGetAttribute" getAttribute :: - Ptr Parameter -> IO ParamAttr - -foreign import ccall unsafe "LLVMAddAttribute" addAttribute :: - Ptr Parameter -> ParamAttr -> IO () - -foreign import ccall unsafe "LLVM_General_GetFunctionRetAttr" getFunctionRetAttr :: - Ptr Function -> IO ParamAttr - -foreign import ccall unsafe "LLVM_General_AddFunctionRetAttr" addFunctionRetAttr :: - Ptr Function -> ParamAttr -> IO () + Ptr Function -> Ptr (Ptr Parameter) -> IO () foreign import ccall unsafe "LLVMGetGC" getGC :: Ptr Function -> IO CString foreign import ccall unsafe "LLVMSetGC" setGC :: Ptr Function -> CString -> IO () + + +foreign import ccall unsafe "LLVM_General_HasFunctionPrefixData" hasPrefixData :: + Ptr Function -> IO LLVMBool + +foreign import ccall unsafe "LLVM_General_GetFunctionPrefixData" getPrefixData :: + Ptr Function -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_General_SetFunctionPrefixData" setPrefixData :: + Ptr Function -> Ptr Constant -> IO () diff --git a/src/LLVM/General/Internal/FFI/FunctionC.cpp b/src/LLVM/General/Internal/FFI/FunctionC.cpp --- a/src/LLVM/General/Internal/FFI/FunctionC.cpp +++ b/src/LLVM/General/Internal/FFI/FunctionC.cpp @@ -2,8 +2,11 @@ #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Attributes.h" #include "llvm/IR/Function.h" +#include "llvm/IR/Value.h" #include "llvm-c/Core.h" +#include "LLVM/General/Internal/FFI/AttributeC.hpp" +#include "LLVM/General/Internal/FFI/CallingConventionC.hpp" using namespace llvm; @@ -22,5 +25,34 @@ ); } +const AttributeSetImpl *LLVM_General_GetFunctionMixedAttributeSet(LLVMValueRef f) { + return wrap(unwrap(f)->getAttributes()); +} + +void LLVM_General_SetFunctionMixedAttributeSet(LLVMValueRef f, AttributeSetImpl *asi) { + unwrap(f)->setAttributes(unwrap(asi)); +} + +LLVMBool LLVM_General_HasFunctionPrefixData(LLVMValueRef f) { + return unwrap(f)->hasPrefixData(); +} + +LLVMValueRef LLVM_General_GetFunctionPrefixData(LLVMValueRef f) { + return wrap(unwrap(f)->getPrefixData()); +} + +void LLVM_General_SetFunctionPrefixData(LLVMValueRef f, LLVMValueRef p) { + unwrap(f)->setPrefixData(unwrap(p)); +} + +unsigned LLVM_General_GetFunctionCallingConvention(LLVMValueRef f) { + LLVM_General_CallingConventionEnumMatches(); + return unsigned(unwrap(f)->getCallingConv()); +} + +void LLVM_General_SetFunctionCallingConvention(LLVMValueRef f, unsigned cc) { + LLVM_General_CallingConventionEnumMatches(); + unwrap(f)->setCallingConv(llvm::CallingConv::ID(cc)); +} } diff --git a/src/LLVM/General/Internal/FFI/GlobalAliasC.cpp b/src/LLVM/General/Internal/FFI/GlobalAliasC.cpp --- a/src/LLVM/General/Internal/FFI/GlobalAliasC.cpp +++ b/src/LLVM/General/Internal/FFI/GlobalAliasC.cpp @@ -1,6 +1,7 @@ #define __STDC_LIMIT_MACROS #include "llvm/IR/LLVMContext.h" #include "llvm/IR/GlobalAlias.h" +#include "llvm/IR/GlobalObject.h" #include "llvm-c/Core.h" diff --git a/src/LLVM/General/Internal/FFI/GlobalValue.h b/src/LLVM/General/Internal/FFI/GlobalValue.h --- a/src/LLVM/General/Internal/FFI/GlobalValue.h +++ b/src/LLVM/General/Internal/FFI/GlobalValue.h @@ -6,24 +6,42 @@ macro(AvailableExternally) \ macro(LinkOnceAny) \ macro(LinkOnceODR) \ - macro(LinkOnceODRAutoHide) \ macro(WeakAny) \ macro(WeakODR) \ macro(Appending) \ macro(Internal) \ macro(Private) \ - macro(DLLImport) \ - macro(DLLExport) \ macro(ExternalWeak) \ - macro(Ghost) \ - macro(Common) \ - macro(LinkerPrivate) \ - macro(LinkerPrivateWeak) \ - + macro(Common) #define LLVM_GENERAL_FOR_EACH_VISIBILITY(macro) \ macro(Default) \ macro(Hidden) \ macro(Protected) \ + +#define LLVM_GENERAL_FOR_EACH_COMDAT_SELECTION_KIND(macro) \ + macro(Any) \ + macro(ExactMatch) \ + macro(Largest) \ + macro(NoDuplicates) \ + macro(SameSize) + +typedef enum { +#define ENUM_CASE(n) LLVM_General_COMDAT_Selection_Kind_ ## n, +LLVM_GENERAL_FOR_EACH_COMDAT_SELECTION_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_General_COMDAT_Selection_Kind; + +#define LLVM_GENERAL_FOR_EACH_DLL_STORAGE_CLASS(macro) \ + macro(Default) \ + macro(DLLImport) \ + macro(DLLExport) + +#define LLVM_GENERAL_FOR_EACH_THREAD_LOCAL_MODE(macro) \ + macro(NotThreadLocal) \ + macro(GeneralDynamicTLSModel) \ + macro(LocalDynamicTLSModel) \ + macro(InitialExecTLSModel) \ + macro(LocalExecTLSModel) #endif diff --git a/src/LLVM/General/Internal/FFI/GlobalValue.hs b/src/LLVM/General/Internal/FFI/GlobalValue.hs --- a/src/LLVM/General/Internal/FFI/GlobalValue.hs +++ b/src/LLVM/General/Internal/FFI/GlobalValue.hs @@ -14,38 +14,66 @@ import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.LLVMCTypes +data COMDAT + foreign import ccall unsafe "LLVMIsAGlobalValue" isAGlobalValue :: - Ptr Value -> IO (Ptr GlobalValue) + Ptr Value -> IO (Ptr GlobalValue) foreign import ccall unsafe "LLVMGetLinkage" getLinkage :: - Ptr GlobalValue -> IO Linkage + Ptr GlobalValue -> IO Linkage foreign import ccall unsafe "LLVMSetLinkage" setLinkage :: - Ptr GlobalValue -> Linkage -> IO () + Ptr GlobalValue -> Linkage -> IO () foreign import ccall unsafe "LLVMGetSection" getSection :: - Ptr GlobalValue -> IO CString + Ptr GlobalValue -> IO CString foreign import ccall unsafe "LLVMSetSection" setSection :: - Ptr GlobalValue -> CString -> IO () + Ptr GlobalValue -> CString -> IO () +foreign import ccall unsafe "LLVM_General_GetCOMDAT" getCOMDAT :: + Ptr GlobalValue -> IO (Ptr COMDAT) + +foreign import ccall unsafe "LLVM_General_SetCOMDAT" setCOMDAT :: + Ptr GlobalObject -> Ptr COMDAT -> IO () + +foreign import ccall unsafe "LLVM_General_GetCOMDATName" getCOMDATName :: + Ptr COMDAT -> Ptr CSize -> IO (Ptr CChar) + +foreign import ccall unsafe "LLVM_General_GetCOMDATSelectionKind" getCOMDATSelectionKind :: + Ptr COMDAT -> IO COMDATSelectionKind + +foreign import ccall unsafe "LLVM_General_SetCOMDATSelectionKind" setCOMDATSelectionKind :: + Ptr COMDAT -> COMDATSelectionKind -> IO () + foreign import ccall unsafe "LLVMGetVisibility" getVisibility :: - Ptr GlobalValue -> IO Visibility + Ptr GlobalValue -> IO Visibility foreign import ccall unsafe "LLVMSetVisibility" setVisibility :: - Ptr GlobalValue -> Visibility -> IO () + Ptr GlobalValue -> Visibility -> IO () +foreign import ccall unsafe "LLVMGetDLLStorageClass" getDLLStorageClass :: + Ptr GlobalValue -> IO DLLStorageClass + +foreign import ccall unsafe "LLVMSetDLLStorageClass" setDLLStorageClass :: + Ptr GlobalValue -> DLLStorageClass -> IO () + foreign import ccall unsafe "LLVMGetAlignment" getAlignment :: - Ptr GlobalValue -> IO CUInt + Ptr GlobalValue -> IO CUInt foreign import ccall unsafe "LLVMSetAlignment" setAlignment :: - Ptr GlobalValue -> CUInt -> IO () + Ptr GlobalValue -> CUInt -> IO () foreign import ccall unsafe "LLVM_General_HasUnnamedAddr" hasUnnamedAddr :: - Ptr GlobalValue -> IO LLVMBool + Ptr GlobalValue -> IO LLVMBool foreign import ccall unsafe "LLVM_General_SetUnnamedAddr" setUnnamedAddr :: - Ptr GlobalValue -> LLVMBool -> IO () + Ptr GlobalValue -> LLVMBool -> IO () +foreign import ccall unsafe "LLVM_General_GetThreadLocalMode" getThreadLocalMode :: + Ptr GlobalValue -> IO ThreadLocalMode + +foreign import ccall unsafe "LLVM_General_SetThreadLocalMode" setThreadLocalMode :: + Ptr GlobalValue -> ThreadLocalMode -> IO () diff --git a/src/LLVM/General/Internal/FFI/GlobalValueC.cpp b/src/LLVM/General/Internal/FFI/GlobalValueC.cpp --- a/src/LLVM/General/Internal/FFI/GlobalValueC.cpp +++ b/src/LLVM/General/Internal/FFI/GlobalValueC.cpp @@ -1,17 +1,67 @@ #define __STDC_LIMIT_MACROS +#include "llvm/IR/Comdat.h" #include "llvm/IR/GlobalValue.h" +#include "llvm/IR/GlobalObject.h" #include "llvm-c/Core.h" +#include "LLVM/General/Internal/FFI/GlobalValue.h" using namespace llvm; extern "C" { +const Comdat *LLVM_General_GetCOMDAT(LLVMValueRef globalVal) { + return unwrap(globalVal)->getComdat(); +} + +void LLVM_General_SetCOMDAT(LLVMValueRef globalObj, Comdat *comdat) { + return unwrap(globalObj)->setComdat(comdat); +} + +const char *LLVM_General_GetCOMDATName(const Comdat &comdat, size_t &size) { + StringRef ref = comdat.getName(); + size = ref.size(); + return ref.data(); +} + +inline void LLVM_General_COMDAT_Selection_Kind_Enum_Matches() { +#define ENUM_CASE(n) static_assert(unsigned(Comdat::n) == unsigned(LLVM_General_COMDAT_Selection_Kind_ ## n), \ + "COMDAT SelectionKind Enum mismatch"); + LLVM_GENERAL_FOR_EACH_COMDAT_SELECTION_KIND(ENUM_CASE) +#undef ENUM_CASE +} + +unsigned LLVM_General_GetCOMDATSelectionKind(const Comdat &comdat) { + LLVM_General_COMDAT_Selection_Kind_Enum_Matches(); + return unsigned(comdat.getSelectionKind()); +} + +void LLVM_General_SetCOMDATSelectionKind(Comdat &comdat, unsigned csk) { + LLVM_General_COMDAT_Selection_Kind_Enum_Matches(); + comdat.setSelectionKind(Comdat::SelectionKind(csk)); +} + LLVMBool LLVM_General_HasUnnamedAddr(LLVMValueRef globalVal) { return unwrap(globalVal)->hasUnnamedAddr(); } void LLVM_General_SetUnnamedAddr(LLVMValueRef globalVal, LLVMBool isUnnamedAddr) { unwrap(globalVal)->setUnnamedAddr(isUnnamedAddr); +} + +inline void LLVM_General_TLS_Model_Enum_Matches() { +#define ENUM_CASE(n) static_assert(unsigned(GlobalValue::n) == unsigned(LLVM ## n), "TLS Model Enum mismatch"); + LLVM_GENERAL_FOR_EACH_THREAD_LOCAL_MODE(ENUM_CASE) +#undef ENUM_CASE +} + +LLVMThreadLocalMode LLVM_General_GetThreadLocalMode(LLVMValueRef globalVal) { + LLVM_General_TLS_Model_Enum_Matches(); + return LLVMThreadLocalMode(unwrap(globalVal)->getThreadLocalMode()); +} + +void LLVM_General_SetThreadLocalMode(LLVMValueRef globalVal, LLVMThreadLocalMode mode) { + LLVM_General_TLS_Model_Enum_Matches(); + unwrap(globalVal)->setThreadLocalMode(GlobalValue::ThreadLocalMode(mode)); } } diff --git a/src/LLVM/General/Internal/FFI/GlobalVariable.hs b/src/LLVM/General/Internal/FFI/GlobalVariable.hs --- a/src/LLVM/General/Internal/FFI/GlobalVariable.hs +++ b/src/LLVM/General/Internal/FFI/GlobalVariable.hs @@ -29,9 +29,3 @@ foreign import ccall unsafe "LLVMSetInitializer" setInitializer :: Ptr GlobalVariable -> Ptr Constant -> IO () -foreign import ccall unsafe "LLVMIsThreadLocal" isThreadLocal :: - Ptr GlobalVariable -> IO LLVMBool - -foreign import ccall unsafe "LLVMSetThreadLocal" setThreadLocal :: - Ptr GlobalVariable -> LLVMBool -> IO () - diff --git a/src/LLVM/General/Internal/FFI/Instruction.h b/src/LLVM/General/Internal/FFI/Instruction.h --- a/src/LLVM/General/Internal/FFI/Instruction.h +++ b/src/LLVM/General/Internal/FFI/Instruction.h @@ -54,4 +54,14 @@ #undef ENUM_CASE } LLVMFastMathFlags; +#define LLVM_GENERAL_FOR_EACH_TAIL_CALL_KIND(macro) \ + macro(None) \ + macro(Tail) \ + macro(MustTail) + +typedef enum { +#define ENUM_CASE(x) LLVM_General_TailCallKind_ ## x, +LLVM_GENERAL_FOR_EACH_TAIL_CALL_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_General_TailCallKind; #endif diff --git a/src/LLVM/General/Internal/FFI/Instruction.hs b/src/LLVM/General/Internal/FFI/Instruction.hs --- a/src/LLVM/General/Internal/FFI/Instruction.hs +++ b/src/LLVM/General/Internal/FFI/Instruction.hs @@ -11,6 +11,7 @@ import Foreign.Ptr import Foreign.C +import LLVM.General.Internal.FFI.Attribute import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.LLVMCTypes @@ -33,33 +34,27 @@ foreign import ccall unsafe "LLVM_General_GetFCmpPredicate" getFCmpPredicate :: Ptr Instruction -> IO FCmpPredicate -foreign import ccall unsafe "LLVMGetInstructionCallConv" getInstructionCallConv :: - Ptr Instruction -> IO CallConv +foreign import ccall unsafe "LLVM_General_GetCallSiteCallingConvention" getCallSiteCallingConvention :: + Ptr Instruction -> IO CallingConvention -foreign import ccall unsafe "LLVMSetInstructionCallConv" setInstructionCallConv :: - Ptr Instruction -> CallConv -> IO () +foreign import ccall unsafe "LLVM_General_SetCallSiteCallingConvention" setCallSiteCallingConvention :: + Ptr Instruction -> CallingConvention -> IO () -foreign import ccall unsafe "LLVMIsTailCall" isTailCall :: - Ptr Instruction -> IO LLVMBool +foreign import ccall unsafe "LLVM_General_GetTailCallKind" getTailCallKind :: + Ptr Instruction -> IO TailCallKind -foreign import ccall unsafe "LLVMSetTailCall" setTailCall :: - Ptr Instruction -> LLVMBool -> IO () +foreign import ccall unsafe "LLVM_General_SetTailCallKind" setTailCallKind :: + Ptr Instruction -> TailCallKind -> IO () -foreign import ccall unsafe "LLVM_General_GetCallInstCalledValue" getCallInstCalledValue :: +foreign import ccall unsafe "LLVM_General_GetCallSiteCalledValue" getCallSiteCalledValue :: Ptr Instruction -> IO (Ptr Value) -foreign import ccall unsafe "LLVM_General_GetCallInstFunctionAttr" getCallInstFunctionAttr :: - Ptr Instruction -> IO FunctionAttr - -foreign import ccall unsafe "LLVM_General_AddCallInstFunctionAttr" addCallInstFunctionAttr :: - Ptr Instruction -> FunctionAttr -> IO () - -foreign import ccall unsafe "LLVM_General_GetCallInstAttr" getCallInstAttr :: - Ptr Instruction -> CUInt -> IO ParamAttr - -foreign import ccall unsafe "LLVM_General_AddCallInstAttr" addCallInstAttr :: - Ptr Instruction -> CUInt -> ParamAttr -> IO () +foreign import ccall unsafe "LLVM_General_GetCallSiteAttributeSet" getCallSiteAttributeSet :: + Ptr Instruction -> IO MixedAttributeSet +foreign import ccall unsafe "LLVM_General_SetCallSiteAttributeSet" setCallSiteAttributeSet :: + Ptr Instruction -> MixedAttributeSet -> IO () + foreign import ccall unsafe "LLVMAddIncoming" addIncoming' :: Ptr Instruction -> Ptr (Ptr Value) -> Ptr (Ptr BasicBlock) -> CUInt -> IO () @@ -104,8 +99,11 @@ foreign import ccall unsafe "LLVM_General_GetAtomicOrdering" getAtomicOrdering :: Ptr Instruction -> IO MemoryOrdering +foreign import ccall unsafe "LLVM_General_GetFailureAtomicOrdering" getFailureAtomicOrdering :: + Ptr Instruction -> IO MemoryOrdering + foreign import ccall unsafe "LLVM_General_GetSynchronizationScope" getSynchronizationScope :: - Ptr Instruction -> IO LLVMBool + Ptr Instruction -> IO SynchronizationScope getAtomicity i = return (,) `ap` getSynchronizationScope i `ap` getAtomicOrdering i diff --git a/src/LLVM/General/Internal/FFI/InstructionC.cpp b/src/LLVM/General/Internal/FFI/InstructionC.cpp --- a/src/LLVM/General/Internal/FFI/InstructionC.cpp +++ b/src/LLVM/General/Internal/FFI/InstructionC.cpp @@ -6,11 +6,13 @@ #include "llvm/IR/Operator.h" #include "llvm/IR/BasicBlock.h" #include "llvm/IR/Metadata.h" -#include "llvm/Support/CallSite.h" +#include "llvm/IR/CallSite.h" #include "llvm-c/Core.h" +#include "LLVM/General/Internal/FFI/AttributeC.hpp" #include "LLVM/General/Internal/FFI/Instruction.h" +#include "LLVM/General/Internal/FFI/CallingConventionC.hpp" using namespace llvm; @@ -75,31 +77,48 @@ return wrap(unwrap(val)->getFastMathFlags()); } -LLVMValueRef LLVM_General_GetCallInstCalledValue( - LLVMValueRef callInst -) { - return wrap(CallSite(unwrap(callInst)).getCalledValue()); +LLVMValueRef LLVM_General_GetCallSiteCalledValue(LLVMValueRef i) { + return wrap(CallSite(unwrap(i)).getCalledValue()); } -LLVMAttribute LLVM_General_GetCallInstAttr(LLVMValueRef callInst, unsigned i) { - return (LLVMAttribute)CallSite(unwrap(callInst)).getAttributes().Raw(i); +const AttributeSetImpl *LLVM_General_GetCallSiteAttributeSet(LLVMValueRef i) { + return wrap(CallSite(unwrap(i)).getAttributes()); } -void LLVM_General_AddCallInstAttr(LLVMValueRef callInst, unsigned i, LLVMAttribute attr) { - CallSite callSite(unwrap(callInst)); - LLVMContext &context = callSite->getContext(); - AttrBuilder attrBuilder(attr); - callSite.setAttributes(callSite.getAttributes().addAttributes(context, i, AttributeSet::get(context, i, attrBuilder))); +void LLVM_General_SetCallSiteAttributeSet(LLVMValueRef i, const AttributeSetImpl *asi) { + CallSite(unwrap(i)).setAttributes(unwrap(asi)); } -LLVMAttribute LLVM_General_GetCallInstFunctionAttr(LLVMValueRef callInst) { - return LLVM_General_GetCallInstAttr(callInst, AttributeSet::FunctionIndex); +unsigned LLVM_General_GetCallSiteCallingConvention(LLVMValueRef i) { + LLVM_General_CallingConventionEnumMatches(); + return unsigned(CallSite(unwrap(i)).getCallingConv()); } -void LLVM_General_AddCallInstFunctionAttr(LLVMValueRef callInst, LLVMAttribute attr) { - LLVM_General_AddCallInstAttr(callInst, AttributeSet::FunctionIndex, attr); +void LLVM_General_SetCallSiteCallingConvention(LLVMValueRef i, unsigned cc) { + LLVM_General_CallingConventionEnumMatches(); + CallSite(unwrap(i)).setCallingConv(llvm::CallingConv::ID(cc)); } +void LLVM_General_TailCallKindEnumMatches() { +#define CHECK(name) \ + static_assert( \ + unsigned(llvm::CallInst::TCK_ ## name) == unsigned(LLVM_General_TailCallKind_ ## name), \ + "LLVM_General_TailCallKind enum out of sync w/ llvm::CallInst::TailCallKind for " #name \ + ); + LLVM_GENERAL_FOR_EACH_TAIL_CALL_KIND(CHECK) +#undef CHECK +} + +unsigned LLVM_General_GetTailCallKind(LLVMValueRef i) { + LLVM_General_TailCallKindEnumMatches(); + return unwrap(i)->getTailCallKind(); +} + +void LLVM_General_SetTailCallKind(LLVMValueRef i, unsigned kind) { + LLVM_General_TailCallKindEnumMatches(); + return unwrap(i)->setTailCallKind(llvm::CallInst::TailCallKind(kind)); +} + LLVMValueRef LLVM_General_GetAllocaNumElements(LLVMValueRef a) { return wrap(unwrap(a)->getArraySize()); } @@ -134,25 +153,32 @@ // ------------------------------------------------------------ -#define LLVM_GENERAL_FOR_EACH_ATOMIC_INST(macro) \ - macro(Load) \ - macro(Store) \ - macro(Fence) \ - macro(AtomicCmpXchg) \ - macro(AtomicRMW) +#define LLVM_GENERAL_FOR_EACH_ATOMIC_INST(macro) \ + macro(Load,) \ + macro(Store,) \ + macro(Fence,) \ + macro(AtomicCmpXchg,Success) \ + macro(AtomicRMW,) LLVMAtomicOrdering LLVM_General_GetAtomicOrdering(LLVMValueRef i) { switch(unwrap(i)->getOpcode()) { -#define ENUM_CASE(n) case Instruction::n: return wrap(unwrap(i)->getOrdering()); +#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap(i)->get ## s ## Ordering()); LLVM_GENERAL_FOR_EACH_ATOMIC_INST(ENUM_CASE) #undef ENUM_CASE default: return LLVMAtomicOrdering(0); } } +LLVMAtomicOrdering LLVM_General_GetFailureAtomicOrdering(LLVMValueRef i) { + switch(unwrap(i)->getOpcode()) { + case Instruction::AtomicCmpXchg: return wrap(unwrap(i)->getFailureOrdering()); + default: return LLVMAtomicOrdering(0); + } +} + LLVMSynchronizationScope LLVM_General_GetSynchronizationScope(LLVMValueRef i) { switch(unwrap(i)->getOpcode()) { -#define ENUM_CASE(n) case Instruction::n: return wrap(unwrap(i)->getSynchScope()); +#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap(i)->getSynchScope()); LLVM_GENERAL_FOR_EACH_ATOMIC_INST(ENUM_CASE) #undef ENUM_CASE default: return LLVMSynchronizationScope(0); @@ -249,4 +275,3 @@ } } - diff --git a/src/LLVM/General/Internal/FFI/LLVMCTypes.hsc b/src/LLVM/General/Internal/FFI/LLVMCTypes.hsc --- a/src/LLVM/General/Internal/FFI/LLVMCTypes.hsc +++ b/src/LLVM/General/Internal/FFI/LLVMCTypes.hsc @@ -12,12 +12,13 @@ #include "llvm-c/Target.h" #include "llvm-c/TargetMachine.h" #include "llvm-c/Linker.h" -#include "LLVM/General/Internal/FFI/Instruction.h" +#include "LLVM/General/Internal/FFI/Attribute.h" +#include "LLVM/General/Internal/FFI/Instruction.h" #include "LLVM/General/Internal/FFI/Value.h" #include "LLVM/General/Internal/FFI/SMDiagnostic.h" #include "LLVM/General/Internal/FFI/InlineAssembly.h" #include "LLVM/General/Internal/FFI/Target.h" -#include "LLVM/General/Internal/FFI/Function.h" +#include "LLVM/General/Internal/FFI/CallingConvention.h" #include "LLVM/General/Internal/FFI/GlobalValue.h" #include "LLVM/General/Internal/FFI/Type.h" #include "LLVM/General/Internal/FFI/Constant.h" @@ -117,6 +118,16 @@ #define MO_Rec(n) { #n, LLVMAtomicOrdering ## n }, #{inject ATOMIC_ORDERING, MemoryOrdering, MemoryOrdering, memoryOrdering, MO_Rec} +newtype SynchronizationScope = SynchronizationScope CUInt + deriving (Eq, Typeable, Data) +#define SS_Rec(n) { #n, LLVM ## n ## SynchronizationScope }, +#{inject SYNCRONIZATION_SCOPE, SynchronizationScope, SynchronizationScope, synchronizationScope, SS_Rec} + +newtype TailCallKind = TailCallKind CUInt + deriving (Eq, Typeable, Data) +#define TCK_Rec(n) { #n, LLVM_General_TailCallKind_ ## n }, +#{inject TAIL_CALL_KIND, TailCallKind, TailCallKind, tailCallKind, TCK_Rec} + newtype Linkage = Linkage CUInt deriving (Eq, Read, Show, Typeable, Data) #define LK_Rec(n) { #n, LLVM ## n ## Linkage }, @@ -127,11 +138,26 @@ #define VIS_Rec(n) { #n, LLVM ## n ## Visibility }, #{inject VISIBILITY, Visibility, Visibility, visibility, VIS_Rec} -newtype CallConv = CallConv CUInt +newtype COMDATSelectionKind = COMDATSelectionKind CUInt deriving (Eq, Read, Show, Typeable, Data) -#define CC_Rec(n) { #n, LLVM ## n ## CallConv }, -#{inject CALLCONV, CallConv, CallConv, callConv, CC_Rec} +#define CSK(n) { #n, LLVM_General_COMDAT_Selection_Kind_ ## n }, +#{inject COMDAT_SELECTION_KIND, COMDATSelectionKind, COMDATSelectionKind, comdatSelectionKind, CSK} +newtype DLLStorageClass = DLLStorageClass CUInt + deriving (Eq, Read, Show, Typeable, Data) +#define DLLSC_Rec(n) { #n, LLVM ## n ## StorageClass }, +#{inject DLL_STORAGE_CLASS, DLLStorageClass, DLLStorageClass, dllStorageClass, DLLSC_Rec} + +newtype CallingConvention = CallingConvention CUInt + deriving (Eq, Read, Show, Typeable, Data) +#define CC_Rec(l, n) { #l, LLVM_General_CallingConvention_ ## l }, +#{inject CALLING_CONVENTION, CallingConvention, CallingConvention, callingConvention, CC_Rec} + +newtype ThreadLocalMode = ThreadLocalMode CUInt + deriving (Eq, Read, Show, Typeable, Data) +#define TLS_Rec(n) { #n, LLVM ## n }, +#{inject THREAD_LOCAL_MODE, ThreadLocalMode, ThreadLocalMode, threadLocalMode, TLS_Rec} + newtype ValueSubclassId = ValueSubclassId CUInt deriving (Eq, Read, Show, Typeable, Data) #define VSID_Rec(n) { #n, LLVM ## n ## SubclassId }, @@ -192,15 +218,25 @@ #define TK_Rec(n) { #n, LLVM ## n ## TypeKind }, #{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec} -newtype ParamAttr = ParamAttr CUInt - deriving (Eq, Read, Show, Bits, Typeable, Data, Num) -#define PA_Rec(n,a) { #n, LLVM ## n ## a }, -#{inject PARAM_ATTR, ParamAttr, ParamAttr, paramAttr, PA_Rec} +#define COMMA , +#define IF_T(z) z +#define IF_F(z) +#define IF2(x) IF_ ## x +#define IF(x) IF2(x) +#define OR_TT T +#define OR_TF T +#define OR_FT T +#define OR_FF F +#define OR(x,y) OR_ ## x ## y +newtype ParameterAttributeKind = ParameterAttributeKind CUInt + deriving (Eq, Read, Show, Typeable, Data) +#define PAK_Rec(n,p,r,f) IF(OR(p,r))({ #n COMMA LLVM_General_AttributeKind_ ## n} COMMA) +#{inject ATTRIBUTE_KIND, ParameterAttributeKind, ParameterAttributeKind, parameterAttributeKind, PAK_Rec} -newtype FunctionAttr = FunctionAttr CUInt - deriving (Eq, Read, Show, Bits, Typeable, Data, Num) -#define FA_Rec(n,a) { #n, LLVM ## n ## a }, -#{inject FUNCTION_ATTR, FunctionAttr, FunctionAttr, functionAttr, FA_Rec} +newtype FunctionAttributeKind = FunctionAttributeKind CUInt + deriving (Eq, Read, Show, Typeable, Data) +#define FAK_Rec(n,p,r,f) IF(f)({ #n COMMA LLVM_General_AttributeKind_ ## n} COMMA) +#{inject ATTRIBUTE_KIND, FunctionAttributeKind, FunctionAttributeKind, functionAttributeKind, FAK_Rec} newtype FloatSemantics = FloatSemantics CUInt deriving (Eq, Read, Show, Typeable, Data) diff --git a/src/LLVM/General/Internal/FFI/LibFunc.h b/src/LLVM/General/Internal/FFI/LibFunc.h --- a/src/LLVM/General/Internal/FFI/LibFunc.h +++ b/src/LLVM/General/Internal/FFI/LibFunc.h @@ -26,7 +26,7 @@ macro(dunder_isoc99_sscanf) \ macro(memcpy_chk) \ macro(sincospi_stret) \ - macro(sincospi_stretf) \ + macro(sincospif_stret) \ macro(sinpi) \ macro(sinpif) \ macro(sqrt_finite) \ @@ -118,6 +118,12 @@ macro(floor) \ macro(floorf) \ macro(floorl) \ + macro(fmax) \ + macro(fmaxf) \ + macro(fmaxl) \ + macro(fmin) \ + macro(fminf) \ + macro(fminl) \ macro(fmod) \ macro(fmodf) \ macro(fmodl) \ @@ -162,6 +168,9 @@ macro(isdigit) \ macro(labs) \ macro(lchown) \ + macro(ldexp) \ + macro(ldexpf) \ + macro(ldexpl) \ macro(llabs) \ macro(log) \ macro(log10) \ diff --git a/src/LLVM/General/Internal/FFI/Module.hs b/src/LLVM/General/Internal/FFI/Module.hs --- a/src/LLVM/General/Internal/FFI/Module.hs +++ b/src/LLVM/General/Internal/FFI/Module.hs @@ -9,8 +9,10 @@ import Foreign.C import LLVM.General.Internal.FFI.Context +import LLVM.General.Internal.FFI.GlobalValue (COMDAT) import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy +import LLVM.General.Internal.FFI.Type data Module @@ -50,6 +52,9 @@ foreign import ccall unsafe "LLVM_General_GetNextAlias" getNextAlias :: Ptr GlobalAlias -> IO (Ptr GlobalAlias) +foreign import ccall unsafe "LLVM_General_GetOrInsertCOMDAT" getOrInsertCOMDAT :: + Ptr Module -> CString -> IO (Ptr COMDAT) + foreign import ccall unsafe "LLVMGetFirstFunction" getFirstFunction :: Ptr Module -> IO (Ptr Function) @@ -66,7 +71,7 @@ Ptr Module -> Ptr Type -> CString -> CUInt -> IO (Ptr GlobalVariable) foreign import ccall unsafe "LLVM_General_JustAddAlias" justAddAlias :: - Ptr Module -> Ptr Type -> CString -> IO (Ptr GlobalAlias) + Ptr Module -> Ptr Type -> AddrSpace -> CString -> IO (Ptr GlobalAlias) foreign import ccall unsafe "LLVMAddFunction" addFunction :: diff --git a/src/LLVM/General/Internal/FFI/ModuleC.cpp b/src/LLVM/General/Internal/FFI/ModuleC.cpp --- a/src/LLVM/General/Internal/FFI/ModuleC.cpp +++ b/src/LLVM/General/Internal/FFI/ModuleC.cpp @@ -23,8 +23,12 @@ return wrap(i); } -LLVMValueRef LLVM_General_JustAddAlias(LLVMModuleRef m, LLVMTypeRef ty, const char *name) { - return wrap(new GlobalAlias(unwrap(ty), GlobalValue::ExternalLinkage, name, 0, unwrap(m))); +Comdat *LLVM_General_GetOrInsertCOMDAT(LLVMModuleRef m, const char *name) { + return unwrap(m)->getOrInsertComdat(name); +} + +LLVMValueRef LLVM_General_JustAddAlias(LLVMModuleRef m, LLVMTypeRef ty, unsigned addrspace, const char *name) { + return wrap(GlobalAlias::create(unwrap(ty), addrspace, GlobalValue::ExternalLinkage, name, 0, unwrap(m))); } NamedMDNode *LLVM_General_GetOrAddNamedMetadata(LLVMModuleRef m, const char *name) { diff --git a/src/LLVM/General/Internal/FFI/PassManagerC.cpp b/src/LLVM/General/Internal/FFI/PassManagerC.cpp --- a/src/LLVM/General/Internal/FFI/PassManagerC.cpp +++ b/src/LLVM/General/Internal/FFI/PassManagerC.cpp @@ -3,8 +3,10 @@ #include "llvm/IR/DataLayout.h" #include "llvm/Transforms/Scalar.h" #include "llvm/Transforms/IPO.h" +#include "llvm/Transforms/IPO/PassManagerBuilder.h" #include "llvm/Transforms/Vectorize.h" #include "llvm/Transforms/Instrumentation.h" +#include "llvm/CodeGen/Passes.h" #include "llvm/PassManager.h" #include "llvm-c/Target.h" #include "llvm-c/Transforms/PassManagerBuilder.h" @@ -51,10 +53,6 @@ extern "C" { -void LLVM_General_AddDataLayoutPass(LLVMPassManagerRef PM, const char *dl) { - unwrap(PM)->add(new DataLayout(dl)); -} - void LLVM_General_LLVMAddAnalysisPasses(LLVMTargetMachineRef T, LLVMPassManagerRef PM) { unwrap(T)->addAnalysisPasses(*unwrap(PM)); } @@ -99,8 +97,8 @@ unwrap(PM)->add(createLoopStrengthReducePass()); } -void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM, LLVMTargetMachineRef T, LLVMBool expensiveEH) { - unwrap(PM)->add(createLowerInvokePass(unwrap(T), expensiveEH)); +void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createLowerInvokePass()); } void LLVM_General_AddSROAPass(LLVMPassManagerRef PM, LLVMBool RequiresDomTree) { @@ -179,46 +177,28 @@ } void LLVM_General_AddAddressSanitizerFunctionPass( - LLVMPassManagerRef PM, - LLVMBool checkInitOrder, - LLVMBool checkUseAfterReturn, - LLVMBool checkLifetime, - char *blacklistFile, - LLVMBool zeroBaseShadow + LLVMPassManagerRef PM ) { - unwrap(PM)->add( - createAddressSanitizerFunctionPass( - checkInitOrder, - checkUseAfterReturn, - checkLifetime, - blacklistFile, - zeroBaseShadow - ) - ); + unwrap(PM)->add(createAddressSanitizerFunctionPass()); } void LLVM_General_AddAddressSanitizerModulePass( - LLVMPassManagerRef PM, - LLVMBool checkInitOrder, - const char *blacklistFile, - bool zeroBaseShadow + LLVMPassManagerRef PM ) { - unwrap(PM)->add(createAddressSanitizerModulePass(checkInitOrder, blacklistFile, zeroBaseShadow)); + unwrap(PM)->add(createAddressSanitizerModulePass()); } void LLVM_General_AddMemorySanitizerPass( LLVMPassManagerRef PM, - LLVMBool trackOrigins, - const char *blacklistFile + LLVMBool trackOrigins ) { - unwrap(PM)->add(createMemorySanitizerPass(trackOrigins, blacklistFile)); + unwrap(PM)->add(createMemorySanitizerPass(trackOrigins)); } void LLVM_General_AddThreadSanitizerPass( - LLVMPassManagerRef PM, - const char *blacklistFile + LLVMPassManagerRef PM ) { - unwrap(PM)->add(createThreadSanitizerPass(blacklistFile)); + unwrap(PM)->add(createThreadSanitizerPass()); } void LLVM_General_AddBoundsCheckingPass(LLVMPassManagerRef PM) { @@ -248,9 +228,10 @@ void LLVM_General_AddLoopVectorizePass( LLVMPassManagerRef PM, - LLVMBool noUnrolling + LLVMBool noUnrolling, + LLVMBool alwaysVectorize ) { - unwrap(PM)->add(createLoopVectorizePass(noUnrolling)); + unwrap(PM)->add(createLoopVectorizePass(noUnrolling, alwaysVectorize)); } void LLVM_General_PassManagerBuilderSetLibraryInfo( diff --git a/src/LLVM/General/Internal/FFI/PtrHierarchy.hs b/src/LLVM/General/Internal/FFI/PtrHierarchy.hs --- a/src/LLVM/General/Internal/FFI/PtrHierarchy.hs +++ b/src/LLVM/General/Internal/FFI/PtrHierarchy.hs @@ -46,10 +46,15 @@ instance ChildOf Constant GlobalValue +-- | +data GlobalObject + +instance ChildOf GlobalValue GlobalObject + -- | data GlobalVariable -instance ChildOf GlobalValue GlobalVariable +instance ChildOf GlobalObject GlobalVariable -- | data GlobalAlias @@ -59,7 +64,7 @@ -- | data Function -instance ChildOf GlobalValue Function +instance ChildOf GlobalObject Function -- | data BasicBlock diff --git a/src/LLVM/General/Internal/FFI/RawOStreamC.cpp b/src/LLVM/General/Internal/FFI/RawOStreamC.cpp --- a/src/LLVM/General/Internal/FFI/RawOStreamC.cpp +++ b/src/LLVM/General/Internal/FFI/RawOStreamC.cpp @@ -1,23 +1,24 @@ #define __STDC_LIMIT_MACROS #include "llvm/Support/raw_ostream.h" +#include "llvm/Support/FileSystem.h" #include "llvm-c/Core.h" using namespace llvm; using sys::fs::F_None; using sys::fs::F_Excl; -using sys::fs::F_Binary; +using sys::fs::F_Text; extern "C" { LLVMBool LLVM_General_WithFileRawOStream( const char *filename, LLVMBool excl, - LLVMBool binary, + LLVMBool text, const char *&error, void (&callback)(raw_ostream &ostream) ) { std::string e; - raw_fd_ostream os(filename, e, (excl ? F_Excl : F_None) | (binary ? F_Binary : F_None)); + raw_fd_ostream os(filename, e, (excl ? F_Excl : F_None) | (text ? F_Text : F_None)); if (!e.empty()) { error = strdup(e.c_str()); return false; diff --git a/src/LLVM/General/Internal/FFI/Target.h b/src/LLVM/General/Internal/FFI/Target.h --- a/src/LLVM/General/Internal/FFI/Target.h +++ b/src/LLVM/General/Internal/FFI/Target.h @@ -41,8 +41,10 @@ macro(DisableTailCalls) \ macro(EnableFastISel) \ macro(PositionIndependentExecutable) \ - macro(EnableSegmentedStacks) \ - macro(UseInitArray) + macro(UseInitArray) \ + macro(DisableIntegratedAS) \ + macro(CompressDebugSections) \ + macro(TrapUnreachable) typedef enum { #define ENUM_CASE(n) LLVM_General_TargetOptionFlag_ ## n, diff --git a/src/LLVM/General/Internal/FFI/Target.hs b/src/LLVM/General/Internal/FFI/Target.hs --- a/src/LLVM/General/Internal/FFI/Target.hs +++ b/src/LLVM/General/Internal/FFI/Target.hs @@ -95,7 +95,7 @@ IO (OwnerTransfered CString) foreign import ccall unsafe "LLVM_General_GetHostCPUName" getHostCPUName :: - IO (OwnerTransfered CString) + Ptr CSize -> IO CString foreign import ccall unsafe "LLVM_General_GetHostCPUFeatures" getHostCPUFeatures :: IO (OwnerTransfered CString) diff --git a/src/LLVM/General/Internal/FFI/TargetC.cpp b/src/LLVM/General/Internal/FFI/TargetC.cpp --- a/src/LLVM/General/Internal/FFI/TargetC.cpp +++ b/src/LLVM/General/Internal/FFI/TargetC.cpp @@ -254,19 +254,20 @@ return strdup(sys::getProcessTriple().c_str()); } -char *LLVM_General_GetHostCPUName() { - return strdup(sys::getHostCPUName().c_str()); +const char *LLVM_General_GetHostCPUName(size_t &len) { + StringRef r = sys::getHostCPUName(); + len = r.size(); + return r.data(); } char *LLVM_General_GetHostCPUFeatures() { StringMap featureMap; std::string features; if (sys::getHostCPUFeatures(featureMap)) { - bool first = true; for(llvm::StringMap::const_iterator it = featureMap.begin(); it != featureMap.end(); ++it) { - if (!first) { features += ","; } - first = false; - features += (it->second ? "+" : "-") + it->first().str(); + if (it->second) { + features += it->first().str() + " "; + } } } return strdup(features.c_str()); @@ -338,7 +339,7 @@ return true; } PassManager passManager; - passManager.add(new DataLayout(*td)); + passManager.add(new DataLayoutPass(*td)); if (tm.addPassesToEmitFile(passManager, destf, unwrap(codeGenFileType))) { *ErrorMessage = strdup("TargetMachine can't emit a file of this type"); return true; diff --git a/src/LLVM/General/Internal/FFI/Threading.hs b/src/LLVM/General/Internal/FFI/Threading.hs --- a/src/LLVM/General/Internal/FFI/Threading.hs +++ b/src/LLVM/General/Internal/FFI/Threading.hs @@ -9,11 +9,5 @@ import LLVM.General.Internal.FFI.LLVMCTypes -foreign import ccall unsafe "LLVMStartMultithreaded" startMultithreaded :: - IO LLVMBool - -foreign import ccall unsafe "LLVMStopMultithreaded" stopMultithreaded :: - IO () - foreign import ccall unsafe "LLVMIsMultithreaded" isMultithreaded :: IO LLVMBool diff --git a/src/LLVM/General/Internal/FFI/Transforms.hs b/src/LLVM/General/Internal/FFI/Transforms.hs --- a/src/LLVM/General/Internal/FFI/Transforms.hs +++ b/src/LLVM/General/Internal/FFI/Transforms.hs @@ -5,7 +5,6 @@ -- | does the constructor for this pass require a TargetMachine object needsTargetMachine "CodeGenPrepare" = True -needsTargetMachine "LowerInvoke" = True needsTargetMachine _ = False -- | Translate a Haskell name (used in the public Haskell interface, typically not abbreviated) diff --git a/src/LLVM/General/Internal/FFI/Value.h b/src/LLVM/General/Internal/FFI/Value.h --- a/src/LLVM/General/Internal/FFI/Value.h +++ b/src/LLVM/General/Internal/FFI/Value.h @@ -22,8 +22,6 @@ macro(MDNode) \ macro(MDString) \ macro(InlineAsm) \ - macro(PseudoSourceValue) \ - macro(FixedStackPseudoSourceValue) \ macro(Instruction) typedef enum { diff --git a/src/LLVM/General/Internal/Function.hs b/src/LLVM/General/Internal/Function.hs --- a/src/LLVM/General/Internal/Function.hs +++ b/src/LLVM/General/Internal/Function.hs @@ -5,8 +5,12 @@ import Control.Monad.Trans import Control.Monad.AnyCont -import Foreign.Ptr +import Foreign.C (CUInt) +import Foreign.Ptr +import Data.Map (Map) +import qualified Data.Map as Map + import qualified LLVM.General.Internal.FFI.Function as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI @@ -14,34 +18,43 @@ import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Value import LLVM.General.Internal.Coding -import LLVM.General.Internal.Attribute () +import LLVM.General.Internal.Constant () +import LLVM.General.Internal.Attribute import qualified LLVM.General.AST as A -import qualified LLVM.General.AST.Attribute as A.A - -getFunctionAttrs :: Ptr FFI.Function -> IO [A.A.FunctionAttribute] -getFunctionAttrs = decodeM <=< FFI.getFunctionAttr +import qualified LLVM.General.AST.Constant as A +import qualified LLVM.General.AST.ParameterAttribute as A.PA -setFunctionAttrs :: Ptr FFI.Function -> [A.A.FunctionAttribute] -> IO () -setFunctionAttrs f = FFI.addFunctionAttr f <=< encodeM +getMixedAttributeSet :: Ptr FFI.Function -> DecodeAST MixedAttributeSet +getMixedAttributeSet = decodeM <=< liftIO . FFI.getMixedAttributeSet -getParameterAttrs :: Ptr FFI.Parameter -> IO [A.A.ParameterAttribute] -getParameterAttrs = decodeM <=< FFI.getAttribute +setFunctionAttributes :: Ptr FFI.Function -> MixedAttributeSet -> EncodeAST () +setFunctionAttributes f = (liftIO . FFI.setMixedAttributeSet f) <=< encodeM -getParameters :: Ptr FFI.Function -> DecodeAST [A.Parameter] -getParameters f = scopeAnyCont $ do +getParameters :: Ptr FFI.Function -> Map CUInt [A.PA.ParameterAttribute] -> DecodeAST [A.Parameter] +getParameters f attrs = scopeAnyCont $ do n <- liftIO (FFI.countParams f) ps <- allocaArray n liftIO $ FFI.getParams f ps params <- peekArray n ps - forM params $ \param -> + forM (zip params [0..]) $ \(param, i) -> return A.Parameter `ap` typeOf param `ap` getLocalName param - `ap` (liftIO $ getParameterAttrs param) + `ap` (return $ Map.findWithDefault [] i attrs) getGC :: Ptr FFI.Function -> DecodeAST (Maybe String) getGC f = scopeAnyCont $ decodeM =<< liftIO (FFI.getGC f) setGC :: Ptr FFI.Function -> Maybe String -> EncodeAST () setGC f gc = scopeAnyCont $ liftIO . FFI.setGC f =<< encodeM gc + +getPrefixData :: Ptr FFI.Function -> DecodeAST (Maybe A.Constant) +getPrefixData f = do + has <- decodeM =<< (liftIO $ FFI.hasPrefixData f) + if has + then decodeM =<< (liftIO $ FFI.getPrefixData f) + else return Nothing + +setPrefixData :: Ptr FFI.Function -> Maybe A.Constant -> EncodeAST () +setPrefixData f = maybe (return ()) (liftIO . FFI.setPrefixData f <=< encodeM) diff --git a/src/LLVM/General/Internal/Global.hs b/src/LLVM/General/Internal/Global.hs --- a/src/LLVM/General/Internal/Global.hs +++ b/src/LLVM/General/Internal/Global.hs @@ -6,9 +6,10 @@ import LLVM.General.Prelude -import Control.Monad.IO.Class -import Foreign.Ptr +import Control.Monad.State import Control.Monad.AnyCont +import Foreign.Ptr +import qualified Data.Map as Map import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI @@ -20,6 +21,9 @@ import qualified LLVM.General.AST.Linkage as A.L import qualified LLVM.General.AST.Visibility as A.V +import qualified LLVM.General.AST.COMDAT as A.COMDAT +import qualified LLVM.General.AST.DLL as A.DLL +import qualified LLVM.General.AST.ThreadLocalStorage as A.TLS genCodingInstance [t| A.L.Linkage |] ''FFI.Linkage [ (FFI.linkageExternal, A.L.External), @@ -31,12 +35,8 @@ (FFI.linkageAppending, A.L.Appending), (FFI.linkageInternal, A.L.Internal), (FFI.linkagePrivate, A.L.Private), - (FFI.linkageDLLImport, A.L.DLLImport), - (FFI.linkageDLLExport, A.L.DLLExport), (FFI.linkageExternalWeak, A.L.ExternWeak), - (FFI.linkageCommon, A.L.Common), - (FFI.linkageLinkerPrivate, A.L.LinkerPrivate), - (FFI.linkageLinkerPrivateWeak, A.L.LinkerPrivateWeak) + (FFI.linkageCommon, A.L.Common) ] getLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.L.Linkage @@ -57,6 +57,18 @@ setVisibility :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.V.Visibility -> EncodeAST () setVisibility g v = liftIO . FFI.setVisibility (FFI.upCast g) =<< encodeM v +genCodingInstance [t| Maybe A.DLL.StorageClass |] ''FFI.DLLStorageClass [ + (FFI.dllStorageClassDefault, Nothing), + (FFI.dllStorageClassDLLImport, Just A.DLL.Import), + (FFI.dllStorageClassDLLExport, Just A.DLL.Export) + ] + +getDLLStorageClass :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe A.DLL.StorageClass) +getDLLStorageClass g = liftIO $ decodeM =<< FFI.getDLLStorageClass (FFI.upCast g) + +setDLLStorageClass :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe A.DLL.StorageClass -> EncodeAST () +setDLLStorageClass g sc = liftIO . FFI.setDLLStorageClass (FFI.upCast g) =<< encodeM sc + getSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe String) getSection g = liftIO $ do s <- decodeM =<< FFI.getSection (FFI.upCast g) @@ -67,8 +79,56 @@ s <- encodeM (maybe "" id s) liftIO $ FFI.setSection (FFI.upCast g) s +genCodingInstance [t| A.COMDAT.SelectionKind |] ''FFI.COMDATSelectionKind [ + (FFI.comdatSelectionKindAny, A.COMDAT.Any), + (FFI.comdatSelectionKindExactMatch, A.COMDAT.ExactMatch), + (FFI.comdatSelectionKindLargest, A.COMDAT.Largest), + (FFI.comdatSelectionKindNoDuplicates, A.COMDAT.NoDuplicates), + (FFI.comdatSelectionKindSameSize, A.COMDAT.SameSize) + ] + +instance DecodeM DecodeAST (String, A.COMDAT.SelectionKind) (Ptr FFI.COMDAT) where + decodeM c = return (,) + `ap` (decodeM $ FFI.getCOMDATName c) + `ap` (decodeM =<< liftIO (FFI.getCOMDATSelectionKind c)) + +getCOMDATName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe String) +getCOMDATName g = do + c <- liftIO $ FFI.getCOMDAT (FFI.upCast g) + if c == nullPtr + then return Nothing + else do + cds <- gets comdats + liftM Just $ case Map.lookup c cds of + Just (name, _) -> return name + Nothing -> do + cd@(name, _) <- decodeM c + modify $ \s -> s { comdats = Map.insert c cd cds } + return name + +setCOMDAT :: FFI.DescendentOf FFI.GlobalObject v => Ptr v -> Maybe String -> EncodeAST () +setCOMDAT _ Nothing = return () +setCOMDAT g (Just name) = do + cd <- referCOMDAT name + liftIO $ FFI.setCOMDAT (FFI.upCast g) cd + setAlignment :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Word32 -> EncodeAST () setAlignment g i = liftIO $ FFI.setAlignment (FFI.upCast g) (fromIntegral i) getAlignment :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST Word32 getAlignment g = liftIO $ fromIntegral <$> FFI.getAlignment (FFI.upCast g) + +genCodingInstance [t| Maybe A.TLS.Model |] ''FFI.ThreadLocalMode [ + (FFI.threadLocalModeNotThreadLocal, Nothing), + (FFI.threadLocalModeGeneralDynamicTLSModel, Just A.TLS.GeneralDynamic), + (FFI.threadLocalModeLocalDynamicTLSModel, Just A.TLS.LocalDynamic), + (FFI.threadLocalModeInitialExecTLSModel, Just A.TLS.InitialExec), + (FFI.threadLocalModeLocalExecTLSModel, Just A.TLS.LocalExec) + ] + +getThreadLocalMode :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe A.TLS.Model) +getThreadLocalMode g = liftIO $ decodeM =<< FFI.getThreadLocalMode (FFI.upCast g) + +setThreadLocalMode :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe A.TLS.Model -> EncodeAST () +setThreadLocalMode g m = liftIO . FFI.setThreadLocalMode (FFI.upCast g) =<< encodeM m + diff --git a/src/LLVM/General/Internal/Instruction.hs b/src/LLVM/General/Internal/Instruction.hs --- a/src/LLVM/General/Internal/Instruction.hs +++ b/src/LLVM/General/Internal/Instruction.hs @@ -33,7 +33,7 @@ import qualified LLVM.General.Internal.FFI.BasicBlock as FFI import LLVM.General.Internal.Atomicity () -import LLVM.General.Internal.Attribute () +import LLVM.General.Internal.Attribute import LLVM.General.Internal.CallingConvention () import LLVM.General.Internal.Coding import LLVM.General.Internal.DecodeAST @@ -42,13 +42,15 @@ import LLVM.General.Internal.Metadata () import LLVM.General.Internal.Operand () import LLVM.General.Internal.RMWOperation () +import LLVM.General.Internal.TailCallKind () import LLVM.General.Internal.Type import LLVM.General.Internal.Value import qualified LLVM.General.AST as A import qualified LLVM.General.AST.Constant as A.C -callInstAttr i j = liftIO $ decodeM =<< FFI.getCallInstAttr i j +callInstAttributeSet :: Ptr FFI.Instruction -> DecodeAST MixedAttributeSet +callInstAttributeSet = decodeM <=< liftIO . FFI.getCallSiteAttributeSet meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata meta i = do @@ -121,20 +123,21 @@ A.metadata' = md } [instrP|Invoke|] -> do - cc <- decodeM =<< liftIO (FFI.getInstructionCallConv i) - rAttrs <- callInstAttr i 0 - fv <- liftIO $ FFI.getCallInstCalledValue i + cc <- decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) + attrs <- callInstAttributeSet i + fv <- liftIO $ FFI.getCallSiteCalledValue i f <- decodeM fv - args <- forM [1..nOps-3] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j - fAttrs <- decodeM =<< liftIO (FFI.getCallInstFunctionAttr i) + args <- forM [1..nOps-3] $ \j -> do + let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes attrs) + return (, pAttrs) `ap` op (j-1) rd <- successor (nOps - 2) ed <- successor (nOps - 1) return A.Invoke { A.callingConvention' = cc, - A.returnAttributes' = rAttrs, + A.returnAttributes' = returnAttributes attrs, A.function' = f, A.arguments' = args, - A.functionAttributes' = fAttrs, + A.functionAttributes' = functionAttributes attrs, A.returnDest = rd, A.exceptionDest = ed, A.metadata' = md @@ -204,13 +207,10 @@ let (argvs, argAttrs) = unzip args (n, argvs) <- encodeM argvs i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s - forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do - attrs <- encodeM attrs - liftIO $ FFI.addCallInstAttr i j attrs - fAttrs <- encodeM fAttrs - liftIO $ FFI.addCallInstFunctionAttr i fAttrs + attrs <- encodeM $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs)) + liftIO $ FFI.setCallSiteAttributeSet i attrs cc <- encodeM cc - liftIO $ FFI.setInstructionCallConv i cc + liftIO $ FFI.setCallSiteCallingConvention i cc return $ FFI.upCast i A.Resume { A.operand0' = op0 @@ -269,20 +269,23 @@ "metadata" -> ([], [| meta i |]) "iPredicate" -> ([], [| decodeM =<< liftIO (FFI.getICmpPredicate i) |]) "fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |]) - "isTailCall" -> ([], [| decodeM =<< liftIO (FFI.isTailCall i) |]) - "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getInstructionCallConv i) |]) - "returnAttributes" -> ([], [| callInstAttr i 0 |]) - "f" -> ([], [| liftIO $ FFI.getCallInstCalledValue i |]) + "tailCallKind" -> ([], [| decodeM =<< liftIO (FFI.getTailCallKind i) |]) + "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) |]) + "attrs" -> ([], [| callInstAttributeSet i |]) + "returnAttributes" -> (["attrs"], [| return $ returnAttributes $(TH.dyn "attrs") |]) + "f" -> ([], [| liftIO $ FFI.getCallSiteCalledValue i |]) "function" -> (["f"], [| decodeM $(TH.dyn "f") |]) - "arguments" -> ([], [| forM [1..nOps-1] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j |]) + "arguments" -> ([], [| forM [1..nOps-1] $ \j -> do + let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes $(TH.dyn "attrs")) + p <- op (j-1) + return (p, pAttrs) |]) "clauses" -> ([], [| forM [1..nOps-1] $ \j -> do v <- liftIO $ FFI.getOperand (FFI.upCast i) j c <- decodeM =<< (liftIO $ FFI.isAConstant v) t <- typeOf v return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |]) - "functionAttributes" -> - ([], [| decodeM =<< liftIO (FFI.getCallInstFunctionAttr i) |]) + "functionAttributes" -> (["attrs"], [| return $ functionAttributes $(TH.dyn "attrs") |]) "type'" -> ([], [| return t |]) "incomingValues" -> ([], [| do @@ -304,6 +307,7 @@ "atomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |]) "volatile" -> ([], [| decodeM =<< liftIO (FFI.getVolatile i) |]) "inBounds" -> ([], [| decodeM =<< liftIO (FFI.getInBounds (FFI.upCast i)) |]) + "failureMemoryOrdering" -> ([], [| decodeM =<< liftIO (FFI.getFailureAtomicOrdering i) |]) "indices" -> ([], [| mapM op [1..nOps-1] |]) "indices'" -> ([], [| do @@ -376,7 +380,7 @@ liftIO $ FFI.addIncoming i ivs3' bs3' ) A.Call { - A.isTailCall = tc, + A.tailCallKind = tck, A.callingConvention = cc, A.returnAttributes = rAttrs, A.function = f, @@ -387,16 +391,12 @@ let (argvs, argAttrs) = unzip args (n, argvs) <- encodeM argvs i <- liftIO $ FFI.buildCall builder fv argvs n s - forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do - attrs <- encodeM attrs - liftIO $ FFI.addCallInstAttr i j attrs - fAttrs <- encodeM fAttrs - liftIO $ FFI.addCallInstFunctionAttr i fAttrs - when tc $ do - tc <- encodeM tc - liftIO $ FFI.setTailCall i tc + attrs <- encodeM $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs)) + liftIO $ FFI.setCallSiteAttributeSet i attrs + tck <- encodeM tck + liftIO $ FFI.setTailCallKind i tck cc <- encodeM cc - liftIO $ FFI.setInstructionCallConv i cc + liftIO $ FFI.setCallSiteCallingConvention i cc return' i A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do c' <- encodeM c diff --git a/src/LLVM/General/Internal/Module.hs b/src/LLVM/General/Internal/Module.hs --- a/src/LLVM/General/Internal/Module.hs +++ b/src/LLVM/General/Internal/Module.hs @@ -10,6 +10,7 @@ import LLVM.General.Prelude import Control.Monad.Trans +import Control.Monad.Trans.Except (runExcept) import Control.Monad.State (gets) import Control.Monad.Exceptable import Control.Monad.AnyCont @@ -38,7 +39,8 @@ import qualified LLVM.General.Internal.FFI.Target as FFI import qualified LLVM.General.Internal.FFI.Value as FFI -import LLVM.General.Internal.BasicBlock +import LLVM.General.Internal.Attribute +import LLVM.General.Internal.BasicBlock import LLVM.General.Internal.Coding import LLVM.General.Internal.Context import LLVM.General.Internal.DecodeAST @@ -135,7 +137,7 @@ -- | write LLVM assembly for a 'Module' to a file writeLLVMAssemblyToFile :: File -> Module -> ExceptT String IO () writeLLVMAssemblyToFile (File path) (Module m) = unExceptableT $ flip runAnyContT return $ do - withFileRawOStream path False False $ liftIO . FFI.writeLLVMAssembly m + withFileRawOStream path False True $ liftIO . FFI.writeLLVMAssembly m class BitcodeInput b where bitcodeMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m) @@ -165,7 +167,7 @@ -- | write LLVM bitcode from a 'Module' into a file writeBitcodeToFile :: File -> Module -> ExceptT String IO () writeBitcodeToFile (File path) (Module m) = unExceptableT $ flip runAnyContT return $ do - withFileRawOStream path False True $ liftIO . FFI.writeBitcode m + withFileRawOStream path False False $ liftIO . FFI.writeBitcode m targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ExceptT String IO () targetMachineEmit fileType (TargetMachine tm) (Module m) os = unExceptableT $ flip runAnyContT return $ do @@ -175,7 +177,7 @@ emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ExceptT String IO () emitToFile fileType tm (File path) m = unExceptableT$ flip runAnyContT return $ do - withFileRawOStream path False True $ targetMachineEmit fileType tm m + withFileRawOStream path False False $ targetMachineEmit fileType tm m emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ExceptT String IO BS.ByteString emitToByteString fileType tm m = unExceptableT $ flip runAnyContT return $ do @@ -213,7 +215,9 @@ liftIO $ FFI.setDataLayout m s getDataLayout :: Ptr FFI.Module -> IO (Maybe A.DataLayout) -getDataLayout m = parseDataLayout <$> (decodeM =<< FFI.getDataLayout m) +getDataLayout m = do + dlString <- decodeM =<< FFI.getDataLayout m + either fail return . runExcept . parseDataLayout A.BigEndian $ dlString -- | Build an LLVM.General.'Module' from a LLVM.General.AST.'LLVM.General.AST.Module' - i.e. -- lower an AST from Haskell into C++ objects. @@ -232,8 +236,16 @@ defineType n t' return $ do maybe (return ()) (setNamedType t') t - return . return . return $ return () + return . return . return . return $ () + A.COMDAT n csk -> do + n' <- encodeM n + csk <- encodeM csk + cd <- liftIO $ FFI.getOrInsertCOMDAT m n' + liftIO $ FFI.setCOMDATSelectionKind cd csk + defineCOMDAT n cd + return . return . return . return . return $ () + A.MetadataNodeDefinition i os -> return . return $ do t <- liftIO $ FFI.createTemporaryMDNodeInContext c defineMDNode i t @@ -254,8 +266,13 @@ A.ModuleInlineAssembly s -> do s <- encodeM s liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s) - return . return . return . return $ return () + return . return . return . return . return $ () + A.FunctionAttributes gid attrs -> do + attrs <- encodeM attrs + defineAttributeGroup gid attrs + return . return . return . return . return $ () + A.GlobalDefinition g -> return . phase $ do eg' :: EncodeAST (Ptr FFI.GlobalValue) <- case g of g@(A.GlobalVariable { A.G.name = n }) -> do @@ -264,9 +281,8 @@ FFI.addGlobalInAddressSpace m typ gName (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g)) defineGlobal n g' + setThreadLocalMode g' (A.G.threadLocalMode g) liftIO $ do - tl <- encodeM (A.G.isThreadLocal g) - FFI.setThreadLocal g' tl hua <- encodeM (A.G.hasUnnamedAddr g) FFI.setUnnamedAddr (FFI.upCast g') hua ic <- encodeM (A.G.isConstant g) @@ -274,25 +290,32 @@ return $ do maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g) setSection g' (A.G.section g) + setCOMDAT g' (A.G.comdat g) setAlignment g' (A.G.alignment g) return (FFI.upCast g') (a@A.G.GlobalAlias { A.G.name = n }) -> do - typ <- encodeM (A.G.type' a) - a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ name + let A.PointerType typ as = A.G.type' a + typ <- encodeM typ + as <- encodeM as + a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ as name defineGlobal n a' + liftIO $ do + hua <- encodeM (A.G.hasUnnamedAddr a) + FFI.setUnnamedAddr (FFI.upCast a') hua return $ do + setThreadLocalMode a' (A.G.threadLocalMode a) (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a) return (FFI.upCast a') - (A.Function _ _ cc rAttrs resultType fName (args,isVarArgs) attrs _ _ gc blocks) -> do - typ <- encodeM $ A.FunctionType resultType (map (\(A.Parameter t _ _) -> t) args) isVarArgs + (A.Function _ _ _ cc rAttrs resultType fName (args, isVarArgs) attrs _ _ _ gc prefix blocks) -> do + typ <- encodeM $ A.FunctionType resultType [t | A.Parameter t _ _ <- args] isVarArgs f <- liftIO . withName fName $ \fName -> FFI.addFunction m fName typ defineGlobal fName f cc <- encodeM cc - liftIO $ FFI.setFunctionCallConv f cc - rAttrs <- encodeM rAttrs - liftIO $ FFI.addFunctionRetAttr f rAttrs - liftIO $ setFunctionAttrs f attrs + liftIO $ FFI.setFunctionCallingConvention f cc + setFunctionAttributes f (MixedAttributeSet attrs rAttrs (Map.fromList $ zip [0..] [pa | A.Parameter _ _ pa <- args])) + setPrefixData f prefix setSection f (A.G.section g) + setCOMDAT f (A.G.comdat g) setAlignment f (A.G.alignment g) setGC f gc forM blocks $ \(A.BasicBlock bName _ _) -> do @@ -303,15 +326,10 @@ ps <- allocaArray nParams liftIO $ FFI.getParams f ps params <- peekArray nParams ps - forM (zip args params) $ \(A.Parameter _ n attrs, p) -> do + forM (zip args params) $ \(A.Parameter _ n _, p) -> do defineLocal n p n <- encodeM n liftIO $ FFI.setValueName (FFI.upCast p) n - unless (null attrs) $ - do attrs <- encodeM attrs - liftIO $ FFI.addAttribute p attrs - return () - return () finishInstrs <- forM blocks $ \(A.BasicBlock bName namedInstrs term) -> do b <- encodeM bName (do @@ -328,6 +346,7 @@ g' <- eg' setLinkage g' (A.G.linkage g) setVisibility g' (A.G.visibility g) + setDLLStorageClass g' (A.G.dllStorageClass g) return $ return () liftIO $ f (Module m) @@ -356,7 +375,8 @@ `ap` return n `ap` getLinkage g `ap` getVisibility g - `ap` (liftIO $ decodeM =<< FFI.isThreadLocal g) + `ap` getDLLStorageClass g + `ap` getThreadLocalMode g `ap` return as `ap` (liftIO $ decodeM =<< FFI.hasUnnamedAddr (FFI.upCast g)) `ap` (liftIO $ decodeM =<< FFI.isGlobalConstant g) @@ -365,6 +385,7 @@ i <- liftIO $ FFI.getInitializer g if i == nullPtr then return Nothing else Just <$> decodeM i) `ap` getSection g + `ap` getCOMDATName g `ap` getAlignment g, do @@ -375,6 +396,9 @@ `ap` return n `ap` getLinkage a `ap` getVisibility a + `ap` getDLLStorageClass a + `ap` getThreadLocalMode a + `ap` (liftIO $ decodeM =<< FFI.hasUnnamedAddr (FFI.upCast a)) `ap` typeOf a `ap` (decodeM =<< (liftIO $ FFI.getAliasee a)), @@ -383,7 +407,8 @@ liftM sequence . forM ffiFunctions $ \f -> localScope $ do A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f n <- getGlobalName f - parameters <- getParameters f + MixedAttributeSet fAttrs rAttrs pAttrs <- getMixedAttributeSet f + parameters <- getParameters f pAttrs decodeBlocks <- do ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock liftM sequence . forM ffiBasicBlocks $ \b -> do @@ -394,15 +419,18 @@ return $ return A.Function `ap` getLinkage f `ap` getVisibility f - `ap` (liftIO $ decodeM =<< FFI.getFunctionCallConv f) - `ap` (liftIO $ decodeM =<< FFI.getFunctionRetAttr f) + `ap` getDLLStorageClass f + `ap` (liftIO $ decodeM =<< FFI.getFunctionCallingConvention f) + `ap` return rAttrs `ap` return returnType `ap` return n `ap` return (parameters, isVarArg) - `ap` (liftIO $ getFunctionAttrs f) + `ap` return fAttrs `ap` getSection f + `ap` getCOMDATName f `ap` getAlignment f `ap` getGC f + `ap` getPrefixData f `ap` decodeBlocks ] @@ -422,5 +450,11 @@ mds <- getMetadataDefinitions - return $ tds ++ ias ++ gs ++ nmds ++ mds + ags <- do + ags <- gets $ Map.toList . functionAttributeSetIDs + forM ags $ \(as, gid) -> return A.FunctionAttributes `ap` return gid `ap` decodeM as + + cds <- gets $ map (uncurry A.COMDAT) . Map.elems . comdats + + return $ tds ++ ias ++ gs ++ nmds ++ mds ++ ags ++ cds ) diff --git a/src/LLVM/General/Internal/RawOStream.hs b/src/LLVM/General/Internal/RawOStream.hs --- a/src/LLVM/General/Internal/RawOStream.hs +++ b/src/LLVM/General/Internal/RawOStream.hs @@ -22,13 +22,13 @@ -> Bool -> (Ptr FFI.RawOStream -> ExceptT String IO ()) -> m () -withFileRawOStream path excl binary c = do +withFileRawOStream path excl text c = do path <- encodeM path excl <- encodeM excl - binary <- encodeM binary + text <- encodeM text msgPtr <- alloca errorRef <- liftIO $ newIORef undefined - succeeded <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl binary msgPtr $ \os -> do + succeeded <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl text msgPtr $ \os -> do r <- runExceptableT (ExceptableT $ c os) writeIORef errorRef r) unless succeeded $ do diff --git a/src/LLVM/General/Internal/TailCallKind.hs b/src/LLVM/General/Internal/TailCallKind.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/TailCallKind.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses + #-} +module LLVM.General.Internal.TailCallKind where + +import LLVM.General.Prelude + +import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI + +import LLVM.General.Internal.Coding +import qualified LLVM.General.AST as A + +genCodingInstance [t| Maybe A.TailCallKind |] ''FFI.TailCallKind [ + (FFI.tailCallKindNone, Nothing), + (FFI.tailCallKindTail, Just A.Tail), + (FFI.tailCallKindMustTail, Just A.MustTail) + ] diff --git a/src/LLVM/General/Internal/Target.hs b/src/LLVM/General/Internal/Target.hs --- a/src/LLVM/General/Internal/Target.hs +++ b/src/LLVM/General/Internal/Target.hs @@ -8,16 +8,15 @@ import LLVM.General.Prelude +import Control.Monad.Trans.Except (runExcept) import Control.Monad.Exceptable import Control.Exception import Control.Monad.AnyCont import Foreign.Ptr import Data.List (intercalate) -import Data.Map (Map) -import qualified Data.Map as Map - -import Text.ParserCombinators.Parsec hiding (many) +import Data.Set (Set) +import qualified Data.Set as Set import LLVM.General.Internal.Coding import LLVM.General.Internal.String () @@ -76,21 +75,12 @@ newtype CPUFeature = CPUFeature String deriving (Eq, Ord, Read, Show) -instance EncodeM e String es => EncodeM e (Map CPUFeature Bool) es where - encodeM = encodeM . intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") ++ f) . Map.toList +instance EncodeM e String es => EncodeM e (Set CPUFeature) es where + encodeM = encodeM . intercalate " " . map (\(CPUFeature f) -> f) . Set.toList -instance (Monad d, DecodeM d String es) => DecodeM d (Map CPUFeature Bool) es where - decodeM es = do - s <- decodeM es - let flag = do - en <- choice [char '-' >> return False, char '+' >> return True] - s <- many1 (noneOf ",") - return (CPUFeature s, en) - features = liftM Map.fromList (flag `sepBy` (char ',')) - case parse (do f <- features; eof; return f) "CPU Feature string" (s :: String) of - Right features -> return features - Left _ -> fail "failure to parse CPUFeature string" - +instance (Monad d, DecodeM d String es) => DecodeM d (Set CPUFeature) es where + decodeM = liftM (Set.fromList . map CPUFeature . words) . decodeM + -- | Find a 'Target' given an architecture and/or a \"triple\". -- | -- | Be sure to run either 'initializeAllTargets' or 'initializeNativeTarget' before expecting this to succeed, depending on what target(s) you want to use. @@ -133,8 +123,10 @@ (FFI.targetOptionFlagDisableTailCalls, TO.disableTailCalls), (FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection), (FFI.targetOptionFlagPositionIndependentExecutable, TO.positionIndependentExecutable), - (FFI.targetOptionFlagEnableSegmentedStacks, TO.enableSegmentedStacks), - (FFI.targetOptionFlagUseInitArray, TO.useInitArray) + (FFI.targetOptionFlagUseInitArray, TO.useInitArray), + (FFI.targetOptionFlagDisableIntegratedAS, TO.disableIntegratedAssembler), + (FFI.targetOptionFlagCompressDebugSections, TO.compressDebugSections), + (FFI.targetOptionFlagTrapUnreachable, TO.trapUnreachable) ] FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts) flip runAnyContT return $ do @@ -177,10 +169,14 @@ <- gof FFI.targetOptionFlagEnableFastISel positionIndependentExecutable <- gof FFI.targetOptionFlagPositionIndependentExecutable - enableSegmentedStacks - <- gof FFI.targetOptionFlagEnableSegmentedStacks useInitArray <- gof FFI.targetOptionFlagUseInitArray + disableIntegratedAssembler + <- gof FFI.targetOptionFlagDisableIntegratedAS + compressDebugSections + <- gof FFI.targetOptionFlagCompressDebugSections + trapUnreachable + <- gof FFI.targetOptionFlagTrapUnreachable stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts trapFunctionName <- decodeM =<< FFI.getTrapFuncName tOpts floatABIType <- decodeM =<< FFI.getFloatABIType tOpts @@ -195,7 +191,7 @@ Target -> String -- ^ triple -> String -- ^ cpu - -> Map CPUFeature Bool -- ^ features + -> Set CPUFeature -- ^ features -> TargetOptions -> Reloc.Model -> CodeModel.Model @@ -256,26 +252,22 @@ -- | the LLVM name for the host CPU getHostCPUName :: IO String -getHostCPUName = decodeM =<< FFI.getHostCPUName +getHostCPUName = decodeM FFI.getHostCPUName -- | a space-separated list of LLVM feature names supported by the host CPU -getHostCPUFeatures :: IO (Map CPUFeature Bool) +getHostCPUFeatures :: IO (Set CPUFeature) getHostCPUFeatures = decodeM =<< FFI.getHostCPUFeatures -- | 'DataLayout' to use for the given 'TargetMachine' getTargetMachineDataLayout :: TargetMachine -> IO DataLayout getTargetMachineDataLayout (TargetMachine m) = do - dl <- decodeM =<< FFI.getTargetMachineDataLayout m - maybe (fail "parseDataLayout failed") return $ parseDataLayout dl + dlString <- decodeM =<< FFI.getTargetMachineDataLayout m + let Right (Just dl) = runExcept . parseDataLayout BigEndian $ dlString + return dl -- | Initialize all targets so they can be found by 'lookupTarget' initializeAllTargets :: IO () initializeAllTargets = FFI.initializeAllTargets - -{-# DEPRECATED withDefaultTargetMachine "use withHostTargetMachine or withTargetMachine" #-} --- | Bracket creation and destruction of a 'TargetMachine' configured for the host. -withDefaultTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a -withDefaultTargetMachine = withHostTargetMachine -- | Bracket creation and destruction of a 'TargetMachine' configured for the host withHostTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a diff --git a/src/LLVM/General/Internal/Threading.hs b/src/LLVM/General/Internal/Threading.hs --- a/src/LLVM/General/Internal/Threading.hs +++ b/src/LLVM/General/Internal/Threading.hs @@ -1,33 +1,12 @@ module LLVM.General.Internal.Threading ( - setMultithreaded, isMultithreaded ) where import LLVM.General.Prelude -import Control.Concurrent.MVar -import System.IO.Unsafe - import qualified LLVM.General.Internal.FFI.Threading as FFI import LLVM.General.Internal.Coding - -lock :: MVar () -{-# NOINLINE lock #-} -lock = unsafePerformIO $ newMVar () - --- | Set the multithreading mode of LLVM. If it is disabled (as by default) locks are not enforced. -setMultithreaded :: Bool -> IO () -setMultithreaded s = do - takeMVar lock - multi <- isMultithreaded - case (s,multi) of - (True,False) -> do - success <- decodeM =<< FFI.startMultithreaded - when (not success) $ error "setMultithreaded: LLVM not built with threading support" - (False,True) -> FFI.stopMultithreaded - _ -> return () - putMVar lock () -- | Check if multithreading is enabled in LLVM isMultithreaded :: IO Bool diff --git a/src/LLVM/General/Target.hs b/src/LLVM/General/Target.hs --- a/src/LLVM/General/Target.hs +++ b/src/LLVM/General/Target.hs @@ -7,7 +7,7 @@ Target, TargetMachine, TargetLowering, CPUFeature(..), withTargetOptions, peekTargetOptions, pokeTargetOptions, - withTargetMachine, withHostTargetMachine, withDefaultTargetMachine, + withTargetMachine, withHostTargetMachine, getTargetLowering, getDefaultTargetTriple, getProcessTargetTriple, getHostCPUName, getHostCPUFeatures, getTargetMachineDataLayout, initializeNativeTarget, initializeAllTargets, diff --git a/src/LLVM/General/Target/Options.hs b/src/LLVM/General/Target/Options.hs --- a/src/LLVM/General/Target/Options.hs +++ b/src/LLVM/General/Target/Options.hs @@ -35,8 +35,10 @@ disableTailCalls :: Bool, enableFastInstructionSelection :: Bool, positionIndependentExecutable :: Bool, - enableSegmentedStacks :: Bool, useInitArray :: Bool, + disableIntegratedAssembler :: Bool, + compressDebugSections :: Bool, + trapUnreachable :: Bool, stackAlignmentOverride :: Word32, trapFunctionName :: String, floatABIType :: FloatABI, diff --git a/src/LLVM/General/Threading.hs b/src/LLVM/General/Threading.hs --- a/src/LLVM/General/Threading.hs +++ b/src/LLVM/General/Threading.hs @@ -4,4 +4,21 @@ isMultithreaded ) where +import LLVM.General.Prelude + import LLVM.General.Internal.Threading + +{-# DEPRECATED setMultithreaded "LLVM no longer features runtime control of multithreading support" #-} +-- | This function used set the multithreading mode of LLVM, but that feature no longer exists. Threading is +-- controlled only at runtime with the configure flag --enable-threads (default is YES). This function will +-- now check that the the compiled-in multithreading support (returned by 'isMultithreaded') is +-- sufficient to support the requested access, and fail if not, so as to prevent uncontrolled use of a +-- version of LLVM compiled to be capable only of singled threaded use by haskell code requesting +-- multithreading support. +setMultithreaded :: Bool -> IO () +setMultithreaded desired = do + actual <- isMultithreaded + when (desired && not actual) $ + fail $ "Multithreading support requested but not available. " ++ + "Please use an LLVM built with threading enabled" + return () diff --git a/src/LLVM/General/Transforms.hs b/src/LLVM/General/Transforms.hs --- a/src/LLVM/General/Transforms.hs +++ b/src/LLVM/General/Transforms.hs @@ -37,8 +37,7 @@ | LoopUnroll { loopUnrollThreshold :: Maybe Word, count :: Maybe Word, allowPartial :: Maybe Bool } | LoopUnswitch { optimizeForSize :: Bool } | LowerAtomic - -- | can use a 'LLVM.General.Target.TargetMachine' - | LowerInvoke { useExpensiveExceptionHandlingSupport :: Bool } + | LowerInvoke | LowerSwitch | LowerExpectIntrinsic | MemcpyOptimization @@ -104,7 +103,8 @@ fastDependencyAnalysis :: Bool } | LoopVectorize { - noUnrolling :: Bool + noUnrolling :: Bool, + alwaysVectorize :: Bool } | SuperwordLevelParallelismVectorize @@ -117,25 +117,12 @@ noRedZone :: Bool, functionNamesInData :: Bool } - | AddressSanitizer { - checkInitOrder :: Bool, - checkUseAfterReturn :: Bool, - checkLifetime :: Bool, - blackListFile :: Maybe FilePath, - zeroBaseShadow :: Bool - } - | AddressSanitizerModule { - checkInitOrder :: Bool, - blackListFile :: Maybe FilePath, - zeroBaseShadow :: Bool - } + | AddressSanitizer + | AddressSanitizerModule | MemorySanitizer { - trackOrigins :: Bool, - blackListFile :: Maybe FilePath - } - | ThreadSanitizer { - blackListFile :: Maybe FilePath + trackOrigins :: Bool } + | ThreadSanitizer | BoundsChecking | DebugGeneratedIR { hideDebugIntrinsics :: Bool, @@ -148,7 +135,8 @@ -- | Defaults for the 'LoopVectorize' pass defaultLoopVectorize = LoopVectorize { - noUnrolling = False + noUnrolling = False, + alwaysVectorize = True } -- | Defaults for the 'BasicBlockVectorize' pass - copied from the C++ code to keep these defaults @@ -195,31 +183,18 @@ } -- | Defaults for 'AddressSanitizer'. -defaultAddressSanitizer = AddressSanitizer { - checkInitOrder = True, - checkUseAfterReturn = False, - checkLifetime = False, - blackListFile = Nothing, - zeroBaseShadow = False -} +defaultAddressSanitizer = AddressSanitizer -- | Defaults for 'AddressSanitizerModule'. -defaultAddressSanitizerModule = AddressSanitizerModule { - checkInitOrder = True, - blackListFile = Nothing, - zeroBaseShadow = False -} +defaultAddressSanitizerModule = AddressSanitizerModule -- | Defaults for 'MemorySanitizer'. defaultMemorySanitizer = MemorySanitizer { - trackOrigins = False, - blackListFile = Nothing + trackOrigins = False } -- | Defaults for 'ThreadSanitizer'. -defaultThreadSanitizer = ThreadSanitizer { - blackListFile = Nothing -} +defaultThreadSanitizer = ThreadSanitizer -- | Defaults for 'DebugGeneratedIR'. defaultDebugGeneratedIR = DebugGeneratedIR { diff --git a/test/LLVM/General/Test/CallingConvention.hs b/test/LLVM/General/Test/CallingConvention.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/General/Test/CallingConvention.hs @@ -0,0 +1,57 @@ +module LLVM.General.Test.CallingConvention where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + +import LLVM.General.Test.Support + +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.General.Context +import LLVM.General.Module +import LLVM.General.AST +import LLVM.General.AST.Type as T +import qualified LLVM.General.AST.CallingConvention as CC +import qualified LLVM.General.AST.Global as G + +tests = testGroup "CallingConvention" [ + testCase name $ strCheck (defaultModule { + moduleDefinitions = [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.callingConvention = cc + } + ] + }) ("; ModuleID = ''\n\ + \\n\ + \declare" ++ (if name == "" then "" else (" " ++ name)) ++ " i32 @foo()\n") + | (name, cc) <- [ + ("", CC.C), + ("fastcc", CC.Fast), + ("coldcc", CC.Cold), + ("cc10", CC.GHC), + ("cc11", CC.HiPE), + ("webkit_jscc", CC.WebKit_JS), + ("anyregcc", CC.AnyReg), + ("preserve_mostcc", CC.PreserveMost), + ("preserve_allcc", CC.PreserveAll), + ("x86_stdcallcc", CC.X86_StdCall), + ("x86_fastcallcc", CC.X86_FastCall), + ("arm_apcscc", CC.ARM_APCS), + ("arm_aapcscc", CC.ARM_AAPCS), + ("arm_aapcs_vfpcc", CC.ARM_AAPCS_VFP), + ("msp430_intrcc", CC.MSP430_INTR), + ("x86_thiscallcc", CC.X86_ThisCall), + ("ptx_kernel", CC.PTX_Kernel), + ("ptx_device", CC.PTX_Device), + ("spir_func", CC.SPIR_FUNC), + ("spir_kernel", CC.SPIR_KERNEL), + ("intel_ocl_bicc", CC.Intel_OCL_BI), + ("x86_64_sysvcc", CC.X86_64_SysV), + ("x86_64_win64cc", CC.X86_64_Win64) + ] + ] diff --git a/test/LLVM/General/Test/DataLayout.hs b/test/LLVM/General/Test/DataLayout.hs --- a/test/LLVM/General/Test/DataLayout.hs +++ b/test/LLVM/General/Test/DataLayout.hs @@ -19,6 +19,7 @@ m s = "; ModuleID = ''\n" ++ s t s = "target datalayout = \"" ++ s ++ "\"\n" +ddl = defaultDataLayout BigEndian tests = testGroup "DataLayout" [ testCase name $ strCheckC (Module "" mdl Nothing []) (m sdl) (m sdlc) @@ -27,12 +28,12 @@ ] ++ [ (name, Just mdl, t sdl, t (fromMaybe sdl msdlc)) | (name, mdl, sdl, msdlc) <- [ - ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e", Nothing), - ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E", Nothing), - ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32", Nothing), + ("little-endian", defaultDataLayout LittleEndian, "e", Nothing), + ("big-endian", defaultDataLayout BigEndian, "E", Nothing), + ("native", ddl { nativeSizes = Just (Set.fromList [8,32]) }, "E-n8:32", Nothing), ( "no pref", - defaultDataLayout { + ddl { pointerLayouts = Map.singleton (AddrSpace 0) @@ -44,50 +45,42 @@ } ) }, - "p:8:64", + "E-p:8:64", Nothing ), ( "no pref", - defaultDataLayout { + ddl { pointerLayouts = - Map.singleton - (AddrSpace 1) - ( - 8, - AlignmentInfo { - abiAlignment = 32, - preferredAlignment = Just 64 - } - ) + Map.insert (AddrSpace 1) (8, AlignmentInfo 32 (Just 64)) (pointerLayouts ddl) }, - "p1:8:32:64", + "E-p1:8:32:64", Nothing ), ( "big", - DataLayout { - endianness = Just LittleEndian, + ddl { + endianness = LittleEndian, + mangling = Just ELFMangling, stackAlignment = Just 128, pointerLayouts = Map.fromList [ - (AddrSpace 0, (64, AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64})) + (AddrSpace 0, (8, AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 16})) ], typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), - ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), - ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 16}), - ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), - ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), - ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), - ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), - ((AggregateAlign, 0), AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 64}), - ((StackAlign, 0), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}) - ], + ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}), + ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}), + ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 256}), + ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}), + ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}), + ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}), + ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256}), + ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}), + ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}), + ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256}) + ] `Map.union` typeLayouts ddl, + aggregateLayout = AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 256}, nativeSizes = Just (Set.fromList [8,16,32,64]) }, - "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128", - Just "e-S128-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-v64:64:64-v128:128:128-f32:32:32-f64:64:64-f80:128:128-a0:0:64-s0:64:64-n8:16:32:64" + "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-f32:32:256-f64:64:256-v64:64:256-v128:128:256-a:0:256-f80:128:256-n8:16:32:64-S128", + Just "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-f32:32:256-f64:64:256-v64:64:256-v128:128:256-a:0:256-f80:128:256-n8:16:32:64-S128" ) ] ] diff --git a/test/LLVM/General/Test/InlineAssembly.hs b/test/LLVM/General/Test/InlineAssembly.hs --- a/test/LLVM/General/Test/InlineAssembly.hs +++ b/test/LLVM/General/Test/InlineAssembly.hs @@ -29,7 +29,7 @@ G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call { - isTailCall = False, + tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], function = Left $ InlineAssembly { diff --git a/test/LLVM/General/Test/Instructions.hs b/test/LLVM/General/Test/Instructions.hs --- a/test/LLVM/General/Test/Instructions.hs +++ b/test/LLVM/General/Test/Instructions.hs @@ -282,7 +282,7 @@ Load { volatile = False, address = a 2, - maybeAtomicity = Just (Atomicity { crossThread = True, memoryOrdering = Acquire }), + maybeAtomicity = Just (CrossThread, Acquire), alignment = 1, metadata = [] }, @@ -291,7 +291,7 @@ Load { volatile = False, address = a 2, - maybeAtomicity = Just (Atomicity { crossThread = False, memoryOrdering = Monotonic }), + maybeAtomicity = Just (SingleThread, Monotonic), alignment = 1, metadata = [] }, @@ -318,17 +318,18 @@ address = a 2, expected = a 0, replacement = a 0, - atomicity = Atomicity { crossThread = True, memoryOrdering = Monotonic }, + atomicity = (CrossThread, Monotonic), + failureMemoryOrdering = Monotonic, metadata = [] }, - "cmpxchg i32* %2, i32 %0, i32 %0 monotonic"), + "cmpxchg i32* %2, i32 %0, i32 %0 monotonic monotonic"), ("atomicrmw", AtomicRMW { volatile = False, rmwOperation = RMWOp.UMax, address = a 2, value = a 0, - atomicity = Atomicity { crossThread = True, memoryOrdering = Release }, + atomicity = (CrossThread, Release), metadata = [] }, "atomicrmw umax i32* %2, i32 %0 release"), @@ -553,13 +554,13 @@ "store i32 %0, i32* %2"), ("fence", Do $ Fence { - atomicity = Atomicity { crossThread = True, memoryOrdering = Acquire }, + atomicity = (CrossThread, Acquire), metadata = [] }, "fence acquire"), ("call", Do $ Call { - isTailCall = False, + tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0))), diff --git a/test/LLVM/General/Test/Instrumentation.hs b/test/LLVM/General/Test/Instrumentation.hs --- a/test/LLVM/General/Test/Instrumentation.hs +++ b/test/LLVM/General/Test/Instrumentation.hs @@ -113,7 +113,7 @@ G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call { - isTailCall = False, + tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], function = Right (ConstantOperand (C.GlobalReference (FunctionType i32 [i32, ptr (ptr i8)] False) (Name "foo"))), @@ -142,8 +142,10 @@ (names ast') `List.intersect` (names ast) @?= names ast | (n,p) <- [ ("GCOVProfiler", defaultGCOVProfiler), +{- ("AddressSanitizer", defaultAddressSanitizer), ("AddressSanitizerModule", defaultAddressSanitizerModule), +-} ("MemorySanitizer", defaultMemorySanitizer), ("ThreadSanitizer", defaultThreadSanitizer), ("BoundsChecking", BoundsChecking), diff --git a/test/LLVM/General/Test/Module.hs b/test/LLVM/General/Test/Module.hs --- a/test/LLVM/General/Test/Module.hs +++ b/test/LLVM/General/Test/Module.hs @@ -10,7 +10,7 @@ import Data.Bits import Data.Word -import qualified Data.Map as Map +import qualified Data.Set as Set import LLVM.General.Context import LLVM.General.Module @@ -18,16 +18,20 @@ import LLVM.General.Diagnostic import LLVM.General.Target import LLVM.General.AST -import LLVM.General.AST.Type as A.T +import LLVM.General.AST.Type as T import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V +import qualified LLVM.General.AST.DLL as DLL import qualified LLVM.General.AST.CallingConvention as CC -import qualified LLVM.General.AST.Attribute as A +import qualified LLVM.General.AST.FunctionAttribute as FA +import qualified LLVM.General.AST.ParameterAttribute as PA +import qualified LLVM.General.AST.ThreadLocalStorage as TLS import qualified LLVM.General.AST.Global as G import qualified LLVM.General.AST.Constant as C +import qualified LLVM.General.AST.COMDAT as COMDAT import qualified LLVM.General.Relocation as R import qualified LLVM.General.CodeModel as CM @@ -38,18 +42,22 @@ \%0 = type { i32, %1*, %0* }\n\ \%1 = type opaque\n\ \\n\ + \$bob = comdat largest\n\ + \\n\ \@0 = global i32 1\n\ - \@1 = external protected addrspace(3) global i32, section \"foo\"\n\ + \@1 = external protected addrspace(3) global i32, section \"foo\", comdat $bob\n\ \@2 = unnamed_addr global i8 2\n\ - \@3 = external global %0\n\ + \@3 = external dllimport global %0\n\ \@4 = external global [4294967296 x i32]\n\ \@.argyle = thread_local global i32 0\n\ + \@5 = thread_local(localdynamic) global i32 1\n\ \\n\ \@three = alias private i32 addrspace(3)* @1\n\ - \@two = alias i32 addrspace(3)* @three\n\ + \@two = unnamed_addr alias i32 addrspace(3)* @three\n\ + \@one = thread_local(initialexec) alias i32* @5\n\ \\n\ - \define i32 @bar() {\n\ - \ %1 = call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\ + \define i32 @bar() prefix i32 1 {\n\ + \ %1 = musttail call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\ \ ret i32 %1\n\ \}\n\ \\n\ @@ -71,7 +79,7 @@ \ ret i32 %r\n\ \}\n\ \\n\ - \attributes #0 = { nounwind readnone uwtable }\n" + \attributes #0 = { nounwind readnone uwtable \"eep\" }\n" handAST = Module "" Nothing Nothing [ TypeDefinition (UnName 0) ( @@ -91,7 +99,8 @@ G.visibility = V.Protected, G.type' = i32, G.addrSpace = AddrSpace 3, - G.section = Just "foo" + G.section = Just "foo", + G.comdat = Just "bob" }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 2, @@ -101,6 +110,7 @@ }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 3, + G.dllStorageClass = Just DLL.Import, G.type' = NamedTypeReference (UnName 0) }, GlobalDefinition $ globalVariableDefaults { @@ -111,34 +121,48 @@ G.name = Name ".argyle", G.type' = i32, G.initializer = Just (C.Int 32 0), - G.isThreadLocal = True + G.threadLocalMode = Just TLS.GeneralDynamic }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 5, + G.type' = i32, + G.threadLocalMode = Just TLS.LocalDynamic, + G.initializer = Just (C.Int 32 1) + }, GlobalDefinition $ globalAliasDefaults { - G.name = Name "three", - G.linkage = L.Private, - G.type' = PointerType i32 (AddrSpace 3), - G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1) + G.name = Name "three", + G.linkage = L.Private, + G.type' = PointerType i32 (AddrSpace 3), + G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1) }, GlobalDefinition $ globalAliasDefaults { G.name = Name "two", + G.hasUnnamedAddr = True, G.type' = PointerType i32 (AddrSpace 3), G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (Name "three") }, + GlobalDefinition $ globalAliasDefaults { + G.name = Name "one", + G.type' = ptr i32, + G.aliasee = C.GlobalReference (ptr i32) (UnName 5), + G.threadLocalMode = Just TLS.InitialExec + }, GlobalDefinition $ functionDefaults { G.returnType = i32, G.name = Name "bar", + G.prefix = Just (C.Int 32 1), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call { - isTailCall = False, + tailCallKind = Just MustTail, callingConvention = CC.C, - returnAttributes = [A.ZeroExt], + returnAttributes = [PA.ZeroExt], function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))), arguments = [ - (ConstantOperand (C.Int 32 1), [A.InReg, A.Alignment 16]), - (ConstantOperand (C.Int 8 4), [A.SignExt]) + (ConstantOperand (C.Int 32 1), [PA.InReg, PA.Alignment 16]), + (ConstantOperand (C.Int 8 4), [PA.SignExt]) ], - functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], + functionAttributes = [Left (FA.GroupID 0)], metadata = [] } ] ( @@ -147,14 +171,14 @@ ] }, GlobalDefinition $ functionDefaults { - G.returnAttributes = [A.ZeroExt], + G.returnAttributes = [PA.ZeroExt], G.returnType = i32, G.name = Name "foo", G.parameters = ([ - Parameter i32 (Name "x") [A.InReg, A.Alignment 16], - Parameter i8 (Name "y") [A.SignExt] + Parameter i32 (Name "x") [PA.InReg, PA.Alignment 16], + Parameter i8 (Name "y") [PA.SignExt] ], False), - G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], + G.functionAttributes = [Left (FA.GroupID 0)], G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { @@ -206,8 +230,10 @@ Do $ Ret (Just (LocalReference i32 (Name "r"))) [] ) ] - } - ] + }, + FunctionAttributes (FA.GroupID 0) [FA.NoUnwind, FA.ReadNone, FA.UWTable, FA.StringAttribute "eep" ""], + COMDAT "bob" COMDAT.Largest + ] tests = testGroup "Module" [ testGroup "withModuleFromString" [ @@ -233,17 +259,17 @@ a <- withModuleFromLLVMAssembly' context s $ \m -> do (t, _) <- failInIO $ lookupTarget Nothing "x86_64-unknown-linux" withTargetOptions $ \to -> do - withTargetMachine t "" "" Map.empty to R.Default CM.Default CGO.Default $ \tm -> do + withTargetMachine t "x86_64-unknown-linux" "" Set.empty to R.Default CM.Default CGO.Default $ \tm -> do failInIO $ moduleTargetAssembly tm m - a @?= "\t.file\t\"\"\n\ - \\t.text\n\ + a @?= "\t.text\n\ + \\t.file\t\"\"\n\ \\t.globl\tmain\n\ \\t.align\t16, 0x90\n\ \\t.type\tmain,@function\n\ \main:\n\ \\t.cfi_startproc\n\ \\txorl\t%eax, %eax\n\ - \\tret\n\ + \\tretq\n\ \.Ltmp0:\n\ \\t.size\tmain, .Ltmp0-main\n\ \\t.cfi_endproc\n\ @@ -293,7 +319,7 @@ \}\n" ast = Module "" Nothing Nothing [ GlobalDefinition $ functionDefaults { - G.returnType = A.T.void, + G.returnType = T.void, G.name = Name "trouble", G.basicBlocks = [ BasicBlock (Name "entry") [ diff --git a/test/LLVM/General/Test/Optimization.hs b/test/LLVM/General/Test/Optimization.hs --- a/test/LLVM/General/Test/Optimization.hs +++ b/test/LLVM/General/Test/Optimization.hs @@ -13,7 +13,7 @@ import LLVM.General.Module import LLVM.General.Context import LLVM.General.PassManager -import LLVM.General.Transforms +import qualified LLVM.General.Transforms as T import LLVM.General.Target import LLVM.General.AST as A @@ -39,7 +39,7 @@ G.returnType = i32, G.name = Name "foo", G.parameters = ([Parameter i32 (Name "x") []], False), - G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], + G.functionAttributes = [Left (A.GroupID 0)], G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { @@ -91,7 +91,8 @@ Do $ Ret (Just (LocalReference i32 (Name "r"))) [] ) ] - } + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] ] isVectory :: A.Module -> Assertion @@ -116,26 +117,27 @@ G.returnType = i32, G.name = Name "foo", G.parameters = ([Parameter i32 (Name "x") []], False), - G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], + G.functionAttributes = [Left (A.GroupID 0)], G.basicBlocks = [ BasicBlock (Name "here") [ ] ( Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] ) ] - } + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] ], testGroup "individual" [ testCase "ConstantPropagation" $ do - mOut <- optimize defaultPassSetSpec { transforms = [ConstantPropagation] } handAST + mOut <- optimize defaultPassSetSpec { transforms = [T.ConstantPropagation] } handAST mOut @?= Module "" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.returnType = i32, G.name = Name "foo", G.parameters = ([Parameter i32 (Name "x") []], False), - G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], + G.functionAttributes = [Left (A.GroupID 0)], G.basicBlocks = [ BasicBlock (UnName 0) [] (Do $ Br (Name "here") []), BasicBlock (Name "here") [] ( @@ -167,7 +169,8 @@ Do $ Ret (Just (LocalReference i32 (Name "r"))) [] ) ] - } + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] ], testCase "BasicBlockVectorization" $ do @@ -196,9 +199,9 @@ ] mOut <- optimize (defaultPassSetSpec { transforms = [ - defaultVectorizeBasicBlocks { requiredChainDepth = 3 }, - InstructionCombining, - GlobalValueNumbering False + T.defaultVectorizeBasicBlocks { T.requiredChainDepth = 3 }, + T.InstructionCombining, + T.GlobalValueNumbering False ] }) mIn isVectory mOut, @@ -207,51 +210,57 @@ mIn = Module { moduleName = "", - moduleDataLayout = Just $ defaultDataLayout { + moduleDataLayout = Just $ (defaultDataLayout BigEndian) { typeLayouts = Map.singleton (VectorAlign, 128) (AlignmentInfo 128 Nothing) }, moduleTargetTriple = Just "x86_64", moduleDefinitions = [ + GlobalDefinition $ globalVariableDefaults { + G.name = Name "a", + G.linkage = L.Common, + G.type' = A.T.ArrayType 2048 i32, + G.initializer = Just (C.Null (A.T.ArrayType 2048 i32)) + }, GlobalDefinition $ functionDefaults { G.returnType = A.T.void, - G.name = Name "foo", - G.parameters = ([Parameter (ptr i32) (Name "x") []], False), + G.name = Name "inc", + G.functionAttributes = [Left (A.GroupID 0)], + G.parameters = ([Parameter i32 (Name "n") []], False), G.basicBlocks = [ - BasicBlock (UnName 0) [] (Do $ Br (UnName 1) []), - BasicBlock (UnName 1) [ - Name "i.0" := Phi i32 [ - (ConstantOperand (C.Int 32 0), UnName 0), - (LocalReference i32 (UnName 8), UnName 7) - ] [], - Name ".0" := Phi (ptr i32) [ - (LocalReference (ptr i32) (Name "x"), UnName 0), - (LocalReference (ptr i32) (UnName 4), UnName 7) + BasicBlock (UnName 0) [ + UnName 1 := ICmp IPred.SGT (LocalReference i32 (Name "n")) (ConstantOperand (C.Int 32 0)) [] + ] (Do $ CondBr (LocalReference i1 (UnName 1)) (Name ".lr.ph") (Name "._crit_edge") []), + BasicBlock (Name ".lr.ph") [ + Name "indvars.iv" := Phi i64 [ + (ConstantOperand (C.Int 64 0), UnName 0), + (LocalReference i64 (Name "indvars.iv.next"), Name ".lr.ph") ] [], - UnName 2 := ICmp IPred.SLT (LocalReference i32 (Name "i.0")) (ConstantOperand (C.Int 32 2048)) [] - ] (Do $ CondBr (LocalReference i1 (UnName 2)) (UnName 3) (UnName 9) []), - BasicBlock (UnName 3) [ - UnName 4 := GetElementPtr True (LocalReference (ptr i32) (Name ".0")) [ - ConstantOperand (C.Int 32 1) + UnName 2 := GetElementPtr True (ConstantOperand (C.GlobalReference (A.T.ArrayType 2048 i32) (Name "a"))) [ + ConstantOperand (C.Int 64 0), + (LocalReference i64 (Name "indvars.iv")) ] [], - UnName 5 := Load False (LocalReference (ptr i32) (Name ".0")) Nothing 4 [], - UnName 6 := Add True False (LocalReference i32 (UnName 5)) (ConstantOperand (C.Int 32 1)) [], - Do $ Store False (LocalReference (ptr i32) (Name ".0")) (LocalReference i32 (UnName 6)) Nothing 4 [] - ] (Do $ Br (UnName 7) []), - BasicBlock (UnName 7) [ - UnName 8 := Add True False (LocalReference i32 (Name "i.0")) (ConstantOperand (C.Int 32 1)) [] - ] (Do $ Br (UnName 1) []), - BasicBlock (UnName 9) [] (Do $ Ret Nothing []) + UnName 3 := Load False (LocalReference (ptr i32) (UnName 2)) Nothing 4 [], + UnName 4 := Trunc (LocalReference i64 (Name "indvars.iv")) i32 [], + UnName 5 := Add True False (LocalReference i32 (UnName 3)) (LocalReference i32 (UnName 4)) [], + Do $ Store False (LocalReference (ptr i32) (UnName 2)) (LocalReference i32 (UnName 5)) Nothing 4 [], + Name "indvars.iv.next" := Add False False (LocalReference i64 (Name "indvars.iv")) (ConstantOperand (C.Int 64 1)) [], + Name "lftr.wideiv" := Trunc (LocalReference i64 (Name "indvars.iv.next")) i32 [], + Name "exitcond" := ICmp IPred.EQ (LocalReference i32 (Name "lftr.wideiv")) (LocalReference i32 (Name "n")) [] + ] (Do $ CondBr (LocalReference i1 (Name "exitcond")) (Name "._crit_edge") (Name ".lr.ph") []), + BasicBlock (Name "._crit_edge") [ + ] (Do $ Ret Nothing []) ] - } + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable, A.StackProtect] ] } mOut <- do let triple = "x86_64" (target, _) <- failInIO $ lookupTarget Nothing triple withTargetOptions $ \targetOptions -> do - withTargetMachine target triple "" Map.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do + withTargetMachine target triple "" Set.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do optimize (defaultPassSetSpec { - transforms = [ defaultLoopVectorize ], + transforms = [ T.defaultLoopVectorize ], dataLayout = moduleDataLayout mIn, targetMachine = Just tm }) mIn @@ -262,45 +271,36 @@ -- The pass seems to be quite deeply dependent on weakly documented presumptions about -- how unwinding works (as is the invoke instruction) withContext $ \context -> do - let triple = "x86_64-apple-darwin" - (target, _) <- failInIO $ lookupTarget Nothing triple - withTargetOptions $ \targetOptions -> do - withTargetMachine target triple "" Map.empty targetOptions - R.Default CM.Default CGO.Default $ \tm -> do - withPassManager (defaultPassSetSpec { transforms = [LowerInvoke False], targetMachine = Just tm}) $ \passManager -> do - let astIn = - Module "" Nothing Nothing [ - GlobalDefinition $ functionDefaults { - G.returnType = i32, - G.name = Name "foo", - G.parameters = ([Parameter i32 (Name "x") []], False), - G.basicBlocks = [ - BasicBlock (Name "here") [ - ] ( - Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] - ) - ] - } - ] - astOut <- withModuleFromAST' context astIn $ \mIn -> do - runPassManager passManager mIn - moduleAST mIn - astOut @?= Module "" Nothing Nothing [ - GlobalDefinition $ functionDefaults { - G.returnType = i32, - G.name = Name "foo", - G.parameters = ([Parameter i32 (Name "x") []], False), - G.basicBlocks = [ - BasicBlock (Name "here") [ - ] ( - Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] - ) - ] - }, - GlobalDefinition $ functionDefaults { - G.returnType = A.T.void, - G.name = Name "abort" - } + withPassManager (defaultPassSetSpec { transforms = [T.LowerInvoke] }) $ \passManager -> do + let astIn = + Module "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] + ) ] + } + ] + astOut <- withModuleFromAST' context astIn $ \mIn -> do + runPassManager passManager mIn + moduleAST mIn + astOut @?= Module "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] + ) + ] + } + ] ] ] diff --git a/test/LLVM/General/Test/Target.hs b/test/LLVM/General/Test/Target.hs --- a/test/LLVM/General/Test/Target.hs +++ b/test/LLVM/General/Test/Target.hs @@ -39,8 +39,10 @@ disableTailCalls <- arbitrary enableFastInstructionSelection <- arbitrary positionIndependentExecutable <- arbitrary - enableSegmentedStacks <- arbitrary useInitArray <- arbitrary + disableIntegratedAssembler <- arbitrary + compressDebugSections <- arbitrary + trapUnreachable <- arbitrary stackAlignmentOverride <- arbitrary trapFunctionName <- elements [ "foo", "bar", "baz" ] floatABIType <- arbitrary @@ -70,8 +72,5 @@ withTargetLibraryInfo triple $ \tli -> do lf <- getLibraryFunction tli "printf" lf @?= Just LF__printf - ], - testCase "Host" $ do - features <- getHostCPUFeatures - return () + ] ] diff --git a/test/LLVM/General/Test/Tests.hs b/test/LLVM/General/Test/Tests.hs --- a/test/LLVM/General/Test/Tests.hs +++ b/test/LLVM/General/Test/Tests.hs @@ -2,6 +2,7 @@ import Test.Framework +import qualified LLVM.General.Test.CallingConvention as CallingConvention import qualified LLVM.General.Test.Constants as Constants import qualified LLVM.General.Test.DataLayout as DataLayout import qualified LLVM.General.Test.ExecutionEngine as ExecutionEngine @@ -17,6 +18,7 @@ import qualified LLVM.General.Test.Instrumentation as Instrumentation tests = testGroup "llvm-general" [ + CallingConvention.tests, Constants.tests, DataLayout.tests, ExecutionEngine.tests,