diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for llvm-pretty + +## 0.12.0.0 (January 2024) + +* Add preliminary support for LLVM versions up through 17. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# `llvm-pretty` + +A pretty printing library that was inspired by the LLVM binding by Lennart +Augustsson. The library provides a monadic interface to a pretty printer, that +allows functions to be defined and called, generating the corresponding LLVM +assembly when run. + +## LLVM language feature support + +Currently, `llvm-pretty` supports LLVM versions up through 17. As a result of +the broad version coverage, the `llvm-pretty` AST is a superset of all versions +of the LLVM AST. This means that the manner in which certain information is +presented in the `llvm-pretty` AST (e.g., during pretty printing) will be +different depending on the LLVM version used to originate the information. +Conversely, it is possible to construct an `llvm-pretty` AST that cannot be +represented in a specific (or any) LLVM version. + +`llvm-pretty` strives to support a reasonable variety of [LLVM language +features](https://llvm.org/docs/LangRef.html), but there are places where our +coverage of the LLVM language is incomplete. If you need a LLVM feature that is +not currently supported by `llvm-pretty`, please [file an +issue](https://github.com/elliottt/llvm-pretty/issues/new). + +## `llvm-pretty` versus `llvm-pretty-bc-parser` + +`llvm-pretty` supports almost everything that one would want to do with LLVM +ASTs. One notable exception is parsing: `llvm-pretty` deliberately does not +support parsing an LLVM module AST from a bitcode file. This functionality is +factored out into a separate +[`llvm-pretty-bc-parser`](https://github.com/GaloisInc/llvm-pretty-bc-parser) +library. `llvm-pretty-bc-parser` generally tries to stay in sync with all of +the LLVM language features that `llvm-pretty` supports, but it may be the case +that some valid `llvm-pretty` ASTs cannot be parsed by `llvm-pretty-bc-parser`. +If you encounter an occurrence of this issue, please [file an +issue](https://github.com/GaloisInc/llvm-pretty-bc-parser/issues/new) at the +`llvm-pretty-bc-parser` issue tracker. diff --git a/llvm-pretty.cabal b/llvm-pretty.cabal --- a/llvm-pretty.cabal +++ b/llvm-pretty.cabal @@ -1,12 +1,12 @@ +Cabal-version: 2.2 Name: llvm-pretty -Version: 0.11.0 -License: BSD3 +Version: 0.12.0.0 +License: BSD-3-Clause License-file: LICENSE Author: Trevor Elliott -Maintainer: awesomelyawesome@gmail.com +Maintainer: rscott@galois.com, kquick@galois.com Category: Text Build-type: Simple -Cabal-version: >=1.16 Synopsis: A pretty printing library inspired by the llvm binding. Description: A pretty printing library that was inspired by the LLVM binding by Lennart @@ -14,15 +14,21 @@ that allows functions to be defined and called, generating the corresponding LLVM assembly when run. tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2 +extra-doc-files: CHANGELOG.md, README.md source-repository head type: git location: http://github.com/elliottt/llvm-pretty -Library +common common Default-language: Haskell2010 + Ghc-options: + -Wall +Library + Import: common + Hs-source-dirs: src Exposed-modules: Text.LLVM Text.LLVM.AST @@ -32,16 +38,41 @@ Text.LLVM.Parser Text.LLVM.PP Text.LLVM.DebugUtils - Other-modules: Text.LLVM.Util + Text.LLVM.Triple + Text.LLVM.Triple.AST + Text.LLVM.Triple.Parse + Text.LLVM.Triple.Print + Other-modules: Text.LLVM.Triple.Parse.ARM + Text.LLVM.Triple.Parse.LookupTable + Text.LLVM.Util - Build-depends: base >= 4 && < 5, + Build-depends: base >= 4.9 && < 5, containers >= 0.4, parsec >= 3, pretty >= 1.0.1, monadLib >= 3.6.1, microlens >= 0.4, microlens-th >= 0.4, + syb >= 0.7, template-haskell >= 2.7, - th-abstraction >= 0.3.1 && <0.4 + th-abstraction >= 0.3.1 && <0.7 - Ghc-options: -Wall +Test-suite llvm-pretty-test + Import: common + Type: exitcode-stdio-1.0 + Main-is: Main.hs + Other-modules: + Output + Triple + TQQDefs + Hs-source-dirs: test + Ghc-options: + -threaded + Build-depends: + llvm-pretty, + base, + pretty, + tasty, + tasty-hunit, + template-haskell, + text diff --git a/src/Text/LLVM.hs b/src/Text/LLVM.hs --- a/src/Text/LLVM.hs +++ b/src/Text/LLVM.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeOperators #-} @@ -7,11 +6,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - module Text.LLVM ( -- * LLVM Monad LLVM() @@ -120,11 +114,7 @@ import qualified Data.Sequence as Seq import qualified Data.Map.Strict as Map -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ( Applicative ) -#endif - -- Fresh Names ----------------------------------------------------------------- type Names = Map.Map String Int @@ -189,12 +179,14 @@ -- | Emit a declaration. declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value) declare rty sym tys va = emitDeclare Declare - { decRetType = rty - , decName = sym - , decArgs = tys - , decVarArgs = va - , decAttrs = [] - , decComdat = Nothing + { decLinkage = Nothing + , decVisibility = Nothing + , decRetType = rty + , decName = sym + , decArgs = tys + , decVarArgs = va + , decAttrs = [] + , decComdat = Nothing } -- | Emit a global declaration. @@ -222,14 +214,16 @@ -- Function Definition --------------------------------------------------------- data FunAttrs = FunAttrs - { funLinkage :: Maybe Linkage - , funGC :: Maybe GC + { funLinkage :: Maybe Linkage + , funVisibility :: Maybe Visibility + , funGC :: Maybe GC } deriving (Show) emptyFunAttrs :: FunAttrs emptyFunAttrs = FunAttrs - { funLinkage = Nothing - , funGC = Nothing + { funLinkage = Nothing + , funVisibility = Nothing + , funGC = Nothing } @@ -273,17 +267,18 @@ define attrs rty fun sig k = do (args,body) <- defineBody [] sig k emitDefine Define - { defLinkage = funLinkage attrs - , defName = fun - , defRetType = rty - , defArgs = args - , defVarArgs = False - , defAttrs = [] - , defSection = Nothing - , defGC = funGC attrs - , defBody = body - , defMetadata = Map.empty - , defComdat = Nothing + { defLinkage = funLinkage attrs + , defVisibility = funVisibility attrs + , defName = fun + , defRetType = rty + , defArgs = args + , defVarArgs = False + , defAttrs = [] + , defSection = Nothing + , defGC = funGC attrs + , defBody = body + , defMetadata = Map.empty + , defComdat = Nothing } -- | A combination of define and @freshSymbol@. @@ -301,17 +296,18 @@ define' attrs rty sym sig va k = do args <- mapM freshArg sig emitDefine Define - { defLinkage = funLinkage attrs - , defName = sym - , defRetType = rty - , defArgs = args - , defVarArgs = va - , defAttrs = [] - , defSection = Nothing - , defGC = funGC attrs - , defBody = snd (runBB (k (map (fmap toValue) args))) - , defMetadata = Map.empty - , defComdat = Nothing + { defLinkage = funLinkage attrs + , defVisibility = funVisibility attrs + , defName = sym + , defRetType = rty + , defArgs = args + , defVarArgs = va + , defAttrs = [] + , defSection = Nothing + , defGC = funGC attrs + , defBody = snd (runBB (k (map (fmap toValue) args))) + , defMetadata = Map.empty + , defComdat = Nothing } -- Basic Block Monad ----------------------------------------------------------- @@ -626,11 +622,8 @@ where es = fmap toValue `fmap` mb -load :: IsValue a => Typed a -> Maybe Align -> BB (Typed Value) -load tv ma = - case typedType tv of - PtrTo ty -> observe ty (Load (toValue `fmap` tv) Nothing ma) - _ -> error "load not given a pointer" +load :: IsValue a => Type -> Typed a -> Maybe Align -> BB (Typed Value) +load ty ptr ma = observe ty (Load ty (toValue `fmap` ptr) Nothing ma) store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB () store a ptr ma = @@ -702,7 +695,7 @@ getelementptr :: IsValue a => Type -> Typed a -> [Typed Value] -> BB (Typed Value) -getelementptr ty ptr ixs = observe ty (GEP False (toValue `fmap` ptr) ixs) +getelementptr ty ptr ixs = observe ty (GEP False ty (toValue `fmap` ptr) ixs) -- | Emit a call instruction, and generate a new variable for its result. call :: IsValue a => Typed a -> [Typed Value] -> BB (Typed Value) diff --git a/src/Text/LLVM/AST.hs b/src/Text/LLVM/AST.hs --- a/src/Text/LLVM/AST.hs +++ b/src/Text/LLVM/AST.hs @@ -1,15 +1,165 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -module Text.LLVM.AST where +{-# LANGUAGE DeriveLift #-} +module Text.LLVM.AST + ( -- * Modules + Module(..) + , emptyModule + -- * Named Metadata + , NamedMd(..) + -- * Unnamed Metadata + , UnnamedMd(..) + -- * Aliases + , GlobalAlias(..) + -- * Data Layout + , DataLayout + , LayoutSpec(..) + , Mangling(..) + , parseDataLayout + -- * Inline Assembly + , InlineAsm + -- * Comdat + , SelectionKind(..) + -- * Identifiers + , Ident(..) + -- * Symbols + , Symbol(..) + -- * Types + , PrimType(..) + , FloatType(..) + , Type, Type'(..) + , updateAliasesA, updateAliases + , isFloatingPoint + , isAlias + , isPrimTypeOf + , isLabel + , isInteger + , isVector + , isVectorOf + , isArray + , isPointer + , eqTypeModuloOpaquePtrs + , cmpTypeModuloOpaquePtrs + , fixupOpaquePtrs + -- * Null values + , NullResult(..) + , primTypeNull + , floatTypeNull + , typeNull + -- * Type Elimination + , elimFunTy + , elimAlias + , elimPtrTo + , elimVector + , elimArray + , elimFunPtr + , elimPrimType + , elimFloatType + , elimSequentialType + -- * Top-level Type Aliases + , TypeDecl(..) + -- * Globals + , Global(..) + , addGlobal + , GlobalAttrs(..) + , emptyGlobalAttrs + -- * Declarations + , Declare(..) + , decFunType + -- * Function Definitions + , Define(..) + , defFunType, addDefine + -- * Function Attributes and attribute groups + , FunAttr(..) + -- * Basic Block Labels + , BlockLabel(..) + -- * Basic Blocks + , BasicBlock'(..), BasicBlock + , brTargets + -- * Attributes + , Linkage(..) + , Visibility(..) + , GC(..) + -- * Typed Things + , Typed(..) + , mapMTyped + -- * Instructions + , ArithOp(..) + , isIArith + , isFArith + , UnaryArithOp(..) + , BitOp(..) + , ConvOp(..) + , AtomicRWOp(..) + , AtomicOrdering(..) + , Align + , Instr'(..), Instr + , Clause'(..), Clause + , isTerminator + , isComment + , isPhi + , ICmpOp(..) + , FCmpOp(..) + -- * Values + , Value'(..), Value + , FP80Value(..) + , ValMd'(..), ValMd + , KindMd + , FnMdAttachments + , GlobalMdAttachments + , DebugLoc'(..), DebugLoc + , isConst + -- * Value Elimination + , elimValSymbol + , elimValInteger + -- * Statements + , Stmt'(..), Stmt + , stmtInstr + , stmtMetadata + , extendMetadata + -- * Constant Expressions + , ConstExpr'(..), ConstExpr + -- * DWARF Debug Info + , DebugInfo'(..), DebugInfo + , DILabel, DILabel'(..) + , DIImportedEntity, DIImportedEntity'(..) + , DITemplateTypeParameter, DITemplateTypeParameter'(..) + , DITemplateValueParameter, DITemplateValueParameter'(..) + , DINameSpace, DINameSpace'(..) + , DwarfAttrEncoding + , DwarfLang + , DwarfTag + , DwarfVirtuality + , DIFlags + , DIEmissionKind + , DIBasicType(..) + , DICompileUnit'(..), DICompileUnit + , DICompositeType'(..), DICompositeType + , DIDerivedType'(..), DIDerivedType + , DIExpression(..) + , DIFile(..) + , DIGlobalVariable'(..), DIGlobalVariable + , DIGlobalVariableExpression'(..), DIGlobalVariableExpression + , DILexicalBlock'(..), DILexicalBlock + , DILexicalBlockFile'(..), DILexicalBlockFile + , DILocalVariable'(..), DILocalVariable + , DISubprogram'(..), DISubprogram + , DISubrange'(..), DISubrange + , DISubroutineType'(..), DISubroutineType + , DIArgList'(..), DIArgList + -- * Aggregate Utilities + , IndexResult(..) + , isInvalid + , resolveGepFull + , resolveGep + , resolveGepBody + , isGepIndex + , isGepStructIndex + , resolveValueIndex + ) where import Data.Functor.Identity (Identity(..)) import Data.Coerce (coerce) @@ -17,28 +167,27 @@ import Data.Typeable (Typeable) import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) import Data.Int (Int32,Int64) +import Data.Generics (everywhere, extQ, mkT, something) import Data.List (genericIndex,genericLength) import qualified Data.Map as Map +import Data.Maybe (isJust) import Data.Semigroup as Sem import Data.String (IsString(fromString)) import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic, Generic1) +import Language.Haskell.TH.Syntax (Lift) import Text.Parsec import Text.Parsec.String -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$)) -import Data.Foldable (Foldable(foldMap)) -import Data.Monoid (Monoid(..)) -import Data.Traversable (Traversable(sequenceA)) -#endif +import Text.LLVM.Triple.AST (TargetTriple) -- Modules --------------------------------------------------------------------- data Module = Module { modSourceName :: Maybe String + , modTriple :: TargetTriple -- ^ target triple , modDataLayout :: DataLayout -- ^ type size and alignment information , modTypes :: [TypeDecl] -- ^ top-level type aliases , modNamedMd :: [NamedMd] @@ -51,9 +200,11 @@ , modAliases :: [GlobalAlias] } deriving (Data, Eq, Ord, Generic, Show, Typeable) +-- | Combines fields pointwise. instance Sem.Semigroup Module where m1 <> m2 = Module { modSourceName = modSourceName m1 `mplus` modSourceName m2 + , modTriple = modTriple m1 <> modTriple m2 , modDataLayout = modDataLayout m1 <> modDataLayout m2 , modTypes = modTypes m1 <> modTypes m2 , modUnnamedMd = modUnnamedMd m1 <> modUnnamedMd m2 @@ -68,11 +219,12 @@ instance Monoid Module where mempty = emptyModule - mappend m1 m2 = m1 <> m2 + mappend = (<>) emptyModule :: Module emptyModule = Module { modSourceName = mempty + , modTriple = mempty , modDataLayout = mempty , modTypes = mempty , modNamedMd = mempty @@ -106,9 +258,11 @@ -- Aliases --------------------------------------------------------------------- data GlobalAlias = GlobalAlias - { aliasName :: Symbol - , aliasType :: Type - , aliasTarget :: Value + { aliasLinkage :: Maybe Linkage + , aliasVisibility :: Maybe Visibility + , aliasName :: Symbol + , aliasType :: Type + , aliasTarget :: Value } deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -215,7 +369,7 @@ -- Identifiers ----------------------------------------------------------------- newtype Ident = Ident String - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift) instance IsString Ident where fromString = Ident @@ -223,7 +377,7 @@ -- Symbols --------------------------------------------------------------------- newtype Symbol = Symbol String - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift) instance Sem.Semigroup Symbol where Symbol a <> Symbol b = Symbol (a <> b) @@ -244,7 +398,7 @@ | FloatType FloatType | X86mmx | Metadata - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift) data FloatType = Half @@ -253,7 +407,7 @@ | Fp128 | X86_fp80 | PPC_fp128 - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable, Lift) type Type = Type' Ident @@ -263,10 +417,32 @@ | Array Word64 (Type' ident) | FunTy (Type' ident) [Type' ident] Bool | PtrTo (Type' ident) + -- ^ A pointer to a memory location of a particular type. See also + -- 'PtrOpaque', which represents a pointer without a pointee type. + -- + -- LLVM pointers can also have an optional address space attribute, but this + -- is not currently represented in the @llvm-pretty@ AST. + | PtrOpaque + -- ^ A pointer to a memory location. Unlike 'PtrTo', a 'PtrOpaque' does not + -- have a pointee type. Instead, instructions interacting through opaque + -- pointers specify the type of the underlying memory they are interacting + -- with. + -- + -- LLVM pointers can also have an optional address space attribute, but this + -- is not currently represented in the @llvm-pretty@ AST. + -- + -- 'PtrOpaque' should not be confused with 'Opaque', which is a completely + -- separate type with a similar-sounding name. | Struct [Type' ident] | PackedStruct [Type' ident] | Vector Word64 (Type' ident) | Opaque + -- ^ An opaque structure type, used to represent structure types that do not + -- have a body specified. This is similar to C's notion of a + -- forward-declared structure. + -- + -- 'Opaque' should not be confused with 'PtrOpaque', which is a completely + -- separate type with a similar-sounding name. deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) -- | Applicatively traverse a type, updating or removing aliases. @@ -277,6 +453,7 @@ Array len ety -> Array len <$> (loop ety) FunTy res ps var -> FunTy <$> (loop res) <*> (traverse loop ps) <*> pure var PtrTo pty -> PtrTo <$> (loop pty) + PtrOpaque -> pure PtrOpaque Struct fs -> Struct <$> (traverse loop fs) PackedStruct fs -> PackedStruct <$> (traverse loop fs) Vector len ety -> Vector <$> pure len <*> (loop ety) @@ -323,9 +500,100 @@ isPointer :: Type -> Bool isPointer (PtrTo _) = True +isPointer PtrOpaque = True isPointer _ = False +-- | Like `Type'`, but where the 'PtrTo' and 'PtrOpaque' constructors have been +-- collapsed into a single 'PtrView' constructor. This provides a coarser notion +-- of type equality than what `Type'` provides, which distinguishes the two +-- types of pointers. +-- +-- `TypeView'` is not used directly in any of the other AST types. Instead, it +-- is used only as an internal data type to power the 'eqTypeModuloOpaquePtrs' +-- and 'cmpTypeModuloOpaquePtrs' functions. +data TypeView' ident + = PrimTypeView PrimType + | AliasView ident + | ArrayView Word64 (TypeView' ident) + | FunTyView (TypeView' ident) [TypeView' ident] Bool + | PtrView + -- ^ The sole pointer type. Both 'PtrTo' and 'PtrOpaque' are mapped to + -- 'PtrView'. + | StructView [TypeView' ident] + | PackedStructView [TypeView' ident] + | VectorView Word64 (TypeView' ident) + | OpaqueView + -- ^ An opaque structure type, used to represent structure types that do not + -- forward-declared structure. + -- + -- 'OpaqueView' should not be confused with opaque pointers, which are + -- mapped to 'PtrView'. + deriving (Eq, Ord) + +-- | Convert a `Type'` value to a `TypeView'` value. +typeView :: Type' ident -> TypeView' ident +-- The two most important cases. Both forms of pointers are mapped to PtrView. +typeView (PtrTo _) = PtrView +typeView PtrOpaque = PtrView +-- All other cases are straightforward. +typeView (PrimType pt) = PrimTypeView pt +typeView (Alias lab) = AliasView lab +typeView (Array len et) = ArrayView len (typeView et) +typeView (FunTy ret args va) = FunTyView (typeView ret) (map typeView args) va +typeView (Struct fs) = StructView (map typeView fs) +typeView (PackedStruct fs) = PackedStructView (map typeView fs) +typeView (Vector len et) = VectorView len (typeView et) +typeView Opaque = OpaqueView + +-- | Check two 'Type's for equality, but treat 'PtrOpaque' types as being equal +-- to @'PtrTo' ty@ types (for any type @ty@). This is a coarser notion of +-- equality than what is provided by the 'Eq' instance for 'Type'. +eqTypeModuloOpaquePtrs :: Eq ident => Type' ident -> Type' ident -> Bool +eqTypeModuloOpaquePtrs x y = typeView x == typeView y + +-- | Compare two 'Type's, but treat 'PtrOpaque' types as being equal to +-- @'PtrTo' ty@ types (for any type @ty@). This is a coarser notion of ordering +-- than what is provided by the 'Ord' instance for 'Type'. +cmpTypeModuloOpaquePtrs :: Ord ident => Type' ident -> Type' ident -> Ordering +cmpTypeModuloOpaquePtrs x y = typeView x `compare` typeView y + +-- | Ensure that if there are any occurrences of opaque pointers, then all +-- non-opaque pointers are converted to opaque ones. +-- +-- This is useful because LLVM tools like @llvm-as@ are stricter than +-- @llvm-pretty@ in that the former forbids mixing opaque and non-opaque +-- pointers, whereas the latter allows this. As a result, the result of +-- pretty-printing an @llvm-pretty@ AST might not be suitable for @llvm-as@'s +-- needs unless you first call this function to ensure that the two types of +-- pointers are not intermixed. +-- +-- This is implemented using "Data.Data" combinators under the hood, which could +-- potentially require a full traversal of the AST. Because of the performance +-- implications of this, we do not call 'fixupOpaquePtrs' in @llvm-pretty@'s +-- pretty-printer. If you wish to combine opaque and non-opaque pointers in your +-- AST, the burden is on you to call this function before pretty-printing. +fixupOpaquePtrs :: Data a => a -> a +fixupOpaquePtrs m + | isJust (gfind isOpaquePtr m) + = everywhere (mkT opaquifyPtr) m + | otherwise + = m + where + isOpaquePtr :: Type -> Bool + isOpaquePtr PtrOpaque = True + isOpaquePtr _ = False + + opaquifyPtr :: Type -> Type + opaquifyPtr (PtrTo _) = PtrOpaque + opaquifyPtr t = t + + -- Find the first occurrence of a @b@ value within the @a@ value that + -- satisfies the predicate and return it with 'Just'. Return 'Nothing' if there + -- are no such occurrences. + gfind :: (Data a, Typeable b) => (b -> Bool) -> a -> Maybe b + gfind p = something (const Nothing `extQ` \x -> if p x then Just x else Nothing) + -- Null Values ----------------------------------------------------------------- data NullResult lab @@ -348,6 +616,7 @@ typeNull :: Type -> NullResult lab typeNull (PrimType pt) = HasNull (primTypeNull pt) typeNull PtrTo{} = HasNull ValNull +typeNull PtrOpaque = HasNull ValNull typeNull (Alias i) = ResolveNull i typeNull _ = HasNull ValZeroInit @@ -432,12 +701,14 @@ -- Declarations ---------------------------------------------------------------- data Declare = Declare - { decRetType :: Type - , decName :: Symbol - , decArgs :: [Type] - , decVarArgs :: Bool - , decAttrs :: [FunAttr] - , decComdat :: Maybe String + { decLinkage :: Maybe Linkage + , decVisibility :: Maybe Visibility + , decRetType :: Type + , decName :: Symbol + , decArgs :: [Type] + , decVarArgs :: Bool + , decAttrs :: [FunAttr] + , decComdat :: Maybe String } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- | The function type of this declaration @@ -448,17 +719,18 @@ -- Function Definitions -------------------------------------------------------- data Define = Define - { defLinkage :: Maybe Linkage - , defRetType :: Type - , defName :: Symbol - , defArgs :: [Typed Ident] - , defVarArgs :: Bool - , defAttrs :: [FunAttr] - , defSection :: Maybe String - , defGC :: Maybe GC - , defBody :: [BasicBlock] - , defMetadata :: FnMdAttachments - , defComdat :: Maybe String + { defLinkage :: Maybe Linkage + , defVisibility :: Maybe Visibility + , defRetType :: Type + , defName :: Symbol + , defArgs :: [Typed Ident] + , defVarArgs :: Bool + , defAttrs :: [FunAttr] + , defSection :: Maybe String + , defGC :: Maybe GC + , defBody :: [BasicBlock] + , defMetadata :: FnMdAttachments + , defComdat :: Maybe String } deriving (Data, Eq, Generic, Ord, Show, Typeable) defFunType :: Define -> Type @@ -652,6 +924,11 @@ isFArith :: ArithOp -> Bool isFArith = not . isIArith +data UnaryArithOp + = FNeg + -- ^ Floating point negation. + deriving (Data, Eq, Generic, Ord, Show, Typeable) + -- | Binary bitwise operators. data BitOp = Shl Bool Bool @@ -744,6 +1021,11 @@ * Middle of basic block. * The result is the same as parameters. -} + | UnaryArith UnaryArithOp (Typed (Value' lab)) + {- ^ * Unary arithmetic operation. + * Middle of basic block. + * The result is the same as the parameter. -} + | Bit BitOp (Typed (Value' lab)) (Value' lab) {- ^ * Binary bit-vector operation, both operands have the same type. * Middle of basic block. @@ -760,6 +1042,17 @@ * Middle of basic block. * The result is as indicated by the provided type. -} + | CallBr Type (Value' lab) [Typed (Value' lab)] lab [lab] + {- ^ * Call a function in asm-goto style: + return type; + function operand; + arguments; + default basic block destination; + other basic block destinations. + * Middle of basic block. + * The result is as indicated by the provided type. + * Introduced in LLVM 9. -} + | Alloca Type (Maybe (Typed (Value' lab))) (Maybe Int) {- ^ * Allocated space on the stack: type of elements; @@ -768,8 +1061,9 @@ * Middle of basic block. * Returns a pointer to hold the given number of elements. -} - | Load (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align) + | Load Type (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align) {- ^ * Read a value from the given address: + type being loaded; address to read from; atomic ordering; assumptions about alignment of the given pointer. @@ -834,10 +1128,11 @@ * Middle of basic block. * Returns a value of the specified type. -} - | GEP Bool (Typed (Value' lab)) [Typed (Value' lab)] + | GEP Bool Type (Typed (Value' lab)) [Typed (Value' lab)] {- ^ * "Get element pointer", compute the address of a field in a structure: inbounds check (value poisoned if this fails); + type to use as a basis for calculations; pointer to parent structure; path to a sub-component of a structure. * Middle of basic block. @@ -918,6 +1213,10 @@ | Resume (Typed (Value' lab)) + | Freeze (Typed (Value' lab)) + {- ^ * Used to stop propagation of @undef@ and @poison@ values. + * Middle of basic block. -} + deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable) type Instr = Instr' BlockLabel @@ -935,6 +1234,7 @@ Ret{} -> True RetVoid -> True Jump{} -> True + CallBr{} -> True Br{} -> True Unreachable -> True Unwind -> True @@ -985,6 +1285,7 @@ | ValZeroInit | ValAsm Bool Bool String String | ValMd (ValMd' lab) + | ValPoison deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type Value = Value' BlockLabel @@ -1065,14 +1366,18 @@ -- Constant Expressions -------------------------------------------------------- data ConstExpr' lab - = ConstGEP Bool (Maybe Word64) (Maybe Type) [Typed (Value' lab)] - -- ^ Element type introduced in LLVM 3.7 + = ConstGEP Bool (Maybe Word64) Type (Typed (Value' lab)) [Typed (Value' lab)] + -- ^ Since LLVM 3.7, constant @getelementptr@ expressions include an explicit + -- type to use as a basis for calculations. For older versions of LLVM, this + -- type can be reconstructed by inspecting the pointee type of the parent + -- pointer value. | ConstConv ConvOp (Typed (Value' lab)) Type | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab)) - | ConstBlockAddr Symbol lab + | ConstBlockAddr (Typed (Value' lab)) lab | ConstFCmp FCmpOp (Typed (Value' lab)) (Typed (Value' lab)) | ConstICmp ICmpOp (Typed (Value' lab)) (Typed (Value' lab)) | ConstArith ArithOp (Typed (Value' lab)) (Value' lab) + | ConstUnaryArith UnaryArithOp (Typed (Value' lab)) | ConstBit BitOp (Typed (Value' lab)) (Value' lab) deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) @@ -1085,7 +1390,8 @@ | DebugInfoCompileUnit (DICompileUnit' lab) | DebugInfoCompositeType (DICompositeType' lab) | DebugInfoDerivedType (DIDerivedType' lab) - | DebugInfoEnumerator String !Int64 + | DebugInfoEnumerator String !Integer Bool + -- ^ The 'Bool' field represents @isUnsigned@, introduced in LLVM 7. | DebugInfoExpression DIExpression | DebugInfoFile DIFile | DebugInfoGlobalVariable (DIGlobalVariable' lab) @@ -1094,13 +1400,16 @@ | DebugInfoLexicalBlockFile (DILexicalBlockFile' lab) | DebugInfoLocalVariable (DILocalVariable' lab) | DebugInfoSubprogram (DISubprogram' lab) - | DebugInfoSubrange DISubrange + | DebugInfoSubrange (DISubrange' lab) | DebugInfoSubroutineType (DISubroutineType' lab) | DebugInfoNameSpace (DINameSpace' lab) | DebugInfoTemplateTypeParameter (DITemplateTypeParameter' lab) | DebugInfoTemplateValueParameter (DITemplateValueParameter' lab) | DebugInfoImportedEntity (DIImportedEntity' lab) | DebugInfoLabel (DILabel' lab) + | DebugInfoArgList (DIArgList' lab) + | DebugInfoAssignID + -- ^ Introduced in LLVM 17. deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DebugInfo = DebugInfo' BlockLabel @@ -1125,16 +1434,18 @@ type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel data DITemplateTypeParameter' lab = DITemplateTypeParameter - { dittpName :: Maybe String - , dittpType :: Maybe (ValMd' lab) + { dittpName :: Maybe String + , dittpType :: Maybe (ValMd' lab) + , dittpIsDefault :: Maybe Bool -- since LLVM 11 } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DITemplateValueParameter = DITemplateValueParameter' BlockLabel data DITemplateValueParameter' lab = DITemplateValueParameter - { ditvpTag :: DwarfTag - , ditvpName :: Maybe String - , ditvpType :: Maybe (ValMd' lab) - , ditvpValue :: ValMd' lab + { ditvpTag :: DwarfTag + , ditvpName :: Maybe String + , ditvpType :: Maybe (ValMd' lab) + , ditvpIsDefault :: Maybe Bool -- since LLVM 11 + , ditvpValue :: ValMd' lab } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DINameSpace = DINameSpace' BlockLabel @@ -1184,6 +1495,12 @@ , dicuMacros :: Maybe (ValMd' lab) , dicuDWOId :: Word64 , dicuSplitDebugInlining :: Bool + , dicuDebugInfoForProf :: Bool + , dicuNameTableKind :: Word64 + -- added in LLVM 11: dicuRangesBaseAddress, dicuSysRoot, and dicuSDK + , dicuRangesBaseAddress :: Bool + , dicuSysRoot :: Maybe String + , dicuSDK :: Maybe String } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DICompileUnit = DICompileUnit' BlockLabel @@ -1205,6 +1522,12 @@ , dictTemplateParams :: Maybe (ValMd' lab) , dictIdentifier :: Maybe String , dictDiscriminator :: Maybe (ValMd' lab) + , dictDataLocation :: Maybe (ValMd' lab) + , dictAssociated :: Maybe (ValMd' lab) + , dictAllocated :: Maybe (ValMd' lab) + , dictRank :: Maybe (ValMd' lab) + , dictAnnotations :: Maybe (ValMd' lab) + -- ^ Introduced in LLVM 14. } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DICompositeType = DICompositeType' BlockLabel @@ -1221,6 +1544,13 @@ , didtOffset :: Word64 , didtFlags :: DIFlags , didtExtraData :: Maybe (ValMd' lab) + , didtDwarfAddressSpace :: Maybe Word32 + -- ^ Introduced in LLVM 5. + -- + -- The 'Maybe' encodes the possibility that there is no associated address + -- space (in LLVM, the sentinel value @0@ is used for this). + , didtAnnotations :: Maybe (ValMd' lab) + -- ^ Introduced in LLVM 14 } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DIDerivedType = DIDerivedType' BlockLabel @@ -1246,6 +1576,8 @@ , digvVariable :: Maybe (ValMd' lab) , digvDeclaration :: Maybe (ValMd' lab) , digvAlignment :: Maybe Word32 + , digvAnnotations :: Maybe (ValMd' lab) + -- ^ Introduced in LLVM 14. } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DIGlobalVariable = DIGlobalVariable' BlockLabel @@ -1282,6 +1614,10 @@ , dilvType :: Maybe (ValMd' lab) , dilvArg :: Word16 , dilvFlags :: DIFlags + , dilvAlignment :: Maybe Word32 + -- ^ Introduced in LLVM 4. + , dilvAnnotations :: Maybe (ValMd' lab) + -- ^ Introduced in LLVM 14. } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DILocalVariable = DILocalVariable' BlockLabel @@ -1305,17 +1641,46 @@ , dispUnit :: Maybe (ValMd' lab) , dispTemplateParams :: Maybe (ValMd' lab) , dispDeclaration :: Maybe (ValMd' lab) - , dispVariables :: Maybe (ValMd' lab) + , dispRetainedNodes :: Maybe (ValMd' lab) , dispThrownTypes :: Maybe (ValMd' lab) + , dispAnnotations :: Maybe (ValMd' lab) + -- ^ Introduced in LLVM 14. } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) type DISubprogram = DISubprogram' BlockLabel -data DISubrange = DISubrange - { disrCount :: Int64 - , disrLowerBound :: Int64 - } deriving (Data, Eq, Generic, Ord, Show, Typeable) +-- | The DISubrange is a Value subrange specification, usually associated with +-- arrays or enumerations. +-- +-- * Early LLVM: only 'disrCount' and 'disrLowerBound' were present, where both +-- were a direct signed 64-bit value. This corresponds to "format 0" in the +-- bitcode encoding (see reference below). +-- +-- * LLVM 7: 'disrCount' changed to metadata representation ('ValMd'). The +-- metadata representation should only be a signed 64-bit integer, a Variable, +-- or an Expression. This corresponds to "format 1" in the bitcode encoding. +-- +-- * LLVM 11: 'disrLowerBound' was changed to a metadata representation and +-- 'disrUpperBound' and 'disrStride' were added (primarily driven by the +-- addition of Fortran support in llvm). All three should only be represented +-- as a signed 64-bit integer, a Variable, or an Expression. This corresponds +-- to "format 2" in the bitcode encoding. See +-- https://github.com/llvm/llvm-project/commit/d20bf5a for this change. +-- +-- Also see +-- https://github.com/llvm/llvm-project/blob/bbe8cd1/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1435-L1461 +-- for how this is read from the bitcode encoding and the use of the format +-- values mentioned above. +data DISubrange' lab = DISubrange + { disrCount :: Maybe (ValMd' lab) + , disrLowerBound :: Maybe (ValMd' lab) + , disrUpperBound :: Maybe (ValMd' lab) + , disrStride :: Maybe (ValMd' lab) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + +type DISubrange = DISubrange' BlockLabel + data DISubroutineType' lab = DISubroutineType { distFlags :: DIFlags , distTypeArray :: Maybe (ValMd' lab) @@ -1323,6 +1688,13 @@ type DISubroutineType = DISubroutineType' BlockLabel +-- | See . +newtype DIArgList' lab = DIArgList + { dialArgs :: [ValMd' lab] + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + +type DIArgList = DIArgList' BlockLabel + -- Aggregate Utilities --------------------------------------------------------- data IndexResult @@ -1341,10 +1713,11 @@ -- on unknown type aliases will return 'Nothing' resolveGepFull :: (Ident -> Maybe Type) {- ^ Type alias resolution -} -> - Type {- ^ Pointer type -} -> + Type {- ^ Base type used for calculations -} -> + Typed (Value' lab) {- ^ Pointer value -} -> [Typed (Value' lab)] {- ^ Path -} -> Maybe Type {- ^ Type of result -} -resolveGepFull env t ixs = go (resolveGep t ixs) +resolveGepFull env baseTy tv ixs = go (resolveGep baseTy tv ixs) where go Invalid = Nothing go (HasType result) = Just result @@ -1353,16 +1726,32 @@ -- | Resolve the type of a GEP instruction. Note that the type produced is the -- type of the result, not necessarily a pointer. -resolveGep :: Type -> [Typed (Value' lab)] -> IndexResult -resolveGep (PtrTo ty0) (v:ixs0) - | isGepIndex v = - resolveGepBody ty0 ixs0 -resolveGep ty0@PtrTo{} (v:ixs0) - | Just i <- elimAlias (typedType v) = - Resolve i (\ty' -> resolveGep ty0 (Typed ty' (typedValue v):ixs0)) -resolveGep (Alias i) ixs = - Resolve i (\ty' -> resolveGep ty' ixs) -resolveGep _ _ = Invalid +resolveGep :: Type -> Typed (Value' lab) -> [Typed (Value' lab)] -> IndexResult +resolveGep baseTy tv ixs = + case ixs of + v:ixs0 + | -- If headed by a pointer and the first index value has a valid GEP + -- index type, proceed to resolve the body of the GEP instruction. + isPointer t + , isGepIndex v + -> resolveGepBody baseTy ixs0 + + | -- If headed by a pointer and the first index has an alias type, + -- resolve the alias and try again. + isPointer t + , Just i <- elimAlias (typedType v) + -> Resolve i (\ty' -> resolveGep baseTy tv (Typed ty' (typedValue v):ixs0)) + + _ | -- If headed by a value with an alias type, resolve the alias and + -- try again. + Alias i <- t + -> Resolve i (\ty' -> resolveGep baseTy (Typed ty' (typedValue tv)) ixs) + + | -- Otherwise, the GEP instruction is invalid. + otherwise + -> Invalid + where + t = typedType tv -- | Resolve the type of a GEP instruction. This assumes that the input has -- already been processed as a pointer. diff --git a/src/Text/LLVM/DebugUtils.hs b/src/Text/LLVM/DebugUtils.hs --- a/src/Text/LLVM/DebugUtils.hs +++ b/src/Text/LLVM/DebugUtils.hs @@ -1,16 +1,17 @@ {-# Language TransformListComp, MonadComprehensions #-} {- | -Module : $Header$ +Module : Text.LLVM.DebugUtils Description : This module interprets the DWARF information associated with a function's argument and return types in order to interpret field name references. License : BSD3 Stability : provisional -Point-of-contact : emertens +Maintainer : emertens@galois.com -} module Text.LLVM.DebugUtils ( -- * Definition type analyzer - Info(..), computeFunctionTypes, valMdToInfo + Info(..), StructFieldInfo(..), BitfieldInfo(..), UnionFieldInfo(..) + , computeFunctionTypes, valMdToInfo , localVariableNameDeclarations -- * Metadata lookup @@ -23,10 +24,19 @@ -- * Info hueristics , guessAliasInfo + , guessTypeInfo + + -- * Function arguments + , debugInfoArgNames + + -- * Line numbers of definitions + , debugInfoGlobalLines + , debugInfoDefineLines ) where import Control.Applicative ((<|>)) import Control.Monad ((<=<)) +import Data.Bits (Bits(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (elemIndex, tails, stripPrefix) @@ -56,27 +66,99 @@ data Info = Pointer Info - | Structure [(String,Word64,Info)] -- ^ Fields: name, bit-offset, info - | Union [(String,Info)] + | Structure (Maybe String) [StructFieldInfo] + | Union (Maybe String) [UnionFieldInfo] + | Typedef String Info | ArrInfo Info - | BaseType String + | BaseType String DIBasicType | Unknown deriving Show -{- -import Text.Show.Pretty -import Data.Foldable +-- | Record debug information about a field in a struct type. +data StructFieldInfo = StructFieldInfo + { sfiName :: String + -- ^ The field name. + , sfiOffset :: Word64 + -- ^ The field's offset (in bits) from the start of the struct. + , sfiBitfield :: Maybe BitfieldInfo + -- ^ If this field resides within a bitfield, this is + -- @'Just' bitfieldInfo@. Otherwise, this is 'Nothing'. + , sfiInfo :: Info + -- ^ The debug 'Info' associated with the field's type. + } deriving Show -test = - do test' "/Users/emertens/Source/saw/saw-script\ - \/examples/llvm/dotprod_struct.bc" - test' "/Users/emertens/Desktop/temp.bc" +-- | Record debug information about a field within a bitfield. For example, +-- the following C struct: +-- +-- @ +-- struct s { +-- int32_t w; +-- uint8_t x1:1; +-- uint8_t x2:2; +-- uint8_t y:1; +-- int32_t z; +-- }; +-- @ +-- +-- Corresponds to the following 'Info': +-- +-- @ +-- 'Structure' +-- [ 'StructFieldInfo' { 'sfiName' = \"w\" +-- , 'sfiOffset' = 0 +-- , 'sfiBitfield' = Nothing +-- , 'sfiInfo' = 'BaseType' \"int32_t\" +-- } +-- , 'StructFieldInfo' { 'sfiName' = \"x1\" +-- , 'sfiOffset' = 32 +-- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1 +-- , 'biBitfieldOffset' = 32 +-- }) +-- , 'sfiInfo' = 'BaseType' \"uint8_t\" +-- } +-- , 'StructFieldInfo' { 'sfiName' = \"x2\" +-- , 'sfiOffset' = 33 +-- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 2 +-- , 'biBitfieldOffset' = 32 +-- }) +-- , 'sfiInfo' = BaseType \"uint8_t\" +-- } +-- , 'StructFieldInfo' { 'sfiName' = \"y\" +-- , 'sfiOffset' = 35 +-- , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1 +-- , 'biBitfieldOffset' = 32 +-- }) +-- , 'sfiInfo' = 'BaseType' \"uint8_t\" +-- } +-- , 'StructFieldInfo' { 'sfiName' = \"z\" +-- , 'sfiOffset' = 64 +-- , 'sfiBitfield' = Nothing +-- , 'sfiInfo' = BaseType \"int32_t\" +-- } +-- ] +-- @ +-- +-- Notice that only @x1@, @x2@, and @y@ have 'BitfieldInfo's, as they are the +-- only fields that were declared with bitfield syntax. +data BitfieldInfo = BitfieldInfo + { biFieldSize :: Word64 + -- ^ The field's size (in bits) within the bitfield. This should not be + -- confused with the size of the field's declared type. For example, the + -- 'biFieldSize' of the @x1@ field is @1@, despite the fact that its + -- declared type, @uint8_t@, is otherwise 8 bits in size. + , biBitfieldOffset :: Word64 + -- ^ The bitfield's offset (in bits) from the start of the struct. Note + -- that for a given field within a bitfield, its 'sfiOffset' is equal to + -- the 'biBitfieldOffset' plus the 'biFieldSize'. + } deriving Show -test' fn = - do Right bc <- parseBitCodeFromFile fn - let mdMap = mkMdMap bc - traverse_ (putStrLn . ppShow . analyzeDefine mdMap) (modDefines bc) --} +-- | Record debug information about a field in a union type. +data UnionFieldInfo = UnionFieldInfo + { ufiName :: String + -- ^ The field name. + , ufiInfo :: Info + -- ^ The debug 'Info' associated with the field's type. + } deriving Show -- | Compute an 'IntMap' of the unnamed metadata in a module mkMdMap :: Module -> IntMap ValMd @@ -89,6 +171,10 @@ getDebugInfo _ (ValMdDebugInfo di) = Just di getDebugInfo _ _ = Nothing +getInteger :: MdMap -> ValMd -> Maybe Integer +getInteger mdMap (ValMdRef i) = getInteger mdMap =<< IntMap.lookup i mdMap +getInteger _ (ValMdValue (Typed _ (ValInteger i))) = Just i +getInteger _ _ = Nothing getList :: MdMap -> ValMd -> Maybe [Maybe ValMd] getList mdMap (ValMdRef i) = getList mdMap =<< IntMap.lookup i mdMap @@ -109,13 +195,15 @@ debugInfoToInfo :: MdMap -> DebugInfo -> Info debugInfoToInfo mdMap (DebugInfoDerivedType dt) | didtTag dt == dwarfPointer = Pointer (valMdToInfo' mdMap (didtBaseType dt)) - | didtTag dt == dwarfTypedef = valMdToInfo' mdMap (didtBaseType dt) - | didtTag dt == dwarfConst = valMdToInfo' mdMap (didtBaseType dt) + | didtTag dt == dwarfTypedef = case didtName dt of + Nothing -> valMdToInfo' mdMap (didtBaseType dt) + Just nm -> Typedef nm (valMdToInfo' mdMap (didtBaseType dt)) + | didtTag dt == dwarfConst = valMdToInfo' mdMap (didtBaseType dt) debugInfoToInfo _ (DebugInfoBasicType bt) - | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) + | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) bt debugInfoToInfo mdMap (DebugInfoCompositeType ct) - | dictTag ct == dwarfStruct = maybe Unknown Structure (getStructFields mdMap ct) - | dictTag ct == dwarfUnion = maybe Unknown Union (getUnionFields mdMap ct) + | dictTag ct == dwarfStruct = maybe Unknown (Structure (dictName ct)) (getStructFields mdMap ct) + | dictTag ct == dwarfUnion = maybe Unknown (Union (dictName ct)) (getUnionFields mdMap ct) | dictTag ct == dwarfArray = ArrInfo (valMdToInfo' mdMap (dictBaseType ct)) debugInfoToInfo _ _ = Unknown @@ -124,26 +212,47 @@ getFieldDIs mdMap = traverse (getDebugInfo mdMap) <=< sequence <=< getList mdMap <=< dictElements - -getStructFields :: MdMap -> DICompositeType -> Maybe [(String, Word64, Info)] +getStructFields :: MdMap -> DICompositeType -> Maybe [StructFieldInfo] getStructFields mdMap = traverse (debugInfoToStructField mdMap) <=< getFieldDIs mdMap -debugInfoToStructField :: MdMap -> DebugInfo -> Maybe (String, Word64, Info) +debugInfoToStructField :: MdMap -> DebugInfo -> Maybe StructFieldInfo debugInfoToStructField mdMap di = do DebugInfoDerivedType dt <- Just di fieldName <- didtName dt - Just (fieldName, didtOffset dt, valMdToInfo' mdMap (didtBaseType dt)) + -- We check if a struct field resides within a bitfield by checking its + -- `flags` field sets `BitField`, which has a numeric value of 19. + -- (https://github.com/llvm/llvm-project/blob/1bebc31c617d1a0773f1d561f02dd17c5e83b23b/llvm/include/llvm/IR/DebugInfoFlags.def#L51) + -- + -- If so, the `size` field records the size in bits, and the `extraData` + -- field records the offset of the overall bitfield from the start of the + -- struct. + -- (https://github.com/llvm/llvm-project/blob/ee7652569854af567ba83e5255d70e80cc8619a1/llvm/lib/CodeGen/AsmPrinter/CodeViewDebug.cpp#L2489-L2508) + let bitfield | testBit (didtFlags dt) 19 + , Just extraData <- didtExtraData dt + , Just bitfieldOffset <- getInteger mdMap extraData + = Just $ BitfieldInfo { biFieldSize = didtSize dt + , biBitfieldOffset = fromInteger bitfieldOffset + } + | otherwise + = Nothing + Just (StructFieldInfo { sfiName = fieldName + , sfiOffset = didtOffset dt + , sfiBitfield = bitfield + , sfiInfo = valMdToInfo' mdMap (didtBaseType dt) + }) -getUnionFields :: MdMap -> DICompositeType -> Maybe [(String, Info)] +getUnionFields :: MdMap -> DICompositeType -> Maybe [UnionFieldInfo] getUnionFields mdMap = traverse (debugInfoToUnionField mdMap) <=< getFieldDIs mdMap -debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe (String, Info) +debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe UnionFieldInfo debugInfoToUnionField mdMap di = do DebugInfoDerivedType dt <- Just di fieldName <- didtName dt - Just (fieldName, valMdToInfo' mdMap (didtBaseType dt)) + Just (UnionFieldInfo { ufiName = fieldName + , ufiInfo = valMdToInfo' mdMap (didtBaseType dt) + }) @@ -154,9 +263,9 @@ computeFunctionTypes :: Module {- ^ module to search -} -> Symbol {- ^ function symbol -} -> - Maybe [Info] {- ^ return and argument type information -} + Maybe [Maybe Info] {- ^ return and argument type information -} computeFunctionTypes m sym = - [ maybe (BaseType "void") (valMdToInfo mdMap) <$> types + [ fmap (valMdToInfo mdMap) <$> types | let mdMap = mkMdMap m , sp <- findSubprogramViaDefine mdMap m sym <|> findSubprogramViaCu mdMap m sym @@ -219,9 +328,10 @@ Info {- ^ type information for specified field -} fieldIndexByPosition i info = case info of - Structure xs -> go [ x | (_,_,x) <- xs ] - Union xs -> go [ x | (_,x) <- xs ] - _ -> Unknown + Typedef _ info' -> fieldIndexByPosition i info' + Structure _ xs -> go [ x | StructFieldInfo{sfiInfo = x} <- xs ] + Union _ xs -> go [ x | UnionFieldInfo{ufiInfo = x} <- xs ] + _ -> Unknown where go xs = case drop i xs of [] -> Unknown @@ -235,9 +345,10 @@ Maybe Int {- ^ zero-based index of field matching the name -} fieldIndexByName n info = case info of - Structure xs -> go [ x | (x,_,_) <- xs ] - Union xs -> go [ x | (x,_) <- xs ] - _ -> Nothing + Typedef _ info' -> fieldIndexByName n info' + Structure _ xs -> go [ x | StructFieldInfo{sfiName = x} <- xs ] + Union _ xs -> go [ x | UnionFieldInfo{ufiName = x} <- xs ] + _ -> Nothing where go = elemIndex n @@ -291,21 +402,29 @@ -- because there's no direct mapping between type aliases -- and debug info. The debug information must be search -- for a textual match. +-- +-- Compared to @guessTypeInfo@, this function first tries +-- to strip the \"struct.\" and \"union.\" prefixes that are +-- commonly added by clang before searching for the type information. guessAliasInfo :: IntMap ValMd {- ^ unnamed metadata -} -> Ident {- ^ alias -} -> Info -guessAliasInfo mdMap (Ident name) = - -- TODO: Support more categories than struct - case stripPrefix "struct." name of - Nothing -> Unknown - Just pfx -> guessStructInfo mdMap pfx +guessAliasInfo mdMap (Ident name) + | Just pfx <- stripPrefix "struct." name = guessTypeInfo mdMap pfx + | Just pfx <- stripPrefix "union." name = guessTypeInfo mdMap pfx + | otherwise = guessTypeInfo mdMap name -guessStructInfo :: +-- | Search the metadata for debug info corresponding +-- to a given type alias. This is considered a heuristic +-- because there's no direct mapping between type aliases +-- and debug info. The debug information must be search +-- for a textual match. +guessTypeInfo :: IntMap ValMd {- ^ unnamed metadata -} -> String {- ^ struct alias -} -> Info -guessStructInfo mdMap name = +guessTypeInfo mdMap name = case mapMaybe (go <=< getDebugInfo mdMap) (IntMap.elems mdMap) of [] -> Unknown x:_ -> x @@ -319,4 +438,67 @@ , Just name == dictName dict = Just (debugInfoToInfo mdMap di) + go _ = Nothing + +------------------------------------------------------------------------ + +-- | Find source-level names of function arguments +debugInfoArgNames :: Module -> Define -> IntMap String +debugInfoArgNames m d = + case Map.lookup dbgKind $ defMetadata d of + Just (ValMdRef s) -> scopeArgs s + _ -> IntMap.empty + where + scopeArgs :: Int -> IntMap String + scopeArgs s = IntMap.fromList . mapMaybe go $ modUnnamedMd m + where + go :: UnnamedMd -> Maybe (Int, String) + go + ( UnnamedMd + { umValues = + ValMdDebugInfo + ( DebugInfoLocalVariable + DILocalVariable + { dilvScope = Just (ValMdRef s'), + dilvArg = a, + dilvName = Just n + } + ) + }) = + if s == s' + then Just (fromIntegral a - 1, n) + else Nothing + go _ = Nothing + +------------------------------------------------------------------------ + +-- | Map global variable names to the line on which the global is defined +debugInfoGlobalLines :: Module -> Map String Int +debugInfoGlobalLines = Map.fromList . mapMaybe go . modUnnamedMd + where + go :: UnnamedMd -> Maybe (String, Int) + go (UnnamedMd + { umValues = ValMdDebugInfo + (DebugInfoGlobalVariable DIGlobalVariable + { digvName = Just n + , digvLine = l + } + ) + }) = Just (n, (fromIntegral l)) + go _ = Nothing + +-- | Map function names to the line on which the function is defined +debugInfoDefineLines :: Module -> Map String Int +debugInfoDefineLines = Map.fromList . mapMaybe go . modUnnamedMd + where + go :: UnnamedMd -> Maybe (String, Int) + go (UnnamedMd + { umValues = ValMdDebugInfo + (DebugInfoSubprogram DISubprogram + { dispName = Just n + , dispIsDefinition = True + , dispLine = l + } + ) + }) = Just (n, (fromIntegral l)) go _ = Nothing diff --git a/src/Text/LLVM/Labels.hs b/src/Text/LLVM/Labels.hs --- a/src/Text/LLVM/Labels.hs +++ b/src/Text/LLVM/Labels.hs @@ -1,21 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - module Text.LLVM.Labels where import Text.LLVM.AST import Text.LLVM.Labels.TH -#if !(MIN_VERSION_base(4,8,0)) -import Control.Applicative ((<$>),Applicative(..)) -import Data.Traversable (traverse) -#endif - class Functor f => HasLabel f where -- | Given a function for resolving labels, where the presence of a symbol -- denotes a label in a different function, rename all labels in a function. @@ -30,6 +19,8 @@ relabel f (Arith op l r) = Arith op <$> traverse (relabel f) l <*> relabel f r + relabel f (UnaryArith op a) = UnaryArith op + <$> traverse (relabel f) a relabel f (Bit op l r) = Bit op <$> traverse (relabel f) l <*> relabel f r @@ -37,10 +28,18 @@ relabel f (Call t r n as) = Call t r <$> relabel f n <*> traverse (traverse (relabel f)) as + relabel f (CallBr r n as u es) = CallBr r + <$> relabel f n + <*> traverse (traverse (relabel f)) as + <*> f Nothing u + <*> traverse (f Nothing) es relabel f (Alloca t n a) = Alloca t <$> traverse (traverse (relabel f)) n <*> pure a - relabel f (Load a mo ma) = Load <$> traverse (relabel f) a <*> pure mo <*> pure ma + relabel f (Load t a mo ma) = Load t + <$> traverse (relabel f) a + <*> pure mo + <*> pure ma relabel f (Store d v mo ma) = Store <$> traverse (relabel f) d <*> traverse (relabel f) v @@ -67,7 +66,7 @@ relabel f (FCmp op l r) = FCmp op <$> traverse (relabel f) l <*> relabel f r - relabel f (GEP ib a is) = GEP ib + relabel f (GEP ib t a is) = GEP ib t <$> traverse (relabel f) a <*> traverse (traverse (relabel f)) is relabel f (Select c l r) = Select @@ -120,6 +119,7 @@ <*> traverse (relabel f) cs relabel f (Resume tv) = Resume <$> traverse (relabel f) tv + relabel f (Freeze tv) = Freeze <$> traverse (relabel f) tv instance HasLabel Stmt' where relabel = $(generateRelabel 'relabel ''Stmt') instance HasLabel Clause' where relabel = $(generateRelabel 'relabel ''Clause') @@ -130,6 +130,7 @@ instance HasLabel DebugInfo' where relabel = $(generateRelabel 'relabel ''DebugInfo') instance HasLabel DIDerivedType' where relabel = $(generateRelabel 'relabel ''DIDerivedType') instance HasLabel DISubroutineType' where relabel = $(generateRelabel 'relabel ''DISubroutineType') +instance HasLabel DISubrange' where relabel = $(generateRelabel 'relabel ''DISubrange') instance HasLabel DIGlobalVariable' where relabel = $(generateRelabel 'relabel ''DIGlobalVariable') instance HasLabel DIGlobalVariableExpression' where relabel = $(generateRelabel 'relabel ''DIGlobalVariableExpression') instance HasLabel DILocalVariable' where relabel = $(generateRelabel 'relabel ''DILocalVariable') @@ -142,8 +143,10 @@ instance HasLabel DITemplateTypeParameter' where relabel = $(generateRelabel 'relabel ''DITemplateTypeParameter') instance HasLabel DITemplateValueParameter' where relabel = $(generateRelabel 'relabel ''DITemplateValueParameter') instance HasLabel DIImportedEntity' where relabel = $(generateRelabel 'relabel ''DIImportedEntity') +instance HasLabel DIArgList' where relabel = $(generateRelabel 'relabel ''DIArgList') -- | Clever instance that actually uses the block name instance HasLabel ConstExpr' where - relabel f (ConstBlockAddr t l) = ConstBlockAddr t <$> f (Just t) l + relabel f (ConstBlockAddr t@(Typed { typedValue = ValSymbol s }) l) = + ConstBlockAddr <$> traverse (relabel f) t <*> f (Just s) l relabel f x = $(generateRelabel 'relabel ''ConstExpr') f x diff --git a/src/Text/LLVM/Lens.hs b/src/Text/LLVM/Lens.hs --- a/src/Text/LLVM/Lens.hs +++ b/src/Text/LLVM/Lens.hs @@ -30,7 +30,7 @@ , ''DebugLoc' , ''DebugInfo' , ''DIFile - , ''DISubrange + , ''DISubrange' , ''DIBasicType , ''DIExpression , ''DISubprogram' @@ -43,6 +43,7 @@ , ''DIDerivedType' , ''DILexicalBlock' , ''DILexicalBlockFile' + , ''DIArgList' , ''Instr' , ''ValMd' , ''ConvOp diff --git a/src/Text/LLVM/PP.hs b/src/Text/LLVM/PP.hs --- a/src/Text/LLVM/PP.hs +++ b/src/Text/LLVM/PP.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} @@ -17,9 +18,11 @@ module Text.LLVM.PP where import Text.LLVM.AST +import Text.LLVM.Triple.AST (TargetTriple) +import Text.LLVM.Triple.Print (printTriple) import Control.Applicative ((<|>)) -import Data.Bits ( shiftR ) +import Data.Bits ( shiftR, (.&.) ) import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper) import Data.List (intersperse) import qualified Data.Map as Map @@ -32,53 +35,96 @@ -- Pretty-printer Config ------------------------------------------------------- -type LLVM = ?config :: Config --- | The differences between various versions of the llvm textual AST. -data Config = Config { cfgLoadImplicitType :: Bool - -- ^ True when the type of the result of a load is - -- derived from its pointer argument, or supplied - -- implicitly. +-- | The value used to specify the LLVM major version. The LLVM text format +-- (i.e. assembly code) changes with different versions of LLVM, so this value is +-- used to select the version the output should be generated for. +-- +-- At the current time, changes primarily occur when the LLVM major version +-- changes, and this is expected to be the case going forward, so it is +-- sufficient to reference the LLVM version by the single major version number. +-- There is one exception and one possible future exception to this approach: +-- +-- 1. During LLVM v3, there were changes in 3.5, 3.6, 3.7, and 3.8. There are +-- explicit @ppLLVMnn@ function entry points for those versions, but in the +-- event that a numerical value is needed, we note the serendipitous fact +-- that prior to LLVM 4, there are exactly 4 versions we need to +-- differentiate and can therefore assign the values of 0, 1, 2, and 3 to +-- those versions (and we have no intention of supporting any other pre-4.0 +-- versions at this point). +-- +-- 2. If at some future date, there are text format changes associated with a +-- minor version, then the LLVM version designation here will need to be +-- enhanced and made more sophisticated. At the present time, the likelihood +-- of that is small enough that the current simple implementation is a +-- benefit over a more complex mechanism that might not be needed. +-- +type LLVMVer = Int - , cfgGEPImplicitType :: Bool - -- ^ True when the type of the result of the GEP - -- instruction is implied. +-- | Helpers for specifying the LLVM versions prior to v4 +llvmV3_5, llvmV3_6, llvmV3_7, llvmV3_8 :: LLVMVer +llvmV3_5 = 0 +llvmV3_6 = 1 +llvmV3_7 = 2 +llvmV3_8 = 3 - , cfgUseDILocation :: Bool - } +-- | This value should be updated when support is added for new LLVM versions; +-- this is used for defaulting and otherwise reporting the maximum LLVM version +-- known to be supported. +llvmVlatest :: LLVMVer +llvmVlatest = 17 -withConfig :: Config -> (LLVM => a) -> a + +-- | The differences between various versions of the llvm textual AST. +newtype Config = Config { cfgVer :: LLVMVer } + +withConfig :: Config -> ((?config :: Config) => a) -> a withConfig cfg body = let ?config = cfg in body -ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: (LLVM => a) -> a +ppLLVM :: LLVMVer -> ((?config :: Config) => a) -> a +ppLLVM llvmver = withConfig Config { cfgVer = llvmver } -ppLLVM = ppLLVM38 +ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: ((?config :: Config) => a) -> a -ppLLVM35 = ppLLVM36 +ppLLVM35 = withConfig Config { cfgVer = llvmV3_5 } +ppLLVM36 = withConfig Config { cfgVer = llvmV3_6 } +ppLLVM37 = withConfig Config { cfgVer = llvmV3_7 } +ppLLVM38 = withConfig Config { cfgVer = llvmV3_8 } -ppLLVM36 = withConfig Config { cfgLoadImplicitType = True - , cfgGEPImplicitType = True - , cfgUseDILocation = False - } -ppLLVM37 = withConfig Config { cfgLoadImplicitType = False - , cfgGEPImplicitType = False - , cfgUseDILocation = True - } -ppLLVM38 = withConfig Config { cfgLoadImplicitType = False - , cfgGEPImplicitType = False - , cfgUseDILocation = True - } +llvmVer :: (?config :: Config) => LLVMVer +llvmVer = cfgVer ?config -checkConfig :: LLVM => (Config -> Bool) -> Bool -checkConfig p = p ?config +-- | This is a helper function for when a list of parameters is gated by a +-- condition (usually the llvmVer value). +when' :: Monoid a => Bool -> a -> a +when' c l = if c then l else mempty +-- | This type encapsulates the ability to convert an object into Doc +-- format. Using this abstraction allows for a consolidated representation of the +-- declaration. Most pretty-printing for LLVM elements will have a @'Fmt' a@ +-- function signature for that element. +type Fmt a = (?config :: Config) => a -> Doc + + +-- | The LLVMPretty class has instances for most AST elements. It allows the +-- conversion of an AST element (and its sub-elements) into a Doc assembly format +-- by simply using the 'llvmPP' method rather than needing to explicitly invoke +-- the specific pretty-printing function for that element. +class LLVMPretty a where llvmPP :: Fmt a + +instance LLVMPretty Module where llvmPP = ppModule +instance LLVMPretty Symbol where llvmPP = ppSymbol +instance LLVMPretty Ident where llvmPP = ppIdent + + -- Modules --------------------------------------------------------------------- -ppModule :: LLVM => Module -> Doc +ppModule :: Fmt Module ppModule m = foldr ($+$) empty $ ppSourceName (modSourceName m) + : ppTargetTriple (modTriple m) : ppDataLayout (modDataLayout m) : ppInlineAsm (modInlineAsm m) : concat [ map ppTypeDecl (modTypes m) @@ -94,18 +140,18 @@ -- Source filename ------------------------------------------------------------- -ppSourceName :: Maybe String -> Doc +ppSourceName :: Fmt (Maybe String) ppSourceName Nothing = empty ppSourceName (Just sn) = "source_filename" <+> char '=' <+> doubleQuotes (text sn) -- Metadata -------------------------------------------------------------------- -ppNamedMd :: NamedMd -> Doc +ppNamedMd :: Fmt NamedMd ppNamedMd nm = sep [ ppMetadata (text (nmName nm)) <+> char '=' , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] -ppUnnamedMd :: LLVM => UnnamedMd -> Doc +ppUnnamedMd :: Fmt UnnamedMd ppUnnamedMd um = sep [ ppMetadata (int (umIndex um)) <+> char '=' , distinct <+> ppValMd (umValues um) ] @@ -116,8 +162,12 @@ -- Aliases --------------------------------------------------------------------- -ppGlobalAlias :: LLVM => GlobalAlias -> Doc -ppGlobalAlias g = ppSymbol (aliasName g) <+> char '=' <+> body +ppGlobalAlias :: Fmt GlobalAlias +ppGlobalAlias g = ppSymbol (aliasName g) + <+> char '=' + <+> ppMaybe ppLinkage (aliasLinkage g) + <+> ppMaybe ppVisibility (aliasVisibility g) + <+> body where val = aliasTarget g body = case val of @@ -125,16 +175,23 @@ _ -> ppValue val +-- Target triple --------------------------------------------------------------- + +-- | Pretty print a 'TargetTriple' +ppTargetTriple :: Fmt TargetTriple +ppTargetTriple triple = "target" <+> "triple" <+> char '=' + <+> doubleQuotes (text (printTriple triple)) + -- Data Layout ----------------------------------------------------------------- -- | Pretty print a data layout specification. -ppDataLayout :: DataLayout -> Doc +ppDataLayout :: Fmt DataLayout ppDataLayout [] = empty ppDataLayout ls = "target" <+> "datalayout" <+> char '=' <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls))) -- | Pretty print a single layout specification. -ppLayoutSpec :: LayoutSpec -> Doc +ppLayoutSpec :: Fmt LayoutSpec ppLayoutSpec ls = case ls of BigEndian -> char 'E' @@ -153,14 +210,14 @@ Mangling m -> char 'm' <> char ':' <> ppMangling m -- | Pretty-print the common case for data layout specifications. -ppLayoutBody :: Int -> Int -> Maybe Int -> Doc +ppLayoutBody :: Int -> Int -> Fmt (Maybe Int) ppLayoutBody size abi mb = int size <> char ':' <> int abi <> pref where pref = case mb of Nothing -> empty Just p -> char ':' <> int p -ppMangling :: Mangling -> Doc +ppMangling :: Fmt Mangling ppMangling ElfMangling = char 'e' ppMangling MipsMangling = char 'm' ppMangling MachOMangling = char 'o' @@ -170,7 +227,7 @@ -- Inline Assembly ------------------------------------------------------------- -- | Pretty-print the inline assembly block. -ppInlineAsm :: InlineAsm -> Doc +ppInlineAsm :: Fmt InlineAsm ppInlineAsm = foldr ($+$) empty . map ppLine where ppLine l = "module asm" <+> doubleQuotes (text l) @@ -178,7 +235,7 @@ -- Identifiers ----------------------------------------------------------------- -ppIdent :: Ident -> Doc +ppIdent :: Fmt Ident ppIdent (Ident n) | validIdentifier n = char '%' <> text n | otherwise = char '%' <> ppStringLiteral n @@ -198,7 +255,7 @@ -- Symbols --------------------------------------------------------------------- -ppSymbol :: Symbol -> Doc +ppSymbol :: Fmt Symbol ppSymbol (Symbol n) | validIdentifier n = char '@' <> text n | otherwise = char '@' <> ppStringLiteral n @@ -206,7 +263,7 @@ -- Types ----------------------------------------------------------------------- -ppPrimType :: PrimType -> Doc +ppPrimType :: Fmt PrimType ppPrimType Label = "label" ppPrimType Void = "void" ppPrimType (Integer i) = char 'i' <> integer (toInteger i) @@ -214,7 +271,7 @@ ppPrimType X86mmx = "x86mmx" ppPrimType Metadata = "metadata" -ppFloatType :: FloatType -> Doc +ppFloatType :: Fmt FloatType ppFloatType Half = "half" ppFloatType Float = "float" ppFloatType Double = "double" @@ -222,73 +279,79 @@ ppFloatType X86_fp80 = "x86_fp80" ppFloatType PPC_fp128 = "ppc_fp128" -ppType :: Type -> Doc +ppType :: Fmt Type ppType (PrimType pt) = ppPrimType pt ppType (Alias i) = ppIdent i ppType (Array len ty) = brackets (integral len <+> char 'x' <+> ppType ty) ppType (PtrTo ty) = ppType ty <> char '*' +ppType PtrOpaque = "ptr" ppType (Struct ts) = structBraces (commas (map ppType ts)) ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts))) ppType (FunTy r as va) = ppType r <> ppArgList va (map ppType as) ppType (Vector len pt) = angles (integral len <+> char 'x' <+> ppType pt) ppType Opaque = "opaque" -ppTypeDecl :: TypeDecl -> Doc +ppTypeDecl :: Fmt TypeDecl ppTypeDecl td = ppIdent (typeName td) <+> char '=' <+> "type" <+> ppType (typeValue td) -- Declarations ---------------------------------------------------------------- -ppGlobal :: LLVM => Global -> Doc +ppGlobal :: Fmt Global ppGlobal g = ppSymbol (globalSym g) <+> char '=' - <+> ppTheGlobalAttrs (globalAttrs g) + <+> ppGlobalAttrs (isJust $ globalValue g) (globalAttrs g) <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g) <> ppAlign (globalAlign g) <> ppAttachedMetadata (Map.toList (globalMetadata g)) - where - isStruct | Just (ValStruct {}) <- globalValue g = True - | otherwise = False - ppTheGlobalAttrs | isStruct = ppStructGlobalAttrs - | otherwise = ppGlobalAttrs -ppGlobalAttrs :: GlobalAttrs -> Doc -ppGlobalAttrs ga +-- | Pretty-print Global Attributes (usually associated with a global variable +-- declaration). The first argument to ppGlobalAttrs indicates whether there is a +-- value associated with this global declaration: a global declaration with a +-- value should not be identified as \"external\" and \"default\" visibility, +-- whereas one without a value may have those attributes. + +ppGlobalAttrs :: Bool -> Fmt GlobalAttrs +ppGlobalAttrs hasValue ga -- LLVM 3.8 does not emit or parse linkage information w/ hidden visibility | Just HiddenVisibility <- gaVisibility ga = ppVisibility HiddenVisibility <+> constant - | otherwise = ppMaybe ppLinkage (gaLinkage ga) <+> ppMaybe ppVisibility (gaVisibility ga) <+> constant - where - constant | gaConstant ga = "constant" - | otherwise = "global" - -ppStructGlobalAttrs :: GlobalAttrs -> Doc -ppStructGlobalAttrs ga - -- LLVM 3.8 does not emit or parse external linkage for - -- global structs - | Just External <- gaLinkage ga, - Just DefaultVisibility <- gaVisibility ga - = constant - | otherwise = ppGlobalAttrs ga + | Just External <- gaLinkage ga + , Just DefaultVisibility <- gaVisibility ga + , hasValue = + -- Just show the value, no "external" or "default". This is based on + -- empirical testing as described in the comment above (testing the + -- following 6 configurations: + -- * uninitialized scalar + -- * uninitialized structure + -- * initialized scalar + -- * initialized structure + -- * external scalar + -- * external structure + constant + | otherwise = + ppMaybe ppLinkage (gaLinkage ga) <+> ppMaybe ppVisibility (gaVisibility ga) <+> constant where constant | gaConstant ga = "constant" | otherwise = "global" -ppDeclare :: Declare -> Doc +ppDeclare :: Fmt Declare ppDeclare d = "declare" + <+> ppMaybe ppLinkage (decLinkage d) + <+> ppMaybe ppVisibility (decVisibility d) <+> ppType (decRetType d) <+> ppSymbol (decName d) <> ppArgList (decVarArgs d) (map ppType (decArgs d)) <+> hsep (ppFunAttr <$> decAttrs d) <> maybe empty ((char ' ' <>) . ppComdatName) (decComdat d) -ppComdatName :: String -> Doc +ppComdatName :: Fmt String ppComdatName s = "comdat" <> parens (char '$' <> text s) -ppComdat :: (String,SelectionKind) -> Doc +ppComdat :: Fmt (String,SelectionKind) ppComdat (n,k) = ppComdatName n <+> char '=' <+> text "comdat" <+> ppSelectionKind k -ppSelectionKind :: SelectionKind -> Doc +ppSelectionKind :: Fmt SelectionKind ppSelectionKind k = case k of ComdatAny -> "any" @@ -297,9 +360,10 @@ ComdatNoDuplicates -> "noduplicates" ComdatSameSize -> "samesize" -ppDefine :: LLVM => Define -> Doc +ppDefine :: Fmt Define ppDefine d = "define" <+> ppMaybe ppLinkage (defLinkage d) + <+> ppMaybe ppVisibility (defVisibility d) <+> ppType (defRetType d) <+> ppSymbol (defName d) <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d)) @@ -318,7 +382,7 @@ -- FunAttr --------------------------------------------------------------------- -ppFunAttr :: FunAttr -> Doc +ppFunAttr :: Fmt FunAttr ppFunAttr a = case a of AlignStack w -> text "alignstack" <> parens (int w) @@ -352,28 +416,28 @@ -- Basic Blocks ---------------------------------------------------------------- -ppLabelDef :: BlockLabel -> Doc +ppLabelDef :: Fmt BlockLabel ppLabelDef (Named (Ident l)) = text l <> char ':' ppLabelDef (Anon i) = char ';' <+> "