llvm-pretty 0.14.0.0 → 0.15.0.0

raw patch · 13 files changed

+1366/−55 lines, 13 filesdep +filepathdep +microlens-platformdep ~microlensPVP ok

version bump matches the API change (PVP)

Dependencies added: filepath, microlens-platform

Dependency ranges changed: microlens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +43/−1
• README.md +6/−1
• llvm-pretty.cabal +9/−2
• src/Text/LLVM.hs +38/−6
• src/Text/LLVM/AST.hs +172/−11
• src/Text/LLVM/Combine.hs +217/−0
• src/Text/LLVM/DebugUtils.hs +136/−5
• src/Text/LLVM/Labels.hs +3/−0
• src/Text/LLVM/Lens.hs +2/−0
• src/Text/LLVM/PP.hs +427/−25
• test/CombineTests.hs +231/−0
• test/Main.hs +2/−0
• test/Output.hs +80/−4

@@ -1,6 +1,48 @@ # Revision history for llvm-pretty -## 0.14.0.0 -- 2026-01-22+## 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:

@@ -7,7 +7,12 @@  ## LLVM language feature support -Currently, `llvm-pretty` supports LLVM versions up through 17. As a result of+<!--+If you update the latest LLVM version mentioned below, make sure to also update+the definition of `llvmVlatest` in `Text.LLVM.PP`.+-->++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

@@ -1,6 +1,7 @@ Cabal-version:       2.2 Name:                llvm-pretty-Version:             0.14.0.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==9.12.3, GHC==9.10.1, GHC==9.8.4+tested-with:         GHC==9.12.2, GHC==9.10.1, GHC==9.8.4 extra-doc-files:     CHANGELOG.md, README.md  @@ -38,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@@ -49,11 +51,14 @@    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.8@@ -63,6 +68,7 @@   Type: exitcode-stdio-1.0   Main-is: Main.hs   Other-modules:+    CombineTests     DataLayout     Metadata     Output@@ -74,6 +80,7 @@   Build-depends:     llvm-pretty,     base,+    microlens,     pretty,     tasty,     tasty-hunit,

@@ -141,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@@ -152,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 ()

@@ -10,6 +10,8 @@ not yet represented here. -} +{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-}@@ -25,7 +27,9 @@     -- * Named Metadata   , NamedMd(..)     -- * Unnamed Metadata-  , UnnamedMd(..)+  , UnnamedMd(..), UnnamedMdIdx(UnnamedMdIdx, unnamedMdIdx)+  , nonNullUnnamedMdIdx+  , nextUnnamedMdIdx     -- * Aliases   , GlobalAlias(..)     -- * Data Layout@@ -125,7 +129,11 @@   , FCmpOp(..)     -- * Values   , Value'(..), Value+  , FPHalfValue(..)+  , FPBFloatValue(..)   , FP80Value(..)+  , FP128Value(..)+  , FP128_PPCValue(..)   , ValMd'(..), ValMd   , KindMd   , FnMdAttachments@@ -163,6 +171,8 @@   , DICompileUnit'(..), DICompileUnit   , DICompositeType'(..), DICompositeType   , DIDerivedType'(..), DIDerivedType+  , DIFixedPointType'(..), DIFixedPointType+  , DIFixedPointKind'(..), DIFixedPointKind   , DIExpression(..)   , DIFile(..)   , DIGlobalVariable'(..), DIGlobalVariable@@ -172,6 +182,7 @@   , DILocalVariable'(..), DILocalVariable   , DISubprogram'(..), DISubprogram   , DISubrange'(..), DISubrange+  , DISubrangeType'(..), DISubrangeType   , DISubroutineType'(..), DISubroutineType   , DIArgList'(..), DIArgList   , dwarf_DW_APPLE_ENUM_KIND_invalid@@ -233,7 +244,12 @@   } 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@@ -249,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@@ -274,14 +294,43 @@  data NamedMd = NamedMd   { nmName   :: String-  , nmValues :: [Int]+  , 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)@@ -507,6 +556,7 @@  data FloatType   = Half+  | BFloat -- ^ Introduced in LLVM 11   | Float   | Double   | Fp128@@ -713,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)@@ -910,22 +963,47 @@  -- 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)@@ -1538,9 +1616,13 @@ 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@@ -1560,13 +1642,36 @@  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)+    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)@@ -1593,9 +1698,13 @@ 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@@ -1764,6 +1873,8 @@   | DebugInfoLabel (DILabel' lab)   | DebugInfoArgList (DIArgList' lab)   | DebugInfoAssignID -- ^ Introduced in LLVM 17.+  | DebugInfoSubrangeType (DISubrangeType' lab)+  | DebugInfoFixedPointType (DIFixedPointType' lab)     deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show)  type DebugInfo = DebugInfo' BlockLabel@@ -1843,10 +1954,28 @@   , dibtEncoding :: DwarfAttrEncoding   , dibtFlags    :: Maybe DIFlags   , 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)@@ -1870,6 +1999,8 @@   , dicuRangesBaseAddress  :: Bool   , dicuSysRoot            :: Maybe String   , dicuSDK                :: Maybe String+  , dicuSourceLanguageVersion :: Word32+    -- ^ added in LLVM 22   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show)  type DICompileUnit = DICompileUnit' BlockLabel@@ -1946,6 +2077,36 @@   } 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]

