diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,119 @@ # Revision history for llvm-pretty +## 0.15.0.0 -- 2026-08-27 + +* Add `LLVM.Combine` module with `llvmModuleCombine` function. This is the + proper way to combine two LLVM `Module` definitions and maintain integrity + (e.g. roughly equivalent to `llvm-link`). The `Module` Semigroup instance is + unsafe and is deprecated (along with the Monoid instance) and scheduled for + removal. Note that `llvmModuleCombine` does not do significant error detection + and it's up to the caller to determine that the modules should be combined. + See the documentation for `llvmModuleCombine` for more details. + +* Support LLVM 22: + * `DICompileUnit'` now has an additional `dicuSourceLanguageVersion :: Word64` + field. + * `DIBasicType'` now has an additional `dibtDataSize :: Word32` field. + +* Support LLVM 21: + * Added support for the `DISubrangeType` metadata. + * Added support for the `DIFixedPointType` metadata. + +* Corrected the printing of non-normal single-precision floating point + constants. + +* Added missing `FloatType` case `BFloat` for 16-bit "Brain" floats. + +* Added missing `Value'` cases for floating point types: + * `ValHalf` containing an `FPHalfValue` (a wrapper around `Word16`) + * `ValBFloat` containing an `FPBFloatValue` (a wrapper around `Word16`) + * `ValFP128` containing an `FP128Value` (a wrapper around two `Word64`) + * `ValFP128_PPC` containing an `FP128_PPCValue` + (a wrapper around two `Double`s) + +* Added the `atFileLines` function to `DebugUtils.hs` which retrieves the + statements associated with a specific source file and line number for user + processing. + +* Added the `ppModuleAtLine` which can be used to pretty-print only the portion + of the bitcode that is associated with a specific source file and line number + (this uses the new `atFileLines` function internally). + +* Breaking change: Unnamed metadata indexes are in an `UnnamedMdIdx` newtype + wrapper now instead of being an undecorated `Int`. + +## 0.14.0.0 -- 2026-01-23 + +* Changes to support LLVM 19 (some of these changes are not backward-compatible): + * Changes to `LayoutSpec` for DataLayout: + * Size specification fields use a common sub-structure `Storage` which itself + contains an `Alignment` common sub-structure: `IntegerSize`, `VectorSize`, + `FloatSize`, and `StackObjSize`. + * The pointer size specification field uses a `PointerSize` sub-structure + that itself contains a `Storage` sub-structure. + * Updated `AggregateSize` to make first field optional (it was dropped in + LLVM 4) and the remaining fields are now provided via the `Alignment` + sub-structure. + * Added `ProgramAddrSpace`, `GlobalAddrSpace`, and `AllocaAddrSpace` + constructors, each defined via an `AddressSpace` sub-structure. + * Added `NonIntegralPointerSpaces` to record address spaces with an + unspecified bitwise representation. + * Added `GoffMangling`, `WindowsX86CoffMangling`, and `XCoffMangling` forms + of Mangling. + * Added `GEPAttr` flags for `GEP` instruction and constant expression, with + `RangeSpec` for the latter. + * Added `numExtraInhabitants` to `DIBasicType`. + * Added support for `DebugRecord` parsing, specifically for: + + * `FUNC_CODE_DEBUG_RECORD_VALUE` + * `FUNC_CODE_DEBUG_RECORD_DECLARE` + * `FUNC_CODE_DEBUG_RECORD_ASSIGN` + * `FUNC_CODE_DEBUG_RECORD_VALUE_SIMPLE` + * `FUNC_CODE_DEBUG_RECORD_LABEL` + + This adds a new field to both the `Result` and `Effect` constructors of the `Stmt` type. + * Pretty-printing with an LLVM version >= 19 now generates an error for `icmp`, + `fcmp`, and `shl` constant expressions that are no longer supported as of + LLVM 19. +* Changes to cast-related instructions: + * Add a `Bool` field to `ZExt` which, if `True`, indicates that the + argument must be non-negative. This is used by LLVM 18 and up. + * Add a `Bool` field to `UiToFp` which, if `True`, indicates that the + argument must be non-negative. This is used by LLVM 19 and up. + * Add `Bool` fields to `Trunc` to check if the truncation would cause + unsigned or signed overflow. These are used by LLVM 20 and up. +* Add a `Bool` field to `ICmp`, which indicates that the arguments must have + the same sign. This is used by LLVM 20 and up. +* Add `dlAtomGroup` and `dlAtomRank` fields to `DebugLoc'`, which were + introduced in LLVM 21. +* Add `dilColumn`, `dilIsArtificial`, and `dilCoroSuspendIdx` fields to + `DILabel'`, which were introduced in LLVM 21. +* The following debug-related fields have had their types changed from `Word64` + to `Maybe (ValMd' lab)`: + + * `DIBasicType'`: `dibtSize` + * `DICompositeType'`: `dictSize` and `dictOffset` + * `DIDerivedType'`: `didtSize` and `didtOffset` + + This allows them to encode non-constant sizes and offsets (a capability used + by Ada, for instance) in LLVM 21 or later. +* Added the `bbStmtModifier` which can be used to modify individual statements as + they are emitted from the top-level instruction generator functions (e.g to add + Debug Metadata to each statement). +* Fix a bug that would cause `indirectbr` statements to be pretty-printed + incorrectly. + +## 0.13.1.0 (October 2025) + +* Add a `FunctionPointerAlign` constructor to `LayoutSpec`. + +## 0.13.0.0 (March 2025) + +* Changed some of the signatures of helper functions in the AST to make them more + flexible by using `Type' ident` rather than `Type` in their signatures (the + latter fixes `ident` to be `Ident`). Changed functions: `isAlias`, + `isPrimTypeOf`, `isVector`, `isVectorOf`, `isArray`, and `isPointer`. + ## 0.12.1.0 (August 2024) * Fix for printing NaN and infinite floating point values. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,7 +7,12 @@ ## LLVM language feature support -Currently, `llvm-pretty` supports LLVM versions up through 17. As a result of + + +Currently, `llvm-pretty` supports LLVM versions up through 22. 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 diff --git a/llvm-pretty.cabal b/llvm-pretty.cabal --- a/llvm-pretty.cabal +++ b/llvm-pretty.cabal @@ -1,6 +1,7 @@ Cabal-version: 2.2 Name: llvm-pretty -Version: 0.12.1.0 +Version: 0.15.0.0 + -- TODO: needs to be 0.15 due to UnnamedMdIdx newtype wrapper License: BSD-3-Clause License-file: LICENSE Author: Trevor Elliott @@ -13,7 +14,7 @@ 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. -tested-with: GHC==8.4.3, GHC==8.2.2, GHC==8.0.2 +tested-with: GHC==9.12.2, GHC==9.10.1, GHC==9.8.4 extra-doc-files: CHANGELOG.md, README.md @@ -25,6 +26,7 @@ Default-language: Haskell2010 Ghc-options: -Wall + -fhide-source-paths Library Import: common @@ -37,6 +39,7 @@ Text.LLVM.Lens Text.LLVM.Parser Text.LLVM.PP + Text.LLVM.Combine Text.LLVM.DebugUtils Text.LLVM.Triple Text.LLVM.Triple.AST @@ -48,20 +51,26 @@ Build-depends: base >= 4.11 && < 5, containers >= 0.4, + filepath >= 1.4, parsec >= 3, pretty >= 1.0.1, monadLib >= 3.6.1, microlens >= 0.4, microlens-th >= 0.4, + microlens-platform >= 0.4, + -- microlens-platform provides the IxValue instance for IntMap syb >= 0.7, template-haskell >= 2.7, - th-abstraction >= 0.3.1 && <0.7 + th-abstraction >= 0.3.1 && <0.8 Test-suite llvm-pretty-test Import: common Type: exitcode-stdio-1.0 Main-is: Main.hs Other-modules: + CombineTests + DataLayout + Metadata Output Triple TQQDefs @@ -71,6 +80,7 @@ Build-depends: llvm-pretty, base, + microlens, pretty, tasty, tasty-hunit, diff --git a/src/Text/LLVM.hs b/src/Text/LLVM.hs --- a/src/Text/LLVM.hs +++ b/src/Text/LLVM.hs @@ -40,6 +40,8 @@ -- * Basic Blocks , BB() + , runBB + , bbStmtModifier , freshLabel , label , comment @@ -139,9 +141,41 @@ -- LLVM Monad ------------------------------------------------------------------ newtype LLVM a = LLVM - { unLLVM :: WriterT Module (StateT Names Id) a + { unLLVM :: WriterT ModuleBuilder (StateT Names Id) a } deriving (Functor,Applicative,Monad,MonadFix) + +-- | This is an internal object used to provide the Monoid/Semigroup building +-- context for the WriterT. There is no Semigroup instance for Module itself, +-- because combining modules is not a trivial operation and it can fail +-- (e.g. duplicate symbols/definitions); see the 'LLVM.Combine' module for a +-- proper link-like combining function. However, the functionality here is not +-- really combining two modules, but instead is constructing a single module from +-- discrete operations and thus we can use the ModuleBuilder newtype wrapper to +-- allow Monoid/Semigroup functionality under this LLVM monad. + +newtype ModuleBuilder = ModuleBuilder { getModule :: Module } + +instance Semigroup ModuleBuilder where + (ModuleBuilder m1) <> (ModuleBuilder m2) = ModuleBuilder $ 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 + , modNamedMd = modNamedMd m1 <> modNamedMd m2 + , modGlobals = modGlobals m1 <> modGlobals m2 + , modDeclares = modDeclares m1 <> modDeclares m2 + , modDefines = modDefines m1 <> modDefines m2 + , modInlineAsm = modInlineAsm m1 <> modInlineAsm m2 + , modAliases = modAliases m1 <> modAliases m2 + , modComdat = modComdat m1 <> modComdat m2 + } + +instance Monoid ModuleBuilder where + mempty = ModuleBuilder emptyModule + + freshNameLLVM :: String -> LLVM String freshNameLLVM pfx = LLVM $ do ns <- get @@ -150,24 +184,24 @@ return n runLLVM :: LLVM a -> (a,Module) -runLLVM = fst . runId . runStateT Map.empty . runWriterT . unLLVM +runLLVM = fmap getModule . fst . runId . runStateT Map.empty . runWriterT . unLLVM emitTypeDecl :: TypeDecl -> LLVM () -emitTypeDecl td = LLVM (put emptyModule { modTypes = [td] }) +emitTypeDecl td = LLVM (put $ ModuleBuilder $ emptyModule { modTypes = [td] }) emitGlobal :: Global -> LLVM (Typed Value) emitGlobal g = - do LLVM (put emptyModule { modGlobals = [g] }) + do LLVM (put $ ModuleBuilder $ emptyModule { modGlobals = [g] }) return (ptrT (globalType g) -: globalSym g) emitDefine :: Define -> LLVM (Typed Value) emitDefine d = - do LLVM (put emptyModule { modDefines = [d] }) + do LLVM (put $ ModuleBuilder $ emptyModule { modDefines = [d] }) return (defFunType d -: defName d) emitDeclare :: Declare -> LLVM (Typed Value) emitDeclare d = - do LLVM (put emptyModule { modDeclares = [d] }) + do LLVM (put $ ModuleBuilder $ emptyModule { modDeclares = [d] }) return (decFunType d -: decName d) alias :: Ident -> Type -> LLVM () @@ -313,9 +347,36 @@ -- Basic Block Monad ----------------------------------------------------------- newtype BB a = BB - { unBB :: WriterT [BasicBlock] (StateT RW Id) a + { unBB :: ReaderT (Stmt -> Stmt) (WriterT [BasicBlock] (StateT RW Id)) a } deriving (Functor,Applicative,Monad,MonadFix) + +-- | The 'bbStmtModifier' function can be used to register a function that can +-- modify the subsequent statements generated into this block. +-- +-- For example, the following 'BB' monad code segment will emit a couple of LLVM +-- statements: +-- +-- > v <- load (iT 8) globalVar Nothing +-- > call fooFunc [v] +-- > jump end +-- +-- But these statements will be \"plain\" in the resulting 'BasicBlock'. If the +-- caller wishes to add debug Metadata for location, they could instead write: +-- +-- > bbStmtModifier (extendMetadata ("dbg", ValMdRef i)) +-- > v <- load (iT 8) globalVar Nothing +-- > bbStmtModifier (extendMetadata ("dbg", ValMdRef j)) +-- > call fooFunc [v] +-- > jump end +-- +-- Where @i@ and @j@ are the metadata index values of the 'DebugLoc' entries +-- describing the source location of the \"load\" and \"call\"+\"jump\" statements, +-- respectively. + +bbStmtModifier :: (Stmt -> Stmt) -> BB a -> BB a +bbStmtModifier stmtModifier = BB . local stmtModifier . unBB + avoidName :: String -> BB () avoidName name = BB $ do rw <- get @@ -332,7 +393,7 @@ runBB :: BB a -> (a,[BasicBlock]) runBB m = - case runId (runStateT emptyRW (runWriterT (unBB body))) of + case runId (runStateT emptyRW (runWriterT (runReaderT id (unBB body)))) of ((a,bbs),_rw) -> (a,bbs) where -- make sure that the last block is terminated @@ -366,17 +427,18 @@ emitStmt stmt = do BB $ do rw <- get - set $! rw { rwStmts = rwStmts rw Seq.|> stmt } + smod <- ask + set $! rw { rwStmts = rwStmts rw Seq.|> smod stmt } when (isTerminator (stmtInstr stmt)) terminateBasicBlock effect :: Instr -> BB () -effect i = emitStmt (Effect i []) +effect i = emitStmt (Effect i mempty []) observe :: Type -> Instr -> BB (Typed Value) observe ty i = do name <- freshNameBB "r" let res = Ident name - emitStmt (Result res i []) + emitStmt (Result res i mempty []) return (Typed ty (ValIdent res)) @@ -507,8 +569,8 @@ rw <- BB get case Seq.viewr (rwStmts rw) of - stmts Seq.:> Result _ i m -> - do BB (set rw { rwStmts = stmts Seq.|> Result r i m }) + stmts Seq.:> Result _ i d m -> + do BB (set rw { rwStmts = stmts Seq.|> Result r i d m }) return (const (ValIdent r) `fmap` tv) _ -> error "assign: invalid argument" @@ -639,10 +701,10 @@ convop k a ty = observe ty (k (toValue `fmap` a) ty) trunc :: IsValue a => Typed a -> Type -> BB (Typed Value) -trunc = convop (Conv Trunc) +trunc = convop (Conv (Trunc False False)) zext :: IsValue a => Typed a -> Type -> BB (Typed Value) -zext = convop (Conv ZExt) +zext = convop (Conv (ZExt False)) sext :: IsValue a => Typed a -> Type -> BB (Typed Value) sext = convop (Conv SExt) @@ -660,7 +722,7 @@ fptosi = convop (Conv FpToSi) uitofp :: IsValue a => Typed a -> Type -> BB (Typed Value) -uitofp = convop (Conv UiToFp) +uitofp = convop (Conv (UiToFp False)) sitofp :: IsValue a => Typed a -> Type -> BB (Typed Value) sitofp = convop (Conv SiToFp) @@ -675,7 +737,7 @@ bitcast = convop (Conv BitCast) icmp :: (IsValue a, IsValue b) => ICmpOp -> Typed a -> b -> BB (Typed Value) -icmp op l r = observe (iT 1) (ICmp op (toValue `fmap` l) (toValue r)) +icmp op l r = observe (iT 1) (ICmp False op (toValue `fmap` l) (toValue r)) fcmp :: (IsValue a, IsValue b) => FCmpOp -> Typed a -> b -> BB (Typed Value) fcmp op l r = observe (iT 1) (FCmp op (toValue `fmap` l) (toValue r)) @@ -695,13 +757,13 @@ getelementptr :: IsValue a => Type -> Typed a -> [Typed Value] -> BB (Typed Value) -getelementptr ty ptr ixs = observe ty (GEP False ty (toValue `fmap` ptr) ixs) +getelementptr ty ptr ixs = observe ty (GEP [] 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) call sym vs = case typedType sym of - ty@(PtrTo (FunTy rty _ _)) -> observe rty (Call False ty (toValue sym) vs) - _ -> error "invalid function type given to call" + PtrTo ty@(FunTy rty _ _) -> observe rty (Call False ty (toValue sym) vs) + _ -> error "invalid function type given to call" -- | Emit a call instruction, but don't generate a new variable for its result. call_ :: IsValue a => Typed a -> [Typed Value] -> BB () 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 @@ -9,12 +9,17 @@ incomplete: there are some values that new LLVM versions would accept but are not yet represented here. -} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} + module Text.LLVM.AST ( -- * Modules Module(..) @@ -22,12 +27,20 @@ -- * Named Metadata , NamedMd(..) -- * Unnamed Metadata - , UnnamedMd(..) + , UnnamedMd(..), UnnamedMdIdx(UnnamedMdIdx, unnamedMdIdx) + , nonNullUnnamedMdIdx + , nextUnnamedMdIdx -- * Aliases , GlobalAlias(..) -- * Data Layout , DataLayout , LayoutSpec(..) + , Alignment(..) + , FunctionPointerAlignType(..) + , Storage(..) + , PointerSize(..) + , AddressSpace + , NumBits , Mangling(..) , parseDataLayout -- * Inline Assembly @@ -116,7 +129,11 @@ , FCmpOp(..) -- * Values , Value'(..), Value + , FPHalfValue(..) + , FPBFloatValue(..) , FP80Value(..) + , FP128Value(..) + , FP128_PPCValue(..) , ValMd'(..), ValMd , KindMd , FnMdAttachments @@ -131,8 +148,12 @@ , stmtInstr , stmtMetadata , extendMetadata + , addDebugRecord -- * Constant Expressions , ConstExpr'(..), ConstExpr + , GEPAttr(..) + , orderedGEPAttrs + , RangeSpec(RangeIndex, Range) -- * DWARF Debug Info , DebugInfo'(..), DebugInfo , DILabel, DILabel'(..) @@ -146,10 +167,12 @@ , DwarfVirtuality , DIFlags , DIEmissionKind - , DIBasicType(..) + , DIBasicType'(..), DIBasicType , DICompileUnit'(..), DICompileUnit , DICompositeType'(..), DICompositeType , DIDerivedType'(..), DIDerivedType + , DIFixedPointType'(..), DIFixedPointType + , DIFixedPointKind'(..), DIFixedPointKind , DIExpression(..) , DIFile(..) , DIGlobalVariable'(..), DIGlobalVariable @@ -159,8 +182,16 @@ , DILocalVariable'(..), DILocalVariable , DISubprogram'(..), DISubprogram , DISubrange'(..), DISubrange + , DISubrangeType'(..), DISubrangeType , DISubroutineType'(..), DISubroutineType , DIArgList'(..), DIArgList + , dwarf_DW_APPLE_ENUM_KIND_invalid + , DebugRecord, DebugRecord'(..) + , DbgRecAssign, DbgRecAssign'(..) + , DbgRecDeclare, DbgRecDeclare'(..) + , DbgRecLabel, DbgRecLabel'(..) + , DbgRecValueSimple, DbgRecValueSimple'(..) + , DbgRecValue, DbgRecValue'(..) -- * Aggregate Utilities , IndexResult(..) , isInvalid @@ -172,18 +203,19 @@ , resolveValueIndex ) where -import Data.Functor.Identity (Identity(..)) +import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) +import Data.Bits ( complement ) import Data.Coerce (coerce) import Data.Data (Data) -import Data.Typeable (Typeable) -import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) -import Data.Int (Int32,Int64) +import Data.Functor.Identity (Identity(..)) import Data.Generics (everywhere, extQ, mkT, something) +import Data.Int (Int32,Int64) 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.Typeable (Typeable) import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic, Generic1) import Language.Haskell.TH.Syntax (Lift) @@ -209,10 +241,15 @@ , modDefines :: [Define] -- ^ internal function declarations (with definitions) , modInlineAsm :: InlineAsm , modAliases :: [GlobalAlias] - } deriving (Data, Eq, Ord, Generic, Show, Typeable) + } deriving (Data, Eq, Ord, Generic, Show) -- | Combines fields pointwise. -instance Sem.Semigroup Module where +instance +#if __GLASGOW_HASKELL__ >= 910 + -- Deprecation of instances was added in GHC 9.10 + {-# DEPRECATED "Unsafe! Scheduled for removal: use llvmModuleCombine instead" #-} +#endif + Sem.Semigroup Module where m1 <> m2 = Module { modSourceName = modSourceName m1 `mplus` modSourceName m2 , modTriple = modTriple m1 <> modTriple m2 @@ -228,9 +265,13 @@ , modComdat = modComdat m1 <> modComdat m2 } -instance Monoid Module where +instance +#if __GLASGOW_HASKELL__ >= 910 + -- Deprecation of instances was added in GHC 9.10 + {-# DEPRECATED "Scheduled for removal: use emptyModule instead" #-} +#endif + Monoid Module where mempty = emptyModule - mappend = (<>) emptyModule :: Module emptyModule = Module @@ -253,17 +294,46 @@ data NamedMd = NamedMd { nmName :: String - , nmValues :: [Int] - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + , nmValues :: [UnnamedMdIdx] + } deriving (Data, Eq, Generic, Ord, Show) -- Unnamed Metadata ------------------------------------------------------------ +-- | This is the type used to represent an unnamed metadata index. A newtype +-- wrapper is used to distinguish the specific use of this value as this +-- particular type of index. +-- +-- The Ord instance is provided to allow these indices to be used as Map keys. +-- Although Num and Enum instances are provided to enable manipulation, care +-- should be taken that these are all very carefully used only where needed and +-- appropriate. In general, the `nextUnnamedMdIdx` function is preferred. +newtype UnnamedMdIdx = UnnamedMdIdx { unnamedMdIdx :: Int } + deriving (Data, Eq, Generic, Ord, Enum, Num, Show) + +-- | This is used when constructing an AST and a new unnamed metadata element is +-- to be added. It should be passed the current maximum known index and will +-- return the new, unused index that should be used. +nextUnnamedMdIdx :: UnnamedMdIdx -> UnnamedMdIdx +nextUnnamedMdIdx (UnnamedMdIdx i) = UnnamedMdIdx $ i + 1 + +-- | In the bitcode, an "optional" unnamed metadata index is indicated by 0 (not +-- present) or the actual index + 1. The parsing should treat these optional as +-- a different type than an UnnamedMdIdx, but this is not presently detected at +-- the parsing level, so this function is used to convert a parsed UnnamedMdIdx +-- to the option of the correct index. +-- +-- Note that it is NOT valid to call this twice (or not at all in the event you +-- are starting with an optional form). +nonNullUnnamedMdIdx :: UnnamedMdIdx -> Maybe UnnamedMdIdx +nonNullUnnamedMdIdx (UnnamedMdIdx i) = + if i == 0 then Nothing else Just $ UnnamedMdIdx $ i - 1 + data UnnamedMd = UnnamedMd - { umIndex :: !Int + { umIndex :: !UnnamedMdIdx , umValues :: ValMd , umDistinct :: Bool - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) -- Aliases --------------------------------------------------------------------- @@ -274,38 +344,79 @@ , aliasName :: Symbol , aliasType :: Type , aliasTarget :: Value - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) -- Data Layout ----------------------------------------------------------------- +-- https://releases.llvm.org/19.1.0/docs/LangRef.html#data-layout type DataLayout = [LayoutSpec] data LayoutSpec = BigEndian | LittleEndian - | PointerSize !Int !Int !Int (Maybe Int) -- ^ address space, size, abi, pref - | IntegerSize !Int !Int (Maybe Int) -- ^ size, abi, pref - | VectorSize !Int !Int (Maybe Int) -- ^ size, abi, pref - | FloatSize !Int !Int (Maybe Int) -- ^ size, abi, pref - | StackObjSize !Int !Int (Maybe Int) -- ^ size, abi, pref - | AggregateSize !Int !Int (Maybe Int) -- ^ size, abi, pref - | NativeIntSize [Int] - | StackAlign !Int -- ^ size + | PointerSize PointerSize + | IntegerSize Storage + | VectorSize Storage + | FloatSize Storage + | StackObjSize Storage + | AggregateSize (Maybe Int) !Alignment -- n.b. first Int present pre-LLVM4 + | NativeIntSize [NumBits] + | StackAlign !NumBits -- ^ size + | ProgramAddrSpace !AddressSpace + | GlobalAddrSpace !AddressSpace + | AllocaAddrSpace !AddressSpace + | FunctionPointerAlign !FunctionPointerAlignType !NumBits -- ^ type, abi | Mangling Mangling - deriving (Data, Eq, Generic, Ord, Show, Typeable) + | NonIntegralPointerSpaces [AddressSpace] + deriving (Data, Eq, Generic, Ord, Show) +data Alignment = Alignment + { alignABI :: !NumBits + , alignPreferred :: Maybe NumBits -- ^ default = alignABI + } + deriving (Data, Eq, Generic, Ord, Show) + +-- | How should a function pointer be aligned? +data FunctionPointerAlignType + = IndependentOfFunctionAlign + -- ^ The alignment of function pointers is independent of the alignment of + -- functions. + | MultipleOfFunctionAlign + -- ^ The alignment of function pointers is a multiple of the explicit + -- alignment specified on the function. + deriving (Data, Eq, Enum, Generic, Ord, Show) + +data Storage = Storage + { storageSize :: !NumBits -- ^ valid range [1,2^24) + , storageAlignment :: Alignment + } + deriving (Data, Eq, Generic, Ord, Show) + +data PointerSize = PtrSize + { ptrAddrSpace :: !AddressSpace + , ptrStorage :: Storage + , ptrAddrIndexSize :: Maybe NumBits -- ^ m.b. <= ptrSize, default = ptrSize + } + deriving (Data, Eq, Generic, Ord, Show) + +type AddressSpace = Int +type NumBits = Int + data Mangling = ElfMangling + | GoffMangling | MipsMangling | MachOMangling | WindowsCoffMangling - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + | WindowsX86CoffMangling + | XCoffMangling + deriving (Data, Eq, Enum, Generic, Ord, Show) -- | Parse the data layout string. parseDataLayout :: MonadPlus m => String -> m DataLayout parseDataLayout str = case parse (pDataLayout <* eof) "" str of - Left _err -> mzero + Left _err -> {- debugging: trace (show err) -} mzero Right specs -> return specs where pDataLayout :: Parser DataLayout @@ -317,11 +428,17 @@ case c of 'E' -> return BigEndian 'e' -> return LittleEndian - 'S' -> StackAlign <$> pInt - 'p' -> PointerSize <$> pInt0 <*> pCInt <*> pCInt <*> pPref - 'i' -> IntegerSize <$> pInt <*> pCInt <*> pPref - 'v' -> VectorSize <$> pInt <*> pCInt <*> pPref - 'f' -> FloatSize <$> pInt <*> pCInt <*> pPref -- size of float, abi-align, pref-align + 'S' -> StackAlign <$> pInt + 'P' -> ProgramAddrSpace <$> pInt -- Added in LLVM7 + 'G' -> GlobalAddrSpace <$> pInt -- Added in LLVM11 + 'A' -> AllocaAddrSpace <$> pInt -- Added in LLVM11 + 'p' -> do as <- pInt <|> return 0 + st <- char ':' >> pStorage + idx <- pCOInt -- Added in LLVM7 + return $ PointerSize $ PtrSize as st idx + 'i' -> IntegerSize <$> pStorage + 'v' -> VectorSize <$> pStorage + 'f' -> FloatSize <$> pStorage -- Note that the data layout specified in the LLVM -- BC/IR file is not a directive to the backend, but -- is instead an indication of what the particular @@ -336,33 +453,59 @@ -- (for example) references to LongDoubleWidth and -- LongDoubleFormat in -- https://github.com/llvm/llvm-project/blob/release_60/clang/lib/Basic/Targets/X86.h - 's' -> StackObjSize <$> pInt <*> pCInt <*> pPref - 'a' -> AggregateSize <$> pInt <*> pCInt <*> pPref - 'n' -> NativeIntSize <$> sepBy pInt (char ':') - 'm' -> Mangling <$> (char ':' >> pMangling) + 's' -> StackObjSize <$> pStorage -- Obsoleted in LLVM4 + 'a' -> alphaNum >>= \case + ':' -> AggregateSize Nothing <$> pAlignment + d -> AggregateSize <$> (Just <$> pIntWithFirstDigit d) + <* char ':' <*> pAlignment + 'F' -> FunctionPointerAlign <$> pFunctionPointerAlignType <*> pInt -- Added in LLVM9 + 'm' -> Mangling <$ char ':' <*> pMangling + 'n' -> alphaNum >>= \case + 'i' -> char ':' + >> (NonIntegralPointerSpaces <$> sepBy pInt (char ':')) + d -> do fs <- pIntWithFirstDigit d + ss <- char ':' *> sepBy pInt (char ':') + return $ NativeIntSize $ fs : ss _ -> mzero + pFunctionPointerAlignType :: Parser FunctionPointerAlignType + pFunctionPointerAlignType = + do c <- letter + case c of + 'i' -> return IndependentOfFunctionAlign + 'n' -> return MultipleOfFunctionAlign + _ -> mzero + pMangling :: Parser Mangling pMangling = do c <- letter case c of 'e' -> return ElfMangling + 'l' -> return GoffMangling 'm' -> return MipsMangling 'o' -> return MachOMangling 'w' -> return WindowsCoffMangling + 'x' -> return WindowsX86CoffMangling + 'a' -> return XCoffMangling _ -> mzero + pAlignment :: Parser Alignment + pAlignment = Alignment <$> pInt <*> pCOInt + + pStorage :: Parser Storage + pStorage = Storage <$> pInt <* char ':' <*> pAlignment + pInt :: Parser Int pInt = read <$> many1 digit - pInt0 :: Parser Int - pInt0 = pInt <|> return 0 + pIntWithFirstDigit :: Char -> Parser Int + pIntWithFirstDigit d0 = read . (d0:) <$> many digit pCInt :: Parser Int pCInt = char ':' >> pInt - pPref :: Parser (Maybe Int) - pPref = optionMaybe pCInt + pCOInt :: Parser (Maybe Int) + pCOInt = optionMaybe pCInt -- Inline Assembly ------------------------------------------------------------- @@ -375,12 +518,12 @@ | ComdatLargest | ComdatNoDuplicates | ComdatSameSize - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show) -- Identifiers ----------------------------------------------------------------- newtype Ident = Ident String - deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift) + deriving (Data, Eq, Generic, Ord, Show, Lift) instance IsString Ident where fromString = Ident @@ -388,7 +531,7 @@ -- Symbols --------------------------------------------------------------------- newtype Symbol = Symbol String - deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift) + deriving (Data, Eq, Generic, Ord, Show, Lift) instance Sem.Semigroup Symbol where Symbol a <> Symbol b = Symbol (a <> b) @@ -409,16 +552,17 @@ | FloatType FloatType | X86mmx | Metadata - deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift) + deriving (Data, Eq, Generic, Ord, Show, Lift) data FloatType = Half + | BFloat -- ^ Introduced in LLVM 11 | Float | Double | Fp128 | X86_fp80 | PPC_fp128 - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable, Lift) + deriving (Data, Eq, Enum, Generic, Ord, Show, Lift) type Type = Type' Ident @@ -454,7 +598,7 @@ -- -- '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) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) -- | Applicatively traverse a type, updating or removing aliases. updateAliasesA :: (Applicative f) => (a -> f (Type' b)) -> Type' a -> f (Type' b) @@ -480,11 +624,11 @@ isFloatingPoint (FloatType _) = True isFloatingPoint _ = False -isAlias :: Type -> Bool +isAlias :: Type' ident -> Bool isAlias Alias{} = True isAlias _ = False -isPrimTypeOf :: (PrimType -> Bool) -> Type -> Bool +isPrimTypeOf :: (PrimType -> Bool) -> Type' ident -> Bool isPrimTypeOf p (PrimType pt) = p pt isPrimTypeOf _ _ = False @@ -496,20 +640,20 @@ isInteger Integer{} = True isInteger _ = False -isVector :: Type -> Bool +isVector :: Type' ident -> Bool isVector Vector{} = True isVector _ = False -isVectorOf :: (Type -> Bool) -> Type -> Bool +isVectorOf :: (Type' ident -> Bool) -> Type' ident -> Bool isVectorOf p (Vector _ e) = p e isVectorOf _ _ = False -isArray :: Type -> Bool +isArray :: Type' ident -> Bool isArray ty = case ty of Array _ _ -> True _ -> False -isPointer :: Type -> Bool +isPointer :: Type' ident -> Bool isPointer (PtrTo _) = True isPointer PtrOpaque = True isPointer _ = False @@ -610,7 +754,7 @@ data NullResult lab = HasNull (Value' lab) | ResolveNull Ident - deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) primTypeNull :: PrimType -> Value' lab primTypeNull (Integer 1) = ValBool False @@ -619,10 +763,13 @@ primTypeNull _ = ValZeroInit floatTypeNull :: FloatType -> Value' lab +floatTypeNull Half = ValHalf $ FPHalf 0 +floatTypeNull BFloat = ValBFloat $ FPBFloat 0 floatTypeNull Float = ValFloat 0 -floatTypeNull Double = ValDouble 0 -- XXX not sure about this +floatTypeNull Double = ValDouble 0 +floatTypeNull Fp128 = ValFP128 $ FP128_LongDouble 0 0 floatTypeNull X86_fp80 = ValFP80 $ FP80_LongDouble 0 0 -floatTypeNull _ = error "must be a float type" +floatTypeNull PPC_fp128 = ValFP128_PPC $ FP128_PPC_DoubleDouble 0 0 typeNull :: Type -> NullResult lab typeNull (PrimType pt) = HasNull (primTypeNull pt) @@ -678,7 +825,7 @@ data TypeDecl = TypeDecl { typeName :: Ident , typeValue :: Type - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) -- Globals --------------------------------------------------------------------- @@ -690,7 +837,7 @@ , globalValue :: Maybe Value , globalAlign :: Maybe Align , globalMetadata :: GlobalMdAttachments - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) addGlobal :: Global -> Module -> Module addGlobal g m = m { modGlobals = g : modGlobals m } @@ -699,7 +846,7 @@ { gaLinkage :: Maybe Linkage , gaVisibility :: Maybe Visibility , gaConstant :: Bool - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) emptyGlobalAttrs :: GlobalAttrs emptyGlobalAttrs = GlobalAttrs @@ -720,7 +867,7 @@ , decVarArgs :: Bool , decAttrs :: [FunAttr] , decComdat :: Maybe String - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) -- | The function type of this declaration decFunType :: Declare -> Type @@ -742,7 +889,7 @@ , defBody :: [BasicBlock] , defMetadata :: FnMdAttachments , defComdat :: Maybe String - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) defFunType :: Define -> Type defFunType Define { .. } = @@ -783,14 +930,14 @@ | SSPreq | SSPstrong | UWTable - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) -- Basic Block Labels ---------------------------------------------------------- data BlockLabel = Named Ident | Anon Int - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) instance IsString BlockLabel where fromString str = Named (fromString str) @@ -800,7 +947,7 @@ data BasicBlock' lab = BasicBlock { bbLabel :: Maybe lab , bbStmts :: [Stmt' lab] - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type BasicBlock = BasicBlock' BlockLabel @@ -816,41 +963,66 @@ -- Attributes ------------------------------------------------------------------ --- | Symbol Linkage +-- | Symbol 'Linkage' provides information on how the symbol should be handled +-- during linking operations. See https://llvm.org/docs/LangRef.html for more +-- details on the meanings of these flags. data Linkage = Private + -- ^ Only accessible by objects in the current module. May be renamed during + -- linking to avoid collisions. Not visible in the object file's symbol table. | LinkerPrivate | LinkerPrivateWeak | LinkerPrivateWeakDefAuto | Internal + -- ^ Similar to private but shows up as a local symbol (e.g. C @static@) | AvailableExternally + -- ^ External declaration, never defined in the object file. Allows inlining + -- and other optimizations knowing the symbol exists externally. May be + -- discarded at will. Only allowed on 'Declare', not on 'Define'. | Linkonce + -- ^ Merged with globals of the same name during linkage. Useful for common + -- inlines, templates, or generated code from translation units that may be + -- overridden with a more definitive definition later. May be discarded if + -- unreferenced. | Weak + -- ^ Same as Linkonce but may not be discarded (e.g. C @weak@). | Common + -- ^ Similar to "weak", but must have a zero initializer and may not be + -- marked "constant". Not valid for functions and aliases. | Appending + -- ^ Only valid for global variables of "pointer to array" type. Similar to + -- section concatenation during linking. No correspondence to an object file + -- feature. | ExternWeak + -- ^ Semantics follows ELF: object is weak until linked. If not linked, it + -- becomes null instead of being undefined. | LinkonceODR + -- ^ Like Linkonce, with C++ "one definition rule", meaning it can be inlined and + -- constants can be folded. | WeakODR + -- ^ Like Weak, with C++ "one definition rule", meaning it can be inlined and + -- constants can be folded. | External + -- ^ If none of the others applies, this is externally visible. | DLLImport | DLLExport - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show) data Visibility = DefaultVisibility | HiddenVisibility | ProtectedVisibility - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) newtype GC = GC { getGC :: String - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) -- Typed Things ---------------------------------------------------------------- data Typed a = Typed { typedType :: Type , typedValue :: a - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) instance Foldable Typed where foldMap f t = f (typedValue t) @@ -920,7 +1092,7 @@ -- ^ * Floating point reminder resulting from floating point division. -- * The reminder has the same sign as the divident (first parameter). - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) isIArith :: ArithOp -> Bool isIArith Add{} = True @@ -938,7 +1110,7 @@ data UnaryArithOp = FNeg -- ^ Floating point negation. - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) -- | Binary bitwise operators. data BitOp @@ -975,23 +1147,55 @@ | And | Or | Xor - deriving (Data, Eq, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) -- | Conversions from one type to another. data ConvOp - = Trunc - | ZExt + = Trunc Bool Bool + -- ^ Truncate an integer value to a smaller integer type. + -- + -- The 'Bool' fields (added in in LLVM 20) encode whether to perform + -- overflow-related checks: + -- + -- * First 'Bool': check for unsigned overflow. + -- * Second 'Bool': check for signed overflow. + -- + -- If the checks fail, then the result is poisoned. + -- + -- These fields can only ever 'True' in 'Conv' instructions in LLVM 20 or + -- later. These fields are always 'False' in 'ConstConv' constant + -- expressions or if the LLVM version is older than 20. + | ZExt Bool + -- ^ Zero extension. + -- + -- The 'Bool' field (added in LLVM 18) encodes whether to enforce that the + -- argument is non-negative. If the 'Bool' is 'True' and the argument is + -- negative, then the result is poisoned. + -- + -- This field can only ever 'True' in 'Conv' instructions in LLVM 18 or + -- later. This field is always 'False' in 'ConstConv' constant expressions + -- or if the LLVM version is older than 18. | SExt | FpTrunc | FpExt | FpToUi | FpToSi - | UiToFp + | UiToFp Bool + -- ^ Convert the argument from an unsigned integer to a floating-point + -- value. + -- + -- The 'Bool' field (added in LLVM 19) encodes whether to enforce that the + -- argument is non-negative. If the 'Bool' is 'True' and the argument is + -- negative, then the result is poisoned. + -- + -- This field can only ever 'True' in 'Conv' instructions in LLVM 19 or + -- later. This field is always 'False' in 'ConstConv' constant expressions + -- or if the LLVM version is older than 19. | SiToFp | PtrToInt | IntToPtr | BitCast - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show) data AtomicRWOp = AtomicXchg @@ -1011,7 +1215,7 @@ | AtomicFMin -- ^ Introduced in LLVM 15 | AtomicUIncWrap -- ^ Introduced in LLVM 16 | AtomicUDecWrap -- ^ Introduced in LLVM 16 - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show) data AtomicOrdering = Unordered @@ -1020,7 +1224,7 @@ | Release | AcqRel | SeqCst - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show) type Align = Int @@ -1129,10 +1333,14 @@ * Middle of basic block. * Effect. -} - | ICmp ICmpOp (Typed (Value' lab)) (Value' lab) + | ICmp Bool ICmpOp (Typed (Value' lab)) (Value' lab) {- ^ * Compare two integral values. * Middle of basic block. - * Returns a boolean value. -} + * Returns a boolean value. + * The 'Bool' field (added in LLVM 20) encodes whether to enforce that + the arguments have the same sign. If the 'Bool' is 'True' and the + arguments have mismatched signs, then the result is poisoned. This + field is always 'False' if the LLVM version is older than 20. -} | FCmp FCmpOp (Typed (Value' lab)) (Value' lab) {- ^ * Compare two floating point values. @@ -1145,16 +1353,19 @@ * Middle of basic block. * Returns a value of the specified type. -} - | GEP Bool Type (Typed (Value' lab)) [Typed (Value' lab)] + | GEP [GEPAttr] 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); + inbounds check attr (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. * Returns the address of the requested member. + It's recommended that the GEPAttr list should be normalized (i.e. only one of + each entry). + The types in path are the types of the index, not the fields. The indexes are in units of fields (i.e., the first element in @@ -1196,7 +1407,16 @@ | ShuffleVector (Typed (Value' lab)) (Value' lab) (Typed (Value' lab)) - + {- ^ * Constructs a fixed permutation of two input vectors: the first + and second arguments are input vectors, and the third argument + is the mask. + * Middle of basic block. + * Returns the permuted vector. For each element, the mask selects + an element from one of the input vectors to copy to the result: + * non-negative mask values represent an index into the concatenated + pair of input vectors, and + * -1 mask value indicates that the output element is poison. + -} | Jump lab {- ^ * Jump to the given basic block. @@ -1208,6 +1428,16 @@ * Ends basic block. -} | Invoke Type (Value' lab) [Typed (Value' lab)] lab lab + {- ^ * Calls the specified target function, then branches to the success + label. If an exception occurs during the call, the exception unwind + handling branches to the second label. + * Arguments: + 1. The function's return type + 2. The function target itself (to be called) + 3. arguments to the function + 4. successful return target label + 5. on-exception unwind target label + * Ends basic block. -} | Comment String -- ^ Comment @@ -1217,31 +1447,58 @@ | Unwind | VaArg (Typed (Value' lab)) Type + -- ^ Accesses arguments passed through \"varargs\" areas of a function call. + -- The argument is a @va_list*@; this instruction returns the value of the + -- specified type located at the target and increments the pointer. + | IndirectBr (Typed (Value' lab)) [lab] + -- ^ Branch via pointer indirection. The argument is the address of the + -- label to jump to. (All) Possible destination targets are provided. | Switch (Typed (Value' lab)) lab [(Integer,lab)] - {- ^ * Multi-way branch: the first value determines the direction - of the branch, the label is a default direction, if the value - does not appear in the jump table, the last argument is the - jump table. + {- ^ * Multi-way branch: the first value determines the target index + for the jump, which is looked up in the third argument table + (key values are unique). The second argument is the default + destination if the target is not found in the table. * Ends basic block. -} | LandingPad Type (Maybe (Typed (Value' lab))) Bool [Clause' lab] + {- ^ Target of an exception (from the 'Invoke' instruction). + * Arguments: + 1. The result type (the values set by the personality function + on re-entry to the function). + 2. The second argument may be the personality function, which defines + values on re-entry. This is used in older LLVM versions and is + not supplied for recent LLVM versions. + 3. True if this block is a "cleanup". + 4. The list of clauses to handle the exception; the clauses are + used to match the exception thrown. + * If no clause matches and cleanup not set, continue unwinding up + the stack (see 'Resume'). + * If cleanup is false, there must be at least one clause + -} | Resume (Typed (Value' lab)) + {- ^ Resumes propagation of an in-flight exception whose unwinding was + interrupted by a 'LandingPad' instruction. + * Argument: the value of the exception to propagate. + -} | Freeze (Typed (Value' lab)) {- ^ * Used to stop propagation of @undef@ and @poison@ values. + * If the argument is @undef@ or @poison@, returns an arbitrary + (but fixed) value of that type instead, otherwise a no-op and + returns its argument. * Middle of basic block. -} - deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Functor, Generic, Ord, Show) type Instr = Instr' BlockLabel data Clause' lab = Catch (Typed (Value' lab)) | Filter (Typed (Value' lab)) - deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type Clause = Clause' BlockLabel @@ -1271,23 +1528,101 @@ -- | Integer comparison operators. data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show) -- | Floating-point comparison operators. data FCmpOp = Ffalse | Foeq | Fogt | Foge | Folt | Fole | Fone | Ford | Fueq | Fugt | Fuge | Fult | Fule | Fune | Funo | Ftrue - deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) + deriving (Data, Eq, Enum, Generic, Ord, Show) +-- Debug Instructions ---------------------------------------------------------- + +-- | Debug Instructions +-- +-- In LLVM 19, debug instructions were added as a replacement for the intrinsic +-- functions previously used. This addition is described in +-- llvm-project/llvm/docs/RemoveDIsDebugInfo.md in the LLVM repository. +data DebugRecord' lab + = DebugRecordValue (DbgRecValue' lab) + | DebugRecordDeclare (DbgRecDeclare' lab) + | DebugRecordAssign (DbgRecAssign' lab) + | DebugRecordValueSimple (DbgRecValueSimple' lab) + | DebugRecordLabel (DbgRecLabel' lab) + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DebugRecord = DebugRecord' BlockLabel + +data DbgRecValue' lab = DbgRecValue + { + drvLocation :: ValMd' lab -- ^ Expected to be a DILocation + , drvLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable + , drvExpression :: ValMd' lab -- ^ Expected to be a DIExpression + , drvValAsMetadata :: ValMd' lab + } + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DbgRecValue = DbgRecValue' BlockLabel + +data DbgRecValueSimple' lab = DbgRecValueSimple + { + drvsLocation :: ValMd' lab -- ^ Expected to be a DILocation + , drvsLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable + , drvsExpression :: ValMd' lab -- ^ Expected to be a DIExpression + , drvsValue :: Typed (Value' lab) + } + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DbgRecValueSimple = DbgRecValueSimple' BlockLabel + +data DbgRecDeclare' lab = DbgRecDeclare + { + drdLocation :: ValMd' lab -- ^ Expected to be a DILocation + , drdLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable + , drdExpression :: ValMd' lab -- ^ Expected to be a DIExpression + , drdValAsMetadata :: ValMd' lab + } + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DbgRecDeclare = DbgRecDeclare' BlockLabel + +data DbgRecAssign' lab = DbgRecAssign + { + draLocation :: ValMd' lab -- ^ Expected to be a DILocation + , draLocalVariable :: ValMd' lab -- ^ Expected to be a DILocalVariable + , draExpression :: ValMd' lab -- ^ Expected to be a DIExpression + , draValAsMetadata :: ValMd' lab + , draAssignID :: ValMd' lab -- ^ Expected to be a DIAssignID + , draExpressionAddr :: ValMd' lab -- ^ Expected to be a DIExpression + , draValAsMetadataAddr :: ValMd' lab + } + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DbgRecAssign = DbgRecAssign' BlockLabel + +data DbgRecLabel' lab = DbgRecLabel + { + drlLocation :: ValMd' lab -- ^ Expected to be a DILocation + , drlLabel :: ValMd' lab -- ^ Expected to be a DILabel + } + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DbgRecLabel = DbgRecLabel' BlockLabel + + -- Values ---------------------------------------------------------------------- data Value' lab = ValInteger Integer | ValBool Bool + | ValHalf FPHalfValue + | ValBFloat FPBFloatValue | ValFloat Float | ValDouble Double | ValFP80 FP80Value + | ValFP128 FP128Value + | ValFP128_PPC FP128_PPCValue | ValIdent Ident | ValSymbol Symbol | ValNull @@ -1303,21 +1638,44 @@ | ValAsm Bool Bool String String | ValMd (ValMd' lab) | ValPoison - deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type Value = Value' BlockLabel +-- | 16-bit half-precision floating point value (IEEE half) +data FPHalfValue = FPHalf Word16 + deriving (Data, Eq, Ord, Generic, Show) + +-- | Different 16-bit half-precision floating point value +-- ("Brain" or "bfloat16") +data FPBFloatValue = FPBFloat Word16 + deriving (Data, Eq, Ord, Generic, Show) + +-- | x86 80-bit long double floating point value +-- (note that there's also an m86k 80-bit float that's almost but +-- not quite the same) data FP80Value = FP80_LongDouble Word16 Word64 - deriving (Data, Eq, Ord, Generic, Show, Typeable) + deriving (Data, Eq, Ord, Generic, Show) +-- | IEEE quad-precision long-double floating point value +data FP128Value = FP128_LongDouble Word64 Word64 + deriving (Data, Eq, Ord, Generic, Show) + +-- | PowerPC pair-of-doubles floating point value +-- (The value represented is the sum of the two doubles, which +-- normally but not necessarily have exponents chosen so this makes +-- sense.) +data FP128_PPCValue = FP128_PPC_DoubleDouble Double Double + deriving (Data, Eq, Ord, Generic, Show) + data ValMd' lab = ValMdString String | ValMdValue (Typed (Value' lab)) - | ValMdRef Int + | ValMdRef UnnamedMdIdx | ValMdNode [Maybe (ValMd' lab)] | ValMdLoc (DebugLoc' lab) | ValMdDebugInfo (DebugInfo' lab) - deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type ValMd = ValMd' BlockLabel @@ -1331,16 +1689,22 @@ , dlScope :: ValMd' lab , dlIA :: Maybe (ValMd' lab) , dlImplicit :: Bool - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + , dlAtomGroup :: Word64 -- ^ Introduced in LLVM 21 + , dlAtomRank :: Word64 -- ^ Introduced in LLVM 21 + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DebugLoc = DebugLoc' BlockLabel isConst :: Value' lab -> Bool isConst ValInteger{} = True isConst ValBool{} = True +isConst ValBFloat{} = True +isConst ValHalf{} = True isConst ValFloat{} = True isConst ValDouble{} = True isConst ValFP80{} = True +isConst ValFP128{} = True +isConst ValFP128_PPC{} = True isConst ValConstExpr{} = True isConst ValZeroInit = True isConst ValNull = True @@ -1358,36 +1722,66 @@ -- Statements ------------------------------------------------------------------ +-- | Each statement, which can return a value (`Result`) referenced by the +-- `Ident` or else it has no return value (`Effect`). The statement has a single +-- Instruction, followed by any Debug Records or associated metadata. +-- +-- See llvm-project/llvm/docs/RemoveDIsDebugInfo.md for discussion on the +-- [DebugRecord] fields. Note that DebugRecords and debug intrinsics may not be +-- mixed in a module; the former is new and preferred over the latter. +-- +-- Technically, DebugRecords are attached to Instructions, but since there's a +-- 1:1 correspondence between Stmt and Instr, it is cleaner to attach the +-- DebugRecords to the Stmt to keep the Instrs from getting additional +-- complications. +-- +-- Each statement may have both Debug Records (2nd-to-last field) and a list of +-- metadata attributes (last field). As noted above, bitcode file should not mix +-- Debug Records and intrinsics; if Debug Records are used, the metadata +-- attribute list should not contain intrinsics (although it may contain other +-- metadata associated with this statement). + data Stmt' lab - = Result Ident (Instr' lab) [(String,ValMd' lab)] - | Effect (Instr' lab) [(String,ValMd' lab)] - deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + = Result Ident (Instr' lab) [DebugRecord' lab] [(String, ValMd' lab)] + | Effect (Instr' lab) [DebugRecord' lab] [(String, ValMd' lab)] + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type Stmt = Stmt' BlockLabel -stmtInstr :: Stmt' lab -> Instr' lab -stmtInstr (Result _ i _) = i -stmtInstr (Effect i _) = i +stmtMetadata :: Stmt' lab -> [(String, ValMd' lab)] +stmtMetadata = \case + Result _ _ _ mds -> mds + Effect _ _ mds -> mds -stmtMetadata :: Stmt' lab -> [(String,ValMd' lab)] -stmtMetadata stmt = case stmt of - Result _ _ mds -> mds - Effect _ mds -> mds +stmtInstr :: Stmt' lab -> Instr' lab +stmtInstr (Result _ i _ _) = i +stmtInstr (Effect i _ _) = i -extendMetadata :: (String,ValMd' lab) -> Stmt' lab -> Stmt' lab +extendMetadata :: Show lab => (String, ValMd' lab) -> Stmt' lab -> Stmt' lab extendMetadata md stmt = case stmt of - Result r i mds -> Result r i (md:mds) - Effect i mds -> Effect i (md:mds) + Result r i [] mds -> Result r i [] (md:mds) + Result _ _ _ _ -> error $ "Adding MD " <> show md <> " after DebugRecord" + Effect i drs mds -> Effect i drs (md:mds) +addDebugRecord :: DebugRecord' lab -> Stmt' lab -> Stmt' lab +addDebugRecord dr = \case + Result r i drs mds -> Result r i (snoc dr drs) mds + Effect i drs mds -> Effect i (snoc dr drs) mds + where + snoc e ls = ls <> [e] -- Constant Expressions -------------------------------------------------------- data ConstExpr' lab - = ConstGEP Bool (Maybe Word64) Type (Typed (Value' lab)) [Typed (Value' lab)] + = ConstGEP [GEPAttr] (Maybe RangeSpec) 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. + -- + -- Since LLVM 19, the bool "inbounds" is now [GEPAttr] and range is via + -- RangeSpec instead of just Word64. It's recommended that the GEPAttr list + -- should be normalized (i.e. only one of each entry). | ConstConv ConvOp (Typed (Value' lab)) Type | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab)) | ConstBlockAddr (Typed (Value' lab)) lab @@ -1396,14 +1790,67 @@ | 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) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type ConstExpr = ConstExpr' BlockLabel +-- | Attributes imposing rules on the GEP; violating any rule results in a poison +-- value. If the base is a vector of pointers, the attributes apply to each +-- computation element-wise. See +-- https://llvm.org/docs/LangRef.html#getelementptr-instruction for more +-- information. +data GEPAttr + = GEP_Inbounds + -- ^ Rules: + -- * Base pointer has an inbounds (but not necessarily live) address of the + -- allocated object it is based on (i.e. points into that allocation or to + -- its end. Size for a growable allocated object is the max size, not the + -- current size. + -- * Pointer must remain inbounds at all times when adding the offsets + -- * Implies 'GEP_NUSW' + | GEP_NUSW + -- ^ No unsigned signed wrap. + -- Rules: + -- * If type of index is larger than ptr index type, truncation preserves + -- the signed value. + -- * Multiplication of an index by the type size does not wrap in a + -- signed sense. + -- * Offset additions (excluding base address) does not wrap in a + -- signed sense + -- * Addition of the current address (as unsigned, truncated to ptr + -- index type) and each offset (as signed) does not wrap the ptr + -- index type. + | GEP_NUW + -- ^ No unsigned wrap + -- Rules: + -- * If type of index is larger than ptr index type, truncation preserves + -- the unsigned value. + -- * Multiplication of an index by the type size does not wrap in an + -- unsigned sense. + -- * Offset additions (excluding base address) does not wrap in an + -- unsigned sense + -- * Addition of the current address (as unsigned, truncated to ptr + -- index type) and each offset (as unsigned) does not wrap the ptr + -- index type. + deriving (Data, Eq, Generic, Ord, Show) + +orderedGEPAttrs :: [GEPAttr] +orderedGEPAttrs = [GEP_Inbounds, GEP_NUSW, GEP_NUW] -- bit0, bit1, ... + +data RangeSpec + = RangeIndex Word64 + -- ^ index of valid range as used in pre-LLVM19 for when "inbounds" as a + -- boolean was True. Deprecated. + | Range Int Integer Integer + -- ^ width of arbitrary-precision integer (in bits) and lower and upper + -- arbitrary-precision integer bounds of that size as [lower, upper). + deriving (Data, Eq, Generic, Ord, Show) + + -- DWARF Debug Info ------------------------------------------------------------ data DebugInfo' lab - = DebugInfoBasicType DIBasicType + = DebugInfoBasicType (DIBasicType' lab) | DebugInfoCompileUnit (DICompileUnit' lab) | DebugInfoCompositeType (DICompositeType' lab) | DebugInfoDerivedType (DIDerivedType' lab) @@ -1425,9 +1872,10 @@ | DebugInfoImportedEntity (DIImportedEntity' lab) | DebugInfoLabel (DILabel' lab) | DebugInfoArgList (DIArgList' lab) - | DebugInfoAssignID - -- ^ Introduced in LLVM 17. - deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + | DebugInfoAssignID -- ^ Introduced in LLVM 17. + | DebugInfoSubrangeType (DISubrangeType' lab) + | DebugInfoFixedPointType (DIFixedPointType' lab) + deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DebugInfo = DebugInfo' BlockLabel @@ -1437,7 +1885,10 @@ , dilName :: String , dilFile :: Maybe (ValMd' lab) , dilLine :: Word32 - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + , dilColumn :: Word32 -- ^ Introduced in LLVM 21. + , dilIsArtificial :: Bool -- ^ Introduced in LLVM 21. + , dilCoroSuspendIdx :: Maybe Word32 -- ^ Introduced in LLVM 21. + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DIImportedEntity = DIImportedEntity' BlockLabel data DIImportedEntity' lab = DIImportedEntity @@ -1447,14 +1898,14 @@ , diieFile :: Maybe (ValMd' lab) , diieLine :: Word32 , diieName :: Maybe String - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel data DITemplateTypeParameter' lab = DITemplateTypeParameter { dittpName :: Maybe String , dittpType :: Maybe (ValMd' lab) , dittpIsDefault :: Maybe Bool -- since LLVM 11 - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DITemplateValueParameter = DITemplateValueParameter' BlockLabel data DITemplateValueParameter' lab = DITemplateValueParameter @@ -1463,7 +1914,7 @@ , ditvpType :: Maybe (ValMd' lab) , ditvpIsDefault :: Maybe Bool -- since LLVM 11 , ditvpValue :: ValMd' lab - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DINameSpace = DINameSpace' BlockLabel data DINameSpace' lab = DINameSpace @@ -1471,7 +1922,7 @@ , dinsScope :: ValMd' lab , dinsFile :: ValMd' lab , dinsLine :: Word32 - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) -- TODO: Turn these into sum types -- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def @@ -1486,15 +1937,45 @@ -- it stabilizes. type DIEmissionKind = Word8 -data DIBasicType = DIBasicType +-- See https://github.com/llvm/llvm-project/commit/eb8901bda11fd55deeecd067fc4c9dcc0fb89984 +dwarf_DW_APPLE_ENUM_KIND_invalid :: Word32 +dwarf_DW_APPLE_ENUM_KIND_invalid = complement (0 :: Word32) -- ~ LLVM 19 + +data DIBasicType' lab = DIBasicType { dibtTag :: DwarfTag , dibtName :: String - , dibtSize :: Word64 + , dibtSize :: Maybe (ValMd' lab) + -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue', + -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or + -- later, this can also be a null reference (i.e., 'Nothing'), a variable + -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an + -- expression (i.e., @Just@ a 'DIExpression'). , dibtAlign :: Word64 , dibtEncoding :: DwarfAttrEncoding , dibtFlags :: Maybe DIFlags - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + , dibtNumExtraInhabitants :: Word64 -- ^ added in LLVM 20. + , dibtDataSize :: Word32 -- ^ added in LLVM 22. + } deriving (Data, Eq, Functor, Generic, Ord, Show) +type DIBasicType = DIBasicType' BlockLabel + +data DISubrangeType' lab = DISubrangeType -- Added in LLVM 21 + { disrtName :: Maybe String + , disrtFile :: Maybe (ValMd' lab) + , disrtLine :: Word32 + , disrtScope :: Maybe (ValMd' lab) + , disrtBaseType :: Maybe (ValMd' lab) -- ^ a type + , disrtSize :: Maybe (ValMd' lab) -- ^ in bits. signed constant, DIVariable, DIGlobalVariable, or DIExpression + , disrtAlign :: Word64 -- ^ in bits + , disrtFlags :: DIFlags + , disrtLowerBound :: Maybe (ValMd' lab) -- ^ signed constant, DIVariable, DIGlobalVariable, or DIExpression + , disrtUpperBound :: Maybe (ValMd' lab) -- ^ signed constant, DIVariable, DIGlobalVariable, or DIExpression + , disrtStride :: Maybe (ValMd' lab) -- ^ signed constant, DIVariable, DIGlobalVariable, or DIExpression + , disrtBias :: Maybe (ValMd' lab) -- ^ signed constant, DIVariable, DIGlobalVariable, or DIExpression + } deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DISubrangeType = DISubrangeType' BlockLabel + data DICompileUnit' lab = DICompileUnit { dicuLanguage :: DwarfLang , dicuFile :: Maybe (ValMd' lab) @@ -1518,7 +1999,9 @@ , dicuRangesBaseAddress :: Bool , dicuSysRoot :: Maybe String , dicuSDK :: Maybe String - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + , dicuSourceLanguageVersion :: Word32 + -- ^ added in LLVM 22 + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DICompileUnit = DICompileUnit' BlockLabel @@ -1529,9 +2012,19 @@ , dictLine :: Word32 , dictScope :: Maybe (ValMd' lab) , dictBaseType :: Maybe (ValMd' lab) - , dictSize :: Word64 + , dictSize :: Maybe (ValMd' lab) + -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue', + -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or + -- later, this can also be a null reference (i.e., 'Nothing'), a variable + -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an + -- expression (i.e., @Just@ a 'DIExpression'). , dictAlign :: Word64 - , dictOffset :: Word64 + , dictOffset :: Maybe (ValMd' lab) + -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue', + -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or + -- later, this can also be a null reference (i.e., 'Nothing'), a variable + -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an + -- expression (i.e., @Just@ a 'DIExpression'). , dictFlags :: DIFlags , dictElements :: Maybe (ValMd' lab) , dictRuntimeLang :: DwarfLang @@ -1543,9 +2036,12 @@ , 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) + , dictAnnotations :: Maybe (ValMd' lab) -- ^ Introduced in LLVM 14. + , dictNumExtraInhabitants :: Word64 -- ^ added in LLVM 20. + , dictSpecification :: Maybe (ValMd' lab) -- ^ added in LLVM 20. + , dictEnumKind :: Maybe Word32 -- ^ added in LLVM 20. + , dictBitStride :: Maybe (ValMd' lab) -- ^ added in LLVM 20. + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DICompositeType = DICompositeType' BlockLabel @@ -1556,9 +2052,19 @@ , didtLine :: Word32 , didtScope :: Maybe (ValMd' lab) , didtBaseType :: Maybe (ValMd' lab) - , didtSize :: Word64 + , didtSize :: Maybe (ValMd' lab) + -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue', + -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or + -- later, this can also be a null reference (i.e., 'Nothing'), a variable + -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an + -- expression (i.e., @Just@ a 'DIExpression'). , didtAlign :: Word64 - , didtOffset :: Word64 + , didtOffset :: Maybe (ValMd' lab) + -- ^ If using LLVM 20 or older, this will always be @Just@ an 'ValMdValue', + -- where the underlying value is a 64-bit 'ValInteger'. If using LLVM 21 or + -- later, this can also be a null reference (i.e., 'Nothing'), a variable + -- (i.e., @Just@ a 'DIGlobalVariable' or 'DILocalVariable'), or an + -- expression (i.e., @Just@ a 'DIExpression'). , didtFlags :: DIFlags , didtExtraData :: Maybe (ValMd' lab) , didtDwarfAddressSpace :: Maybe Word32 @@ -1568,18 +2074,48 @@ -- 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) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DIDerivedType = DIDerivedType' BlockLabel +-- | The DIFixedPointType represents fixed-point types as an integer with a scale +-- factor. It's a derivation of the DIBaseType, although only two encodings are +-- permitted: DW_ATE_signed_fixed and DW_ATE_unsigned_fixed. +data DIFixedPointType' lab = DIFixedPointType -- Added in LLVM 21 + { difptTag :: DwarfTag + , difptName :: Maybe String + , difptSize :: Maybe (ValMd' lab) -- ^ in bits. signed constant, DIVariable, DIGlobalVariable, or DIExpression + , difptAlign :: Word64 -- ^ in bits + , difptEncoding :: DwarfAttrEncoding -- ^ only DW_ATE_signed_fixed or DW_ATE_unsigned_fixed + , difptFlags :: DIFlags + -- n.b. in the bitcode representation, kind, factor, numerator, and denominator + -- are all present, and kind controls which are actually used. + , difptKind :: DIFixedPointKind' lab + } deriving (Data, Eq, Functor, Generic, Ord, Show) + +data DIFixedPointKind' lab = FixedPointBinary Integer + -- ^ A binary fixed point type where the (signed) + -- scale factor is a power of 2. + | FixedPointDecimal Integer + -- ^ A decimal fixed point type where the (signed) + -- scale factor is a power of 10. + | FixedPointRational Integer Integer + -- ^ The scale factor is an arbitrary rational + -- number, specified by these numerator and + -- denominator values. + deriving (Data, Eq, Functor, Generic, Ord, Show) + +type DIFixedPointType = DIFixedPointType' BlockLabel +type DIFixedPointKind = DIFixedPointKind' BlockLabel + data DIExpression = DIExpression { dieElements :: [Word64] - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) data DIFile = DIFile { difFilename :: FilePath , difDirectory :: FilePath - } deriving (Data, Eq, Generic, Ord, Show, Typeable) + } deriving (Data, Eq, Generic, Ord, Show) data DIGlobalVariable' lab = DIGlobalVariable { digvScope :: Maybe (ValMd' lab) @@ -1595,14 +2131,14 @@ , digvAlignment :: Maybe Word32 , digvAnnotations :: Maybe (ValMd' lab) -- ^ Introduced in LLVM 14. - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DIGlobalVariable = DIGlobalVariable' BlockLabel data DIGlobalVariableExpression' lab = DIGlobalVariableExpression { digveVariable :: Maybe (ValMd' lab) , digveExpression :: Maybe (ValMd' lab) - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DIGlobalVariableExpression = DIGlobalVariableExpression' BlockLabel @@ -1611,7 +2147,7 @@ , dilbFile :: Maybe (ValMd' lab) , dilbLine :: Word32 , dilbColumn :: Word16 - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DILexicalBlock = DILexicalBlock' BlockLabel @@ -1619,7 +2155,7 @@ { dilbfScope :: ValMd' lab , dilbfFile :: Maybe (ValMd' lab) , dilbfDiscriminator :: Word32 - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DILexicalBlockFile = DILexicalBlockFile' BlockLabel @@ -1635,7 +2171,7 @@ -- ^ Introduced in LLVM 4. , dilvAnnotations :: Maybe (ValMd' lab) -- ^ Introduced in LLVM 14. - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DILocalVariable = DILocalVariable' BlockLabel @@ -1662,7 +2198,7 @@ , dispThrownTypes :: Maybe (ValMd' lab) , dispAnnotations :: Maybe (ValMd' lab) -- ^ Introduced in LLVM 14. - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DISubprogram = DISubprogram' BlockLabel @@ -1694,21 +2230,21 @@ , disrLowerBound :: Maybe (ValMd' lab) , disrUpperBound :: Maybe (ValMd' lab) , disrStride :: Maybe (ValMd' lab) - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DISubrange = DISubrange' BlockLabel data DISubroutineType' lab = DISubroutineType { distFlags :: DIFlags , distTypeArray :: Maybe (ValMd' lab) - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DISubroutineType = DISubroutineType' BlockLabel -- | See . newtype DIArgList' lab = DIArgList { dialArgs :: [ValMd' lab] - } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) + } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show) type DIArgList = DIArgList' BlockLabel @@ -1718,7 +2254,7 @@ = Invalid -- ^ An invalid use of GEP | HasType Type -- ^ A resolved type | Resolve Ident (Type -> IndexResult) -- ^ Continue, after resolving an alias - deriving (Generic, Typeable) + deriving (Generic) isInvalid :: IndexResult -> Bool isInvalid ir = case ir of diff --git a/src/Text/LLVM/Combine.hs b/src/Text/LLVM/Combine.hs new file mode 100644 --- /dev/null +++ b/src/Text/LLVM/Combine.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE LambdaCase #-} + +{- | +Module : Text.LLVM.Combine +Description : Combine LLVM Modules +License : BSD3 +Maintainer : Kevin Quick +Stability : provisional + +This module provides the ability to smash together LLVM 'Module' specifications +to provide the ability to load separate LLVM 'Module's (e.g. bitcode files) and +analyze them as if they had been linked together as a single program. + +-} + +module Text.LLVM.Combine + ( + llvmModuleCombine + ) +where + +import Data.Bool ( bool ) +import Data.Generics.Schemes ( everywhere ) +import Data.Generics.Aliases ( mkT ) +import Lens.Micro +import Lens.Micro.Extras +import Data.Function ( on ) +import Data.List ( find ) +import Data.Maybe ( fromMaybe ) +import Data.String ( fromString ) +import Text.LLVM.AST +import Text.LLVM.Lens + + +-- | Combines LLVM 'Module's into a single, composite 'Module'. This is akin to +-- linking, but just from the perspective of what is needed for program analysis. +-- +-- This differs from `llvm-link` in the following known ways: +-- +-- 1. The `llvm-link` tool uses structural typing resolution: if two modules +-- each have a type with the same structure, the resulting module will only +-- have one type; the name from one of the modules is chosen and all +-- references to the typename in the other module will be rewritten to the +-- first module. +-- +-- The `llvmModuleCombine` function takes a slightly different approach: types +-- are not structurally coalesced, but this means that type names are +-- deconflicted by adding a numbered suffix. This still requires modifying +-- the type name throughout that module, but (a) there are probably fewer type +-- name conflicts than structural equivalences, and (b) the original name is +-- still part of the new name which maintains origin information. +-- +-- 2. The `llvm-link` tool will occasionally rewrite calls to llvm intrinsics to +-- explicitly add the default personality specification. For example, +-- `llvm.stacksave` may be rewritten to `llvm.stacksave.p0`. Because these +-- are intrinsics, this should not have any significant impact on the result, +-- but `llvmModuleCombine` does not perform this naming update. +-- +-- 3. External declaration resolution is type independent and only name +-- sensitive. If 'Module' A has an external declaration `declare @f(i32 x)` +-- and 'Module' B has a definition `define @f(float x)`, then this +-- `llvmModuleCombine` operation will use the latter to satisfy the former (by +-- removing the former) even though the types do not match. +-- +llvmModuleCombine :: Module -> Module -> Module +llvmModuleCombine a addModule = + let defs = a ^. modDefinesLens + decls = a ^. modDeclaresLens + newDefs = b ^. modDefinesLens + newDecls = b ^. modDeclaresLens + rmvDefined = flip (foldr removeDefined) + newDeclsLessOldDefs = rmvDefined defs newDecls + oldDeclsLessNewDefs = rmvDefined newDefs decls + joinedName n = Just $ fromMaybe "..." n <> "+" <> fromMaybe "..." (modSourceName b) + newUmdBase = let umIdxs = umIndex <$> modUnnamedMd a + in bool (succ $ maximum umIdxs) (UnnamedMdIdx 0) $ null umIdxs + -- unnamed metadata is referenced almost everywhere, so update that globally + -- first: + b = updateUmd newUmdBase (deConflictTypes addModule (a ^. modTypesLens)) + in a + & modSourceNameLens %~ joinedName + & modDeclaresLens .~ (oldDeclsLessNewDefs <> newDeclsLessOldDefs) + & modDefinesLens %~ deConflict (b ^. modDefinesLens) + & modTypesLens <>~ b ^. modTypesLens + & modUnnamedMdLens <>~ b ^. modUnnamedMdLens + & modNamedMdLens <>~ b ^. modNamedMdLens + & modComdatLens <>~ b ^. modComdatLens + & modGlobalsLens <>~ b ^. modGlobalsLens + & modInlineAsmLens <>~ b ^. modInlineAsmLens + & modAliasesLens <>~ b ^. modAliasesLens + -- TODO Globals any should override Linkage external for the same name + -- TODO verify modTriple and modDataLayout are the same? + + +-- | Rewrites type references in the input module to ensure uniqueness against +-- all types mentioned in the second module. +deConflictTypes :: Module -> [TypeDecl] -> Module +deConflictTypes inpMod existingTypes = + let resolveTypeConflict m t = + if any (((==) `on` typeName) t) existingTypes + then renameType m t (let Ident n = typeName t in n <> "___") (0 :: Int) + else m + renameType m t b n = + let newName = Ident (b <> show n) + in if any ((newName ==) . typeName) existingTypes + then if n > 100000 + then error $ "Unable to generate unique type name for " <> b + else renameType m t b $ succ n + else everywhere (mkT (chngType (typeName t) newName)) m + chngType oldName newName n = bool n newName $ n == oldName + in foldl resolveTypeConflict inpMod (inpMod ^. modTypesLens) + + +-- | A 'Define' takes precedence over a 'Declare'. When combining modules, +-- module A may 'Declare' a function that is handled by a 'Define' in module B, +-- so get rid of the 'Declare' when putting A and B together. + +removeDefined :: Define -> [Declare] -> [Declare] +removeDefined def = filter ((def ^. defNameLens /=) . view decNameLens) + + +-- | 'Module' A and 'Module' B may have a Define with the same name ('Symbol'). +-- This is normal when linking multiple modules together, and is resolved by +-- linkers as guided by the 'Linkage' information for the two 'Definition's, +-- usually by either renaming or merging. + +deConflict :: [Define] -> [Define] -> [Define] +deConflict new curr = uncurry (<>) $ foldl deConflictDef (curr, new) new + where + deConflictDef (ads, bds) bd = + case find (((==) `on` defName) bd) ads of + Nothing -> (ads, bds) + Just ad -> handle ads bds ad bd + handle ads bds ad bd = + case bd ^. defLinkageLens of + Just Private -> (ads, renameDef bd (view defNameLens <$> ads) bds) + Just LinkerPrivate -> (ads, renameDef bd (view defNameLens <$> ads) bds) + Just LinkerPrivateWeak -> + (ads, renameDef bd (view defNameLens <$> ads) bds) -- ?? + Just LinkerPrivateWeakDefAuto -> + (ads, renameDef bd (view defNameLens <$> ads) bds) -- ?? + Just Internal -> (ads, renameDef bd (view defNameLens <$> ads) bds) + Just AvailableExternally -> + -- Never happen: not allowed on defines. Ignore + (ads, bds) + Just Linkonce -> (mergeDef ad bd ads, removeDef bd bds) + Just Weak -> (mergeDef ad bd ads, removeDef bd bds) + Just Common -> (mergeDef ad bd ads, removeDef bd bds) + Just ExternWeak -> (mergeDef ad bd ads, removeDef bd bds) + Just LinkonceODR -> (mergeDef ad bd ads, removeDef bd bds) + Just WeakODR -> (mergeDef ad bd ads, removeDef bd bds) + Just Appending -> (appendDef ad bd ads, removeDef bd bds) + Just External -> + -- This should never happen: it is truly a symbol conflict. A + -- linker would reject this, but here we will just preserve the + -- original. + (ads, removeDef bd bds) + Just DLLImport -> (ads, removeDef bd bds) -- ?? + Just DLLExport -> (ads, removeDef bd bds) -- ?? + Nothing -> + -- No linkage specified. The default is 'External', with associated + -- considerations as documented for that case above. + (ads, removeDef bd bds) + +-- Note: Used for Linkonce, Weak, Common, ExternWeak, LinkonceODR, WeakODR. LLVM +-- docs say "merged", but also indicates that maybe there is a replacement +-- instead? For now, treat "merged" as appending. +mergeDef :: Define -> Define -> [Define] -> [Define] +mergeDef = appendDef + +appendDef :: Define -> Define -> [Define] -> [Define] +appendDef d1 d2 = + let appenD = d1 & defBodyLens <>~ d2 ^. defBodyLens + in (appenD :) . filter (((/=) `on` defName) d1) + +removeDef :: Define -> [Define] -> [Define] +removeDef d = filter (((/=) `on` defName) d) + + +-- Renames the Defined symbol to a new name using a discriminator to avoid a +-- conflict. Only valid for renaming Private/Internal Defines such that changing +-- any reference to the original Symbol to the new Symbol in the provided set of +-- Defines is sufficient to change all references. Note therefore this excludes: +-- renaming of global variables, changing a GlobalAlias. + +renameDef :: Define -> [Symbol] -> [Define] -> [Define] +renameDef toRename known inDefs = + -- KWQ TODO: needs to change GlobalAlias aliasName? + -- + let getNewName nm n = + -- Note: adds a "discriminator" to the name in a way that is valid for + -- both C functions and C++ mangled names (see + -- https://itanium-cxx-abi.github.io/cxx-abi/abi.html#mangling-scope). + let nn = if n < 10 + then nm <> "_" <> show n + else nm <> "__" <> show n <> "_" + in case find ((fromString nn ==) . defName) inDefs of + Just _ -> getNewName nm $ succ n + Nothing -> + if fromString nn `elem` known + then getNewName nm $ succ n + else nn + (Symbol oldname) = defName toRename + newName = Symbol $ getNewName oldname (1 :: Integer) + in changeSym (defName toRename) newName inDefs + + +changeSym :: Symbol -> Symbol -> [Define] -> [Define] +changeSym old new = everywhere (mkT chngSym) + where + chngSym s = bool s new $ old == s + +-- | Adjusts all unnamed metadata indices in the Module to begin at the specified +-- newBase, which allows this module to be combined without conflict with a +-- module whose metadata indices are all below the newBase. +updateUmd :: UnnamedMdIdx -> Module -> Module +updateUmd newBase = everywhere (mkT (\n -> n + newBase)) 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,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# Language TransformListComp, MonadComprehensions #-} {- | Module : Text.LLVM.DebugUtils @@ -32,11 +34,16 @@ -- * Line numbers of definitions , debugInfoGlobalLines , debugInfoDefineLines + , atFileLines + , AtFileLines(atDefine, atBlockStart, atStmt, atGlobal) + , DefineRel(..) + , BlockRel(..) ) where import Control.Applicative ((<|>)) import Control.Monad ((<=<)) import Data.Bits (Bits(..)) +import Data.Bool (bool) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (elemIndex, tails, stripPrefix) @@ -44,6 +51,9 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, listToMaybe, maybeToList, mapMaybe) import Data.Word (Word16, Word64) +import Lens.Micro.Platform ((^.), at, _Just, to) +import System.FilePath ( (), equalFilePath, normalise + , hasTrailingPathSeparator ) import Text.LLVM.AST dbgKind :: String @@ -162,22 +172,50 @@ -- | Compute an 'IntMap' of the unnamed metadata in a module mkMdMap :: Module -> IntMap ValMd -mkMdMap m = IntMap.fromList [ (umIndex md, umValues md) | md <- modUnnamedMd m ] +mkMdMap m = IntMap.fromList [ (unnamedMdIdx $ umIndex md, umValues md) + | md <- modUnnamedMd m ] ------------------------------------------------------------------------ getDebugInfo :: MdMap -> ValMd -> Maybe DebugInfo -getDebugInfo mdMap (ValMdRef i) = getDebugInfo mdMap =<< IntMap.lookup i mdMap +getDebugInfo mdMap (ValMdRef (UnnamedMdIdx i)) = + getDebugInfo mdMap =<< IntMap.lookup i mdMap getDebugInfo _ (ValMdDebugInfo di) = Just di getDebugInfo _ _ = Nothing +getMDFile :: MdMap -> ValMd -> Maybe FilePath +getMDFile mdMap = \case + ValMdDebugInfo (DebugInfoFile i) -> pure $ difDirectory i difFilename i + -- ^^ found it! ^^ or else vvv keep looking (recursively) vvv + ValMdLoc l -> getMDFile mdMap $ dlScope l + ValMdRef i -> mdMap ^. at (unnamedMdIdx i) . _Just . to (getMDFile mdMap) + ValMdDebugInfo (DebugInfoGlobalVariable gv) -> + (getMDFile mdMap =<< digvFile gv) <|> (getMDFile mdMap =<< digvScope gv) + ValMdDebugInfo (DebugInfoLocalVariable lv) -> + (getMDFile mdMap =<< dilvFile lv) <|> (getMDFile mdMap =<< dilvScope lv) + ValMdDebugInfo (DebugInfoSubprogram sp) -> + (getMDFile mdMap =<< dispFile sp) <|> (getMDFile mdMap =<< dispScope sp) + ValMdDebugInfo (DebugInfoLexicalBlock lb) -> + (getMDFile mdMap =<< dilbFile lb) <|> (getMDFile mdMap =<< dilbScope lb) + ValMdDebugInfo (DebugInfoLexicalBlockFile lf) -> + (getMDFile mdMap =<< dilbfFile lf) <|> (getMDFile mdMap $ dilbfScope lf) + ValMdDebugInfo (DebugInfoDerivedType dt) -> + (getMDFile mdMap =<< didtFile dt) <|> (getMDFile mdMap =<< didtScope dt) + ValMdDebugInfo (DebugInfoCompositeType ct) -> + (getMDFile mdMap =<< dictFile ct) <|> (getMDFile mdMap =<< dictScope ct) + ValMdDebugInfo (DebugInfoCompileUnit cu) -> getMDFile mdMap =<< dicuFile cu + ValMdDebugInfo (DebugInfoNameSpace ns) -> getMDFile mdMap $ dinsFile ns + ValMdDebugInfo (DebugInfoLabel bl) -> + (getMDFile mdMap =<< dilFile bl) <|> (getMDFile mdMap =<< dilScope bl) + _ -> Nothing + getInteger :: MdMap -> ValMd -> Maybe Integer -getInteger mdMap (ValMdRef i) = getInteger mdMap =<< IntMap.lookup i mdMap +getInteger mdMap (ValMdRef (UnnamedMdIdx 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 +getList mdMap (ValMdRef (UnnamedMdIdx i)) = getList mdMap =<< IntMap.lookup i mdMap getList _ (ValMdNode di) = Just di getList _ _ = Nothing @@ -230,16 +268,28 @@ let bitfield | testBit (didtFlags dt) 19 , Just extraData <- didtExtraData dt , Just bitfieldOffset <- getInteger mdMap extraData - = Just $ BitfieldInfo { biFieldSize = didtSize dt - , biBitfieldOffset = fromInteger bitfieldOffset - } + = do size <- getSizeOrOffset (didtSize dt) + Just $ BitfieldInfo { biFieldSize = size + , biBitfieldOffset = fromInteger bitfieldOffset + } | otherwise = Nothing + offset <- getSizeOrOffset (didtOffset dt) Just (StructFieldInfo { sfiName = fieldName - , sfiOffset = didtOffset dt + , sfiOffset = offset , sfiBitfield = bitfield , sfiInfo = valMdToInfo' mdMap (didtBaseType dt) }) + where + -- TODO: Currently, this only recognizes bare integer (i.e., 'ValInteger') + -- sizes and offsets. This is likely good enough for Clang-derived LLVM, but + -- Ada-derived LLVM may contain more complex metadata values that this + -- currently doesn't handle. + getSizeOrOffset :: Maybe ValMd -> Maybe Word64 + getSizeOrOffset (Just (ValMdValue tv)) + | ValInteger i <- typedValue tv + = Just (fromInteger i) + getSizeOrOffset _ = Nothing getUnionFields :: MdMap -> DICompositeType -> Maybe [UnionFieldInfo] @@ -365,10 +415,10 @@ where aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident - aux ( Effect (Store src dst _ _) _ - : Effect (Call _ _ (ValSymbol (Symbol what)) [var,md,_]) _ + aux ( Effect (Store src dst _ _) _ _ + : Effect (Call _ _ (ValSymbol (Symbol what)) [var,md,_]) _ _ : _) sofar - | what == "llvm.dbg.declare" + | what == "llvm.dbg.declare" -- pre-LLVM19: intrinsic declaration match , Just dstIdent <- extractIdent dst , Just srcIdent <- extractIdent src , Just varIdent <- extractIdent var @@ -376,9 +426,9 @@ , Just name <- extractLvName md = Map.insert name srcIdent sofar - aux ( Effect (Call _ _ (ValSymbol (Symbol what)) [var,_,md,_]) _ + aux ( Effect (Call _ _ (ValSymbol (Symbol what)) [var,_,md,_]) _ _ : _) sofar - | what == "llvm.dbg.value" + | what == "llvm.dbg.value" -- pre-LLVM19: intrinsic declaration match , Just key <- extractIdent var , Just name <- extractLvName md = Map.insert name key sofar @@ -449,7 +499,7 @@ Just (ValMdRef s) -> scopeArgs s _ -> IntMap.empty where - scopeArgs :: Int -> IntMap String + scopeArgs :: UnnamedMdIdx -> IntMap String scopeArgs s = IntMap.fromList . mapMaybe go $ modUnnamedMd m where go :: UnnamedMd -> Maybe (Int, String) @@ -502,3 +552,96 @@ ) }) = Just (n, (fromIntegral l)) go _ = Nothing + + +-- | Given a file and line number and a handler, call the appropriate handler +-- method on every Define, Block, and Stmt that is associated with the line +-- number. +atFileLines :: AtFileLines a b + => b -> a -> FilePath -> Integer -> Module -> a +atFileLines handle seed file line mdule = + let mdMap = mkMdMap mdule + matchesFile x = + let fn = normalise file + fl = length fn + xl = length x + (p,r) = splitAt (xl - fl) x + in and [ fl <= xl + , fn `equalFilePath` r + , null p || hasTrailingPathSeparator p + ] + locMatch di = + let getMDLine = \case + ValMdLoc x@(DebugLoc {}) -> dlLine x + ValMdDebugInfo (DebugInfoSubprogram x) -> dispLine x + ValMdDebugInfo (DebugInfoLocalVariable x) -> dilvLine x + ValMdDebugInfo (DebugInfoLexicalBlock x) -> dilbLine x + ValMdDebugInfo (DebugInfoGlobalVariable x) -> digvLine x + ValMdDebugInfo (DebugInfoDerivedType x) -> didtLine x + ValMdDebugInfo (DebugInfoCompositeType x) -> dictLine x + ValMdDebugInfo (DebugInfoNameSpace x) -> dinsLine x + ValMdDebugInfo (DebugInfoLabel x) -> dilLine x + ValMdRef (UnnamedMdIdx i) -> maybe 0 getMDLine $ mdMap ^. at i + _ -> 0 + in and [ maybe False matchesFile (getMDFile mdMap di) + , line == (toInteger $ getMDLine di) + ] + onGlobal a g = + bool a (atGlobal handle g a) $ any locMatch $ Map.elems $ globalMetadata g + onDefs a d = + let isMatch = any locMatch $ Map.elems $ defMetadata d + onDecl = bool id (atDefine handle d) isMatch + in snd $ foldl onBlock (FirstBlock isMatch, onDecl a) $ defBody d + onBlock (dr, a) bb = + let onBlockLabel = case bbStmts bb of + [] -> id + (s:_) -> bool id (atBlockStart handle dr bb) + $ any (locMatch . snd) $ stmtMetadata s + sseed = (dr, FirstBlockStmt, onBlockLabel a) + (_, _, blkstmts) = foldl onStmt sseed $ bbStmts bb + in (OtherBlock, blkstmts) + onStmt (dr, br, a) s = + bool + (dr, FirstLineStmt, a) + (dr, ContiguousStmt, atStmt handle dr br s a) + $ or [ any (locMatch . snd) $ stmtMetadata s + -- n.b. the DebugRecords describe associated data, but do not + -- (at this time, circa LLVM 22) contain instruction location + -- references, so they are not considered here. + , dr == FirstBlock True && null (stmtMetadata s) + ] + in foldl onGlobal (foldl onDefs seed $ modDefines mdule) $ modGlobals mdule + +-- | The handler passed to 'atFileLines' must be an instance of this class. +-- +-- Here, @b@ is an object for which the following methods can be called with an +-- accumulator @a@ and the corresponding LLVM AST element that has the @lab@ +-- label type. The method will return an updated accumulator. +class AtFileLines a b where + -- | The 'atDefine' method is called (before any enclosed 'BasicBlock' or + -- 'Stmt' elements) if the file and line number are associated with the + -- 'Define' signature line. + atDefine :: b -> Define -> a -> a + -- | The 'atBlockStart' method is called if the first 'Stmt' in the + -- 'BasicBlock' is associated with the file and line number, and before any + -- 'Stmt's in the block are passed to 'atStmt'. + -- the first block in the 'Define'. + atBlockStart :: b -> DefineRel -> BasicBlock -> a -> a + -- | The 'atStmt' method is called for every 'Stmt' in the basic block that is + -- associated with the file and line number. The boolean value passed is + -- true if the 'Stmt' immediately follows a previous 'Stmt' that was + -- associated with the same line, or if this was the first 'Stmt' in the + -- block. + atStmt :: b -> DefineRel -> BlockRel -> Stmt -> a -> a + -- | The 'atGlobal' method is called for evey 'Global' that is associated with + -- the file and line number. + atGlobal :: b -> Global -> a -> a + +data DefineRel = FirstBlock Bool -- ^ first block of a 'Define', matched file & line? + | OtherBlock -- ^ other blocks of a 'Define' + deriving Eq + +data BlockRel = FirstBlockStmt -- ^ first statement in a 'BasicBlock' + | ContiguousStmt -- ^ previous statement also matched the file & line + | FirstLineStmt -- ^ previous statement did not match the file & line + deriving Eq 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 @@ -60,7 +60,8 @@ <*> traverse (relabel f) a <*> pure s <*> pure o - relabel f (ICmp op l r) = ICmp op + relabel f (ICmp samesign op l r) + = ICmp samesign op <$> traverse (relabel f) l <*> relabel f r relabel f (FCmp op l r) = FCmp op @@ -125,9 +126,17 @@ instance HasLabel Clause' where relabel = $(generateRelabel 'relabel ''Clause') instance HasLabel Value' where relabel = $(generateRelabel 'relabel ''Value') instance HasLabel ValMd' where relabel = $(generateRelabel 'relabel ''ValMd') +instance HasLabel DebugRecord' where relabel = $(generateRelabel 'relabel ''DebugRecord') +instance HasLabel DbgRecAssign' where relabel = $(generateRelabel 'relabel ''DbgRecAssign') +instance HasLabel DbgRecDeclare' where relabel = $(generateRelabel 'relabel ''DbgRecDeclare') +instance HasLabel DbgRecLabel' where relabel = $(generateRelabel 'relabel ''DbgRecLabel') +instance HasLabel DbgRecValueSimple' where relabel = $(generateRelabel 'relabel ''DbgRecValueSimple') +instance HasLabel DbgRecValue' where relabel = $(generateRelabel 'relabel ''DbgRecValue') instance HasLabel DILabel' where relabel = $(generateRelabel 'relabel ''DILabel') instance HasLabel DebugLoc' where relabel = $(generateRelabel 'relabel ''DebugLoc') instance HasLabel DebugInfo' where relabel = $(generateRelabel 'relabel ''DebugInfo') +instance HasLabel DIBasicType' where relabel = $(generateRelabel 'relabel ''DIBasicType') +instance HasLabel DISubrangeType' where relabel = $(generateRelabel 'relabel ''DISubrangeType') instance HasLabel DIDerivedType' where relabel = $(generateRelabel 'relabel ''DIDerivedType') instance HasLabel DISubroutineType' where relabel = $(generateRelabel 'relabel ''DISubroutineType') instance HasLabel DISubrange' where relabel = $(generateRelabel 'relabel ''DISubrange') @@ -136,6 +145,8 @@ instance HasLabel DILocalVariable' where relabel = $(generateRelabel 'relabel ''DILocalVariable') instance HasLabel DISubprogram' where relabel = $(generateRelabel 'relabel ''DISubprogram') instance HasLabel DICompositeType' where relabel = $(generateRelabel 'relabel ''DICompositeType') +instance HasLabel DIFixedPointType' where relabel = $(generateRelabel 'relabel ''DIFixedPointType') +instance HasLabel DIFixedPointKind' where relabel = $(generateRelabel 'relabel ''DIFixedPointKind') instance HasLabel DILexicalBlock' where relabel = $(generateRelabel 'relabel ''DILexicalBlock') instance HasLabel DICompileUnit' where relabel = $(generateRelabel 'relabel ''DICompileUnit') instance HasLabel DILexicalBlockFile' where relabel = $(generateRelabel 'relabel ''DILexicalBlockFile') 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 @@ -31,7 +31,9 @@ , ''DebugInfo' , ''DIFile , ''DISubrange' - , ''DIBasicType + , ''DIBasicType' + , ''DISubrangeType' + , ''DIFixedPointType' , ''DIExpression , ''DISubprogram' , ''DISubroutineType' 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,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Text.LLVM.PP @@ -15,22 +17,176 @@ -- -- This is the pretty-printer for llvm assembly versions 3.6 and lower. -- -module Text.LLVM.PP where +module Text.LLVM.PP + ( + Config(Config, cfgVer), withConfig + , Fmt + , LLVMVer, llvmVer, llvmVerToString + , llvmVlatest, llvmV3_5, llvmV3_6, llvmV3_7, llvmV3_8 + , ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 + , LLVMPretty(llvmPP) + , ppModule + , ppSourceName + , ppNamedMd + , ppUnnamedMd + , ppGlobalAlias + , ppTargetTriple + , ppDataLayout + , ppLayoutSpec + , ppPointerSize + , ppStorage + , ppAlignment + , ppFunctionPointerAlignType + , ppMangling + , ppInlineAsm + , ppIdent + , ppSymbol + , ppPrimType + , ppFloatType + , ppType + , ppTypeDecl + , ppGlobal + , ppGlobalMetadata + , ppGlobalAttrs + , ppDeclare + , ppComdatName + , ppComdat + , ppSelectionKind + , ppDefineSig + , ppDefine + , ppFunAttr + , ppLabelDef + , ppLabel + , PrettyLabel(ppLabel') + , ppBasicBlock + , ppStmt + , ppAttachedMetadata + , ppLinkage + , ppVisibility + , ppGC + , ppTyped + , ppSignBits + , ppExact + , ppArithOp + , ppUnaryArithOp + , ppBitOp + , ppConvOp + , ppAtomicOrdering + , ppAtomicOp + , ppScope + , ppInstr + , ppLoad + , ppStore + , ppClauses + , ppClause + , ppTypedLabel + , ppSwitchEntry + , ppVectorIndex + , ppAlign + , ppAlloca + , ppCall + , ppCallBr + , ppCallSym + , ppGEP + , ppInvoke + , ppPhiArg + , ppICmpOp + , ppFCmpOp + , ppValue' + , ppValue + , ppValMd' + , ppValMd + , ppDebugLoc' + , ppDebugLoc + , ppTypedValMd + , ppMetadata + , ppMetadataNode' + , ppMetadataNode + , ppStringLiteral + , ppAsm + , ppConstExpr' + , ppConstExpr + , ppGepFlags + , ppDebugInfo' + , ppDebugRecords + , ppDebugRecord' + , ppDbgRecValue' + , ppDbgRecDeclare' + , ppDbgRecAssign' + , ppDbgRecValueSimple' + , ppDebugInfo + , ppDIImportedEntity' + , ppDIImportedEntity + , ppDILabel' + , ppDILabel + , ppDINameSpace' + , ppDINameSpace + , ppDITemplateTypeParameter' + , ppDITemplateTypeParameter + , ppDITemplateValueParameter' + , ppDITemplateValueParameter + , ppDIBasicType' + , ppDISubrangeType' + , ppDISubrangeType + , ppDICompileUnit' + , ppDICompileUnit + , ppFlags + , ppDICompositeType' + , ppDICompositeType + , ppDIDerivedType' + , ppDIDerivedType + , ppDIEnumerator + , ppDIFixedPointType' + , ppDIFixedPointType + , ppDIExpression + , ppDIFile + , ppDIGlobalVariable' + , ppDIGlobalVariable + , ppDIGlobalVariableExpression' + , ppDIGlobalVariableExpression + , ppDILexicalBlock' + , ppDILexicalBlock + , ppDILexicalBlockFile' + , ppDILexicalBlockFile + , ppDILocalVariable' + , ppDILocalVariable + , ppDISubprogram' + , ppDISubprogram + , ppDISubrange' + , ppDISubrange + , ppDISubroutineType' + , ppDISubroutineType + , ppDIArgList' + , ppDIArgList + , ppModuleAtLine + , ppArgList + , ppBool + , ppInt64ValMd' + , ppSizeOrOffsetValMd' + , ppMaybe + , hex + , onlyOnLLVM + , droppedInLLVM + ) +where import Text.LLVM.AST +import Text.LLVM.DebugUtils import Text.LLVM.Triple.AST (TargetTriple) import Text.LLVM.Triple.Print (printTriple) import Control.Applicative ((<|>)) -import Data.Bits ( shiftR, (.&.) ) +import Data.Bits ( shiftL, shiftR, (.|.), (.&.) ) +import Data.Bool ( bool ) import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper) -import Data.List (intersperse) +import Data.List ( intersperse, nub ) import qualified Data.Map as Map import Data.Maybe (catMaybes,fromMaybe,isJust) -import GHC.Float (castDoubleToWord64, castFloatToWord32) +import GHC.Float (castDoubleToWord64, castWord32ToFloat, float2Double) import Numeric (showHex) import Text.PrettyPrint.HughesPJ import Data.Int +import Data.Word (Word16, Word32) import Prelude hiding ((<>)) @@ -73,8 +229,8 @@ -- this is used for defaulting and otherwise reporting the maximum LLVM version -- known to be supported. llvmVlatest :: LLVMVer -llvmVlatest = 17 - +llvmVlatest = 22 -- If you update this, make sure to also update the latest LLVM + -- version mentioned in the README. -- | The differences between various versions of the llvm textual AST. newtype Config = Config { cfgVer :: LLVMVer } @@ -159,11 +315,11 @@ ppNamedMd :: Fmt NamedMd ppNamedMd nm = sep [ ppMetadata (text (nmName nm)) <+> char '=' - , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] + , ppMetadata (braces (commas (map (ppMetadata . int . unnamedMdIdx) (nmValues nm)))) ] ppUnnamedMd :: Fmt UnnamedMd ppUnnamedMd um = - sep [ ppMetadata (int (umIndex um)) <+> char '=' + sep [ ppMetadata (int (unnamedMdIdx $ umIndex um)) <+> char '=' , distinct <+> ppValMd (umValues um) ] where distinct | umDistinct um = "distinct" @@ -206,32 +362,59 @@ case ls of BigEndian -> char 'E' LittleEndian -> char 'e' - PointerSize 0 sz abi pref -> char 'p' <> char ':' <> ppLayoutBody sz abi pref - PointerSize n sz abi pref -> char 'p' <> int n <> char ':' - <> ppLayoutBody sz abi pref - IntegerSize sz abi pref -> char 'i' <> ppLayoutBody sz abi pref - VectorSize sz abi pref -> char 'v' <> ppLayoutBody sz abi pref - FloatSize sz abi pref -> char 'f' <> ppLayoutBody sz abi pref - StackObjSize sz abi pref -> char 's' <> ppLayoutBody sz abi pref - AggregateSize sz abi pref -> char 'a' <> ppLayoutBody sz abi pref + PointerSize ps -> char 'p' <> ppPointerSize ps + IntegerSize sz -> char 'i' <> ppStorage sz + VectorSize sz -> char 'v' <> ppStorage sz + FloatSize sz -> char 'f' <> ppStorage sz + StackObjSize sz -> char 's' <> ppStorage sz + AggregateSize Nothing a -> char 'a' <> char ':' <> ppAlignment a + AggregateSize (Just s) a -> char 'a' <> int s <> char ':' <> ppAlignment a NativeIntSize szs -> char 'n' <> hcat (punctuate (char ':') (map int szs)) StackAlign a -> char 'S' <> int a + ProgramAddrSpace as -> char 'P' <> int as + GlobalAddrSpace as -> char 'G' <> int as + AllocaAddrSpace as -> char 'A' <> int as + FunctionPointerAlign ty abi -> + char 'F' <> ppFunctionPointerAlignType ty <> int abi Mangling m -> char 'm' <> char ':' <> ppMangling m + NonIntegralPointerSpaces asl -> + "ni:" <> hcat (punctuate (char ':') (map int asl)) --- | Pretty-print the common case for data layout specifications. -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 +ppPointerSize :: Fmt PointerSize +ppPointerSize ps = + if ptrAddrSpace ps == 0 + then char ':' <> ppStorage (ptrStorage ps) + <> ppOptColonInt (ptrAddrIndexSize ps) + else int (ptrAddrSpace ps) <> char ':' <> ppStorage (ptrStorage ps) + <> ppOptColonInt (ptrAddrIndexSize ps) +ppStorage :: Fmt Storage +ppStorage s = int (storageSize s) <> char ':' + <> ppAlignment (storageAlignment s) + +ppAlignment :: Fmt Alignment +ppAlignment a = int (alignABI a) <> ppOptColonInt (alignPreferred a) + +ppOptColonInt :: Fmt (Maybe Int) +ppOptColonInt = \case + Nothing -> empty + Just i -> char ':' <> int i + +ppFunctionPointerAlignType :: Fmt FunctionPointerAlignType +ppFunctionPointerAlignType ty = + case ty of + IndependentOfFunctionAlign -> char 'i' + MultipleOfFunctionAlign -> char 'n' + ppMangling :: Fmt Mangling ppMangling ElfMangling = char 'e' +ppMangling GoffMangling = char 'l' ppMangling MipsMangling = char 'm' ppMangling MachOMangling = char 'o' ppMangling WindowsCoffMangling = char 'w' +ppMangling WindowsX86CoffMangling = char 'x' +ppMangling XCoffMangling = char 'a' -- Inline Assembly ------------------------------------------------------------- @@ -283,6 +466,7 @@ ppFloatType :: Fmt FloatType ppFloatType Half = "half" +ppFloatType BFloat = "bfloat" ppFloatType Float = "float" ppFloatType Double = "double" ppFloatType Fp128 = "fp128" @@ -313,8 +497,15 @@ <+> ppGlobalAttrs (isJust $ globalValue g) (globalAttrs g) <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g) <> ppAlign (globalAlign g) - <> ppAttachedMetadata (Map.toList (globalMetadata g)) + <> ppGlobalMetadata (Map.toList (globalMetadata g)) +ppGlobalMetadata :: Fmt [(String, ValMd' BlockLabel)] +ppGlobalMetadata mds + | null mds = empty + | otherwise = comma <+> commas (map step mds) + where + step (l,md) = ppMetadata (text l) <+> ppValMd md + -- | 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 @@ -370,26 +561,29 @@ ComdatNoDuplicates -> "noduplicates" ComdatSameSize -> "samesize" -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)) - <+> hsep (ppFunAttr <$> defAttrs d) - <+> ppMaybe (\s -> "section" <+> doubleQuotes (text s)) (defSection d) - <+> ppMaybe (\gc -> "gc" <+> ppGC gc) (defGC d) - <+> ppMds (defMetadata d) - <+> char '{' - $+$ vcat (map ppBasicBlock (defBody d)) - $+$ char '}' +ppDefineSig :: Fmt Define +ppDefineSig d = "define" + <+> ppMaybe ppLinkage (defLinkage d) + <+> ppMaybe ppVisibility (defVisibility d) + <+> ppType (defRetType d) + <+> ppSymbol (defName d) + <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d)) + <+> hsep (ppFunAttr <$> defAttrs d) + <+> ppMaybe (\s -> "section" <+> doubleQuotes (text s)) (defSection d) + <+> ppMaybe (\gc -> "gc" <+> ppGC gc) (defGC d) + <+> ppMds (defMetadata d) where ppMds mdm = case Map.toList mdm of [] -> empty mds -> hsep [ "!" <> text k <+> ppValMd md | (k, md) <- mds ] +ppDefine :: Fmt Define +ppDefine d = ppDefineSig d + <+> char '{' + $+$ vcat (map ppBasicBlock (defBody d)) + $+$ char '}' + -- FunAttr --------------------------------------------------------------------- ppFunAttr :: Fmt FunAttr @@ -439,13 +633,48 @@ $+$ nest 2 (vcat (map ppStmt (bbStmts bb))) +-- | Many of the pretty printing functions (based on 'Pretty') in this module are +-- written for the monomorphized `BlockLabel` version of the AST objects, but +-- some (those ending with a "tick" or single-quote) support the parameterized form. +-- +-- When the parameterized label type is known to be 'BlockLabel', then 'ppLabel' +-- can be passed as this first argument to those pretty printing functions. +-- +-- When the parameterized label type is not known (e.g. when implementing other +-- libraries that utilize @llvm-pretty@), the library may need to invoke the +-- pretty printer without passing an explicit label printer, and can instead use +-- the following class as a constraint for an instance that will be resolved +-- later. +-- +-- For example: +-- +-- > data Something lab = Something { ..., val :: Value' lab, ... } +-- > +-- > instance PrettyLabel lab => Pretty Something where +-- > pretty s = .... <> ppValue' ppLabel' <> +-- +-- Note that the `PrettyLabel` class is very similar to the `Pretty` class, but +-- unlike the latter's `pretty` method, the `PrettyLabel` returns the `Fmt` +-- object that allows the pretty-printing to be affected by the implicit `Config` +-- parameter; this aligns the `PrettyLabel` usage to the other pretty-printing +-- functions in this module. + +class PrettyLabel lab where + ppLabel' :: Fmt lab + +instance PrettyLabel BlockLabel where + ppLabel' = ppLabel + + -- Statements ------------------------------------------------------------------ ppStmt :: Fmt Stmt ppStmt stmt = case stmt of - Result var i mds -> ppIdent var <+> char '=' <+> ppInstr i - <> ppAttachedMetadata mds - Effect i mds -> ppInstr i <> ppAttachedMetadata mds + Result var i drs mds -> ppDebugRecords drs (ppIdent var <+> char '=' + <+> ppInstr i + <> ppAttachedMetadata mds) + Effect i drs mds -> ppDebugRecords drs (ppInstr i + <> ppAttachedMetadata mds) ppAttachedMetadata :: Fmt [(String,ValMd)] ppAttachedMetadata mds @@ -523,14 +752,14 @@ ppBitOp Xor = "xor" ppConvOp :: Fmt ConvOp -ppConvOp Trunc = "trunc" -ppConvOp ZExt = "zext" +ppConvOp (Trunc nuw nsw) = "trunc" <+> ppSignBits nuw nsw +ppConvOp (ZExt nneg) = "zext" <+> opt nneg "nneg" ppConvOp SExt = "sext" ppConvOp FpTrunc = "fptrunc" ppConvOp FpExt = "fpext" ppConvOp FpToUi = "fptoui" ppConvOp FpToSi = "fptosi" -ppConvOp UiToFp = "uitofp" +ppConvOp (UiToFp nneg) = "uitofp" <+> opt nneg "nneg" ppConvOp SiToFp = "sitofp" ppConvOp PtrToInt = "ptrtoint" ppConvOp IntToPtr = "inttoptr" @@ -599,7 +828,7 @@ <> comma <+> ppTyped ppValue a <+> ppScope s <+> ppAtomicOrdering o - ICmp op l r -> "icmp" <+> ppICmpOp op + ICmp samesign op l r -> "icmp" <+> opt samesign "samesign" <+> ppICmpOp op <+> ppTyped ppValue l <> comma <+> ppValue r FCmp op l r -> "fcmp" <+> ppFCmpOp op <+> ppTyped ppValue l <> comma <+> ppValue r @@ -616,7 +845,7 @@ ShuffleVector a b m -> "shufflevector" <+> ppTyped ppValue a <> comma <+> ppTyped ppValue (b <$ a) <> comma <+> ppTyped ppValue m - GEP ib ty ptr ixs -> ppGEP ib ty ptr ixs + GEP gf ty ptr ixs -> ppGEP gf ty ptr ixs Comment str -> char ';' <+> text str Jump i -> "br" <+> ppTypedLabel i @@ -639,7 +868,10 @@ <> comma <+> ppVectorIndex i IndirectBr d ls -> "indirectbr" <+> ppTyped ppValue d - <> comma <+> commas (map ppTypedLabel ls) + <> comma + <+> char '[' + <+> commas (map ppTypedLabel ls) + <+> char ']' Switch c d ls -> "switch" <+> ppTyped ppValue c <> comma <+> ppTypedLabel d @@ -771,19 +1003,20 @@ -> ppType res _ -> ppType ty -ppGEP :: Bool -> Type -> Typed Value -> Fmt [Typed Value] -ppGEP ib ty ptr ixs = - "getelementptr" <+> inbounds +ppGEP :: [GEPAttr] -> Type -> Typed Value -> Fmt [Typed Value] +ppGEP gf ty ptr ixs = + "getelementptr" + <+> (if inlineIsBool + then (if GEP_Inbounds `elem` gf then "inbounds" else empty) + else ppGepFlags gf) <+> (if isExplicit then explicit else empty) <+> commas (map (ppTyped ppValue) (ptr:ixs)) where isExplicit = llvmVer >= llvmV3_7 + inlineIsBool = llvmVer < 19 explicit = ppType ty <> comma - inbounds | ib = "inbounds" - | otherwise = empty - ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> Fmt BlockLabel ppInvoke ty f args to uw = body where @@ -825,17 +1058,89 @@ ppFCmpOp Funo = "uno" ppFCmpOp Ftrue = "true" +-- | Pad a string by prepending '0'. +zerofill :: Int -> String -> String +zerofill width s = + let len = length s + padding = if len < width then width - len else 0 + zeros = take padding $ repeat '0' + in + zeros ++ s + +-- | Check if a half-float is an infinite or NaN value. +halfBitsIsInfOrNaN :: Word16 -> Bool +halfBitsIsInfOrNaN x = + -- Half floats have a 1-bit sign, 5-bit exponent, and 10-bit + -- significand. If the exponent field is all ones, the value + -- is either +/- Inf (if the significand is 0) or a Nan. + (x .&. 0x7c00) == 0x7c00 + +-- | Convert the bit representation of a half-float to a single. +halfToSingleBits :: Word16 -> Word32 +halfToSingleBits x = + -- Half floats have a 1-bit sign, 5-bit exponent, and 10-bit + -- significand. + -- + -- 32-bit single floats have a 1-bit sign, 8-bit exponent, and + -- 23-bit significand. Convert as follows: + -- - mask off the sign bit, widen, shift into place + -- - mask off the significand, widen, shift into place + -- (at the top of the new significand; rest stays 0) + -- - mask off the exponent + -- - convert it to int; if that's 0, it stays 0 + -- - otherwise re-offset it, convert to Word32, and shift + -- + let sign = shiftL (fromIntegral (x .&. 0x8000)) (31 - 15) + signif = shiftL (fromIntegral (x .&. 0xfff)) (23 - 10) + expBits = x .&. 0x7c00 + expo = case fromIntegral @Word16 @Int (shiftR expBits 10) of + 0 -> 0 + n -> shiftL (fromIntegral ((n - 15) + 127)) 23 + in + sign .|. expo .|. signif + +-- | Check if a bfloat is an infinite or NaN value. +bfloatBitsIsInfOrNaN :: Word16 -> Bool +bfloatBitsIsInfOrNaN x = + -- BFloat half floats have a 1-bit sign, 8-bit exponent, and 7-bit + -- significand. If the exponent field is all ones, the value + -- is either +/- Inf (if the significand is 0) or a Nan. + (x .&. 0x7f80) == 0x7f80 + +-- | Convert the bit representation of a bfloat to a single. +bfloatToSingleBits :: Word16 -> Word32 +bfloatToSingleBits x = + -- Since 32-bit floats are the same layout, just with 16 bits + -- more precision, all we need to do is widen and shift left. + shiftL (fromIntegral x) 16 + ppValue' :: Fmt i -> Fmt (Value' i) ppValue' pp val = case val of ValInteger i -> integer i ValBool b -> ppBool b -- Note: for +Inf/-Inf/NaNs, we want to output the bit-correct sequence + ValHalf (FPHalf x) -> + -- Shown in hex as 0H<<4-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants + if halfBitsIsInfOrNaN x + then text "0xH" <> text (zerofill 4 $ showHex x "") + else float $ castWord32ToFloat $ halfToSingleBits x + ValBFloat (FPBFloat x) -> + -- Shown in hex as 0R<<4-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants + if bfloatBitsIsInfOrNaN x + then text "0xR" <> text (zerofill 4 $ showHex x "") + else float $ castWord32ToFloat $ bfloatToSingleBits x ValFloat f -> if isInfinite f || isNaN f - then text "0x" <> text (showHex (castFloatToWord32 f) "") + -- shown as 0x<<16-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants + then text "0x" <> text (showHex (castDoubleToWord64 $ float2Double f) "") else float f ValDouble d -> if isInfinite d || isNaN d + -- shown as 0x<<16-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants then text "0x" <> text (showHex (castDoubleToWord64 d) "") else double d ValFP80 (FP80_LongDouble e s) -> @@ -845,6 +1150,19 @@ | otherwise = showHex n fld v i = pad ((v `shiftR` (i * 8)) .&. 0xff) in "0xK" <> text (foldr (fld e) (foldr (fld s) "" $ reverse [0..7::Int]) [1, 0]) + ValFP128 (FP128_LongDouble a b) -> + -- shown as 0xL<<32-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants + let print64 k = zerofill 16 $ showHex k "" in + "0xL" <> text (print64 a ++ print64 b) + ValFP128_PPC (FP128_PPC_DoubleDouble a b) -> + -- shown as 0xM<<32-hex-digits>>, per + -- https://llvm.org/docs/LangRef.html#simple-constants + let print64 k = zerofill 16 $ showHex k "" + a' = print64 (castDoubleToWord64 a) + b' = print64 (castDoubleToWord64 b) + in + "0xM" <> text (a' ++ b') ValIdent i -> ppIdent i ValSymbol s -> ppSymbol s ValNull -> "null" @@ -871,7 +1189,7 @@ ppValMd' pp m = case m of ValMdString str -> ppMetadata (ppStringLiteral str) ValMdValue tv -> ppTyped (ppValue' pp) tv - ValMdRef i -> ppMetadata (int i) + ValMdRef i -> ppMetadata (int $ unnamedMdIdx i) ValMdNode vs -> ppMetadataNode' pp vs ValMdLoc l -> ppDebugLoc' pp l ValMdDebugInfo di -> ppDebugInfo' pp di @@ -885,13 +1203,20 @@ <> parens (commas [ "line:" <+> integral (dlLine dl) , "column:" <+> integral (dlCol dl) , "scope:" <+> ppValMd' pp (dlScope dl) - ] <> mbIA <> mbImplicit) + ] <> mbIA <> mbImplicit <> + when' (llvmVer >= 21) (mbAtomGroup <> mbAtomRank)) where mbIA = case dlIA dl of Just md -> comma <+> "inlinedAt:" <+> ppValMd' pp md Nothing -> empty mbImplicit = if dlImplicit dl then comma <+> "implicit" else empty + mbAtomGroup = if dlAtomGroup dl > 0 + then comma <+> "atomGroup:" <+> integral (dlAtomGroup dl) + else empty + mbAtomRank = if dlAtomRank dl > 0 + then comma <+> "atomRank:" <+> integral (dlAtomRank dl) + else empty ppDebugLoc :: Fmt DebugLoc ppDebugLoc = ppDebugLoc' ppLabel @@ -934,24 +1259,76 @@ ppConstExpr' :: Fmt i -> Fmt (ConstExpr' i) ppConstExpr' pp expr = case expr of - ConstGEP inb _mix ty ptr ixs -> + ConstGEP optflgs mrng ty ptr ixs -> "getelementptr" - <+> opt inb "inbounds" - <+> parens (commas (ppType ty : map ppTyp' (ptr:ixs))) - ConstConv op tv t -> ppConvOp op <+> parens (ppTyp' tv <+> "to" <+> ppType t) + <+> ppGepFlags optflgs + <+> ppRange mrng + <+> parens (commas ( + let argIndices = 0 : [0..] -- rval, ptr, then ixs indices + in reverse -- ppTyp's pushes entries to the listg head + $ foldl (ppTyp's mrng) [ppType ty] + $ zip argIndices (ptr:ixs))) + ConstConv op tv t -> + let droppedIn18 = case op of + -- https://github.com/llvm/llvm-project commit e4a4122 dropped ZExt and SExt + ZExt _ -> True + SExt -> True + -- https://github.com/llvm/llvm-project commit 17764d2 dropped FpTrunc through SiToFP + FpTrunc -> True + FpExt -> True + FpToUi -> True + FpToSi -> True + UiToFp _ -> True + SiToFp -> True + _ -> False + ppConstConv = ppConvOp op <+> parens (ppTyp' tv <+> "to" <+> ppType t) + in if droppedIn18 + then droppedInLLVM 18 "fptrunc/fpext/fptoui/fptosi/uitofp/sitofp constexprs" ppConstConv + else ppConstConv ConstSelect c l r -> - "select" <+> parens (commas [ ppTyp' c, ppTyp' l , ppTyp' r]) + droppedInLLVM 17 "select constexpr" -- https://github.com/llvm/llvm-project commit bbfb13a + + $ "select" <+> parens (commas [ ppTyp' c, ppTyp' l , ppTyp' r]) ConstBlockAddr t l -> "blockaddress" <+> parens (ppVal' (typedValue t) <> comma <+> pp l) - ConstFCmp op a b -> "fcmp" <+> ppFCmpOp op <+> ppTupleT a b - ConstICmp op a b -> "icmp" <+> ppICmpOp op <+> ppTupleT a b + ConstFCmp op a b -> droppedInLLVM 19 "fcmp constexprs" + $ "fcmp" <+> ppFCmpOp op <+> ppTupleT a b + ConstICmp op a b -> droppedInLLVM 19 "icmp constexprs" + $ "icmp" <+> ppICmpOp op <+> ppTupleT a b ConstArith op a b -> ppArithOp op <+> ppTuple a b ConstUnaryArith op a -> ppUnaryArithOp op <+> ppTyp' a - ConstBit op a b -> ppBitOp op <+> ppTuple a b + ConstBit op@(Shl _ _) a b -> droppedInLLVM 19 "shl constexprs" + $ ppBitOp op <+> ppTuple a b + ConstBit Xor a b -> ppBitOp Xor <+> ppTuple a b + ConstBit op a b -> droppedInLLVM 18 "and/or/lshr/ashr constexprs" + $ ppBitOp op <+> ppTuple a b where ppTuple a b = parens $ ppTyped ppVal' a <> comma <+> ppVal' b ppTupleT a b = parens $ ppTyped ppVal' a <> comma <+> ppTyp' b ppVal' = ppValue' pp ppTyp' = ppTyped ppVal' + ppTyp's mrng a (i,t) = + let inrangeMark = if Just (RangeIndex i) == mrng then "inrange" else empty + in (inrangeMark <+> ppTyp' t) : a + ppRange = + let ppR = \case + RangeIndex _i -> empty -- handled in ppTyp's + Range _ l u -> + "inrange(" <> integral l <> ", " <> integral u <> ")" + in maybe empty ppR +ppGepFlags :: Fmt [GEPAttr] +ppGepFlags s = + let fltr = if GEP_Inbounds `elem` s + then + -- inbounds implies nusw, but LLVM stipulates that if + -- inbounds is present, nusw is not also printed. + filter (/= GEP_NUSW) + else id + ppF = \case + GEP_Inbounds -> "inbounds" + GEP_NUSW -> "nusw" + GEP_NUW -> "nuw" + in foldl (\o f -> o <+> ppF f) empty $ fltr $ nub s + ppConstExpr :: Fmt ConstExpr ppConstExpr = ppConstExpr' ppLabel @@ -959,7 +1336,7 @@ ppDebugInfo' :: Fmt i -> Fmt (DebugInfo' i) ppDebugInfo' pp di = case di of - DebugInfoBasicType bt -> ppDIBasicType bt + DebugInfoBasicType bt -> ppDIBasicType' pp bt DebugInfoCompileUnit cu -> ppDICompileUnit' pp cu DebugInfoCompositeType ct -> ppDICompositeType' pp ct DebugInfoDerivedType dt -> ppDIDerivedType' pp dt @@ -973,6 +1350,8 @@ DebugInfoLocalVariable lv -> ppDILocalVariable' pp lv DebugInfoSubprogram sp -> ppDISubprogram' pp sp DebugInfoSubrange sr -> ppDISubrange' pp sr + DebugInfoSubrangeType srt -> ppDISubrangeType' pp srt + DebugInfoFixedPointType fpt -> ppDIFixedPointType' pp fpt DebugInfoSubroutineType st -> ppDISubroutineType' pp st DebugInfoNameSpace ns -> ppDINameSpace' pp ns DebugInfoTemplateTypeParameter dttp -> ppDITemplateTypeParameter' pp dttp @@ -981,7 +1360,69 @@ DebugInfoLabel dil -> ppDILabel' pp dil DebugInfoArgList args -> ppDIArgList' pp args DebugInfoAssignID -> "!DIAssignID()" + -- DebugRecordDeclare drd -> ppDbgRecDeclare' pp drd +-- Prints DebugRecords (introduced in LLVM 19) which replace debug intrinsics and +-- unlike the intrinsics that follow the instruction, the debug records *precede* +-- the Instruction they affect. +ppDebugRecords :: [DebugRecord' BlockLabel] -> Fmt Doc +ppDebugRecords [] = id +ppDebugRecords drs = ((nest 2 $ vcat (ppDebugRecord' ppLabel <$> drs)) $$) + +ppDebugRecord' :: Fmt lab -> Fmt (DebugRecord' lab) +ppDebugRecord' pl = \case + DebugRecordValue drv -> ppDbgRecValue' pl drv + DebugRecordDeclare drd -> ppDbgRecDeclare' pl drd + DebugRecordAssign dra -> ppDbgRecAssign' pl dra + DebugRecordValueSimple dvs -> ppDbgRecValueSimple' pl dvs + DebugRecordLabel drl -> ppDbgRecLabel' pl drl + +ppDbgRecValue' :: Fmt lab -> Fmt (DbgRecValue' lab) +ppDbgRecValue' pl dr = + "#dbg_value" + <> parens (commas [ ppValMd' pl $ drvValAsMetadata dr + , ppValMd' pl $ drvLocalVariable dr + , ppValMd' pl $ drvExpression dr + , ppValMd' pl $ drvLocation dr + ]) + +ppDbgRecDeclare' :: Fmt lab -> Fmt (DbgRecDeclare' lab) +ppDbgRecDeclare' pl dr = + "#dbg_declare" + <> parens (commas [ ppValMd' pl $ drdValAsMetadata dr + , ppValMd' pl $ drdLocalVariable dr + , ppValMd' pl $ drdExpression dr + , ppValMd' pl $ drdLocation dr + ]) + +ppDbgRecAssign' :: Fmt lab -> Fmt (DbgRecAssign' lab) +ppDbgRecAssign' pl dr = + "#dbg_assign" + <> parens (commas [ ppValMd' pl $ draValAsMetadata dr + , ppValMd' pl $ draLocalVariable dr + , ppValMd' pl $ draExpression dr + , ppValMd' pl $ draAssignID dr + , ppValMd' pl $ draValAsMetadataAddr dr + , ppValMd' pl $ draExpressionAddr dr + , ppValMd' pl $ draLocation dr + ]) + +ppDbgRecValueSimple' :: Fmt lab -> Fmt (DbgRecValueSimple' lab) +ppDbgRecValueSimple' pl dr = + "#dbg_value" + <> parens (commas [ ppTyped (ppValue' pl) $ drvsValue dr + , ppValMd' pl $ drvsLocalVariable dr + , ppValMd' pl $ drvsExpression dr + , ppValMd' pl $ drvsLocation dr + ]) + +ppDbgRecLabel' :: Fmt lab -> Fmt (DbgRecLabel' lab) +ppDbgRecLabel' pl dr = + "#dbg_label" + <> parens (commas [ ppValMd' pl $ drlLabel dr + , ppValMd' pl $ drlLocation dr + ]) + ppDebugInfo :: Fmt DebugInfo ppDebugInfo = ppDebugInfo' ppLabel @@ -1000,11 +1441,17 @@ ppDILabel' :: Fmt i -> Fmt (DILabel' i) ppDILabel' pp ie = "!DILabel" - <> parens (mcommas [ (("scope:" <+>) . ppValMd' pp) <$> dilScope ie - , pure ("name:" <+> ppStringLiteral (dilName ie)) - , (("file:" <+>) . ppValMd' pp) <$> dilFile ie - , pure ("line:" <+> integral (dilLine ie)) - ]) + <> parens (mcommas $ + [ (("scope:" <+>) . ppValMd' pp) <$> dilScope ie + , pure ("name:" <+> ppStringLiteral (dilName ie)) + , (("file:" <+>) . ppValMd' pp) <$> dilFile ie + , pure ("line:" <+> integral (dilLine ie)) + ] ++ + when' (llvmVer >= 21) + [ pure ("column:" <+> integral (dilColumn ie)) + , pure ("isArtificial:" <+> ppBool (dilIsArtificial ie)) + , (("coroSuspendIdx:" <+>) . integral) <$> dilCoroSuspendIdx ie + ]) ppDILabel :: Fmt DILabel ppDILabel = ppDILabel' ppLabel @@ -1040,19 +1487,48 @@ ppDITemplateValueParameter :: Fmt DITemplateValueParameter ppDITemplateValueParameter = ppDITemplateValueParameter' ppLabel -ppDIBasicType :: Fmt DIBasicType -ppDIBasicType bt = "!DIBasicType" - <> parens (commas [ "tag:" <+> integral (dibtTag bt) - , "name:" <+> doubleQuotes (text (dibtName bt)) - , "size:" <+> integral (dibtSize bt) - , "align:" <+> integral (dibtAlign bt) - , "encoding:" <+> integral (dibtEncoding bt) - ] <> mbFlags) - where - mbFlags = case dibtFlags bt of - Just flags -> comma <+> "flags:" <+> integral flags - Nothing -> empty +ppDIBasicType' :: Fmt i -> Fmt (DIBasicType' i) +ppDIBasicType' pp bt = "!DIBasicType" + <> parens (mcommas $ + [ pure ("tag:" <+> integral (dibtTag bt)) + , pure ("name:" <+> doubleQuotes (text (dibtName bt))) + , (("size:" <+>) . ppSizeOrOffsetValMd' pp) <$> dibtSize bt + , pure ("align:" <+> integral (dibtAlign bt)) + , pure ("encoding:" <+> integral (dibtEncoding bt)) + , (("flags:" <+>) . integral) + <$> dibtFlags bt + , if dibtNumExtraInhabitants bt > 0 + then pure ("numExtraInhabitants:" <+> integral (dibtNumExtraInhabitants bt)) + else Nothing + ] + ++ + when' (llvmVer >= 22) + [ if dibtDataSize bt > 0 + then pure ("dataSize:" <+> integral (dibtDataSize bt)) + else Nothing + ] + ) +ppDISubrangeType' :: Fmt i -> Fmt (DISubrangeType' i) +ppDISubrangeType' pp srt = "!DISubrangeType" + <> parens (mcommas + [ (("name:" <+>) . doubleQuotes . text) <$> (disrtName srt) + , (("file:" <+>) . ppValMd' pp) <$> (disrtFile srt) + , pure ("line:" <+> integral (disrtLine srt)) + , (("scope:" <+>) . ppValMd' pp) <$> (disrtScope srt) + , (("size:" <+>) . ppValMd' pp) <$> (disrtSize srt) + , pure ("align:" <+> integral (disrtAlign srt)) + , pure ("flags:" <+> integral (disrtFlags srt)) + , (("baseType:" <+>) . ppValMd' pp) <$> (disrtBaseType srt) + , (("lowerBound:" <+>) . ppInt64ValMd' True pp) <$> disrtLowerBound srt + , (("upperBound:" <+>) . ppInt64ValMd' True pp) <$> disrtUpperBound srt + , (("stride:" <+>) . ppInt64ValMd' True pp) <$> disrtStride srt + , (("bias:" <+>) . ppInt64ValMd' True pp) <$> disrtBias srt + ]) + +ppDISubrangeType :: Fmt DISubrangeType +ppDISubrangeType = ppDISubrangeType' ppLabel + ppDICompileUnit' :: Fmt i -> Fmt (DICompileUnit' i) ppDICompileUnit' pp cu = "!DICompileUnit" <> parens (mcommas $ @@ -1085,6 +1561,12 @@ , (("sdk:" <+>) . doubleQuotes . text) <$> (dicuSDK cu) ] + ++ + when' (llvmVer >= 22) + [ if dicuSourceLanguageVersion cu > 0 + then pure ("sourceLanguageVersion:" <+> integral (dicuSourceLanguageVersion cu)) + else Nothing + ] ) @@ -1102,9 +1584,9 @@ , (("file:" <+>) . ppValMd' pp) <$> (dictFile ct) , pure ("line:" <+> integral (dictLine ct)) , (("baseType:" <+>) . ppValMd' pp) <$> (dictBaseType ct) - , pure ("size:" <+> integral (dictSize ct)) + , (("size:" <+>) . ppSizeOrOffsetValMd' pp) <$> dictSize ct , pure ("align:" <+> integral (dictAlign ct)) - , pure ("offset:" <+> integral (dictOffset ct)) + , (("offset:" <+>) . ppSizeOrOffsetValMd' pp) <$> dictOffset ct , pure ("flags:" <+> integral (dictFlags ct)) , (("elements:" <+>) . ppValMd' pp) <$> (dictElements ct) , pure ("runtimeLang:" <+> integral (dictRuntimeLang ct)) @@ -1117,6 +1599,12 @@ , (("allocated:" <+>) . ppValMd' pp) <$> (dictAllocated ct) , (("rank:" <+>) . ppValMd' pp) <$> (dictRank ct) , (("annotations:" <+>) . ppValMd' pp) <$> (dictAnnotations ct) + , if dictNumExtraInhabitants ct > 0 + then pure ("numExtraInhabitants:" <+> integral (dictNumExtraInhabitants ct)) + else Nothing + , (("specification:" <+>) . ppValMd' pp) <$> (dictSpecification ct) + , (("enumKind:" <+>) . integral) <$> (dictEnumKind ct) + , (("bitStride:" <+>) . ppValMd' pp) <$> (dictBitStride ct) ]) ppDICompositeType :: Fmt DICompositeType @@ -1131,9 +1619,9 @@ , pure ("line:" <+> integral (didtLine dt)) , (("scope:" <+>) . ppValMd' pp) <$> (didtScope dt) , ("baseType:" <+>) <$> (ppValMd' pp <$> didtBaseType dt <|> Just "null") - , pure ("size:" <+> integral (didtSize dt)) + , (("size:" <+>) . ppSizeOrOffsetValMd' pp) <$> didtSize dt , pure ("align:" <+> integral (didtAlign dt)) - , pure ("offset:" <+> integral (didtOffset dt)) + , (("offset:" <+>) . ppSizeOrOffsetValMd' pp) <$> didtOffset dt , pure ("flags:" <+> integral (didtFlags dt)) , (("extraData:" <+>) . ppValMd' pp) <$> (didtExtraData dt) , (("dwarfAddressSpace:" <+>) . integral) <$> didtDwarfAddressSpace dt @@ -1150,6 +1638,35 @@ , "isUnsigned:" <+> ppBool u ]) +ppDIFixedPointType' :: Fmt i -> Fmt (DIFixedPointType' i) +ppDIFixedPointType' pp t = "!DIFixedPointType" + <> parens (mcommas $ + [ pure ("tag:" <+> integral (difptTag t)) + , (("name:" <+>) . doubleQuotes . text) <$> (difptName t) + , (("size:" <+>) . ppValMd' pp) <$> (difptSize t) + , pure ("align:" <+> integral (difptAlign t)) + , pure ("encoding:" <+> integral (difptEncoding t)) + , pure ("flags:" <+> integral (difptFlags t)) + ] + ++ case difptKind t of + FixedPointBinary v -> + [ pure "kind: Binary" + , pure ("factor:" <+> integral v) + ] + FixedPointDecimal v -> + [ pure "kind: Decimal" + , pure ("factor:" <+> integral v) + ] + FixedPointRational n d -> + [ pure "kind: Rational" + , pure ("numerator:" <+> integral n) + , pure ("denominator:" <+> integral d) + ] + ) + +ppDIFixedPointType :: Fmt DIFixedPointType +ppDIFixedPointType = ppDIFixedPointType' ppLabel + ppDIExpression :: Fmt DIExpression ppDIExpression e = "!DIExpression" <> parens (commas (map integral (dieElements e))) @@ -1305,6 +1822,66 @@ ppDIArgList :: Fmt DIArgList ppDIArgList = ppDIArgList' ppLabel + +-- ------------------------------------------------------------------- +-- Auxiliary pretty-printing functions +-- +-- These are alternative pretty-printing functions (instead of the pretty-printers +-- for the basic AST elements above). These functions can be used in +-- situations where additional or alternative pretty-printing functionality is +-- needed. + +-- | This is an auxiliary pretty printer for showing just part of a module: the +-- part corresponding to a specific source file and line in the source file +-- (whereas ppModule or even ppDefine will show the *entire* module or +-- definition/function). A range of lines can be displayed by iterative calls +-- over multiple lines. +-- +-- > putStrLn $ ppLLVM llvmVlatest $ ppModuleAtLine "foo.c" 23 llvmModule +-- +-- The above example shows all the lines in llvmModule that correspond to line 23 +-- of the "foo.c" source file. +ppModuleAtLine :: (?config :: Config) => String -> Integer -> Fmt Module +ppModuleAtLine file line = + toDoc . atFileLines (AddDocAtLine ?config) (Start empty) file line + +-- internal helper for the AtFileLines instance below +data AddDocAtLine = AddDocAtLine Config + +-- internal helper for the AtFileLines instance below +data DocBld = Start Doc -- ^ at the start: doc-so-far + | DF DocBld Define Doc + -- ^ atDefine: doc-so-far, the define, and the doc for the body of + -- the AtFileLines + | BS DocBld (Maybe BlockLabel) Doc + -- ^ atBlockStart: doc-so-far, block label (if any), and doc for the + -- block body + +instance AtFileLines DocBld AddDocAtLine where + atDefine _ d docbld = DF docbld d empty + atBlockStart _ _dr bb docbld = BS docbld (bbLabel bb) empty + atStmt (AddDocAtLine c) _dr br s = + let isContig = case br of + FirstBlockStmt -> True + ContiguousStmt -> True + FirstLineStmt -> False + in withConfig c $ emit $ bool (text "..." $$) (empty $$) isContig $ ppStmt s + atGlobal (AddDocAtLine c) g = withConfig c $ emit $ ppGlobal g + +-- internal helper for the AtFileLines instance below +emit :: Doc -> DocBld -> DocBld +emit n = \case + DF b s d -> DF b s (d $$ n) + BS b l d -> BS b l (d $$ n) + Start d -> Start (d $$ n) + +-- internal helper for the AtFileLines instance below +toDoc :: Fmt DocBld +toDoc = \case + DF b s d -> toDoc b $$ ppDefineSig s $$ nest 2 d + BS b l d -> toDoc b $$ text "" $$ ppMaybe ppLabelDef l $$ d + Start d -> d + -- Utilities ------------------------------------------------------------------- ppBool :: Fmt Bool @@ -1337,7 +1914,7 @@ ValMdValue tv | PrimType (Integer _) <- typedType tv , ValInteger i <- typedValue tv - -> integer i -- 64 bits is the largest Int, so no conversion needed + -> integer i -- 64 bits is the largest Int, so no conversion needed. o@(ValMdDebugInfo (DebugInfoGlobalVariable gv)) -> case digvVariable gv of Nothing -> when' canFallBack $ ppValMd' pp o @@ -1351,7 +1928,18 @@ -- ValMdRef _idx -> mempty -- no table here to look this up... o -> when' canFallBack $ ppValMd' pp o +-- | Print the size or offset of a type-related metadata node. This value can +-- either be an integer literal (in which case the bare literal is printed), or +-- in LLVM 21 or later, it can be a more complicated metadata expression (in +-- which case the metadata is pretty-printed). +ppSizeOrOffsetValMd' :: Fmt i -> Fmt (ValMd' i) +ppSizeOrOffsetValMd' pp = \case + ValMdValue tv + | ValInteger i <- typedValue tv + -> integer i + o -> when' (llvmVer >= 21) $ ppValMd' pp o + commas :: Fmt [Doc] commas = fsep . punctuate comma @@ -1376,3 +1964,11 @@ | llvmVer >= fromVer = id | otherwise = error $ name ++ " is supported only on LLVM >= " ++ llvmVerToString fromVer + +-- | Throw an error if the @?config@ version is older than the given version. The +-- String indicates which constructor is unavailable in the error message. +droppedInLLVM :: (?config :: Config) => LLVMVer -> String -> a -> a +droppedInLLVM fromVer name + | llvmVer >= fromVer = error $ name ++ " is supported only up to LLVM >= " + ++ llvmVerToString fromVer + | otherwise = id diff --git a/src/Text/LLVM/Triple/AST.hs b/src/Text/LLVM/Triple/AST.hs --- a/src/Text/LLVM/Triple/AST.hs +++ b/src/Text/LLVM/Triple/AST.hs @@ -21,7 +21,6 @@ ) where import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics (Generic) -- | The constructors of this type exactly mirror the LLVM @enum ArchType@, @@ -150,7 +149,7 @@ | RenderScript64 -- | NEC SX-Aurora Vector Engine | VE - deriving (Bounded, Data, Eq, Enum, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Eq, Enum, Generic, Ord, Read, Show) -- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS -- is 'UnknownArch'. @@ -216,7 +215,7 @@ | SPIRVSubArch_v13 | SPIRVSubArch_v14 | SPIRVSubArch_v15 - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show) -- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS -- is 'NoSubArch'. @@ -250,7 +249,7 @@ | Mesa | SUSE | OpenEmbedded - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show) -- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS -- is 'UnknownVendor'. @@ -323,7 +322,7 @@ | Emscripten -- | DirectX ShaderModel | ShaderModel - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show) -- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS -- is 'UnknownOS'. @@ -386,7 +385,7 @@ | Callable | Mesh | Amplification - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show) -- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS -- is 'UnknownEnvironment'. @@ -414,7 +413,7 @@ | SPIRV | Wasm | XCOFF - deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show) -- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS -- is 'UnknownObjectFormat'. @@ -440,7 +439,7 @@ , ttEnv :: Environment , ttObjFmt :: ObjectFormat } - deriving (Bounded, Data, Eq, Generic, Ord, Read, Show, Typeable) + deriving (Bounded, Data, Eq, Generic, Ord, Read, Show) -- | Combines fields pointwise. instance Semigroup TargetTriple where diff --git a/test/CombineTests.hs b/test/CombineTests.hs new file mode 100644 --- /dev/null +++ b/test/CombineTests.hs @@ -0,0 +1,231 @@ +module CombineTests + ( + tests + ) +where + +import Data.Function ( on ) +import Data.String ( fromString ) +import Lens.Micro + +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ( assertBool, testCase, (@?=) ) + +import Text.LLVM -- ( emptyModule ) +import Text.LLVM.Combine +import Text.LLVM.Lens + + +tests :: Tasty.TestTree +tests = Tasty.testGroup "LLVM combine" + [ + testCase "empty equivalences" + $ let llvm1 = emptyModule + llvm2 = emptyModule + llvm3 = emptyModule + llvmAll = llvmModuleCombine (llvmModuleCombine llvm1 llvm2) llvm3 + in assertBool "combining empty is empty" + $ and [ llvm1 == llvm1 + , ((==) `on` (modSourceNameLens .~ Nothing)) llvmAll llvm1 + , ((==) `on` (modSourceNameLens .~ Nothing)) llvmAll llvm2 + , ((==) `on` (modSourceNameLens .~ Nothing)) llvmAll llvm3 + ] + + , testCase "metadata updates" + $ let llvm1 = emptyModule + & modUnnamedMdLens .~ [ UnnamedMd { umIndex = 1 + , umValues = ValMdString "a" + , umDistinct = False + } + ] + & modNamedMdLens .~ [ NamedMd { nmName = "frog" + , nmValues = [1] + } + ] + llvm2 = emptyModule + & modUnnamedMdLens .~ [ UnnamedMd { umIndex = 1 + , umValues = ValMdString "B" + , umDistinct = False + } + , UnnamedMd { umIndex = 2 + , umValues = ValMdRef 1 + , umDistinct = False + } + ] + & modNamedMdLens .~ [ NamedMd { nmName = "pig" + , nmValues = [2, 1] + } + ] + llvmAll = llvmModuleCombine llvm1 llvm2 + in do llvmAll ^. modUnnamedMdLens @?= + [ UnnamedMd { umIndex = 1 + , umValues = ValMdString "a" + , umDistinct = False + } + , UnnamedMd { umIndex = 3 + , umValues = ValMdString "B" + , umDistinct = False + } + , UnnamedMd { umIndex = 4 + , umValues = ValMdRef 3 + , umDistinct = False + } + ] + llvmAll ^. modNamedMdLens @?= + [ NamedMd { nmName = "frog" + , nmValues = [1] + } + , NamedMd { nmName = "pig" + , nmValues = [4, 3] + } + ] + + , testCase "type name deconflicting" + $ let llvm1 = emptyModule + & modTypesLens .~ [ TypeDecl { typeName = fromString "type1" + , typeValue = Opaque } + , TypeDecl { typeName = fromString "type1___0" + , typeValue = Alias $ fromString "cow" + } + ] + llvm2 = emptyModule + & modTypesLens .~ [ TypeDecl { typeName = fromString "type1" + , typeValue = PrimType Void + } + , TypeDecl { typeName = fromString "type1___0" + , typeValue = Alias $ fromString "moo" + } + , TypeDecl { typeName = fromString "type2" + , typeValue = PtrOpaque + } + ] + & modDefinesLens .~ + [ + Define { defName = fromString "foo" + , defLinkage = Nothing + , defVisibility = Nothing + , defComdat = Nothing + , defMetadata = mempty + , defGC = Nothing + , defSection = Nothing + , defVarArgs = False + , defArgs = + [ Typed { typedType = Alias $ fromString "moo" + , typedValue = fromString "type1___0" + } + ] + , defRetType = PrimType Void + , defAttrs = mempty + , defBody = [] + } + ] + llvmAll = llvmModuleCombine llvm1 llvm2 + in do llvmAll ^. modTypesLens @?= + [ TypeDecl { typeName = fromString "type1" + , typeValue = Opaque } + , TypeDecl { typeName = fromString "type1___0" + , typeValue = Alias $ fromString "cow" + } + , TypeDecl { typeName = fromString "type1___1" + , typeValue = PrimType Void + } + , TypeDecl { typeName = fromString "type1___0___0" + , typeValue = Alias $ fromString "moo" + } + , TypeDecl { typeName = fromString "type2" + , typeValue = PtrOpaque + } + ] + llvmAll ^. modDefinesLens @?= + [ + Define { defName = fromString "foo" + , defLinkage = Nothing + , defVisibility = Nothing + , defComdat = Nothing + , defMetadata = mempty + , defGC = Nothing + , defSection = Nothing + , defVarArgs = False + , defArgs = + [ Typed { typedType = Alias $ fromString "moo" + , typedValue = fromString "type1___0___0" + } + ] + , defRetType = PrimType Void + , defAttrs = mempty + , defBody = [] + } + ] + , testCase "internal define name deconflicting" + $ let d1 = Define { defName = fromString "foo" + , defLinkage = Just Internal + , defVisibility = Nothing + , defComdat = Nothing + , defMetadata = mempty + , defGC = Nothing + , defSection = Nothing + , defVarArgs = False + , defArgs = + [ Typed { typedType = Alias $ fromString "moo" + , typedValue = fromString "type1" + } + ] + , defRetType = PrimType $ Integer 8 + , defAttrs = mempty + , defBody = [] + } + d2 = Define { defName = fromString "foo" + , defLinkage = Just Internal + , defVisibility = Nothing + , defComdat = Nothing + , defMetadata = mempty + , defGC = Nothing + , defSection = Nothing + , defVarArgs = False + , defArgs = [] + , defRetType = PrimType Void + , defAttrs = mempty + , defBody = [] + } + llvm1 = emptyModule & modDefinesLens .~ [ d1 ] + llvm2 = emptyModule & modDefinesLens .~ [ d2 ] + llvmAll = llvmModuleCombine llvm1 llvm2 + in do llvmAll ^. modDefinesLens @?= + [ d1 + , d2 & defNameLens .~ fromString "foo_1" + ] + + , testCase "declare to define resolution" + $ let d1 = Declare { decName = fromString "foo" + , decLinkage = Nothing + , decVisibility = Nothing + , decComdat = Nothing + , decVarArgs = False + , decArgs = [ Alias $ fromString "moo" ] + , decRetType = PrimType $ Integer 8 + , decAttrs = mempty + } + d2 = Define { defName = fromString "foo" + , defLinkage = Nothing + , defVisibility = Nothing + , defComdat = Nothing + , defMetadata = mempty + , defGC = Nothing + , defSection = Nothing + , defVarArgs = False + , defArgs = + [ Typed { typedType = Alias $ fromString "cow" + , typedValue = fromString "type1" + } + ] + , defRetType = PrimType $ Integer 8 + , defAttrs = mempty + , defBody = [] + } + llvm1 = emptyModule & modDeclaresLens .~ [ d1 ] + llvm2 = emptyModule & modDefinesLens .~ [ d2 ] + llvmAll = llvmModuleCombine llvm1 llvm2 + in do llvmAll ^. modDefinesLens @?= [ d2 ] + llvmAll ^. modDeclaresLens @?= [] + + ] diff --git a/test/DataLayout.hs b/test/DataLayout.hs new file mode 100644 --- /dev/null +++ b/test/DataLayout.hs @@ -0,0 +1,31 @@ +module DataLayout ( tests ) where + +import Text.LLVM.AST +import Text.LLVM.PP + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + let rspDL s = Just $ "target datalayout = \"" <> s <> "\"" + ppDL = show . ppLLVM llvmVlatest ppDataLayout + in testGroup "Test DataLayout" + [ testCase "datalayout 0" $ ppDL <$> parseDataLayout "" @?= Just "" + , testCase "datalayout 1" + $ let dl = "e" in ppDL <$> parseDataLayout dl @?= rspDL dl + , testCase "datalayout 2" + $ let dl = "e-m:e" in ppDL <$> parseDataLayout dl @?= rspDL dl + , testCase "datalayout 3" + $ let dl = "e-m:e-p270:32:32" + in ppDL <$> parseDataLayout dl @?= rspDL dl + , testCase "datalayout 4" + $ let dl = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-i128:128-f80:128-S128" + in ppDL <$> parseDataLayout dl @?= rspDL dl + , testCase "datalayout 5" + $ let dl = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-i128:128-f80:128-n8:16:32:64-S128" + in ppDL <$> parseDataLayout dl @?= rspDL dl + , testCase "datalayout 6" + $ let dl = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-i128:128-f80:128-n8:16:32:64-ni:3:4-S128" + in ppDL <$> parseDataLayout dl @?= rspDL dl + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,12 +2,18 @@ import qualified Test.Tasty as Tasty -import qualified Triple +import qualified CombineTests +import qualified DataLayout +import qualified Metadata import qualified Output +import qualified Triple main :: IO () main = Tasty.defaultMain $ Tasty.testGroup "LLVM tests" [ - Output.tests + DataLayout.tests + , Metadata.tests + , Output.tests , Triple.tests + , CombineTests.tests ] diff --git a/test/Metadata.hs b/test/Metadata.hs new file mode 100644 --- /dev/null +++ b/test/Metadata.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeApplications #-} + +-- | This module provides some testing of the metadata that can be attached to +-- Statements. + +module Metadata ( tests ) where + +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit + +import Text.LLVM.AST + + +tests :: Tasty.TestTree +tests = Tasty.testGroup "LLVM metadata tests" $ + let s1 = Effect (Load PtrOpaque (Typed Opaque ValNull) Nothing Nothing) + mempty md1 + s2 = Result (Ident "r1") + (Load PtrOpaque (Typed Opaque ValNull) Nothing Nothing) + mempty md1 + md1 = [ ("foo", ValMdLoc $ DebugLoc { dlLine = 12 + , dlCol = 34 + , dlScope = ValMdRef 5 + , dlIA = Nothing + , dlImplicit = True + , dlAtomGroup = 0 + , dlAtomRank = 0 }) + , ("moo", ValMdString @Value "cow") + ] + in + [ + testCase "stmtMetadata Effect" $ stmtMetadata s1 @?= md1 + , testCase "stmtMetadata Result" $ stmtMetadata s2 @?= md1 + ] diff --git a/test/Output.hs b/test/Output.hs --- a/test/Output.hs +++ b/test/Output.hs @@ -32,15 +32,23 @@ -- output are seen. s1, s2 :: Stmt s1 = Effect - (GEP True (Alias (Ident "hi")) (Typed Opaque dcu) []) - [] + (GEP [GEP_Inbounds] (Alias (Ident "hi")) (Typed Opaque dcu) []) + mempty [] s2 = Effect (Load PtrOpaque (Typed Opaque ValNull) Nothing Nothing) + mempty [ ("location", ValMdLoc $ DebugLoc { dlLine = 12 , dlCol = 34 , dlScope = ValMdRef 5 , dlIA = Nothing - , dlImplicit = True }) + , dlImplicit = True + , dlAtomGroup = 0 + , dlAtomRank = 0 }) ] + s3 = Effect + (IndirectBr + (Typed PtrOpaque (ValIdent "addr")) + [Named "hello", Named "world"]) + [] [] dcu :: Value dcu = ValMd $ ValMdDebugInfo @@ -66,6 +74,7 @@ , dicuRangesBaseAddress = True , dicuSysRoot = Just "the root" , dicuSDK = Just "SDK" + , dicuSourceLanguageVersion = 0 } dtt = ValMdDebugInfo $ DebugInfoTemplateTypeParameter @@ -75,10 +84,10 @@ } blk1 = BasicBlock { bbLabel = Just $ Named $ Ident "blk1" , bbStmts = - [ Result (Ident "r1") (Comment "insanity follows...") [] - , Effect (Jump $ Named $ Ident "blk1") [] - , Result (Ident "oh no") RetVoid [] - , Effect (Br (Typed (PrimType Metadata) ValZeroInit) (Anon 3) (Named "oh no")) [] + [ Result (Ident "r1") (Comment "insanity follows...") mempty [] + , Effect (Jump $ Named $ Ident "blk1") mempty [] + , Result (Ident "oh no") RetVoid mempty [] + , Effect (Br (Typed (PrimType Metadata) ValZeroInit) (Anon 3) (Named "oh no")) mempty [] ] } blk2 = BasicBlock { bbLabel = Just $ Anon 123 @@ -167,6 +176,51 @@ ---- |] + , testCase "Stmt 1, LLVM 18" $ + assertEqLines (ppToText $ ppLLVM 18 $ ppStmt s1) [sq| + Significant changes occur in LLVM 19; ensure that the output is as + expected just prior to those changes to properly capture the + inflection point. + ---- + getelementptr inbounds %hi, opaque !DICompileUnit(language: 12, + producer: "llvm-pretty-test", + isOptimized: true, + flags: "some flags", + runtimeVersion: 3, + emissionKind: 1, + enums: !DITemplateTypeParameter(name: ttp), + dwoId: 2, + splitDebugInlining: false, + debugInfoForProfiling: true, + nameTableKind: 4, + rangesBaseAddress: true, + sysroot: "the root", + sdk: "SDK") + ---- + |] + + , testCase "Stmt 1, LLVM 19" $ + assertEqLines (ppToText $ ppLLVM 19 $ ppStmt s1) [sq| + In LLVM 19, the GEP instruction "inbounds" is no longer a boolean + but a flag with multiple possible values (only one is checked here). + ---- + getelementptr inbounds %hi, opaque !DICompileUnit(language: 12, + producer: "llvm-pretty-test", + isOptimized: true, + flags: "some flags", + runtimeVersion: 3, + emissionKind: 1, + enums: !DITemplateTypeParameter(name: ttp), + dwoId: 2, + splitDebugInlining: false, + debugInfoForProfiling: true, + nameTableKind: 4, + rangesBaseAddress: true, + sysroot: "the root", + sdk: "SDK") + ---- + |] + ------------------------------------------------------------ , testCase "Stmt 2, LLVM 3.5" $ @@ -203,6 +257,18 @@ (ppToText $ ppLLVM 10 $ ppStmt s2) ------------------------------------------------------------ + + , testCase "Stmt 3" $ + assertEqLines [sq| + `indirectbr` pretty-printing works as expected (#174) + ---- + indirectbr ptr %addr, [ label %hello, + label %world ] + ---- + |] + (ppToText $ ppLLVM llvmVlatest $ ppStmt s3) + + ------------------------------------------------------------ -- Verify named labels and label targets are emitted correctly , testCase "Blk 1, LLVM 3.5" $ @@ -244,25 +310,85 @@ -------- |] + , testCase "Zero (half float)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValHalf (FPHalf 0x0000))) + "0.0" + + , testCase "One (half float)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValHalf (FPHalf 0x3c00))) + "1.0" + + , testCase "Two (half float)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValHalf (FPHalf 0x4000))) + "2.0" + + , testCase "Positive Infinity (half float)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValHalf (FPHalf 0x7c00))) + "0xH7c00" + + , testCase "Negative Infinity (half float)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValHalf (FPHalf 0xfc00))) + "0xHfc00" + + , testCase "NaN (half float)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValHalf (FPHalf 0x7c55))) + "0xH7c55" + + , testCase "Zero (bfloat)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValBFloat (FPBFloat 0x0000))) + "0.0" + + , testCase "One (bfloat)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValBFloat (FPBFloat 0x3f80))) + "1.0" + + , testCase "Two (bfloat)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValBFloat (FPBFloat 0x4000))) + "2.0" + + , testCase "Positive Infinity (bfloat)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValBFloat (FPBFloat 0x7f80))) + "0xR7f80" + + , testCase "Negative Infinity (bfloat)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValBFloat (FPBFloat 0xff80))) + "0xRff80" + + , testCase "NaN (bfloat)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValBFloat (FPBFloat 0x7f85))) + "0xR7f85" + , testCase "Positive Infinity (float)" $ assertEqLines (ppToText $ ppLLVM37 ppValue (ValFloat (castWord32ToFloat 0x7F800000))) - "0x7f800000" + "0x7ff0000000000000" , testCase "Negative Infinity (float)" $ assertEqLines (ppToText $ ppLLVM37 ppValue (ValFloat (castWord32ToFloat 0xFF800000))) - "0xff800000" + "0xfff0000000000000" , testCase "NaN 1 (float)" $ assertEqLines (ppToText $ ppLLVM37 ppValue (ValFloat (castWord32ToFloat 0x7FC00000))) - "0x7fc00000" + "0x7ff8000000000000" , testCase "NaN 2 (float)" $ assertEqLines (ppToText $ ppLLVM37 ppValue (ValFloat (castWord32ToFloat 0x7FD00000))) - "0x7fd00000" + "0x7ffa000000000000" , testCase "Positive Infinity (double)" $ assertEqLines @@ -283,6 +409,21 @@ assertEqLines (ppToText $ ppLLVM37 ppValue (ValDouble (castWord64ToDouble 0x7FFD000000000000))) "0x7ffd000000000000" + + , testCase "Zero (FP80)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValFP80 (FP80_LongDouble 0x0000 0x0000000000000000))) + "0xK00000000000000000000" + + , testCase "Zero (FP128)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValFP128 (FP128_LongDouble 0x0000000000000000 0x0000000000000000))) + "0xL00000000000000000000000000000000" + + , testCase "Zero (FP128_PPC)" $ + assertEqLines + (ppToText $ ppLLVM37 ppValue (ValFP128_PPC (FP128_PPC_DoubleDouble 0.0 0.0))) + "0xM00000000000000000000000000000000" ]