llvm-base-types (empty) → 0.3.0
raw patch · 14 files changed
+3890/−0 lines, 14 filesdep +GenericPrettydep +basedep +containerssetup-changed
Dependencies added: GenericPretty, base, containers, deepseq, dwarf, failure, graphviz, hashable, pretty, regex-tdfa, text, transformers, unordered-containers, vector
Files
- LICENSE +30/−0
- README.md +19/−0
- Setup.hs +2/−0
- llvm-base-types.cabal +47/−0
- src/Data/LLVM/Internal/DataLayout.hs +137/−0
- src/Data/LLVM/Internal/ForceModule.hs +325/−0
- src/Data/LLVM/Internal/Paths.hs +3/−0
- src/Data/LLVM/Internal/Printers.hs +904/−0
- src/Data/LLVM/Types.hs +133/−0
- src/Data/LLVM/Types/Attributes.chs +264/−0
- src/Data/LLVM/Types/Dwarf.hs +144/−0
- src/Data/LLVM/Types/Identifiers.hs +76/−0
- src/Data/LLVM/Types/Referential.hs +1556/−0
- src/c++/llvm-base-enums.h +250/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011, Tristan Ravitch++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tristan Ravitch nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,19 @@+This package defines types used in the llvm-analysis and+llvm-data-interop packages.++This is a separate package mostly because llvm-data-interop needed to+be split out due to C++ linkage issues. llvm-data-interop needs the+definitions in this packages but cannot depend on llvm-analysis (which+also needs these types).++Further, to avoid code duplication some of the C++ enumeration values+used in llvm-data-interop are actually included with this package.+The definitions in this package are used (via c2hs) to build Haskell+equivalents. The base types need these definitions, but the+llvm-data-interop package also needs to be able to find the header.+This is handled in Setup.hs in llvm-data-interop with cooperation from+this package (which exports the cabal-generated path to the installed+header).++Only llvm-data-interop and llvm-analysis should ever need to reference+this package since llvm-analysis re-exports all of the definitions.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ llvm-base-types.cabal view
@@ -0,0 +1,47 @@+-- Initial llvm-base-types.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: llvm-base-types+version: 0.3.0+synopsis: The base types for a mostly pure Haskell LLVM analysis library+-- description:+license: BSD3+license-file: LICENSE+author: Tristan Ravitch+maintainer: travitch@cs.wisc.edu+-- copyright:+category: Data+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.6.3+data-files: src/c++/llvm-base-enums.h+extra-source-files: src/c++/llvm-base-enums.h+ README.md++library+ default-language: Haskell2010+ build-depends: base == 4.*,+ hashable >= 1.1.2.0,+ transformers >= 0.3,+ graphviz >= 2999.12.0.3,+ GenericPretty > 1,+ dwarf, deepseq, vector, failure,+ text, regex-tdfa, pretty,+ unordered-containers, containers+ exposed-modules: Data.LLVM.Types,+ Data.LLVM.Internal.Paths+ other-modules: Paths_llvm_base_types,+ Data.LLVM.Internal.DataLayout,+ Data.LLVM.Internal.ForceModule,+ Data.LLVM.Internal.Printers,+ Data.LLVM.Types.Dwarf,+ Data.LLVM.Types.Identifiers,+ Data.LLVM.Types.Attributes,+ Data.LLVM.Types.Referential+ build-tools: c2hs+ ghc-options: -Wall -funbox-strict-fields+ ghc-prof-options: -auto-all+ hs-source-dirs: src+ include-dirs: src+ -- other-modules:+ -- build-depends:
+ src/Data/LLVM/Internal/DataLayout.hs view
@@ -0,0 +1,137 @@+module Data.LLVM.Internal.DataLayout (+ Endianness(..),+ AlignmentPref(..),+ DataLayout(..),+ defaultDataLayout,+ parseDataLayout+ ) where++import Data.Text ( Text )+import qualified Data.Text as T+import Data.List ( foldl' )++data Endianness = EndianBig+ | EndianLittle+ deriving (Eq, Ord, Show)++data AlignmentPref = AlignmentPref { alignmentPrefSize :: !Int+ , alignmentPrefABI :: !Int+ , alignmentPrefPref :: !Int+ }+ deriving (Eq, Ord, Show)++data DataLayout = DataLayout { targetEndianness :: !Endianness+ , targetStackAlignment :: Maybe Int+ , targetIntegerWidths :: [Int]+ , targetPointerPrefs :: AlignmentPref+ , targetIntegerPrefs :: [AlignmentPref]+ , targetVectorPrefs :: [AlignmentPref]+ , targetFloatPrefs :: [AlignmentPref]+ , targetAggregatePrefs :: [AlignmentPref]+ , targetStackObjectPrefs :: [AlignmentPref]+ }+ deriving (Eq, Ord, Show)++defaultDataLayout :: DataLayout+defaultDataLayout = DataLayout { targetEndianness = EndianBig+ , targetStackAlignment = Nothing+ , targetIntegerWidths = []+ , targetPointerPrefs = AlignmentPref 64 64 64+ , targetIntegerPrefs = [ AlignmentPref 1 8 8+ , AlignmentPref 8 8 8+ , AlignmentPref 16 16 16+ , AlignmentPref 32 32 32+ , AlignmentPref 64 32 64+ ]+ , targetVectorPrefs = [ AlignmentPref 64 64 64+ , AlignmentPref 128 128 128+ ]+ , targetFloatPrefs = [ AlignmentPref 32 32 32+ , AlignmentPref 64 64 64+ ]+ , targetAggregatePrefs = [ AlignmentPref 0 0 1 ]+ , targetStackObjectPrefs = [ AlignmentPref 0 64 64 ]+ }++parseDataLayout :: Text -> Either String DataLayout+parseDataLayout dl = foldr parseModifier (Right defaultDataLayout) modifiers+ where+ modifiers = T.split (=='-') dl++-- | Split a string on a separator+splitOn :: Char -> String -> [String]+splitOn _ [] = []+splitOn sep s = reverse (reverse leftover : parts)+ where+ (leftover, parts) = foldl' doSplit ([], []) s+ doSplit (cur, acc) c =+ case c == sep of+ True -> ([], reverse cur : acc)+ False -> (c : cur, acc)++parseAlignPref :: String -> Maybe AlignmentPref+parseAlignPref s =+ case splitOn ':' s of+ [ssz, sabi, spref] ->+ case (parseInt ssz, parseInt sabi, parseInt spref) of+ (Just sz, Just abi, Just pref) -> Just $! AlignmentPref sz abi pref+ _ -> Nothing+ _ -> Nothing++mergePreference :: AlignmentPref -> [AlignmentPref] -> [AlignmentPref]+mergePreference newP oldPs = newP : ps+ where+ ps = filter (\p -> alignmentPrefSize p /= alignmentPrefSize newP) oldPs++parseInt :: String -> Maybe Int+parseInt s =+ case reads s of+ [(i, "")] -> Just i+ _ -> Nothing++parseModifier :: Text -> Either String DataLayout -> Either String DataLayout+parseModifier _ acc@(Left _) = acc+parseModifier m (Right acc) =+ case T.unpack m of+ ['E'] -> Right acc { targetEndianness = EndianBig }+ ['e'] -> Right acc { targetEndianness = EndianLittle }+ 'p' : ':' : rest ->+ case splitOn ':' rest of+ [ssz, sabi, spref] ->+ case (parseInt ssz, parseInt sabi, parseInt spref) of+ (Just sz, Just abi, Just pref) -> Right acc { targetPointerPrefs = AlignmentPref sz abi pref }+ _ -> Left ("Could not parse pointer alignments: " ++ show rest)+ [ssz, sabi] ->+ case (parseInt ssz, parseInt sabi) of+ (Just sz, Just abi) -> Right acc { targetPointerPrefs = AlignmentPref sz abi abi }+ _ -> Left ("Could not parse pointer alignments: " ++ show rest)+ _ -> Left ("Could not parse pointer alignments: " ++ show rest)+ 'i' : rest ->+ case parseAlignPref rest of+ Nothing -> Left ("Invalid integer alignment preference: " ++ rest)+ Just p -> Right acc { targetIntegerPrefs = mergePreference p (targetIntegerPrefs acc) }+ 'v' : rest ->+ case parseAlignPref rest of+ Nothing -> Left ("Invalid vector alignment preference: " ++ rest)+ Just p -> Right acc { targetVectorPrefs = mergePreference p (targetVectorPrefs acc) }+ 'f' : rest ->+ case parseAlignPref rest of+ Nothing -> Left ("Invalid float alignment preference: " ++ rest)+ Just p -> Right acc { targetFloatPrefs = mergePreference p (targetFloatPrefs acc) }+ 'a' : rest ->+ case parseAlignPref rest of+ Nothing -> Left ("Invalid aggregate aggregate preference: " ++ rest)+ Just p -> Right acc { targetAggregatePrefs = mergePreference p (targetAggregatePrefs acc) }+ 's' : rest ->+ case parseAlignPref rest of+ Nothing -> Left ("Invalid stack object alignment preference: " ++ rest)+ Just p -> Right acc { targetStackObjectPrefs = mergePreference p (targetStackObjectPrefs acc) }+ 'S' : rest ->+ case reads rest of+ [(align, "")] -> Right acc { targetStackAlignment = Just align }+ _ -> Left ("Expected stack alignment: " ++ rest)+ 'n' : rest ->+ case mapM parseInt (splitOn ':' rest) of+ Nothing -> Left ("Expected int list: " ++ rest)+ Just is -> Right acc { targetIntegerWidths = is }+ _ -> Left ("Unexpected data layout specifier: " ++ T.unpack m)
+ src/Data/LLVM/Internal/ForceModule.hs view
@@ -0,0 +1,325 @@+module Data.LLVM.Internal.ForceModule (+ -- * Types+ ForceMonad,+ -- * Functions+ forceFunction,+ forceGlobalVariable,+ forceGlobalAlias,+ forceExternalValue,+ forceExternalFunction,+ forceMetadataT+ ) where++import Control.DeepSeq+import Control.Monad.Trans.State.Strict+import Data.HashSet ( HashSet )+import qualified Data.HashSet as S++import Data.LLVM.Types.Referential++type ForceMonad = State (HashSet Value, HashSet Metadata)++forceInstruction :: Instruction -> ForceMonad ()+forceInstruction i = do+ instructionType i `seq` i `seq` return ()+ mapM_ metaForceIfNeeded (instructionMetadata i)+ case i of+ RetInst { retInstValue = rv } -> maybe (return ()) forceValueIfConstant rv+ UnconditionalBranchInst { unconditionalBranchTarget = t } ->+ t `seq` return ()+ BranchInst { branchCondition = c+ , branchTrueTarget = tt+ , branchFalseTarget = ft+ } -> do+ forceValueIfConstant c+ tt `seq` ft `seq` i `seq` return ()+ SwitchInst { switchValue = sv+ , switchDefaultTarget = dt+ , switchCases = cs+ } -> do+ dt `seq` i `seq` return ()+ forceValueIfConstant sv+ let forceValPair (v1, v2) = v2 `seq` forceValueIfConstant v1+ mapM_ forceValPair cs+ IndirectBranchInst { indirectBranchAddress = addr+ , indirectBranchTargets = targets+ } -> do+ foldr seq (return ()) targets+ forceValueIfConstant addr+ UnreachableInst { } -> return ()+ ExtractElementInst { extractElementVector = vec+ , extractElementIndex = idx+ } ->+ mapM_ forceValueIfConstant [ vec, idx ]+ InsertElementInst { insertElementVector = vec+ , insertElementValue = val+ , insertElementIndex = idx+ } ->+ mapM_ forceValueIfConstant [ vec, val, idx ]+ ShuffleVectorInst { shuffleVectorV1 = v1+ , shuffleVectorV2 = v2+ , shuffleVectorMask = mask+ } ->+ mapM_ forceValueIfConstant [ v1, v2, mask ]+ ExtractValueInst { extractValueAggregate = agg+ , extractValueIndices = idxs+ } -> do+ forceValueIfConstant agg+ idxs `deepseq` return ()+ InsertValueInst { insertValueAggregate = agg+ , insertValueValue = val+ , insertValueIndices = idxs+ } -> do+ mapM_ forceValueIfConstant [ agg, val ]+ idxs `deepseq` return ()+ AllocaInst { allocaNumElements = elems } -> forceValueIfConstant elems+ LoadInst { loadAddress = addr } -> forceValueIfConstant addr+ StoreInst { storeValue = val+ , storeAddress = addr } ->+ mapM_ forceValueIfConstant [ val, addr ]+ AddInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ SubInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ MulInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ DivInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ RemInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ ShlInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ LshrInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ AshrInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ AndInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ OrInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ XorInst { binaryLhs = v1+ , binaryRhs = v2 } -> mapM_ forceValueIfConstant [ v1, v2 ]+ TruncInst { castedValue = cv } -> forceValueIfConstant cv+ ZExtInst { castedValue = cv } -> forceValueIfConstant cv+ SExtInst { castedValue = cv } -> forceValueIfConstant cv+ FPTruncInst { castedValue = cv } -> forceValueIfConstant cv+ FPExtInst { castedValue = cv } -> forceValueIfConstant cv+ FPToSIInst { castedValue = cv } -> forceValueIfConstant cv+ FPToUIInst { castedValue = cv } -> forceValueIfConstant cv+ SIToFPInst { castedValue = cv } -> forceValueIfConstant cv+ UIToFPInst { castedValue = cv } -> forceValueIfConstant cv+ PtrToIntInst { castedValue = cv } -> forceValueIfConstant cv+ IntToPtrInst { castedValue = cv } -> forceValueIfConstant cv+ BitcastInst { castedValue = cv } -> forceValueIfConstant cv+ ICmpInst { cmpV1 = v1+ , cmpV2 = v2+ } -> mapM_ forceValueIfConstant [ v1, v2 ]+ FCmpInst { cmpV1 = v1+ , cmpV2 = v2+ } -> mapM_ forceValueIfConstant [ v1, v2 ]+ SelectInst { selectCondition = c+ , selectTrueValue = tv+ , selectFalseValue = fv+ } -> mapM_ forceValueIfConstant [ c, tv, fv ]+ CallInst { callFunction = f+ , callAttrs = fattrs+ , callArguments = args+ , callParamAttrs = paramAttrs+ } -> do+ paramAttrs `deepseq` fattrs `deepseq` return ()+ forceValueIfConstant f+ let forceArg (v, ps) = forceValueIfConstant v >> ps `deepseq` return ()+ mapM_ forceArg args+ GetElementPtrInst { getElementPtrValue = v+ , getElementPtrIndices = idxs+ } -> mapM_ forceValueIfConstant (v:idxs)+ InvokeInst { invokeFunction = f+ , invokeParamAttrs = paramAttrs+ , invokeArguments = args+ , invokeAttrs = attrs+ , invokeNormalLabel = normal+ , invokeUnwindLabel = unwind+ } -> do+ paramAttrs `deepseq` attrs `deepseq` normal `seq` unwind `seq` return ()+ forceValueIfConstant f+ let forceArg (v, ps) = forceValueIfConstant v >> ps `deepseq` return ()+ mapM_ forceArg args+ VaArgInst { vaArgValue = v } -> forceValueIfConstant v+ PhiNode { phiIncomingValues = vs } -> do+ let forcePair (v1, v2) = forceValueIfConstant v1 >> forceValueIfConstant v2+ mapM_ forcePair vs+ ResumeInst { resumeException = ex } -> forceValueIfConstant ex+ FenceInst {} -> return ()+ AtomicCmpXchgInst { atomicCmpXchgPointer = p+ , atomicCmpXchgComparison = c+ , atomicCmpXchgNewValue = v+ } ->+ mapM_ forceValueIfConstant [ p, c, v ]+ AtomicRMWInst { atomicRMWPointer = p+ , atomicRMWValue = v+ } ->+ mapM_ forceValueIfConstant [ p, v ]+ LandingPadInst { landingPadPersonality = p+ , landingPadClauses = cs+ } -> do+ forceValueIfConstant p+ let forceClause (c, t) = do+ forceValueIfConstant c+ t `seq` return ()+ mapM_ forceClause cs++++forceValueIfConstant :: Value -> ForceMonad ()+forceValueIfConstant v = do+ valueName v `deepseq` valueUniqueId v `deepseq` v `seq` return ()+ mapM_ metaForceIfNeeded (valueMetadata v)+ case valueContent v of+ ConstantC c -> forceConstant c+ _ -> valueContent v `seq` return ()++forceConstant :: Constant -> ForceMonad ()+forceConstant c = case constantType c `seq` c of+ UndefValue { } -> return ()+ ConstantAggregateZero { } -> return ()+ ConstantPointerNull { } -> return ()+ BlockAddress { } -> blockAddressFunction c `seq` blockAddressBlock c `seq` return ()+ ConstantArray { } -> mapM_ forceValueIfConstant (constantArrayValues c)+ ConstantFP { } -> return ()+ ConstantInt { } -> return ()+ ConstantString { } -> return ()+ ConstantStruct { } -> mapM_ forceValueIfConstant (constantStructValues c)+ ConstantVector { } -> mapM_ forceValueIfConstant (constantVectorValues c)+ ConstantValue { } -> forceInstruction (constantInstruction c)+ InlineAsm { } -> return ()++forceFunction :: Function -> ForceMonad ()+forceFunction f = do+ functionRetAttrs f `deepseq` functionAttrs f `deepseq`+ functionSection f `seq` f `seq` return ()+ mapM_ forceBasicBlock (functionBody f)+ mapM_ forceArgument (functionParameters f)+ mapM_ metaForceIfNeeded (functionMetadata f)++forceArgument :: Argument -> ForceMonad ()+forceArgument a = do+ argumentParamAttrs a `deepseq` argumentType a `seq` a `seq` return ()+ mapM_ metaForceIfNeeded (argumentMetadata a)++forceGlobalVariable :: GlobalVariable -> ForceMonad ()+forceGlobalVariable gv = do+ globalVariableType gv `seq` gv `seq` return ()+ mapM_ metaForceIfNeeded (globalVariableMetadata gv)+ maybe (return ()) forceValueIfConstant (globalVariableInitializer gv)++forceGlobalAlias :: GlobalAlias -> ForceMonad ()+forceGlobalAlias ga = do+ ga `seq` return ()+ forceValueIfConstant (globalAliasTarget ga)+ mapM_ metaForceIfNeeded (globalAliasMetadata ga)++forceExternalValue :: ExternalValue -> ForceMonad ()+forceExternalValue ev = do+ externalValueType ev `seq` ev `seq` return ()+ mapM_ metaForceIfNeeded (externalValueMetadata ev)++forceExternalFunction :: ExternalFunction -> ForceMonad ()+forceExternalFunction ef = do+ externalFunctionAttrs ef `deepseq` externalFunctionType ef `seq` ef `seq` return ()+ mapM_ metaForceIfNeeded (externalFunctionMetadata ef)++forceBasicBlock :: BasicBlock -> ForceMonad ()+forceBasicBlock b = do+ valueName b `deepseq` valueType b `seq` b `seq` return ()+ mapM_ metaForceIfNeeded (valueMetadata b)+ mapM_ forceInstruction (basicBlockInstructions b)++metaForceIfNeeded :: Metadata -> ForceMonad ()+metaForceIfNeeded m = do+ (vset, mset) <- get+ case S.member m mset of+ True -> return ()+ False -> do+ put (vset, S.insert m mset)+ forceMetadata m+ where+ forceMetadata :: Metadata -> ForceMonad ()+ forceMetadata md = do+ md `seq` return ()+ forceMetadataT md++maybeMetaForceIfNeeded :: Maybe Metadata -> ForceMonad ()+maybeMetaForceIfNeeded Nothing = return ()+maybeMetaForceIfNeeded (Just m) = metaForceIfNeeded m++forceMetadataT :: Metadata -> ForceMonad ()+forceMetadataT m@(MetaSourceLocation {}) = do+ m `seq` return ()+ maybe (return ()) metaForceIfNeeded (metaSourceScope m)+forceMetadataT m@(MetaDWLexicalBlock {}) = do+ m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaLexicalBlockContext m ]+forceMetadataT m@(MetaDWCompileUnit {}) = do+ mapM_ maybeMetaForceIfNeeded $ metaCompileUnitEnumTypes m+ mapM_ maybeMetaForceIfNeeded $ metaCompileUnitRetainedTypes m+ mapM_ maybeMetaForceIfNeeded $ metaCompileUnitSubprograms m+ mapM_ maybeMetaForceIfNeeded $ metaCompileUnitGlobalVariables m+ metaCompileUnitSourceFile m `seq` metaCompileUnitCompileDir m `seq`+ metaCompileUnitProducer m `seq` metaCompileUnitFlags m `seq` m `seq` return ()+forceMetadataT m@(MetaDWFile {}) = do+ metaFileSourceFile m `seq` metaFileSourceDir m `seq` m `seq` return ()+forceMetadataT m@(MetaDWVariable {}) = do+ metaGlobalVarName m `seq` metaGlobalVarDisplayName m `seq`+ metaGlobalVarLinkageName m `seq` m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaGlobalVarContext m+ , metaGlobalVarType m+ ]+forceMetadataT m@(MetaDWSubprogram {}) = do+ metaSubprogramName m `seq` metaSubprogramDisplayName m `seq`+ metaSubprogramLinkageName m `seq` m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaSubprogramContext m+ , metaSubprogramType m+ ]+ maybe (return ()) metaForceIfNeeded (metaSubprogramBaseType m)+forceMetadataT m@(MetaDWBaseType {}) = do+ metaBaseTypeName m `seq` m `seq` return ()+ maybe (return ()) metaForceIfNeeded (metaBaseTypeContext m)+forceMetadataT m@(MetaDWDerivedType {}) = do+ metaDerivedTypeName m `seq` m `seq` return ()+ maybe (return ()) metaForceIfNeeded (metaDerivedTypeContext m)+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaDerivedTypeParent m+ ]+forceMetadataT m@(MetaDWCompositeType {}) = do+ metaCompositeTypeName m `seq` m `seq` return ()+ maybe (return ()) metaForceIfNeeded (metaCompositeTypeContext m)+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaCompositeTypeParent m+ , metaCompositeTypeMembers m+ , metaCompositeTypeContainer m+ , metaCompositeTypeTemplateParams m+ ]+forceMetadataT m@(MetaDWSubrange {}) = m `seq` return ()+forceMetadataT m@(MetaDWEnumerator {}) =+ metaEnumeratorName m `seq` m `seq` return ()+forceMetadataT m@(MetaDWLocal {}) = do+ metaLocalName m `seq` m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaLocalContext m+ , metaLocalType m+ ]+forceMetadataT m@(MetadataList _ ms) = do+ m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) ms+forceMetadataT m@(MetaDWNamespace {}) = do+ m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaNamespaceContext m+ ]+forceMetadataT m@(MetaDWTemplateTypeParameter {}) = do+ m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaTemplateTypeParameterContext m+ , metaTemplateTypeParameterType m+ ]+forceMetadataT m@(MetaDWTemplateValueParameter {}) = do+ m `seq` return ()+ mapM_ (maybe (return ()) metaForceIfNeeded) [ metaTemplateValueParameterContext m+ , metaTemplateValueParameterType m+ ]+forceMetadataT (MetadataUnknown _ _) = return ()
+ src/Data/LLVM/Internal/Paths.hs view
@@ -0,0 +1,3 @@+module Data.LLVM.Internal.Paths ( getDataFileName ) where++import Paths_llvm_base_types
+ src/Data/LLVM/Internal/Printers.hs view
@@ -0,0 +1,904 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | Define the unparser for our LLVM IR+module Data.LLVM.Internal.Printers (+ printMetadata,+ printAsm,+ printType,+ printValue+ ) where++import Data.GraphViz+import Data.Int+import Data.List ( intersperse )+import Data.Monoid+import Data.Text ( Text, unpack )+import Data.Text.Lazy ( toStrict )+import Data.Text.Lazy.Builder+import qualified Text.PrettyPrint as PP+import Text.PrettyPrint.GenericPretty++import Data.LLVM.Types.Attributes+import Data.LLVM.Types.Identifiers+import Data.LLVM.Types.Referential++-- TODO List+--+-- * Pretty up the DataLayout+-- * Print out named type definitions+-- * Make the function type printing as flexible as the official+-- version++showUntypedMDName :: Metadata -> Builder+showUntypedMDName = fromString . ("!"++) . show . metaValueUniqueId++showMDName :: Metadata -> Builder+showMDName = fromString . ("metadata !"++) . show . metaValueUniqueId++showMDString :: Text -> Builder+showMDString t = mconcat [ fromString "metadata !\""+ , fromText t+ , singleton '"'+ ]++showBool :: Bool -> Builder+showBool True = fromString "i1 true"+showBool False = fromString "i1 false"++maybeShowMDName :: Maybe Metadata -> Builder+maybeShowMDName Nothing = fromString "null"+maybeShowMDName (Just m) = showMDName m++dbgTag :: Int -> Builder+dbgTag i = fromShow (i + fromIntegral llvmDebugVersion)++printMetadata :: Metadata -> Builder+printMetadata md@MetaSourceLocation { } =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", fromShow (metaSourceRow md)+ , fromString ", i32 ", fromShow (metaSourceCol md)+ , fromString ", ", maybeShowMDName (metaSourceScope md)+ , fromString" null}"+ ]+printMetadata md@MetaDWLexicalBlock { } =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 11+ , fromString ", i32 ", fromShow (metaLexicalBlockRow md)+ , fromString ", i32 ", fromShow (metaLexicalBlockCol md)+ , fromString ", ", maybeShowMDName (metaLexicalBlockContext md)+ , fromString "}"+ ]+printMetadata md@MetaDWCompileUnit {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 17+ , fromString ", i32 ", fromShow (metaCompileUnitLanguage md)+ , fromString ", ", showMDString (metaCompileUnitSourceFile md)+ , fromString ", ", showMDString (metaCompileUnitCompileDir md)+ , fromString ", ", showMDString (metaCompileUnitProducer md)+ , fromString ", ", showBool (metaCompileUnitIsMain md)+ , fromString ", ", showBool (metaCompileUnitIsOpt md)+ , fromString ", i32 ", fromShow (metaCompileUnitVersion md)+ , fromString "}"+ ]+printMetadata md@MetaDWFile {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 41+ , fromString ", ", showMDString (metaFileSourceFile md)+ , fromString ", ", showMDString (metaFileSourceDir md)+ , fromString "}"+ ]+printMetadata md@MetaDWVariable {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 52+ , fromString ", ", maybeShowMDName (metaGlobalVarContext md)+ , fromString ", ", showMDString (metaGlobalVarName md)+ , fromString ", ", showMDString (metaGlobalVarDisplayName md)+ , fromString ", ", showMDString (metaGlobalVarLinkageName md)+ , fromString ", i32 ", fromShow (metaGlobalVarLine md)+ , fromString ", ", maybeShowMDName (metaGlobalVarType md)+ , fromString ", ", showBool (metaGlobalVarStatic md)+ , fromString ", ", showBool (metaGlobalVarNotExtern md)+ , fromString "}"+ ]+printMetadata md@MetaDWSubprogram {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 46+ , fromString ", ", maybeShowMDName (metaSubprogramContext md)+ , fromString ", ", showMDString (metaSubprogramName md)+ , fromString ", ", showMDString (metaSubprogramDisplayName md)+ , fromString ", ", showMDString (metaSubprogramLinkageName md)+ , fromString ", i32 ", fromShow (metaSubprogramLine md)+ , fromString ", ", maybeShowMDName (metaSubprogramType md)+ , fromString ", ", showBool (metaSubprogramStatic md)+ , fromString ", ", showBool (metaSubprogramNotExtern md)+ , fromString ", i32 ", fromShow (metaSubprogramVirtuality md)+ , fromString ", i32 ", fromShow (metaSubprogramVirtIndex md)+ , fromString ", ", maybeShowMDName (metaSubprogramBaseType md)+ , fromString ", ", showBool (metaSubprogramArtificial md)+ , fromString ", ", showBool (metaSubprogramOptimized md)+ , fromString "}"+ ]+printMetadata md@MetaDWBaseType {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 36+ , fromString ", ", maybeShowMDName (metaBaseTypeContext md)+ , fromString ", ", showMDString (metaBaseTypeName md)+-- , fromString ", ", maybeShowMDName (metaBaseTypeFile md)+ , fromString ", i32 ", fromShow (metaBaseTypeLine md)+ , fromString ", i32 ", fromShow (metaBaseTypeSize md)+ , fromString ", i32 ", fromShow (metaBaseTypeAlign md)+ , fromString ", i64 ", fromShow (metaBaseTypeOffset md)+ , fromString ", i32 ", fromShow (metaBaseTypeFlags md)+ , fromString ", i32 ", fromShow (metaBaseTypeEncoding md)+ , fromString "}"+ ]+printMetadata md@MetaDWDerivedType {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", fromShow (metaDerivedTypeTag md)+ , fromString ", ", maybeShowMDName (metaDerivedTypeContext md)+ , fromString ", ", showMDString (metaDerivedTypeName md)+-- , fromString ", ", maybeShowMDName (metaDerivedTypeFile md)+ , fromString ", i32 ", fromShow (metaDerivedTypeLine md)+ , fromString ", i32 ", fromShow (metaDerivedTypeSize md)+ , fromString ", i32 ", fromShow (metaDerivedTypeAlign md)+ , fromString ", i64 ", fromShow (metaDerivedTypeOffset md)+ , fromString ", ", maybeShowMDName (metaDerivedTypeParent md)+ , fromString "}"+ ]+printMetadata md@MetaDWCompositeType {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", fromShow (metaCompositeTypeTag md)+ , fromString ", ", maybeShowMDName (metaCompositeTypeContext md)+ , fromString ", ", showMDString (metaCompositeTypeName md)+-- , fromString ", ", maybeShowMDName (metaCompositeTypeFile md)+ , fromString ", i32 ", fromShow (metaCompositeTypeLine md)+ , fromString ", i32 ", fromShow (metaCompositeTypeSize md)+ , fromString ", i32 ", fromShow (metaCompositeTypeAlign md)+ , fromString ", i64 ", fromShow (metaCompositeTypeOffset md)+ , fromString ", i32 ", fromShow (metaCompositeTypeFlags md)+ , fromString ", ", maybeShowMDName (metaCompositeTypeParent md)+ , fromString ", ", maybeShowMDName (metaCompositeTypeMembers md)+ , fromString ", i32 ", fromShow (metaCompositeTypeRuntime md)+ , fromString "}"+ ]+printMetadata md@MetaDWSubrange {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 33+ , fromString ", i32 ", fromShow (metaSubrangeLow md)+ , fromString ", i32 ", fromShow (metaSubrangeHigh md)+ , fromString "}"+ ]+printMetadata md@MetaDWEnumerator {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 40+ , fromString ", ", showMDString (metaEnumeratorName md)+ , fromString ", i32 ", fromShow (metaEnumeratorValue md)+ , fromString "}"+ ]+printMetadata md@MetaDWLocal {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", fromShow (metaLocalTag md)+ , fromString ", ", maybeShowMDName (metaLocalContext md)+ , fromString ", ", showMDString (metaLocalName md)+ , fromString ", i32 ", fromShow (metaLocalLine md)+ , fromString ", ", maybeShowMDName (metaLocalType md)+ , fromString "}"+ ]+printMetadata md@(MetadataList _ vals) =+ mconcat [ showUntypedMDName md, fromString " = metadata !{"+ , mconcat $ intersperse (fromString ", ") (map maybeShowMDName vals)+ , fromString "}"+ ]+printMetadata md@MetaDWNamespace {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 57+ , fromString ", ", showMDString (metaNamespaceName md)+ , fromString ", ", maybeShowMDName (metaNamespaceContext md)+ , fromString ", i32 ", fromShow (metaNamespaceLine md)+ , fromString "}"+ ]+printMetadata md@MetaDWTemplateTypeParameter {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 0x2f+ , fromString ", ", showMDString (metaTemplateTypeParameterName md)+ , fromString ", i32 ", fromShow (metaTemplateTypeParameterLine md)+ , fromString ", i32 ", fromShow (metaTemplateTypeParameterCol md)+ , fromString ", ", maybeShowMDName (metaTemplateTypeParameterContext md)+ , fromString ", ", maybeShowMDName (metaTemplateTypeParameterType md)+ , fromString "}"+ ]+printMetadata md@MetaDWTemplateValueParameter {} =+ mconcat [ showUntypedMDName md, fromString " = metadata !{i32 ", dbgTag 0x30+ , fromString ", ", showMDString (metaTemplateValueParameterName md)+ , fromString ", i32 ", fromShow (metaTemplateValueParameterLine md)+ , fromString ", i32 ", fromShow (metaTemplateValueParameterCol md)+ , fromString ", ", maybeShowMDName (metaTemplateValueParameterContext md)+ , fromString ", ", maybeShowMDName (metaTemplateValueParameterType md)+ , fromString ", i64 ", fromShow (metaTemplateValueParameterValue md)+ , fromString "}"+ ]+printMetadata md@(MetadataUnknown _ s) =+ mconcat [ showUntypedMDName md, fromString " = metadata ", fromText s ]++-- Take all of the asm chunks, break their contents into lines,+-- then wrap each of those lines in the 'module asm' wrapper.+-- Combine them into a single string with newlines.+printAsm :: Assembly -> Builder+printAsm asm = mconcat asmLines+ where+ asmLines = map adorn (lines (show asm))+ adorn s = mconcat [fromString "module asm \"", fromString s, fromString "\"\n"]++-- When referencing a non-constant value during printing, just use+-- this instead of printValue to avoid problems printing cyclic data.+-- If the value doesn't have a name, just print it (it should be a+-- constant).+printConstOrName :: Value -> Builder+printConstOrName v =+ case valueName v of+ Nothing -> mconcat [ printType (valueType v), singleton ' ', printValue v ]+ Just ident -> mconcat [ printType (valueType v), singleton ' ', fromShow ident ]++printConstOrNameNoType :: Value -> Builder+printConstOrNameNoType v =+ case valueName v of+ Nothing -> printValue v+ Just ident -> fromShow ident++compose :: [Builder] -> Builder+compose = mconcat . intersperse (singleton ' ') . filter (/= mempty)++quote :: Builder -> Builder+quote s = mconcat [ singleton '\\', s, singleton '\\' ]++printValue :: Value -> Builder+printValue v = case valueContent v of+ FunctionC f ->+ let retAttrS = unwords $ map show (functionRetAttrs f)+ argS = commaSep $ map (printValue . toValue) (functionParameters f)+ fAttrS = spaceSep $ map fromShow (functionAttrs f)+ bodyS = lineSep $ map (printValue . toValue) (functionBody f)+ vaTag = if functionIsVararg f then ", ..." else ""+ (TypeFunction rtype _ _) = functionType f+ name = functionName f+ in compose [ fromString "define", fromShow (functionLinkage f)+ , fromShow (functionVisibility f), fromShow (functionCC f)+ , fromString retAttrS, printType rtype, fromShow name, singleton '('+ , argS, fromString vaTag, singleton ')', fAttrS+ , maybe mempty fromText (functionSection f)+ , printAlignment (functionAlign f)+ , maybe mempty fromShow (functionGCName f)+ , fromString "{\n", bodyS, singleton '}'+ ]+ ArgumentC a ->+ compose [ printType (argumentType a)+ , compose $ map fromShow (argumentParamAttrs a)+ , fromShow (argumentName a)+ ]+ BasicBlockC b ->+ let indent = (fromString " " `mappend`)+ dbgS = map (printDebugTag . valueMetadata) (basicBlockInstructions b)+ instS = map (printValue . toValue) (basicBlockInstructions b)+ instS' = zipWith mappend instS dbgS+ instS'' = mconcat $ intersperse (singleton '\n') $ map indent instS'+ identS = fromText $ identifierContent (basicBlockName b)+ label = case isAnonymousIdentifier (basicBlockName b) of+ True -> fromString "; <label>:" `mappend` identS+ False -> identS `mappend` singleton ':'+ in mconcat [ label, singleton '\n', instS'' ]+ GlobalVariableC g ->+ let TypePointer _ addrSpace = globalVariableType g+ addrSpaceS = case addrSpace of+ 0 -> mempty+ _ -> mconcat [ fromString "addrspace(", fromShow addrSpace, singleton ')' ]+ annotsS = if globalVariableIsConstant g then fromString "constant" else mempty+ initS = maybe mempty printConstOrName (globalVariableInitializer g)+ sectionS = maybe mempty ((fromString ", section" `mappend`) . quote . fromText) (globalVariableSection g)+ in compose [ fromShow (globalVariableName g), singleton '=', addrSpaceS+ , fromShow (globalVariableLinkage g), fromShow (globalVariableVisibility g)+ , annotsS, initS, sectionS, printAlignment (globalVariableAlignment g)+ ]+ GlobalAliasC a ->+ compose [ fromShow (globalAliasName a)+ , fromString "= alias"+ , fromShow (globalAliasLinkage a)+ , fromShow (globalAliasVisibility a)+ , printConstOrName (globalAliasTarget a)+ ]+ ExternalValueC e ->+ compose [ fromString "declare"+ , printType (valueType e)+ , fromShow (externalValueName e)+ ]+ ExternalFunctionC e ->+ let TypeFunction rtype argTypes isva = externalFunctionType e+ in compose [ fromString "declare", printType rtype+ , fromShow (externalFunctionName e)+ , singleton '(', commaSep $ map printType argTypes+ , fromString $ if isva then ", ..." else ""+ , singleton ')'+ ]+ InstructionC i ->+ case i of+ RetInst { retInstValue = Just rv } ->+ compose [ fromString "ret", printConstOrName rv ]+ RetInst { } -> fromString "ret void"+ ResumeInst { resumeException = val } ->+ compose [ fromString "resume", printConstOrName val ]+ UnconditionalBranchInst { unconditionalBranchTarget = dest } ->+ compose [ fromString "br", (printConstOrName . toValue) dest ]+ BranchInst { branchCondition = cond+ , branchTrueTarget = tTarget+ , branchFalseTarget = fTarget+ } ->+ compose [ fromString "br", printConstOrName cond+ , singleton ',', printConstOrName (toValue tTarget)+ , singleton ',', printConstOrName (toValue fTarget)+ ]+ SwitchInst { switchValue = val+ , switchDefaultTarget = defTarget+ , switchCases = cases+ } ->+ let caseDests = mconcat $ intersperse (singleton ' ') $ map printPair cases+ printPair (caseVal, caseDest) =+ mconcat [ printConstOrName caseVal+ , fromString ", "+ , printConstOrName (toValue caseDest)+ ]+ in compose [ fromString "switch", printConstOrName val+ , singleton ',', printConstOrName (toValue defTarget)+ , singleton '[', caseDests, singleton ']'+ ]+ IndirectBranchInst { indirectBranchAddress = addr+ , indirectBranchTargets = targets+ } ->+ compose [ fromString "indirectbr", printConstOrName addr+ , singleton '[', commaSep $ map (printConstOrName . toValue) targets+ , singleton ']'+ ]+ UnreachableInst { } -> fromString "unreachable"+ AddInst { } -> printFlaggedBinaryOp "add" i+ SubInst { } -> printFlaggedBinaryOp "sub" i+ MulInst { } -> printFlaggedBinaryOp "mul" i+ DivInst { } -> printBinaryOp "div" i+ RemInst { } -> printBinaryOp "rem" i+ ShlInst { } -> printBinaryOp "shl" i+ LshrInst { } -> printBinaryOp "lshr" i+ AshrInst { } -> printBinaryOp "ashr" i+ AndInst { } -> printBinaryOp "and" i+ OrInst { } -> printBinaryOp "or" i+ XorInst { } -> printBinaryOp "xor" i+ ExtractElementInst { extractElementVector = vec+ , extractElementIndex = idx+ } ->+ compose [ printInstNamePrefix i+ , fromString "extractelement"+ , printConstOrName vec, singleton ','+ , printConstOrName idx+ ]+ InsertElementInst { insertElementVector = vec+ , insertElementValue = val+ , insertElementIndex = idx+ } ->+ compose [ printInstNamePrefix i+ , fromString "insertelement"+ , printConstOrName vec, singleton ','+ , printConstOrName val, singleton ','+ , printConstOrName idx+ ]+ ShuffleVectorInst { shuffleVectorV1 = v1+ , shuffleVectorV2 = v2+ , shuffleVectorMask = mask+ } ->+ compose [ printInstNamePrefix i+ , fromString "shufflevector"+ , printConstOrName v1, singleton ','+ , printConstOrName v2, singleton ','+ , printConstOrName mask+ ]+ ExtractValueInst { extractValueAggregate = agg+ , extractValueIndices = indices+ } ->+ compose [ printInstNamePrefix i+ , fromString "extractvalue"+ , printConstOrName agg+ , commaSep $ map fromShow indices+ ]+ InsertValueInst { insertValueAggregate = agg+ , insertValueValue = val+ , insertValueIndices = indices+ } ->+ compose [ printInstNamePrefix i+ , fromString "insertvalue"+ , printConstOrName agg, singleton ','+ , printConstOrName val, singleton ','+ , commaSep $ map fromShow indices+ ]+ AllocaInst { allocaNumElements = elems+ , allocaAlign = align+ } ->+ let count = case valueContent elems of+ ConstantC ConstantInt { constantIntValue = 1 } -> mempty+ _ -> fromString ", " `mappend` printConstOrName elems+ TypePointer ty _ = instructionType i+ in compose [ printInstNamePrefix i+ , fromString "alloca"+ , printType ty+ , count+ , printAlignment align+ ]+ LoadInst { loadIsVolatile = volatile+ , loadAddress = src+ , loadAlignment = align+ } ->+ compose [ printInstNamePrefix i+ , printVolatileFlag volatile+ , fromString "load"+ , printConstOrName src+ , printAlignment align+ ]+ StoreInst { storeIsVolatile = volatile+ , storeValue = val+ , storeAddress = dest+ , storeAlignment = align+ } ->+ compose [ printVolatileFlag volatile+ , fromString "store"+ , printConstOrName val, singleton ','+ , printConstOrName dest+ , printAlignment align+ ]+ FenceInst { fenceOrdering = o, fenceScope = s } ->+ compose [ fromString "fence", fromShow s, fromShow o ]+ AtomicCmpXchgInst { atomicCmpXchgOrdering = o+ , atomicCmpXchgScope = s+ , atomicCmpXchgIsVolatile = isVol+ , atomicCmpXchgAddressSpace = _ -- ?+ , atomicCmpXchgPointer = ptr+ , atomicCmpXchgComparison = cmp+ , atomicCmpXchgNewValue = newV+ } ->+ compose [ fromString "cmpxchg", printVolatileFlag isVol+ , printConstOrName ptr, singleton ','+ , printConstOrName cmp, singleton ','+ , printConstOrName newV+ , fromShow s, fromShow o+ ]+ AtomicRMWInst { atomicRMWOrdering = o+ , atomicRMWScope = s+ , atomicRMWOperation = op+ , atomicRMWIsVolatile = isVol+ , atomicRMWPointer = p+ , atomicRMWValue = val+ , atomicRMWAddressSpace = _ -- ?+ } ->+ compose [ fromString "atomicrmw", printVolatileFlag isVol+ , fromShow op+ , printConstOrName p, singleton ','+ , printConstOrName val+ , fromShow s+ , fromShow o+ ]+ TruncInst { } -> printTypecast "trunc" i+ ZExtInst { } -> printTypecast "zext" i+ SExtInst { } -> printTypecast "sext" i+ FPTruncInst { } -> printTypecast "fptrunc" i+ FPExtInst { } -> printTypecast "fpext" i+ FPToUIInst { } -> printTypecast "fptoui" i+ FPToSIInst { } -> printTypecast "fptosi" i+ UIToFPInst { } -> printTypecast "uitofp" i+ SIToFPInst { } -> printTypecast "sitofp" i+ PtrToIntInst { } -> printTypecast "ptrtoint" i+ IntToPtrInst { } -> printTypecast "inttoptr" i+ BitcastInst { } -> printTypecast "bitcast" i+ ICmpInst { cmpPredicate = cond+ , cmpV1 = v1+ , cmpV2 = v2+ } ->+ compose [ printInstNamePrefix i+ , fromString "icmp"+ , fromShow cond+ , printConstOrName v1, singleton ','+ , printConstOrNameNoType v2+ ]+ FCmpInst { cmpPredicate = cond+ , cmpV1 = v1+ , cmpV2 = v2+ } ->+ compose [ printInstNamePrefix i+ , fromString "fcmp"+ , fromShow cond+ , printConstOrName v1, singleton ','+ , printConstOrNameNoType v2+ ]+ PhiNode { phiIncomingValues = vals+ } ->+ let printPair (val, lab) =+ mconcat [ singleton '[', printConstOrNameNoType val+ , fromString ", ", printConstOrNameNoType lab+ , singleton ']'+ ]+ valS = mconcat $ intersperse (fromString ", ") $ map printPair vals+ in compose [ printInstNamePrefix i+ , fromString "phi"+ , printType (instructionType i)+ , singleton '[', valS, singleton ']'+ ]+ SelectInst { selectCondition = cond+ , selectTrueValue = v1+ , selectFalseValue = v2+ } ->+ compose [ printInstNamePrefix i+ , fromString "select"+ , printConstOrName cond, singleton ','+ , printConstOrName v1, singleton ','+ , printConstOrName v2+ ]+ GetElementPtrInst { getElementPtrInBounds = inBounds+ , getElementPtrValue = val+ , getElementPtrIndices = indices+ } ->+ compose [ printInstNamePrefix i+ , fromString "getelementptr"+ , printInBounds inBounds+ , printConstOrName val, singleton ','+ , mconcat $ intersperse (fromString ", ") $ map printConstOrName indices+ ]+ CallInst { callIsTail = isTail+ , callConvention = cc+ , callParamAttrs = pattrs+ , callFunction = f+ , callArguments = args+ , callAttrs = cattrs+ , callHasSRet = _+ } ->+ let rtype = valueType i+ -- case valueType f of+ -- TypeFunction r _ _ -> r+ -- TypePointer (TypeFunction r _ _) _ -> r+ -- _ -> error ("Unknown function return type: " ++ show (valueType f))+ in compose [ printInstNamePrefix i+ , printTailTag isTail+ , fromString "call"+ , fromShow cc+ , mconcat $ intersperse (singleton ' ') $ map fromShow pattrs+ , printType rtype+ , printConstOrNameNoType f+ , singleton '('+ , mconcat $ intersperse (fromString ", ") $ map printArgument args+ , singleton ')'+ , mconcat $ intersperse (singleton ' ') $ map fromShow cattrs+ ]+ InvokeInst { invokeConvention = cc+ , invokeParamAttrs = pattrs+ , invokeFunction = f+ , invokeArguments = args+ , invokeAttrs = atts+ , invokeNormalLabel = nlabel+ , invokeUnwindLabel = ulabel+ , invokeHasSRet = _+ } ->+ compose [ printInstNamePrefix i+ , fromString "invoke"+ , fromShow cc+ , spaceSep $ map fromShow pattrs+ , printConstOrName f+ , singleton '('+ , commaSep $ map printArgument args+ , singleton ')'+ , spaceSep $ map fromShow atts+ , fromString "to", printConstOrName (toValue nlabel)+ , fromString "unwind", printConstOrName (toValue ulabel)+ ]+ VaArgInst { vaArgValue = va } ->+ compose [ printInstNamePrefix i+ , fromString "va_arg"+ , printConstOrName va, singleton ','+ , printType (instructionType i)+ ]+ -- FIXME: This might not be correct in printing the filter+ -- functions...+ LandingPadInst { landingPadPersonality = p+ , landingPadIsCleanup = isClean+ , landingPadClauses = cs+ } ->+ compose [ printInstNamePrefix i+ , fromString "landingpad"+ , printType (instructionType i)+ , fromString "personality"+ , printConstOrName p+ , if isClean then fromString "cleanup" else mempty+ , spaceSep $ map printClause cs+ ]+ ConstantC c -> printConstant c++printClause :: (Value, LandingPadClause) -> Builder+printClause (v, p) =+ case p of+ LPCatch -> compose [ fromString "catch", printConstOrName v ]+ LPFilter -> compose [ fromString "filter", printConstOrName v ]++commaSep :: [Builder] -> Builder+commaSep = mconcat . intersperse (fromString ", ")++spaceSep :: [Builder] -> Builder+spaceSep = mconcat . intersperse (singleton ' ')++lineSep :: [Builder] -> Builder+lineSep = mconcat . intersperse (singleton '\n')++printConstant :: Constant -> Builder+printConstant c = case c of+ UndefValue { } -> fromString "undef"+ ConstantAggregateZero { } -> fromString "zeroinitializer"+ ConstantPointerNull { } -> fromString "null"+ BlockAddress { blockAddressFunction = f+ , blockAddressBlock = b+ } ->+ mconcat [ fromString "blockaddress("+ , printConstOrNameNoType (toValue f)+ , fromString ", "+ , printConstOrNameNoType (toValue b)+ , singleton ')'+ ]+ ConstantArray { constantArrayValues = vs } ->+ mconcat [ singleton '['+ , commaSep $ map printConstOrName vs, singleton ']'+ ]+ ConstantFP { constantFPValue = d } -> fromShow d+ ConstantInt { constantIntValue = i } -> fromShow i+ ConstantString { constantStringValue = s } ->+ mconcat [ fromString "c\"", fromText s, singleton '"' ]+ ConstantStruct { constantStructValues = vs } ->+ mconcat [ singleton '{', commaSep $ map printConstOrName vs, singleton '}' ]+ ConstantVector { constantVectorValues = vs } ->+ mconcat [ singleton '<', commaSep $ map printConstOrName vs, singleton '>' ]+ ConstantValue { constantInstruction = i } ->+ mconcat [ printType (constantType c), singleton ' ', printConstInst i ]+ InlineAsm { inlineAsmString = asm+ , inlineAsmConstraints = constraints+ } ->+ mconcat [ fromString "asm \"", fromText asm+ , fromString "\", \"", fromText constraints, singleton '"' ]++printArgument :: (Value, [ParamAttribute]) -> Builder+printArgument (v, atts) =+ compose [ printType $ valueType v+ , spaceSep $ map fromShow atts+ , printConstOrNameNoType v+ ]++instance Show Argument where+ show a = builderToString $ printArgument (toValue a, [])++printConstInst :: Instruction -> Builder+printConstInst valT = case valT of+ TruncInst { } -> printTypecastConst "trunc" valT+ ZExtInst { } -> printTypecastConst "zext" valT+ SExtInst { } -> printTypecastConst "sext" valT+ FPTruncInst { } -> printTypecastConst "fptrunc" valT+ FPExtInst { } -> printTypecastConst "fpext" valT+ FPToUIInst { } -> printTypecastConst "fptoui" valT+ FPToSIInst { } -> printTypecastConst "fptosi" valT+ UIToFPInst { } -> printTypecastConst "uitofp" valT+ SIToFPInst { } -> printTypecastConst "sitofp" valT+ PtrToIntInst { } -> printTypecastConst "ptrtoint" valT+ IntToPtrInst { } -> printTypecastConst "inttoptr" valT+ BitcastInst { } -> printTypecastConst "bitcast" valT+ GetElementPtrInst { getElementPtrInBounds = inBounds+ , getElementPtrValue = val+ , getElementPtrIndices = indices+ } ->+ compose [ fromString "getelementptr"+ , printInBounds inBounds+ , singleton '('+ , printConstOrName val, fromString ", "+ , commaSep $ map printConstOrName indices+ , singleton ')'+ ]+ SelectInst { selectCondition = cond+ , selectTrueValue = v1+ , selectFalseValue = v2+ } ->+ mconcat [ fromString "select ("+ , printConstOrName cond, fromString ", "+ , printConstOrName v1, fromString ", "+ , printConstOrName v2, singleton ')'+ ]+ ICmpInst { cmpPredicate = cond+ , cmpV1 = v1+ , cmpV2 = v2+ } ->+ mconcat [ fromString "icmp ", fromShow cond, fromString " ("+ , printConstOrName v1, fromString ", "+ , printConstOrName v2, singleton ')'+ ]+ FCmpInst { cmpPredicate = cond+ , cmpV1 = v1+ , cmpV2 = v2+ } ->+ mconcat [ fromString "fcmp ", fromShow cond, fromString " ("+ , printConstOrName v1, fromString ", "+ , printConstOrName v2, singleton ')'+ ]+ ExtractElementInst { extractElementVector = v+ , extractElementIndex = idx+ } ->+ mconcat [ fromString "extractelement ("+ , printConstOrName v, fromString ", "+ , printConstOrName idx, singleton ')'+ ]+ InsertElementInst { insertElementVector = vec+ , insertElementValue = val+ , insertElementIndex = idx+ } ->+ mconcat [ fromString "insertelement ("+ , printConstOrName vec, fromString ", "+ , printConstOrName val, fromString ", "+ , printConstOrName idx, singleton ')'+ ]+ ShuffleVectorInst { shuffleVectorV1 = v1+ , shuffleVectorV2 = v2+ , shuffleVectorMask = mask+ } ->+ mconcat [ fromString "shufflevector ("+ , printConstOrName v1, fromString ", "+ , printConstOrName v2, fromString ", "+ , printConstOrName mask, singleton ')'+ ]+ ExtractValueInst { extractValueAggregate = agg+ , extractValueIndices = indices+ } ->+ mconcat [ fromString "extractvalue ("+ , printConstOrName agg, fromString ", "+ , commaSep $ map fromShow indices, singleton ')'+ ]+ InsertValueInst { insertValueAggregate = agg+ , insertValueValue = val+ , insertValueIndices = indices+ } ->+ mconcat [ fromString "insertvalue ("+ , printConstOrName agg, fromString ", "+ , printConstOrName val, fromString ", "+ , commaSep $ map fromShow indices, singleton ')'+ ]+ AddInst { } -> printBinaryConst "add" valT+ SubInst { } -> printBinaryConst "sub" valT+ MulInst { } -> printBinaryConst "mul" valT+ DivInst { } -> printBinaryConst "div" valT+ RemInst { } -> printBinaryConst "rem" valT+ ShlInst { } -> printBinaryConst "shl" valT+ LshrInst { } -> printBinaryConst "lshr" valT+ AshrInst { } -> printBinaryConst "ashr" valT+ AndInst { } -> printBinaryConst "and" valT+ OrInst { } -> printBinaryConst "or" valT+ XorInst { } -> printBinaryConst "xor" valT+ _ -> error "Non-constant ValueT"++printBinaryConst :: String -> Instruction -> Builder+printBinaryConst name inst =+ mconcat [ fromString name, fromString " ("+ , printConstOrName (binaryLhs inst), fromString ", "+ , printConstOrName (binaryRhs inst), singleton ')'+ ]++printTypecastConst :: String -> Instruction -> Builder+printTypecastConst n inst =+ mconcat [ fromString n, fromString " (", printConstOrName (castedValue inst)+ , fromString " to ", printType (instructionType inst), singleton ')'+ ]++printTailTag :: Bool -> Builder+printTailTag isTail = if isTail then fromString "tail" else mempty++printVolatileFlag :: Bool -> Builder+printVolatileFlag f = if f then fromString "volatile" else mempty++printAlignment :: Int64 -> Builder+printAlignment align =+ case align of+ 0 -> mempty+ _ -> fromString ", align " `mappend` fromShow align++printTypecast :: String -> Instruction -> Builder+printTypecast str inst =+ compose [ printInstNamePrefix inst+ , fromString str+ , printConstOrName (castedValue inst)+ , fromString "to"+ , printType (valueType inst)+ ]++printInBounds :: Bool -> Builder+printInBounds inBounds = if inBounds then fromString "inbounds" else mempty++printFlaggedBinaryOp :: String -> Instruction -> Builder+printFlaggedBinaryOp str inst =+ compose [ printInstNamePrefix inst+ , fromString str+ , fromShow (binaryArithFlags inst)+ , printType (instructionType inst)+ , printConstOrNameNoType (binaryLhs inst), singleton ','+ , printConstOrNameNoType (binaryRhs inst)+ ]++printBinaryOp :: String -> Instruction -> Builder+printBinaryOp str inst =+ compose [ printInstNamePrefix inst+ , fromString str+ , printType (instructionType inst)+ , printConstOrNameNoType (binaryLhs inst), singleton ','+ , printConstOrNameNoType (binaryRhs inst)+ ]++printInstNamePrefix :: Instruction -> Builder+printInstNamePrefix i =+ case instructionName i of+ Nothing -> mempty+ Just n -> mconcat [ fromShow n, fromString " =" ]++-- | This is kind of gross - it only prints out the first piece of+-- metadata.+printDebugTag :: [Metadata] -> Builder+printDebugTag [] = mempty+printDebugTag (md:_) =+ fromString ", !dbg !" `mappend` fromShow (metaValueUniqueId md)++printType :: Type -> Builder+printType (TypeInteger bits) = singleton 'i' `mappend` fromShow bits+printType TypeFloat = fromString "float"+printType TypeDouble = fromString "double"+printType TypeFP128 = fromString "fp128"+printType TypeX86FP80 = fromString "x86_fp80"+printType TypePPCFP128 = fromString "ppc_fp128"+printType TypeX86MMX = fromString "x86mmx"+printType TypeVoid = fromString "void"+printType TypeLabel = fromString "label"+printType TypeMetadata = fromString "metadata"+printType (TypeArray n ty) =+ mconcat [ singleton '[', fromShow n, fromString " x "+ , printType ty, singleton ']'+ ]+printType (TypeVector n ty) =+ mconcat [ singleton '<', fromShow n, fromString " x "+ , printType ty, singleton '>'+ ]+printType (TypeFunction retT argTs isVa) =+ mconcat [ printType retT, singleton '(', argVals, vaTag, singleton ')' ]+ where+ argVals = commaSep $ map printType argTs+ vaTag = if isVa then fromString ", ..." else mempty+printType (TypePointer ty _) = mconcat [ printType ty, singleton '*' ]+printType (TypeStruct (Left _) ts p) =+ case p of+ True -> mconcat [ singleton '<', fieldVals, singleton '>' ]+ False -> mconcat [ singleton '{', fieldVals, singleton '}' ]+ where fieldVals = commaSep $ map printType ts+printType (TypeStruct (Right n) _ _) = singleton '%' `mappend` fromText n++instance Show Metadata where+ show = builderToString . printMetadata++instance Show Type where+ show = builderToString . printType++instance Show Value where+ show = builderToString . printValue++instance Labellable Value where+ toLabelValue = toLabelValue . show++instance Show Instruction where+ show = builderToString . printValue . toValue++instance Show Function where+ show = builderToString . printValue . toValue++instance Show GlobalVariable where+ show = builderToString . printValue . toValue++instance Show BasicBlock where+ show = builderToString . printValue . toValue++instance Out Type where+ docPrec _ = PP.text . show+ doc = PP.text . show++instance Out Value where+ docPrec _ = PP.text . show+ doc = PP.text . show++instance Out Instruction where+ docPrec _ = PP.text . show+ doc = PP.text . show++builderToString :: Builder -> String+builderToString = unpack . toStrict . toLazyText++fromShow :: (Show a) => a -> Builder+fromShow = fromString . show
+ src/Data/LLVM/Types.hs view
@@ -0,0 +1,133 @@+{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.LLVM.Types (+ Module(..),+ moduleGlobals,+ findFunctionByName,+ findMain,+ module Data.LLVM.Types.Attributes,+ module Data.LLVM.Types.Dwarf,+ module Data.LLVM.Types.Identifiers,+ module Data.LLVM.Types.Referential,+ module Data.LLVM.Internal.DataLayout+ ) where++import Control.DeepSeq+import Control.Monad.Trans.State.Strict+import qualified Data.HashSet as S+import Data.List ( find, intersperse )+import Data.Monoid+import Data.Text ( Text )+import qualified Data.Text as T+import Data.Text.Lazy ( toStrict )+import Data.Text.Lazy.Builder++import Data.LLVM.Internal.ForceModule+import Data.LLVM.Internal.Printers+import Data.LLVM.Internal.DataLayout+import Data.LLVM.Types.Attributes+import Data.LLVM.Types.Dwarf+import Data.LLVM.Types.Identifiers+import Data.LLVM.Types.Referential++-- | This is the top-level representation of a program in LLVM. This+-- is the type returned from all of the parsers, and all analysis+-- begins at the Module level.+data Module = Module { moduleIdentifier :: Text+ , moduleDataLayout :: DataLayout+ , moduleDataLayoutString :: Text+ -- ^ The layout of the primitive datatypes on+ -- the architecture this module was generated+ -- for+ , moduleTarget :: Text -- TargetTriple+ -- ^ The architecture that this module was+ -- generated for+ , moduleAssembly :: Assembly+ -- ^ Module-level assembly declarations+ , moduleDefinedFunctions :: [Function]+ , moduleGlobalVariables :: [GlobalVariable]+ , moduleExternalValues :: [ExternalValue]+ , moduleExternalFunctions :: [ExternalFunction]+ , moduleAliases :: [GlobalAlias]+ , moduleEnumMetadata :: [Metadata]+ -- ^ All enumerations in the Module. These+ -- should provide a bit more information than+ -- just combing the types appearing in+ -- interfaces.+ , moduleRetainedTypeMetadata :: [Metadata]+ -- ^ The retained types in the Module. Only+ -- available with new-style metadata.+ , moduleRetainedTypes :: [Type]+ -- ^ All of the IR-level types retained by the+ -- module.+ , moduleNextId :: UniqueId+ , moduleTypeSizes :: Type -> Maybe Int+ }++-- | Implementation of the Show instance+--+-- FIXME: Print out the external values and functions+printModule :: Module -> Builder+printModule Module { moduleIdentifier = _+ , moduleDataLayoutString = layout+ , moduleTarget = triple+ , moduleAssembly = asm+ , moduleAliases = aliases+ , moduleGlobalVariables = vars+ , moduleDefinedFunctions = funcs+ , moduleExternalValues = _ -- evars+ , moduleExternalFunctions = _ -- efuncs+ } =+ mconcat [ layoutS, singleton '\n', tripleS, singleton '\n', asmS, singleton '\n'+ , aliasesS, singleton '\n', varS, fromString "\n\n", funcS, singleton '\n'+ ]+ where+ layoutS = mconcat [ fromString "target datalayout = \""+ , fromString (show layout), singleton '"'+ ]+ tripleS = mconcat [ fromString "target triple = \"", fromString (show triple), singleton '"' ]+ asmS = printAsm asm+ aliasesS = mconcat $ intersperse (fromString "\n") $ map (printValue . toValue) aliases+ varS = mconcat $ intersperse (fromString "\n") $ map (printValue . toValue) vars+ funcS = mconcat $ intersperse (fromString "\n\n") $ map (printValue . toValue) funcs++-- | Get a list of all types of globals in the Module (functions,+-- aliases, and global variables)+moduleGlobals :: Module -> [Value]+moduleGlobals m = concat [ map toValue $ moduleAliases m+ , map toValue $ moduleGlobalVariables m+ , map toValue $ moduleDefinedFunctions m+ , map toValue $ moduleExternalValues m+ , map toValue $ moduleExternalFunctions m+ ]++instance Show Module where+ show = T.unpack . toStrict . toLazyText . printModule++instance NFData Module where+ rnf m = evalState (forceModule m) (S.empty, S.empty) `seq` ()++-- | Force the module to be fully evaluated to rnf form from the+-- top-down. There are cycles, so we have to be careful to avoid+-- traversing them infinitely.+forceModule :: Module -> ForceMonad Module+forceModule m = do+ mapM_ forceGlobalAlias (moduleAliases m)+ mapM_ forceGlobalVariable (moduleGlobalVariables m)+ mapM_ forceFunction (moduleDefinedFunctions m)+ mapM_ forceExternalValue (moduleExternalValues m)+ mapM_ forceExternalFunction (moduleExternalFunctions m)+ mapM_ forceMetadataT (moduleEnumMetadata m)+ mapM_ forceMetadataT (moduleRetainedTypeMetadata m)+ return $ moduleAssembly m `deepseq` m `seq` m++-- | Find a function in the Module by its name.+findFunctionByName :: Module -> String -> Maybe Function+findFunctionByName m s = find isFunc $ moduleDefinedFunctions m+ where+ funcIdent = makeGlobalIdentifier (T.pack s)+ isFunc f = functionName f == funcIdent++-- | Find the function named 'main' in the 'Module', if any.+findMain :: Module -> Maybe Function+findMain m = findFunctionByName m "main"
+ src/Data/LLVM/Types/Attributes.chs view
@@ -0,0 +1,264 @@+module Data.LLVM.Types.Attributes (+ -- * Types+ ArithFlags(..),+ defaultArithFlags,+ CmpPredicate(..),+ CallingConvention(..),+ defaultCallingConvention,+ LinkageType(..),+ defaultLinkage,+ VisibilityStyle(..),+ defaultVisibility,+ ParamAttribute(..),+ FunctionAttribute(..),+ TargetTriple(..),+ Assembly(..),+ AtomicOperation(..),+ LandingPadClause(..),+ AtomicOrdering(..),+ defaultAtomicOrdering,+ SynchronizationScope(..),+ defaultSynchronizationScope+ ) where++#include "c++/llvm-base-enums.h"++import Control.DeepSeq+import Data.Text ( Text, unpack )++-- | Types of symbol linkage. Note that LTLinkerPrivateWeakDefAuto is+-- only available in llvm < 3.2.+{#enum LinkageType {} deriving (Eq) #}+instance Show LinkageType where+ show LTExternal = ""+ show LTAvailableExternally = "available_externally"+ show LTLinkOnceAny = "linkonce"+ show LTLinkOnceODR = "linkonce_odr"+ show LTWeakAny = "weak"+ show LTWeakODR = "weak_odr"+ show LTAppending = "appending"+ show LTInternal = "internal"+ show LTPrivate = "private"+ show LTLinkerPrivate = "linker_private"+ show LTLinkerPrivateWeak = "linker_private_weak"+ show LTLinkerPrivateWeakDefAuto = "linker_private_weak_def_auto"+ show LTDLLImport = "dllimport"+ show LTDLLExport = "dllexport"+ show LTExternalWeak = "extern_weak"+ show LTCommon = "common"++instance NFData LinkageType+defaultLinkage :: LinkageType+defaultLinkage = LTExternal++{#enum VisibilityStyle {} deriving (Eq) #}++instance Show VisibilityStyle where+ show VisibilityDefault = ""+ show VisibilityHidden = "hidden"+ show VisibilityProtected = "protected"++instance NFData VisibilityStyle+defaultVisibility :: VisibilityStyle+defaultVisibility = VisibilityDefault++{#enum CAtomicOrdering as AtomicOrdering {} deriving (Eq) #}++instance Show AtomicOrdering where+ show OrderNotAtomic = ""+ show OrderUnordered = "unordered"+ show OrderMonotonic = "monotonic"+ show OrderAcquire = "acquire"+ show OrderRelease = "release"+ show OrderAcquireRelease = "acq_rel"+ show OrderSequentiallyConsistent = "seq_cst"++instance NFData AtomicOrdering+defaultAtomicOrdering :: AtomicOrdering+defaultAtomicOrdering = OrderNotAtomic++{#enum CSynchronizationScope as SynchronizationScope {} deriving (Eq) #}++instance Show SynchronizationScope where+ show SSSingleThread = "singlethread"+ show SSCrossThread = ""++instance NFData SynchronizationScope+defaultSynchronizationScope :: SynchronizationScope+defaultSynchronizationScope = SSCrossThread++{#enum AtomicOperation {} deriving (Eq) #}++instance Show AtomicOperation where+ show AOXchg = "xchg"+ show AOAdd = "add"+ show AOSub = "sub"+ show AOAnd = "and"+ show AONand = "nand"+ show AOOr = "or"+ show AOXor = "xor"+ show AOMax = "max"+ show AOMin = "min"+ show AOUMax = "umax"+ show AOUMin = "umin"++instance NFData AtomicOperation++{#enum LandingPadClause {} deriving (Eq) #}++instance Show LandingPadClause where+ show LPCatch = "catch"+ show LPFilter = "filter"++instance NFData LandingPadClause++{#enum ArithFlags {} deriving (Eq) #}++instance Show ArithFlags where+ show ArithNone = ""+ show ArithNUW = "nuw"+ show ArithNSW = "nsw"+ show ArithBoth = "nuw nsw"++instance NFData ArithFlags+defaultArithFlags :: ArithFlags+defaultArithFlags = ArithNone++{#enum CmpPredicate {underscoreToCase} deriving (Eq) #}++instance Show CmpPredicate where+ show FCmpFalse = "false"+ show FCmpOeq = "oeq"+ show FCmpOgt = "ogt"+ show FCmpOge = "oge"+ show FCmpOlt = "olt"+ show FCmpOle = "ole"+ show FCmpOne = "one"+ show FCmpOrd = "ord"+ show FCmpUno = "uno"+ show FCmpUeq = "ueq"+ show FCmpUgt = "ugt"+ show FCmpUge = "uge"+ show FCmpUlt = "ult"+ show FCmpUle = "ule"+ show FCmpUne = "une"+ show FCmpTrue = "true"+ show ICmpEq = "eq"+ show ICmpNe = "ne"+ show ICmpUgt = "ugt"+ show ICmpUge = "uge"+ show ICmpUlt = "ult"+ show ICmpUle = "ule"+ show ICmpSgt = "sgt"+ show ICmpSge = "sge"+ show ICmpSlt = "slt"+ show ICmpSle = "sle"++instance NFData CmpPredicate+++{#enum CallingConvention {} deriving (Eq) #}+instance Show CallingConvention where+ show CC_C = ""+ show CC_FAST = "fastcc"+ show CC_COLD = "coldcc"+ show CC_GHC = "cc 10"+ show CC_X86_STDCALL = "cc 64"+ show CC_X86_FASTCALL = "cc 65"+ show CC_ARM_APCS = "cc 66"+ show CC_ARM_AAPCS = "cc 67"+ show CC_ARM_AAPCS_VFP = "cc 68"+ show CC_MSP430_INTR = "cc 69"+ show CC_X86_THISCALL = "cc 70"+ show CC_PTX_KERNEL = "cc 71"+ show CC_PTX_DEVICE = "cc 72"+ show CC_MBLAZE_INTR = "cc 73"+ show CC_MBLAZE_SVOL = "cc 74"++instance NFData CallingConvention+defaultCallingConvention :: CallingConvention+defaultCallingConvention = CC_C++ -- Representing Assembly+data Assembly = Assembly !Text+ deriving (Eq, Ord)++instance Show Assembly where+ show (Assembly txt) = unpack txt++instance NFData Assembly where+ rnf a@(Assembly txt) = txt `seq` a `seq` ()+++-- Param attributes++data ParamAttribute = PAZeroExt+ | PASignExt+ | PAInReg+ | PAByVal+ | PASRet+ | PANoAlias+ | PANoCapture+ | PANest+ | PAAlign !Int+ deriving (Eq, Ord)++instance NFData ParamAttribute++instance Show ParamAttribute where+ show PAZeroExt = "zeroext"+ show PASignExt = "signext"+ show PAInReg = "inreg"+ show PAByVal = "byval"+ show PASRet = "sret"+ show PANoAlias = "noalias"+ show PANoCapture = "nocapture"+ show PANest = "nest"+ show (PAAlign i) = "align " ++ show i++-- Function Attributes++data FunctionAttribute = FAAlignStack !Int+ | FAAlwaysInline+ | FAHotPatch+ | FAInlineHint+ | FANaked+ | FANoImplicitFloat+ | FANoInline+ | FANoRedZone+ | FANoReturn+ | FANoUnwind+ | FAOptSize+ | FAReadNone+ | FAReadOnly+ | FASSP+ | FASSPReq+ deriving (Eq, Ord)++instance NFData FunctionAttribute++instance Show FunctionAttribute where+ show (FAAlignStack n) = "alignstack(" ++ show n ++ ")"+ show FAAlwaysInline = "alwaysinline"+ show FAHotPatch = "hotpatch"+ show FAInlineHint = "inlinehint"+ show FANaked = "naked"+ show FANoImplicitFloat = "noimplicitfloat"+ show FANoInline = "noinline"+ show FANoRedZone = "noredzone"+ show FANoReturn = "noreturn"+ show FANoUnwind = "nounwind"+ show FAOptSize = "optsize"+ show FAReadNone = "readnone"+ show FAReadOnly = "readonly"+ show FASSP = "ssp"+ show FASSPReq = "sspreq"++data TargetTriple = TargetTriple Text+ deriving (Eq)++instance Show TargetTriple where+ show (TargetTriple t) = unpack t++instance NFData TargetTriple where+ rnf t@(TargetTriple t') = t' `seq` t `seq` ()
+ src/Data/LLVM/Types/Dwarf.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE StandaloneDeriving #-}+module Data.LLVM.Types.Dwarf (+ -- * Types+ module Data.Dwarf,+ DW_TAG(..),+ dw_tag+ ) where++import Data.Dwarf hiding ( DW_TAG(..) )++deriving instance Ord DW_LANG+deriving instance Ord DW_VIRTUALITY+deriving instance Ord DW_ATE+deriving instance Ord DW_TAG++data DW_TAG+ = DW_TAG_array_type+ | DW_TAG_class_type+ | DW_TAG_entry_point+ | DW_TAG_enumeration_type+ | DW_TAG_formal_parameter+ | DW_TAG_imported_declaration+ | DW_TAG_label+ | DW_TAG_lexical_block+ | DW_TAG_member+ | DW_TAG_pointer_type+ | DW_TAG_reference_type+ | DW_TAG_compile_unit+ | DW_TAG_string_type+ | DW_TAG_structure_type+ | DW_TAG_subroutine_type+ | DW_TAG_typedef+ | DW_TAG_union_type+ | DW_TAG_unspecified_parameters+ | DW_TAG_variant+ | DW_TAG_common_block+ | DW_TAG_common_inclusion+ | DW_TAG_inheritance+ | DW_TAG_inlined_subroutine+ | DW_TAG_module+ | DW_TAG_ptr_to_member_type+ | DW_TAG_set_type+ | DW_TAG_subrange_type+ | DW_TAG_with_stmt+ | DW_TAG_access_declaration+ | DW_TAG_base_type+ | DW_TAG_catch_block+ | DW_TAG_const_type+ | DW_TAG_constant+ | DW_TAG_enumerator+ | DW_TAG_file_type+ | DW_TAG_friend+ | DW_TAG_namelist+ | DW_TAG_namelist_item+ | DW_TAG_packed_type+ | DW_TAG_subprogram+ | DW_TAG_template_type_parameter+ | DW_TAG_template_value_parameter+ | DW_TAG_thrown_type+ | DW_TAG_try_block+ | DW_TAG_variant_part+ | DW_TAG_variable+ | DW_TAG_volatile_type+ | DW_TAG_dwarf_procedure+ | DW_TAG_restrict_type+ | DW_TAG_interface_type+ | DW_TAG_namespace+ | DW_TAG_imported_module+ | DW_TAG_unspecified_type+ | DW_TAG_partial_unit+ | DW_TAG_imported_unit+ | DW_TAG_condition+ | DW_TAG_shared_type+ -- Added these since Data.Dwarf doesn't seem to support them+ | DW_TAG_auto_variable+ | DW_TAG_arg_variable+ | DW_TAG_return_variable+ deriving (Show, Eq)++-- | Copied from Data.Dwarf since it is not exported+dw_tag :: (Num a, Show a, Ord a) => a -> Maybe DW_TAG+dw_tag 0x01 = return DW_TAG_array_type+dw_tag 0x02 = return DW_TAG_class_type+dw_tag 0x03 = return DW_TAG_entry_point+dw_tag 0x04 = return DW_TAG_enumeration_type+dw_tag 0x05 = return DW_TAG_formal_parameter+dw_tag 0x08 = return DW_TAG_imported_declaration+dw_tag 0x0a = return DW_TAG_label+dw_tag 0x0b = return DW_TAG_lexical_block+dw_tag 0x0d = return DW_TAG_member+dw_tag 0x0f = return DW_TAG_pointer_type+dw_tag 0x10 = return DW_TAG_reference_type+dw_tag 0x11 = return DW_TAG_compile_unit+dw_tag 0x12 = return DW_TAG_string_type+dw_tag 0x13 = return DW_TAG_structure_type+dw_tag 0x15 = return DW_TAG_subroutine_type+dw_tag 0x16 = return DW_TAG_typedef+dw_tag 0x17 = return DW_TAG_union_type+dw_tag 0x18 = return DW_TAG_unspecified_parameters+dw_tag 0x19 = return DW_TAG_variant+dw_tag 0x1a = return DW_TAG_common_block+dw_tag 0x1b = return DW_TAG_common_inclusion+dw_tag 0x1c = return DW_TAG_inheritance+dw_tag 0x1d = return DW_TAG_inlined_subroutine+dw_tag 0x1e = return DW_TAG_module+dw_tag 0x1f = return DW_TAG_ptr_to_member_type+dw_tag 0x20 = return DW_TAG_set_type+dw_tag 0x21 = return DW_TAG_subrange_type+dw_tag 0x22 = return DW_TAG_with_stmt+dw_tag 0x23 = return DW_TAG_access_declaration+dw_tag 0x24 = return DW_TAG_base_type+dw_tag 0x25 = return DW_TAG_catch_block+dw_tag 0x26 = return DW_TAG_const_type+dw_tag 0x27 = return DW_TAG_constant+dw_tag 0x28 = return DW_TAG_enumerator+dw_tag 0x29 = return DW_TAG_file_type+dw_tag 0x2a = return DW_TAG_friend+dw_tag 0x2b = return DW_TAG_namelist+dw_tag 0x2c = return DW_TAG_namelist_item+dw_tag 0x2d = return DW_TAG_packed_type+dw_tag 0x2e = return DW_TAG_subprogram+dw_tag 0x2f = return DW_TAG_template_type_parameter+dw_tag 0x30 = return DW_TAG_template_value_parameter+dw_tag 0x31 = return DW_TAG_thrown_type+dw_tag 0x32 = return DW_TAG_try_block+dw_tag 0x33 = return DW_TAG_variant_part+dw_tag 0x34 = return DW_TAG_variable+dw_tag 0x35 = return DW_TAG_volatile_type+dw_tag 0x36 = return DW_TAG_dwarf_procedure+dw_tag 0x37 = return DW_TAG_restrict_type+dw_tag 0x38 = return DW_TAG_interface_type+dw_tag 0x39 = return DW_TAG_namespace+dw_tag 0x3a = return DW_TAG_imported_module+dw_tag 0x3b = return DW_TAG_unspecified_type+dw_tag 0x3c = return DW_TAG_partial_unit+dw_tag 0x3d = return DW_TAG_imported_unit+dw_tag 0x3f = return DW_TAG_condition+dw_tag 0x40 = return DW_TAG_shared_type+dw_tag 0x100 = return DW_TAG_auto_variable+dw_tag 0x101 = return DW_TAG_arg_variable+dw_tag 0x102 = return DW_TAG_return_variable+dw_tag n | 0x4080 <= n && n <= 0xffff = Nothing -- error $ "User DW_TAG data requires extension of parser for code " ++ show n+dw_tag _ = Nothing -- error $ "Unrecognized DW_TAG " ++ show n
+ src/Data/LLVM/Types/Identifiers.hs view
@@ -0,0 +1,76 @@+module Data.LLVM.Types.Identifiers (+ -- * Types+ Identifier,+ -- * Accessor+ identifierAsString,+ identifierContent,+ isAnonymousIdentifier,+ -- * Builders+ makeAnonymousLocal,+ makeLocalIdentifier,+ makeGlobalIdentifier,+ makeMetaIdentifier+ ) where++import Control.DeepSeq+import Data.Hashable+import Data.Text ( Text, unpack, pack )++data Identifier = LocalIdentifier { _identifierContent :: !Text+ , _identifierHash :: !Int+ }+ | AnonymousLocalIdentifier { _identifierNumber :: !Int }+ | GlobalIdentifier { _identifierContent :: !Text+ , _identifierHash :: !Int+ }+ | MetaIdentifier { _identifierContent :: !Text+ , _identifierHash :: !Int+ }+ deriving (Eq, Ord)++instance Show Identifier where+ show LocalIdentifier { _identifierContent = t } = '%' : unpack t+ show AnonymousLocalIdentifier { _identifierNumber = n } = '%' : show n+ show GlobalIdentifier { _identifierContent = t } = '@' : unpack t+ show MetaIdentifier { _identifierContent = t } = '!' : unpack t++instance Hashable Identifier where+ hashWithSalt s (AnonymousLocalIdentifier n) = s `hashWithSalt` n+ hashWithSalt s i = s `hashWithSalt` _identifierHash i++instance NFData Identifier where+ rnf AnonymousLocalIdentifier {} = ()+ rnf i = _identifierContent i `seq` _identifierHash i `seq` ()++makeAnonymousLocal :: Int -> Identifier+makeAnonymousLocal = AnonymousLocalIdentifier++makeLocalIdentifier :: Text -> Identifier+makeLocalIdentifier t =+ LocalIdentifier { _identifierContent = t+ , _identifierHash = hash t+ }++makeGlobalIdentifier :: Text -> Identifier+makeGlobalIdentifier t =+ GlobalIdentifier { _identifierContent = t+ , _identifierHash = hash t+ }++makeMetaIdentifier :: Text -> Identifier+makeMetaIdentifier t =+ MetaIdentifier { _identifierContent = t+ , _identifierHash = hash t+ }++identifierAsString :: Identifier -> String+identifierAsString (AnonymousLocalIdentifier n) = show n+identifierAsString i = unpack (identifierContent i)++identifierContent :: Identifier -> Text+identifierContent (AnonymousLocalIdentifier n) = pack (show n)+identifierContent i = _identifierContent i++isAnonymousIdentifier :: Identifier -> Bool+isAnonymousIdentifier AnonymousLocalIdentifier {} = True+isAnonymousIdentifier _ = False
+ src/Data/LLVM/Types/Referential.hs view
@@ -0,0 +1,1556 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}+module Data.LLVM.Types.Referential (+ -- * Basic Types+ Type(..),+ StructTypeNameError(..),+ structTypeToName,+ structBaseName,+ stripPointerTypes,+ UniqueId,+ IsValue(..),+ Value(..),+ toValue,+ valueContent',+ stripBitcasts,+ FromValue(..),+ -- * Functions+ Function(..),+ HasFunction(..),+ functionBody,+ functionInstructions,+ functionReturnType,+ functionExitBlock,+ functionExitBlocks,+ functionIsVararg,+ functionEntryInstruction,+ functionExitInstruction,+ functionExitInstructions,+ -- * External Functions+ ExternalFunction(..),+ externalIsIntrinsic,+ externalFunctionParameterTypes,+ -- * Arguments+ Argument(..),+ argumentIndex,+ -- * Basic Blocks+ BasicBlock(..),+ basicBlockInstructions,+ basicBlockTerminatorInstruction,+ firstNonPhiInstruction,+ isFirstNonPhiInstruction,+ basicBlockSplitPhiNodes,+ -- * Instructions+ Instruction(..),+ instructionType,+ instructionName,+ instructionFunction,+ instructionIsTerminator,+ instructionIsEntry,+ instructionIsPhiNode,+ instructionOperands,+ -- * Globals+ GlobalVariable(..),+ GlobalAlias(..),+ ExternalValue(..),+ -- * Constants+ Constant(..),+ -- * Metadata+ Metadata(..),+ -- * Debug info+ llvmDebugVersion+ ) where++import Control.DeepSeq+import Control.Exception+import Control.Failure+import Data.Hashable+import Data.Int+import Data.List ( elemIndex )+import Data.Ord ( comparing )+import Data.Text ( Text, isPrefixOf )+import qualified Data.Text as T+import Data.Typeable+import Data.Vector ( Vector )+import qualified Data.Vector as V+import Data.Word ( Word64 )+import Text.Printf+import Text.Regex.TDFA++import Data.LLVM.Types.Attributes+import Data.LLVM.Types.Dwarf+import Data.LLVM.Types.Identifiers++-- | This is the version of LLVM's debug information that this library+-- supports.+llvmDebugVersion :: Integer+llvmDebugVersion = 524288++-- This isn't very honest, but Values are part of Modules and+-- are fully evaluated before the module is constructed.+instance NFData Instruction where+ rnf _ = ()+instance NFData Value where+ rnf _ = ()+instance NFData BasicBlock where+ rnf _ = ()+instance NFData Function where+ rnf _ = ()+instance NFData Argument where+ rnf _ = ()+instance NFData Type where+ rnf _ = ()++-- | The type system of LLVM+data Type = TypeInteger !Int+ -- ^ Integral types; the parameter holds the number of+ -- bits required to represent the type.+ | TypeFloat+ | TypeDouble+ | TypeFP128+ | TypeX86FP80+ | TypePPCFP128+ | TypeX86MMX+ | TypeVoid+ | TypeLabel+ | TypeMetadata+ | TypeArray !Int Type+ -- ^ Fixed-length arrays, where the Int holds the number+ -- of elements in arrays of this type.+ | TypeVector !Int Type+ -- ^ Vectors with a fixed length. These are vectors in+ -- the SSE sense.+ | TypeFunction Type [Type] !Bool+ -- ^ Functions with a return type, list of argument types,+ -- and a flag that denotes whether or not the function+ -- accepts varargs+ | TypePointer Type !Int+ | TypeStruct (Either Word64 Text) [Type] !Bool+ -- ^ Struct types have a list of types in thes struct and+ -- a flag that is True if they are packed. Named structs+ -- have a (Right stringName) as the name. Anonymous+ -- structs have a meaningless (but unique within the+ -- Module) integer identifier in the (Left structId).++data StructTypeNameError = NotStructType+ deriving (Typeable, Show)++-- | Strip off the struct. prefix and any .NNN suffixes added by LLVM+-- to a struct type name. If the type is not a struct type, return+-- Nothing.+structTypeToName :: (Failure StructTypeNameError m) => Type -> m String+structTypeToName (TypeStruct (Right n) _ _) =+ return $ structBaseName (T.unpack n)+structTypeToName _ = failure NotStructType++structBaseName :: String -> String+structBaseName s =+ let pfx:_ = captures+ in pfx+ where+ pattern :: String+ pattern = "([[:alpha:]]+\\.[:<> [:alnum:]_]+)(\\.[[:digit:]]+)*"+ m :: (String, String, String, [String])+ m = s =~ pattern+ (_, _, _, captures) = m+++-- | Take a type and remove all of its pointer wrappers+stripPointerTypes :: Type -> Type+stripPointerTypes t =+ case t of+ TypePointer t' _ -> stripPointerTypes t'+ _ -> t+++-- Deriving an Ord instance won't work because Type is a cyclic data+-- structure and the derived instances end up stuck in infinite loops.+-- Defining a more traditional one that just breaks cycles is really+-- tedious here, so just base Ord off of equality and then make the+-- ordering arbitrary (but consistent) based on the Hashable instance.+instance Ord Type where+ compare = compareType++compareType :: Type -> Type -> Ordering+compareType ty1 ty2+ | ty1 == ty2 = EQ+ | otherwise =+ case (ty1, ty2) of+ (TypeStruct (Right n1) _ _, TypeStruct (Right n2) _ _) ->+ compare n1 n2+ (TypeStruct (Left n1) _ _, TypeStruct (Left n2) _ _) ->+ compare n1 n2+ (TypePointer t1 p1, TypePointer t2 p2) -> compare (t1, p1) (t2, p2)+ (TypeArray i1 t1, TypeArray i2 t2) -> compare (i1, t1) (i2, t2)+ (TypeVector i1 t1, TypeVector i2 t2) -> compare (i1, t1) (i2, t2)+ (TypeFunction r1 ts1 v1, TypeFunction r2 ts2 v2) ->+ compare (r1, ts1, v1) (r2, ts2, v2)+ _ -> compare (typeOrdKey ty1) (typeOrdKey ty2)++typeOrdKey :: Type -> Int+typeOrdKey (TypeInteger i) = negate i+typeOrdKey TypeFloat = 1+typeOrdKey TypeDouble = 2+typeOrdKey TypeFP128 = 3+typeOrdKey TypeX86MMX = 4+typeOrdKey TypeX86FP80 = 5+typeOrdKey TypePPCFP128 = 6+typeOrdKey TypeVoid = 7+typeOrdKey TypeLabel = 8+typeOrdKey TypeMetadata = 9+typeOrdKey (TypeArray _ _) = 10+typeOrdKey (TypeVector _ _) = 11+typeOrdKey (TypeFunction _ _ _) = 12+typeOrdKey (TypePointer _ _) = 13+typeOrdKey (TypeStruct (Right _) _ _) = 14+typeOrdKey (TypeStruct (Left _) _ _) = 15++instance Hashable Type where+ hashWithSalt s (TypeInteger i) =+ s `hashWithSalt` (1 :: Int) `hashWithSalt` i+ hashWithSalt s TypeFloat = s `hashWithSalt` (2 :: Int)+ hashWithSalt s TypeDouble = s `hashWithSalt` (3 :: Int)+ hashWithSalt s TypeFP128 = s `hashWithSalt` (4 :: Int)+ hashWithSalt s TypeX86FP80 = s `hashWithSalt` (5 :: Int)+ hashWithSalt s TypePPCFP128 = s `hashWithSalt` (6 :: Int)+ hashWithSalt s TypeX86MMX = s `hashWithSalt` (7 :: Int)+ hashWithSalt s TypeVoid = s `hashWithSalt` (8 :: Int)+ hashWithSalt s TypeLabel = s `hashWithSalt` (9 :: Int)+ hashWithSalt s TypeMetadata = s `hashWithSalt` (10 :: Int)+ hashWithSalt s (TypeArray i t) =+ s `hashWithSalt` (11 :: Int) `hashWithSalt` i `hashWithSalt` t+ hashWithSalt s (TypeVector i t) =+ s `hashWithSalt` (12 :: Int) `hashWithSalt` i `hashWithSalt` t+ hashWithSalt s (TypeFunction r ts v) =+ s `hashWithSalt` (13 :: Int) `hashWithSalt` r `hashWithSalt` ts `hashWithSalt` v+ hashWithSalt s (TypePointer t as) =+ s `hashWithSalt` (15 :: Int) `hashWithSalt` t `hashWithSalt` as+ hashWithSalt s (TypeStruct (Right n) _ _) =+ s `hashWithSalt` (16 :: Int) `hashWithSalt` n+ hashWithSalt s (TypeStruct (Left tid) _ p) =+ s `hashWithSalt` (17 :: Int) `hashWithSalt` tid `hashWithSalt` p++instance Eq Type where+ TypeInteger i1 == TypeInteger i2 = i1 == i2+ TypeFloat == TypeFloat = True+ TypeDouble == TypeDouble = True+ TypeFP128 == TypeFP128 = True+ TypeX86FP80 == TypeX86FP80 = True+ TypePPCFP128 == TypePPCFP128 = True+ TypeX86MMX == TypeX86MMX = True+ TypeVoid == TypeVoid = True+ TypeLabel == TypeLabel = True+ TypeMetadata == TypeMetadata = True+ TypeArray i1 t1 == TypeArray i2 t2 = i1 == i2 && t1 == t2+ TypeVector i1 t1 == TypeVector i2 t2 = i1 == i2 && t1 == t2+ TypeFunction r1 ts1 v1 == TypeFunction r2 ts2 v2 =+ v1 == v2 && r1 == r2 && ts1 == ts2+ TypePointer t1 as1 == TypePointer t2 as2 = t1 == t2 && as1 == as2+ TypeStruct (Right n1) _ _ == TypeStruct (Right n2) _ _ = n1 == n2+ TypeStruct (Left tid1) _ _ == TypeStruct (Left tid2) _ _ =+ tid1 == tid2+ _ == _ = False++data Metadata =+ MetaSourceLocation { metaValueUniqueId :: UniqueId+ , metaSourceRow :: !Int32+ , metaSourceCol :: !Int32+ , metaSourceScope :: Maybe Metadata+ }+ | MetaDWLexicalBlock { metaValueUniqueId :: UniqueId+ , metaLexicalBlockRow :: !Int32+ , metaLexicalBlockCol :: !Int32+ , metaLexicalBlockContext :: Maybe Metadata+ }+ | MetaDWNamespace { metaValueUniqueId :: UniqueId+ , metaNamespaceContext :: Maybe Metadata+ , metaNamespaceName :: !Text+ , metaNamespaceLine :: !Int32+ }+ | MetaDWCompileUnit { metaValueUniqueId :: UniqueId+ , metaCompileUnitLanguage :: !DW_LANG+ , metaCompileUnitSourceFile :: !Text+ , metaCompileUnitCompileDir :: !Text+ , metaCompileUnitProducer :: !Text+ , metaCompileUnitIsMain :: !Bool+ -- ^ This field is always False in LLVM >= 3.3+ , metaCompileUnitIsOpt :: !Bool+ , metaCompileUnitFlags :: !Text+ , metaCompileUnitVersion :: !Int32+ , metaCompileUnitEnumTypes :: [Maybe Metadata]+ , metaCompileUnitRetainedTypes :: [Maybe Metadata]+ , metaCompileUnitSubprograms :: [Maybe Metadata]+ , metaCompileUnitGlobalVariables :: [Maybe Metadata]+ }+ | MetaDWFile { metaValueUniqueId :: UniqueId+ , metaFileSourceFile :: !Text+ , metaFileSourceDir :: !Text+ }+ | MetaDWVariable { metaValueUniqueId :: UniqueId+ , metaGlobalVarContext :: Maybe Metadata+ , metaGlobalVarName :: !Text+ , metaGlobalVarDisplayName :: !Text+ , metaGlobalVarLinkageName :: !Text+ , metaGlobalVarLine :: !Int32+ , metaGlobalVarType :: Maybe Metadata+ , metaGlobalVarStatic :: !Bool+ , metaGlobalVarNotExtern :: !Bool+ }+ | MetaDWSubprogram { metaValueUniqueId :: UniqueId+ , metaSubprogramContext :: Maybe Metadata+ , metaSubprogramName :: !Text+ , metaSubprogramDisplayName :: !Text+ , metaSubprogramLinkageName :: !Text+ , metaSubprogramLine :: !Int32+ , metaSubprogramType :: Maybe Metadata+ , metaSubprogramIsExplicit :: !Bool+ , metaSubprogramIsPrototyped :: !Bool+ , metaSubprogramStatic :: !Bool+ , metaSubprogramNotExtern :: !Bool+ , metaSubprogramVirtuality :: !DW_VIRTUALITY+ , metaSubprogramVirtIndex :: !Int32+ , metaSubprogramBaseType :: Maybe Metadata+ , metaSubprogramArtificial :: !Bool+ , metaSubprogramOptimized :: !Bool+ }+ | MetaDWBaseType { metaValueUniqueId :: UniqueId+ , metaBaseTypeContext :: Maybe Metadata+ , metaBaseTypeName :: !Text+ , metaBaseTypeFilename :: !Text+ , metaBaseTypeDirectory :: !Text+ , metaBaseTypeLine :: !Int32+ , metaBaseTypeSize :: !Int64+ , metaBaseTypeAlign :: !Int64+ , metaBaseTypeOffset :: !Int64+ , metaBaseTypeFlags :: !Int32+ , metaBaseTypeEncoding :: !DW_ATE+ }+ | MetaDWDerivedType { metaValueUniqueId :: UniqueId+ , metaDerivedTypeTag :: !DW_TAG+ , metaDerivedTypeContext :: Maybe Metadata+ , metaDerivedTypeName :: !Text+ , metaDerivedTypeFilename :: !Text+ , metaDerivedTypeDirectory :: !Text+ , metaDerivedTypeLine :: !Int32+ , metaDerivedTypeSize :: !Int64+ , metaDerivedTypeAlign :: !Int64+ , metaDerivedTypeOffset :: !Int64+ , metaDerivedTypeIsArtificial :: !Bool+ , metaDerivedTypeIsVirtual :: !Bool+ , metaDerivedTypeIsForward :: !Bool+ , metaDerivedTypeIsPrivate :: !Bool+ , metaDerivedTypeIsProtected :: !Bool+ , metaDerivedTypeParent :: Maybe Metadata+ }+ | MetaDWCompositeType { metaValueUniqueId :: UniqueId+ , metaCompositeTypeTag :: !DW_TAG+ , metaCompositeTypeContext :: Maybe Metadata+ , metaCompositeTypeName :: !Text+ , metaCompositeTypeFilename :: !Text+ , metaCompositeTypeDirectory :: !Text+ , metaCompositeTypeLine :: !Int32+ , metaCompositeTypeSize :: !Int64+ , metaCompositeTypeAlign :: !Int64+ , metaCompositeTypeOffset :: !Int64+ , metaCompositeTypeFlags :: !Int32+ , metaCompositeTypeParent :: Maybe Metadata+ , metaCompositeTypeMembers :: Maybe Metadata+ , metaCompositeTypeRuntime :: !Int32+ , metaCompositeTypeContainer :: Maybe Metadata+ , metaCompositeTypeTemplateParams :: Maybe Metadata+ , metaCompositeTypeIsArtificial :: !Bool+ , metaCompositeTypeIsVirtual :: !Bool+ , metaCompositeTypeIsForward :: !Bool+ , metaCompositeTypeIsProtected :: !Bool+ , metaCompositeTypeIsPrivate :: !Bool+ , metaCompositeTypeIsByRefStruct :: !Bool+ }+ | MetaDWSubrange { metaValueUniqueId :: UniqueId+ , metaSubrangeLow :: !Int64+ , metaSubrangeHigh :: !Int64+ }+ | MetaDWEnumerator { metaValueUniqueId :: UniqueId+ , metaEnumeratorName :: !Text+ , metaEnumeratorValue :: !Int64+ }+ | MetaDWLocal { metaValueUniqueId :: UniqueId+ , metaLocalTag :: !DW_TAG+ , metaLocalContext :: Maybe Metadata+ , metaLocalName :: !Text+ , metaLocalLine :: !Int32+ , metaLocalArgNo :: !Int32+ , metaLocalType :: Maybe Metadata+ , metaLocalIsArtificial :: !Bool+ , metaLocalIsBlockByRefVar :: !Bool+ , metaLocalAddrElements :: [Int64]+ }+ | MetaDWTemplateTypeParameter { metaValueUniqueId :: UniqueId+ , metaTemplateTypeParameterContext :: Maybe Metadata+ , metaTemplateTypeParameterType :: Maybe Metadata+ , metaTemplateTypeParameterLine :: !Int32+ , metaTemplateTypeParameterCol :: !Int32+ , metaTemplateTypeParameterName :: !Text+ }+ | MetaDWTemplateValueParameter { metaValueUniqueId :: UniqueId+ , metaTemplateValueParameterContext :: Maybe Metadata+ , metaTemplateValueParameterType :: Maybe Metadata+ , metaTemplateValueParameterLine :: !Int32+ , metaTemplateValueParameterCol :: !Int32+ , metaTemplateValueParameterValue :: !Int64+ , metaTemplateValueParameterName :: !Text+ }+ | MetadataUnknown { metaValueUniqueId :: UniqueId+ , metaUnknownValue :: !Text+ }+ | MetadataList { metaValueUniqueId :: UniqueId+ , metaListElements :: [Maybe Metadata]+ }++-- | The type of the unique identifiers that let us to work with+-- 'Value's and 'Metadata`, despite the cycles in the object graph.+-- These ids are typically used as hash keys and give objects of these+-- types identity.+type UniqueId = Int++instance Eq Metadata where+ mv1 == mv2 = metaValueUniqueId mv1 == metaValueUniqueId mv2++instance Ord Metadata where+ compare = comparing metaValueUniqueId++instance Hashable Metadata where+ hashWithSalt s = hashWithSalt s . metaValueUniqueId++-- | A wrapper around 'ValueT' values that tracks the 'Type', name,+-- and attached metadata. valueName is mostly informational at this+-- point. All references will be resolved as part of the graph, but+-- the name will be useful for visualization purposes and+-- serialization.+-- data Value = forall a . IsValue a => Value a++-- Functions have parameters if they are not external+data Value = FunctionC Function+ | ArgumentC Argument+ | BasicBlockC BasicBlock+ | GlobalVariableC GlobalVariable+ | GlobalAliasC GlobalAlias+ | ExternalValueC ExternalValue+ | ExternalFunctionC ExternalFunction+ | InstructionC Instruction+ | ConstantC Constant++class IsValue a where+ valueType :: a -> Type+ valueName :: a -> Maybe Identifier+ valueMetadata :: a -> [Metadata]+ valueContent :: a -> Value+ valueUniqueId :: a -> UniqueId++instance IsValue Value where+ valueType a =+ case a of+ FunctionC f -> functionType f+ ArgumentC arg -> argumentType arg+ BasicBlockC _ -> TypeLabel+ GlobalVariableC g -> globalVariableType g+ GlobalAliasC g -> valueType g+ ExternalValueC e -> externalValueType e+ ExternalFunctionC e -> externalFunctionType e+ InstructionC i -> instructionType i+ ConstantC c -> constantType c+ valueName a =+ case a of+ FunctionC f -> valueName f+ ArgumentC arg -> valueName arg+ BasicBlockC b -> valueName b+ GlobalVariableC g -> valueName g+ GlobalAliasC g -> valueName g+ ExternalValueC e -> valueName e+ ExternalFunctionC e -> valueName e+ InstructionC i -> valueName i+ ConstantC _ -> Nothing+ valueMetadata a =+ case a of+ FunctionC f -> functionMetadata f+ ArgumentC arg -> argumentMetadata arg+ BasicBlockC b -> basicBlockMetadata b+ GlobalVariableC g -> globalVariableMetadata g+ GlobalAliasC g -> valueMetadata g+ ExternalValueC e -> externalValueMetadata e+ ExternalFunctionC e -> externalFunctionMetadata e+ InstructionC i -> instructionMetadata i+ ConstantC _ -> []+ valueContent = id+ valueUniqueId a =+ case a of+ FunctionC f -> functionUniqueId f+ ArgumentC arg -> argumentUniqueId arg+ BasicBlockC b -> basicBlockUniqueId b+ GlobalVariableC g -> globalVariableUniqueId g+ GlobalAliasC g -> valueUniqueId g+ ExternalValueC e -> externalValueUniqueId e+ ExternalFunctionC e -> externalFunctionUniqueId e+ InstructionC i -> instructionUniqueId i+ ConstantC c -> constantUniqueId c++toValue :: (IsValue a) => a -> Value+toValue = valueContent++data FailedCast = FailedCast String+ deriving (Typeable, Show)++instance Exception FailedCast++-- | Safely convert a 'Value' to a concrete type (like Argument or+-- Instruction). This is most useful in pure Monads that handle+-- failure, like Maybe, MaybeT, and Either. If the requested+-- conversion is not possible, the normal failure semantics are+-- provided. Example:+--+-- >+class FromValue a where+ fromValue :: (Failure FailedCast f) => Value -> f a++instance FromValue Constant where+ fromValue v =+ case valueContent' v of+ ConstantC c -> return c+ _ -> failure $! FailedCast "Constant"++instance FromValue GlobalAlias where+ fromValue v =+ case valueContent' v of+ GlobalAliasC g -> return g+ _ -> failure $! FailedCast "GlobalAlias"++instance FromValue ExternalValue where+ fromValue v =+ case valueContent' v of+ ExternalValueC e -> return e+ _ -> failure $! FailedCast "ExternalValue"++instance FromValue GlobalVariable where+ fromValue v =+ case valueContent' v of+ GlobalVariableC g -> return g+ _ -> failure $! FailedCast "GlobalVariable"++instance FromValue Argument where+ fromValue v =+ case valueContent' v of+ ArgumentC a -> return a+ _ -> failure $! FailedCast "Argument"++instance FromValue Function where+ fromValue v =+ case valueContent' v of+ FunctionC f -> return f+ _ -> failure $! FailedCast "Function"++instance FromValue Instruction where+ fromValue v =+ case valueContent' v of+ InstructionC i -> return i+ _ -> failure $! FailedCast "Instruction"++instance FromValue ExternalFunction where+ fromValue v =+ case valueContent' v of+ ExternalFunctionC f -> return f+ _ -> failure $! FailedCast "ExternalFunction"++instance FromValue BasicBlock where+ fromValue v =+ case valueContent' v of+ BasicBlockC b -> return b+ _ -> failure $! FailedCast "BasicBlock"+++instance Eq Value where+ (==) = valueEq++{-# INLINE valueEq #-}+valueEq :: Value -> Value -> Bool+valueEq v1 v2 =+ valueUniqueId v1 == valueUniqueId v2++instance Ord Value where+ v1 `compare` v2 = comparing valueUniqueId v1 v2++instance Hashable Value where+ hashWithSalt s = hashWithSalt s . valueUniqueId++class HasFunction a where+ getFunction :: a -> Function++instance HasFunction Function where+ getFunction = id++data Function = Function { functionType :: Type+ , functionName :: !Identifier+ , functionMetadata :: [Metadata]+ , functionUniqueId :: UniqueId+ , functionParameters :: [Argument]+ , functionBodyVector :: Vector BasicBlock+ , functionLinkage :: !LinkageType+ , functionVisibility :: !VisibilityStyle+ , functionCC :: !CallingConvention+ , functionRetAttrs :: [ParamAttribute]+ , functionAttrs :: [FunctionAttribute]+ , functionSection :: !(Maybe Text)+ , functionAlign :: !Int64+ , functionGCName :: !(Maybe Text)+ }++functionIsVararg :: Function -> Bool+functionIsVararg Function { functionType = TypeFunction _ _ isva } = isva+functionIsVararg v = error $ printf "Value %d is not a function" (valueUniqueId v)++{-# INLINABLE functionReturnType #-}+functionReturnType :: Function -> Type+functionReturnType f = rt where+ TypeFunction rt _ _ = functionType f++{-# INLINABLE functionBody #-}+functionBody :: Function -> [BasicBlock]+functionBody = V.toList . functionBodyVector++{-# INLINABLE functionInstructions #-}+functionInstructions :: Function -> [Instruction]+functionInstructions = concatMap basicBlockInstructions . functionBody++functionEntryInstruction :: Function -> Instruction+functionEntryInstruction f = e1+ where+ (bb1:_) = functionBody f+ (e1:_) = basicBlockInstructions bb1++-- | Get the ret instruction for a Function+functionExitInstruction :: Function -> Maybe Instruction+functionExitInstruction f =+ case filter isRetInst is of+ [] -> Nothing -- error $ "Function has no ret instruction: " ++ show (functionName f)+ [ri] -> Just ri+ _ -> Nothing -- error $ "Function has multiple ret instructions: " ++ show (functionName f)+ where+ is = concatMap basicBlockInstructions (functionBody f)+ isRetInst RetInst {} = True+ isRetInst _ = False++-- | Get all exit instructions for a Function (ret, unreachable, unwind)+functionExitInstructions :: Function -> [Instruction]+functionExitInstructions f = filter isRetInst is+ where+ is = concatMap basicBlockInstructions (functionBody f)+ isRetInst RetInst {} = True+ isRetInst UnreachableInst {} = True+ isRetInst _ = False++functionExitBlock :: Function -> BasicBlock+functionExitBlock f =+ case filter terminatorIsExitInst bbs of+ [] -> error $ "Function has no ret instruction: " ++ show (functionName f)+ [rb] -> rb+ _ -> error $ "Function has multiple ret instructions: " ++ show (functionName f)+ where+ bbs = functionBody f+ terminatorIsExitInst bb =+ case basicBlockTerminatorInstruction bb of+ RetInst {} -> True+ _ -> False++functionExitBlocks :: Function -> [BasicBlock]+functionExitBlocks f =+ case filter terminatorIsExitInst bbs of+ [] -> error $ "Function has no ret instruction: " ++ show (functionName f)+ rbs -> rbs+ where+ bbs = functionBody f+ terminatorIsExitInst bb =+ case basicBlockTerminatorInstruction bb of+ RetInst {} -> True+ UnreachableInst {} -> True+ ResumeInst {} -> True+ _ -> False++instance IsValue Function where+ valueType = functionType+ valueName = Just . functionName+ valueMetadata = functionMetadata+ valueContent = FunctionC+ valueUniqueId = functionUniqueId++instance Eq Function where+ f1 == f2 = functionUniqueId f1 == functionUniqueId f2++instance Hashable Function where+ hashWithSalt s = hashWithSalt s . functionUniqueId++instance Ord Function where+ f1 `compare` f2 = comparing functionUniqueId f1 f2++data Argument = Argument { argumentType :: Type+ , argumentName :: !Identifier+ , argumentMetadata :: [Metadata]+ , argumentUniqueId :: UniqueId+ , argumentParamAttrs :: [ParamAttribute]+ , argumentFunction :: Function+ }++instance IsValue Argument where+ valueType = argumentType+ valueName = Just . argumentName+ valueMetadata = argumentMetadata+ valueContent = ArgumentC+ valueUniqueId = argumentUniqueId++instance Hashable Argument where+ hashWithSalt s = hashWithSalt s . argumentUniqueId++instance Eq Argument where+ a1 == a2 = argumentUniqueId a1 == argumentUniqueId a2++instance Ord Argument where+ a1 `compare` a2 = comparing argumentUniqueId a1 a2++-- | Find the zero-based index into the argument list of the 'Function'+-- containing this 'Argument'.+argumentIndex :: Argument -> Int+argumentIndex a = ix+ where+ f = argumentFunction a+ Just ix = elemIndex a (functionParameters f)++data BasicBlock = BasicBlock { basicBlockName :: !Identifier+ , basicBlockMetadata :: [Metadata]+ , basicBlockUniqueId :: UniqueId+ , basicBlockInstructionVector :: Vector Instruction+ , basicBlockFunction :: Function+ }++{-# INLINABLE basicBlockInstructions #-}+basicBlockInstructions :: BasicBlock -> [Instruction]+basicBlockInstructions = V.toList . basicBlockInstructionVector++{-# INLINABLE basicBlockTerminatorInstruction #-}+basicBlockTerminatorInstruction :: BasicBlock -> Instruction+basicBlockTerminatorInstruction = V.last . basicBlockInstructionVector++{-# INLINABLE firstNonPhiInstruction #-}+-- | Get the first instruction in a basic block that is not a Phi+-- node. This is total because basic blocks cannot be empty and must+-- end in a terminator instruction (Phi nodes are not terminators).+firstNonPhiInstruction :: BasicBlock -> Instruction+firstNonPhiInstruction bb = i+ where+ i : _ = dropWhile instructionIsPhiNode (basicBlockInstructions bb)++{-# INLINABLE instructionIsPhiNode #-}+-- | Predicate to test an instruction to see if it is a phi node+instructionIsPhiNode :: Instruction -> Bool+instructionIsPhiNode v = case v of+ PhiNode {} -> True+ _ -> False++{-# INLINABLE isFirstNonPhiInstruction #-}+-- | Determine if @i@ is the first non-phi instruction in its block.+isFirstNonPhiInstruction :: Instruction -> Bool+isFirstNonPhiInstruction i = i == firstNonPhiInstruction bb+ where+ Just bb = instructionBasicBlock i++{-# INLINABLE basicBlockSplitPhiNodes #-}+-- | Split a block's instructions into phi nodes and the rest+basicBlockSplitPhiNodes :: BasicBlock -> ([Instruction], [Instruction])+basicBlockSplitPhiNodes = span instructionIsPhiNode . basicBlockInstructions++instance IsValue BasicBlock where+ valueType _ = TypeLabel+ valueName = Just . basicBlockName+ valueMetadata = basicBlockMetadata+ valueContent = BasicBlockC+ valueUniqueId = basicBlockUniqueId++instance Hashable BasicBlock where+ hashWithSalt s = hashWithSalt s . basicBlockUniqueId++instance Eq BasicBlock where+ f1 == f2 = basicBlockUniqueId f1 == basicBlockUniqueId f2++instance Ord BasicBlock where+ b1 `compare` b2 = comparing basicBlockUniqueId b1 b2++data GlobalVariable = GlobalVariable { globalVariableType :: Type+ , globalVariableName :: !Identifier+ , globalVariableMetadata :: [Metadata]+ , globalVariableUniqueId :: UniqueId+ , globalVariableLinkage :: !LinkageType+ , globalVariableVisibility :: !VisibilityStyle+ , globalVariableInitializer :: Maybe Value+ , globalVariableAlignment :: !Int64+ , globalVariableSection :: !(Maybe Text)+ , globalVariableIsThreadLocal :: !Bool+ , globalVariableIsConstant :: !Bool+ }++instance IsValue GlobalVariable where+ valueType = globalVariableType+ valueName = Just . globalVariableName+ valueMetadata = globalVariableMetadata+ valueContent = GlobalVariableC+ valueUniqueId = globalVariableUniqueId++instance Eq GlobalVariable where+ f1 == f2 = globalVariableUniqueId f1 == globalVariableUniqueId f2++instance Hashable GlobalVariable where+ hashWithSalt s = hashWithSalt s . globalVariableUniqueId++instance Ord GlobalVariable where+ g1 `compare` g2 = comparing globalVariableUniqueId g1 g2++data GlobalAlias = GlobalAlias { globalAliasTarget :: Value+ , globalAliasLinkage :: !LinkageType+ , globalAliasName :: !Identifier+ , globalAliasVisibility :: !VisibilityStyle+ , globalAliasMetadata :: [Metadata]+ , globalAliasUniqueId :: UniqueId+ }++instance IsValue GlobalAlias where+ valueType = valueType . globalAliasTarget+ valueName = Just . globalAliasName+ valueMetadata = globalAliasMetadata+ valueContent = GlobalAliasC+ valueUniqueId = globalAliasUniqueId++instance Eq GlobalAlias where+ f1 == f2 = globalAliasUniqueId f1 == globalAliasUniqueId f2++instance Hashable GlobalAlias where+ hashWithSalt s = hashWithSalt s . globalAliasUniqueId++instance Ord GlobalAlias where+ g1 `compare` g2 = comparing globalAliasUniqueId g1 g2++data ExternalValue = ExternalValue { externalValueType :: Type+ , externalValueName :: !Identifier+ , externalValueMetadata :: [Metadata]+ , externalValueUniqueId :: UniqueId+ }++instance IsValue ExternalValue where+ valueType = externalValueType+ valueName = Just . externalValueName+ valueMetadata = externalValueMetadata+ valueContent = ExternalValueC+ valueUniqueId = externalValueUniqueId++instance Eq ExternalValue where+ f1 == f2 = externalValueUniqueId f1 == externalValueUniqueId f2++instance Hashable ExternalValue where+ hashWithSalt s = hashWithSalt s . externalValueUniqueId++instance Ord ExternalValue where+ e1 `compare` e2 = comparing externalValueUniqueId e1 e2++data ExternalFunction = ExternalFunction { externalFunctionType :: Type+ , externalFunctionName :: !Identifier+ , externalFunctionMetadata :: [Metadata]+ , externalFunctionUniqueId :: UniqueId+ , externalFunctionAttrs :: [FunctionAttribute]+ }++instance Show ExternalFunction where+ show = show . externalFunctionName++instance IsValue ExternalFunction where+ valueType = externalFunctionType+ valueName = Just . externalFunctionName+ valueMetadata = externalFunctionMetadata+ valueContent = ExternalFunctionC+ valueUniqueId = externalFunctionUniqueId++instance Eq ExternalFunction where+ f1 == f2 = externalFunctionUniqueId f1 == externalFunctionUniqueId f2++instance Hashable ExternalFunction where+ hashWithSalt s = hashWithSalt s . externalFunctionUniqueId++instance Ord ExternalFunction where+ f1 `compare` f2 = comparing externalFunctionUniqueId f1 f2++externalFunctionParameterTypes :: ExternalFunction -> [Type]+externalFunctionParameterTypes ef = ts+ where+ TypeFunction _ ts _ = externalFunctionType ef++externalIsIntrinsic :: ExternalFunction -> Bool+externalIsIntrinsic =+ isPrefixOf "llvm." . identifierContent . externalFunctionName+++{-# INLINABLE instructionIsTerminator #-}+-- | Determine if an instruction is a Terminator instruction (i.e.,+-- ends a BasicBlock)+instructionIsTerminator :: Instruction -> Bool+instructionIsTerminator RetInst {} = True+instructionIsTerminator UnconditionalBranchInst {} = True+instructionIsTerminator BranchInst {} = True+instructionIsTerminator SwitchInst {} = True+instructionIsTerminator IndirectBranchInst {} = True+instructionIsTerminator ResumeInst {} = True+instructionIsTerminator UnreachableInst {} = True+instructionIsTerminator InvokeInst {} = True+instructionIsTerminator _ = False++instructionIsEntry :: Instruction -> Bool+instructionIsEntry i = i == ei+ where+ ei = V.unsafeHead $ basicBlockInstructionVector bb+ Just bb = instructionBasicBlock i++instructionFunction :: Instruction -> Maybe Function+instructionFunction i = do+ bb <- instructionBasicBlock i+ return $ basicBlockFunction bb++instructionType :: Instruction -> Type+instructionType i =+ case i of+ RetInst {} -> TypeVoid+ UnconditionalBranchInst {} -> TypeVoid+ BranchInst {} -> TypeVoid+ SwitchInst {} -> TypeVoid+ IndirectBranchInst {} -> TypeVoid+ ResumeInst {} -> TypeVoid+ UnreachableInst {} -> TypeVoid+ StoreInst {} -> TypeVoid+ FenceInst {} -> TypeVoid+ AtomicCmpXchgInst {} -> TypeVoid+ AtomicRMWInst {} -> TypeVoid+ _ -> _instructionType i++instructionName :: Instruction -> Maybe Identifier+instructionName i =+ case i of+ RetInst {} -> Nothing+ UnconditionalBranchInst {} -> Nothing+ BranchInst {} -> Nothing+ SwitchInst {} -> Nothing+ IndirectBranchInst {} -> Nothing+ ResumeInst {} -> Nothing+ UnreachableInst {} -> Nothing+ StoreInst {} -> Nothing+ FenceInst {} -> Nothing+ AtomicCmpXchgInst {} -> Nothing+ AtomicRMWInst {} -> Nothing+ _ -> _instructionName i++data Instruction = RetInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , retInstValue :: Maybe Value+ }+ | UnconditionalBranchInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , unconditionalBranchTarget :: BasicBlock+ }+ | BranchInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , branchCondition :: Value+ , branchTrueTarget :: BasicBlock+ , branchFalseTarget :: BasicBlock+ }+ | SwitchInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , switchValue :: Value+ , switchDefaultTarget :: BasicBlock+ , switchCases :: [(Value, BasicBlock)]+ }+ | IndirectBranchInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , indirectBranchAddress :: Value+ , indirectBranchTargets :: [BasicBlock]+ }+ -- ^ The target must be derived from a blockaddress constant+ -- The list is a list of possible target destinations+ | ResumeInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , resumeException :: Value+ }+ | UnreachableInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ }+ | ExtractElementInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , extractElementVector :: Value+ , extractElementIndex :: Value+ }+ | InsertElementInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , insertElementVector :: Value+ , insertElementValue :: Value+ , insertElementIndex :: Value+ }+ | ShuffleVectorInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , shuffleVectorV1 :: Value+ , shuffleVectorV2 :: Value+ , shuffleVectorMask :: Value+ }+ | ExtractValueInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , extractValueAggregate :: Value+ , extractValueIndices :: [Int]+ }+ | InsertValueInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , insertValueAggregate :: Value+ , insertValueValue :: Value+ , insertValueIndices :: [Int]+ }+ | AllocaInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , allocaNumElements :: Value+ , allocaAlign :: !Int64+ }+ | LoadInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , loadIsVolatile :: !Bool+ , loadAddress :: Value+ , loadAlignment :: !Int64+ }+ | StoreInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , storeIsVolatile :: !Bool+ , storeValue :: Value+ , storeAddress :: Value+ , storeAlignment :: !Int64+ , storeAddressSpace :: !Int+ }+ | FenceInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , fenceOrdering :: !AtomicOrdering+ , fenceScope :: !SynchronizationScope+ }+ | AtomicCmpXchgInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , atomicCmpXchgOrdering :: !AtomicOrdering+ , atomicCmpXchgScope :: !SynchronizationScope+ , atomicCmpXchgIsVolatile :: !Bool+ , atomicCmpXchgAddressSpace :: !Int+ , atomicCmpXchgPointer :: Value+ , atomicCmpXchgComparison :: Value+ , atomicCmpXchgNewValue :: Value+ }+ | AtomicRMWInst { instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , atomicRMWOrdering :: !AtomicOrdering+ , atomicRMWScope :: !SynchronizationScope+ , atomicRMWOperation :: !AtomicOperation+ , atomicRMWIsVolatile :: !Bool+ , atomicRMWPointer :: Value+ , atomicRMWValue :: Value+ , atomicRMWAddressSpace :: !Int+ }+ | AddInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryArithFlags :: !ArithFlags+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | SubInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryArithFlags :: !ArithFlags+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | MulInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryArithFlags :: !ArithFlags+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | DivInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | RemInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | ShlInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | LshrInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | AshrInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | AndInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | OrInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | XorInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , binaryLhs :: Value+ , binaryRhs :: Value+ }+ | TruncInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | ZExtInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | SExtInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | FPTruncInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | FPExtInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | FPToSIInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | FPToUIInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | SIToFPInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | UIToFPInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | PtrToIntInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | IntToPtrInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | BitcastInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , castedValue :: Value+ }+ | ICmpInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , cmpPredicate :: !CmpPredicate+ , cmpV1 :: Value+ , cmpV2 :: Value+ }+ | FCmpInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , cmpPredicate :: !CmpPredicate+ , cmpV1 :: Value+ , cmpV2 :: Value+ }+ | SelectInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , selectCondition :: Value+ , selectTrueValue :: Value+ , selectFalseValue :: Value+ }+ | CallInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , callIsTail :: !Bool+ , callConvention :: !CallingConvention+ , callParamAttrs :: [ParamAttribute]+ , callFunction :: Value+ , callArguments :: [(Value, [ParamAttribute])]+ , callAttrs :: [FunctionAttribute]+ , callHasSRet :: !Bool+ }+ | GetElementPtrInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , getElementPtrInBounds :: !Bool+ , getElementPtrValue :: Value+ , getElementPtrIndices :: [Value]+ , getElementPtrAddrSpace :: !Int+ }+ | InvokeInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , invokeConvention :: !CallingConvention+ , invokeParamAttrs :: [ParamAttribute]+ , invokeFunction :: Value+ , invokeArguments :: [(Value, [ParamAttribute])]+ , invokeAttrs :: [FunctionAttribute]+ , invokeNormalLabel :: BasicBlock+ , invokeUnwindLabel :: BasicBlock+ , invokeHasSRet :: !Bool+ }+ | VaArgInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , vaArgValue :: Value+ }+ | LandingPadInst { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , landingPadPersonality :: Value+ , landingPadIsCleanup :: !Bool+ , landingPadClauses :: [(Value, LandingPadClause)]+ }+ | PhiNode { _instructionType :: Type+ , _instructionName :: !(Maybe Identifier)+ , instructionMetadata :: [Metadata]+ , instructionUniqueId :: UniqueId+ , instructionBasicBlock :: Maybe BasicBlock+ , phiIncomingValues :: [(Value, Value)]+ }+instance IsValue Instruction where+ valueType = instructionType+ valueName = instructionName+ valueMetadata = instructionMetadata+ valueContent = InstructionC+ valueUniqueId = instructionUniqueId++instance Eq Instruction where+ i1 == i2 = instructionUniqueId i1 == instructionUniqueId i2++instance Hashable Instruction where+ hashWithSalt s = hashWithSalt s . instructionUniqueId++instance Ord Instruction where+ i1 `compare` i2 = comparing instructionUniqueId i1 i2++-- | Return all of the operands for an instruction. Note that "special"+-- operands (like the 'Type' in a vararg inst) cannot be returned. For+-- Phi nodes, only the incoming values (not their sources) are returned.+instructionOperands :: Instruction -> [Value]+instructionOperands i =+ case i of+ RetInst { retInstValue = rv } -> maybe [] (:[]) rv+ UnconditionalBranchInst { } -> []+ BranchInst { branchCondition = c } -> [c]+ SwitchInst { switchValue = v } -> [v]+ IndirectBranchInst { indirectBranchAddress = a } -> [a]+ ResumeInst { resumeException = e } -> [e]+ UnreachableInst { } -> []+ ExtractElementInst { extractElementVector = v+ , extractElementIndex = ix+ } -> [v, ix]+ InsertElementInst { insertElementVector = v+ , insertElementIndex = ix+ , insertElementValue = val+ } -> [v, ix, val]+ ShuffleVectorInst { shuffleVectorV1 = v1+ , shuffleVectorV2 = v2+ , shuffleVectorMask = m+ } -> [v1, v2, m]+ ExtractValueInst { extractValueAggregate = a } -> [a]+ InsertValueInst { insertValueAggregate = a+ , insertValueValue = v+ } -> [a, v]+ AllocaInst { allocaNumElements = n } -> [n]+ LoadInst { loadAddress = la } -> [la]+ StoreInst { storeValue = sv, storeAddress = sa } -> [sv, sa]+ FenceInst { } -> []+ AtomicCmpXchgInst { atomicCmpXchgPointer = p+ , atomicCmpXchgNewValue = nv+ , atomicCmpXchgComparison = c+ } -> [p, nv, c]+ AtomicRMWInst { atomicRMWPointer = p+ , atomicRMWValue = v+ } -> [p, v]+ AddInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ SubInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ MulInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ DivInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ RemInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ ShlInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ LshrInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ AshrInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ AndInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ OrInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ XorInst { binaryLhs = lhs+ , binaryRhs = rhs+ } -> [lhs, rhs]+ TruncInst { castedValue = cv } -> [cv]+ ZExtInst { castedValue = cv } -> [cv]+ SExtInst { castedValue = cv } -> [cv]+ FPTruncInst { castedValue = cv } -> [cv]+ FPExtInst { castedValue = cv } -> [cv]+ FPToSIInst { castedValue = cv } -> [cv]+ FPToUIInst { castedValue = cv } -> [cv]+ SIToFPInst { castedValue = cv } -> [cv]+ UIToFPInst { castedValue = cv } -> [cv]+ PtrToIntInst { castedValue = cv } -> [cv]+ IntToPtrInst { castedValue = cv } -> [cv]+ BitcastInst { castedValue = cv } -> [cv]+ ICmpInst { cmpV1 = v1, cmpV2 = v2 } -> [v1, v2]+ FCmpInst { cmpV1 = v1, cmpV2 = v2 } -> [v1, v2]+ SelectInst { selectCondition = c+ , selectTrueValue = t+ , selectFalseValue = f+ } -> [c, t, f]+ CallInst { callFunction = cf+ , callArguments = (map fst -> args)+ } -> cf : args+ GetElementPtrInst { getElementPtrValue = v+ , getElementPtrIndices = ixs+ } -> v : ixs+ InvokeInst { invokeFunction = cf+ , invokeArguments = (map fst -> args)+ } -> cf : args+ VaArgInst { vaArgValue = v } -> [v]+ LandingPadInst { landingPadPersonality = p+ , landingPadClauses = (map fst -> clauses)+ } -> p : clauses+ PhiNode { phiIncomingValues = (map fst -> ivs) } -> ivs++++data Constant = UndefValue { constantType :: Type+ , constantUniqueId :: UniqueId+ }+ | ConstantAggregateZero { constantType :: Type+ , constantUniqueId :: UniqueId+ }+ | ConstantPointerNull { constantType :: Type+ , constantUniqueId :: UniqueId+ }+ | BlockAddress { constantType :: Type+ , constantUniqueId :: UniqueId+ , blockAddressFunction :: Function+ , blockAddressBlock :: BasicBlock+ }+ | ConstantArray { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantArrayValues :: [Value]+ }+ | ConstantFP { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantFPValue :: !Double+ }+ | ConstantInt { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantIntValue :: !Integer+ }+ | ConstantString { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantStringValue :: !Text+ }+ | ConstantStruct { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantStructValues :: [Value]+ }+ | ConstantVector { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantVectorValues :: [Value]+ }+ | ConstantValue { constantType :: Type+ , constantUniqueId :: UniqueId+ , constantInstruction :: Instruction+ }+ | InlineAsm { constantType :: Type+ , constantUniqueId :: UniqueId+ , inlineAsmString :: !Text+ , inlineAsmConstraints :: !Text+ }++instance IsValue Constant where+ valueType = constantType+ valueName _ = Nothing+ valueMetadata _ = []+ valueContent = ConstantC+ valueUniqueId = constantUniqueId++instance Eq Constant where+ c1 == c2 = constantUniqueId c1 == constantUniqueId c2++instance Hashable Constant where+ hashWithSalt s = hashWithSalt s . constantUniqueId++instance Ord Constant where+ c1 `compare` c2 = comparing constantUniqueId c1 c2++{-# INLINABLE valueContent' #-}+-- | A version of @valueContent@ that ignores (peeks through)+-- bitcasts. This is most useful in view patterns.+valueContent' :: IsValue a => a -> Value+valueContent' v =+ case valueContent v of+ InstructionC BitcastInst { castedValue = cv } -> valueContent' cv+ ConstantC ConstantValue { constantInstruction = BitcastInst { castedValue = cv } } -> valueContent' cv+ _ -> valueContent v++{-# INLINABLE stripBitcasts #-}+-- | Strip all wrapper bitcasts from a Value+stripBitcasts :: IsValue a => a -> Value+stripBitcasts v =+ case valueContent v of+ InstructionC BitcastInst { castedValue = cv } -> stripBitcasts cv+ ConstantC ConstantValue { constantInstruction = BitcastInst { castedValue = cv } } -> stripBitcasts cv+ _ -> valueContent v
+ src/c++/llvm-base-enums.h view
@@ -0,0 +1,250 @@+#include <stdint.h>++/*!+ Arithmetic flags+ */+typedef enum {+ ArithNone,+ ArithNUW,+ ArithNSW,+ ArithBoth+} ArithFlags;++/*!+ Possible predicates for the icmp and fcmp instructions+ */+typedef enum {+ F_CMP_FALSE,+ F_CMP_OEQ,+ F_CMP_OGT,+ F_CMP_OGE,+ F_CMP_OLT,+ F_CMP_OLE,+ F_CMP_ONE,+ F_CMP_ORD,+ F_CMP_UNO,+ F_CMP_UEQ,+ F_CMP_UGT,+ F_CMP_UGE,+ F_CMP_ULT,+ F_CMP_ULE,+ F_CMP_UNE,+ F_CMP_TRUE,+ I_CMP_EQ,+ I_CMP_NE,+ I_CMP_UGT,+ I_CMP_UGE,+ I_CMP_ULT,+ I_CMP_ULE,+ I_CMP_SGT,+ I_CMP_SGE,+ I_CMP_SLT,+ I_CMP_SLE+} CmpPredicate;++/*!+ Function calling conventions+ */+typedef enum {+ CC_C,+ CC_FAST,+ CC_COLD,+ CC_GHC,+ CC_X86_STDCALL,+ CC_X86_FASTCALL,+ CC_ARM_APCS,+ CC_ARM_AAPCS,+ CC_ARM_AAPCS_VFP,+ CC_MSP430_INTR,+ CC_X86_THISCALL,+ CC_PTX_KERNEL,+ CC_PTX_DEVICE,+ CC_MBLAZE_INTR,+ CC_MBLAZE_SVOL+} CallingConvention;++/*!+ Type tags+ */+typedef enum {+ TYPE_VOID,+ TYPE_FLOAT,+ TYPE_DOUBLE,+ TYPE_X86_FP80,+ TYPE_FP128,+ TYPE_PPC_FP128,+ TYPE_LABEL,+ TYPE_METADATA,+ TYPE_X86_MMX,+ TYPE_INTEGER,+ TYPE_FUNCTION,+ TYPE_STRUCT,+ TYPE_ARRAY,+ TYPE_POINTER,+ TYPE_VECTOR+} TypeTag;++/*!+ Metadata tags+*/+typedef enum {+ META_LOCATION,+ META_DERIVEDTYPE,+ META_COMPOSITETYPE,+ META_BASICTYPE,+ META_VARIABLE,+ META_SUBPROGRAM,+ META_GLOBALVARIABLE,+ META_FILE,+ META_COMPILEUNIT,+ META_NAMESPACE,+ META_LEXICALBLOCK,+ META_SUBRANGE,+ META_ENUMERATOR,+ META_ARRAY,+ META_TEMPLATETYPEPARAMETER,+ META_TEMPLATEVALUEPARAMETER,+ META_UNKNOWN /* For unknown pieces of metadata */+} MetaTag;++/*!+ Value tags+ */+typedef enum {+ VAL_ARGUMENT,+ VAL_BASICBLOCK,+ // Constants+ VAL_INLINEASM,+ VAL_BLOCKADDRESS,+ VAL_CONSTANTAGGREGATEZERO,+ VAL_CONSTANTARRAY,+ VAL_CONSTANTFP,+ VAL_CONSTANTINT,+ VAL_CONSTANTPOINTERNULL,+ VAL_CONSTANTSTRUCT,+ VAL_CONSTANTVECTOR,+ VAL_UNDEFVALUE,+ VAL_CONSTANTEXPR,+ // Insts+ VAL_RETINST, // 0 or 1 operand+ VAL_BRANCHINST, // 1 or 3 operands+ VAL_SWITCHINST, // op[0] = switchval, op[1] = default dest, op[2n]+ // = value to match, op[2n+1] = dest for match+ VAL_INDIRECTBRINST, // op[0] = address, rest are possible dests+ VAL_INVOKEINST,+ VAL_RESUMEINST,+ VAL_UNREACHABLEINST,+ VAL_ADDINST,+ VAL_FADDINST,+ VAL_SUBINST,+ VAL_FSUBINST,+ VAL_MULINST,+ VAL_FMULINST,+ VAL_UDIVINST,+ VAL_SDIVINST,+ VAL_FDIVINST,+ VAL_UREMINST,+ VAL_SREMINST,+ VAL_FREMINST,+ VAL_SHLINST,+ VAL_LSHRINST,+ VAL_ASHRINST,+ VAL_ANDINST,+ VAL_ORINST,+ VAL_XORINST,+ VAL_ALLOCAINST,+ VAL_LOADINST,+ VAL_STOREINST,+ VAL_GETELEMENTPTRINST,+ VAL_FENCEINST,+ VAL_ATOMICCMPXCHGINST,+ VAL_ATOMICRMWINST,+ VAL_TRUNCINST,+ VAL_ZEXTINST,+ VAL_SEXTINST,+ VAL_FPTOUIINST,+ VAL_FPTOSIINST,+ VAL_UITOFPINST,+ VAL_SITOFPINST,+ VAL_FPTRUNCINST,+ VAL_FPEXTINST,+ VAL_PTRTOINTINST,+ VAL_INTTOPTRINST,+ VAL_BITCASTINST,+ VAL_ICMPINST,+ VAL_FCMPINST,+ VAL_PHINODE,+ VAL_CALLINST,+ VAL_SELECTINST, // 0 = condition, 1 = trueval, 2 = falseval+ VAL_VAARGINST,+ VAL_EXTRACTELEMENTINST, // 0 = vector, 1 = index+ VAL_INSERTELEMENTINST, // 0 = vector, 1 = value, 2 = index+ VAL_SHUFFLEVECTORINST, // 0 = v1, 1 = v2, v3 = mask+ VAL_EXTRACTVALUEINST,+ VAL_INSERTVALUEINST,+ VAL_LANDINGPADINST,+ // Globals+ VAL_FUNCTION,+ VAL_GLOBALVARIABLE,+ VAL_ALIAS+} ValueTag;+++typedef enum {+ LTExternal,+ LTAvailableExternally,+ LTLinkOnceAny,+ LTLinkOnceODR,+ LTWeakAny,+ LTWeakODR,+ LTAppending,+ LTInternal,+ LTPrivate,+ LTLinkerPrivate,+ LTLinkerPrivateWeak,+ LTLinkerPrivateWeakDefAuto,+ LTDLLImport,+ LTDLLExport,+ LTExternalWeak,+ LTCommon+} LinkageType;++typedef enum {+ VisibilityDefault,+ VisibilityHidden,+ VisibilityProtected+} VisibilityStyle;++typedef enum {+ OrderNotAtomic,+ OrderUnordered,+ OrderMonotonic,+ OrderAcquire,+ OrderRelease,+ OrderAcquireRelease,+ OrderSequentiallyConsistent+} CAtomicOrdering;++typedef enum {+ SSSingleThread,+ SSCrossThread+} CSynchronizationScope;++typedef enum {+ AOXchg,+ AOAdd,+ AOSub,+ AOAnd,+ AONand,+ AOOr,+ AOXor,+ AOMax,+ AOMin,+ AOUMax,+ AOUMin+} AtomicOperation;++typedef enum {+ LPCatch,+ LPFilter+} LandingPadClause;