@@ -0,0 +1,217 @@+{-# LANGUAGE LambdaCase #-}++{- |+Module      : Text.LLVM.Combine+Description : Combine LLVM Modules+License     : BSD3+Maintainer  : Kevin Quick <kquick@galois.com>+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))

@@ -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 @@ -461,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)@@ -514,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

@@ -136,6 +136,7 @@ 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')@@ -144,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')

@@ -32,6 +32,8 @@     , ''DIFile     , ''DISubrange'     , ''DIBasicType'+    , ''DISubrangeType'+    , ''DIFixedPointType'     , ''DIExpression     , ''DISubprogram'     , ''DISubroutineType'

@@ -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, 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 = 19-+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"@@ -310,6 +466,7 @@  ppFloatType :: Fmt FloatType ppFloatType Half      = "half"+ppFloatType BFloat    = "bfloat" ppFloatType Float     = "float" ppFloatType Double    = "double" ppFloatType Fp128     = "fp128"@@ -404,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@@ -473,6 +633,39 @@               $+$ 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@@ -865,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) ->@@ -885,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"@@ -911,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@@ -1072,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@@ -1209,7 +1489,7 @@  ppDIBasicType' :: Fmt i -> Fmt (DIBasicType' i) ppDIBasicType' pp bt = "!DIBasicType"-  <> parens (mcommas+  <> parens (mcommas $        [ pure ("tag:"      <+> integral (dibtTag bt))        , pure ("name:"     <+> doubleQuotes (text (dibtName bt)))        ,     (("size:"     <+>) . ppSizeOrOffsetValMd' pp) <$> dibtSize bt@@ -1220,8 +1500,35 @@        , 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 $@@ -1254,6 +1561,12 @@        ,     (("sdk:"                   <+>) . doubleQuotes . text)              <$> (dicuSDK cu)        ]+       +++       when' (llvmVer >= 22)+       [ if dicuSourceLanguageVersion cu > 0+         then pure ("sourceLanguageVersion:" <+> integral (dicuSourceLanguageVersion cu))+         else Nothing+       ]        )  @@ -1325,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)))@@ -1480,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@@ -1512,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

@@ -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 @?= []++  ]

@@ -2,6 +2,7 @@  import qualified Test.Tasty as Tasty +import qualified CombineTests import qualified DataLayout import qualified Metadata import qualified Output@@ -14,4 +15,5 @@        , Metadata.tests        , Output.tests        , Triple.tests+       , CombineTests.tests        ]

@@ -74,6 +74,7 @@                               , dicuRangesBaseAddress = True                               , dicuSysRoot = Just "the root"                               , dicuSDK = Just "SDK"+                              , dicuSourceLanguageVersion = 0                               }         dtt = ValMdDebugInfo               $ DebugInfoTemplateTypeParameter@@ -309,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@@ -348,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"    ]