llvm-pretty 0.11.0 → 0.12.0.0

raw patch · 20 files changed

+3113/−415 lines, 20 filesdep +llvm-prettydep +sybdep +tastydep ~basedep ~prettydep ~template-haskellnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: llvm-pretty, syb, tasty, tasty-hunit, text

Dependency ranges changed: base, pretty, template-haskell, th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +36/−0
• llvm-pretty.cabal +40/−9
• src/Text/LLVM.hs +41/−48
• src/Text/LLVM/AST.hs +457/−68
• src/Text/LLVM/DebugUtils.hs +227/−45
• src/Text/LLVM/Labels.hs +17/−14
• src/Text/LLVM/Lens.hs +2/−1
• src/Text/LLVM/PP.hs +407/−230
• src/Text/LLVM/Parser.hs +1/−0
• src/Text/LLVM/Triple.hs +17/−0
• src/Text/LLVM/Triple/AST.hs +467/−0
• src/Text/LLVM/Triple/Parse.hs +294/−0
• src/Text/LLVM/Triple/Parse/ARM.hs +347/−0
• src/Text/LLVM/Triple/Parse/LookupTable.hs +77/−0
• src/Text/LLVM/Triple/Print.hs +229/−0
• test/Main.hs +13/−0
• test/Output.hs +302/−0
• test/TQQDefs.hs +62/−0
• test/Triple.hs +72/−0

@@ -0,0 +1,5 @@+# Revision history for llvm-pretty++## 0.12.0.0 (January 2024)++* Add preliminary support for LLVM versions up through 17.

@@ -0,0 +1,36 @@+# `llvm-pretty`++A pretty printing library that was inspired by the LLVM binding by Lennart+Augustsson. The library provides a monadic interface to a pretty printer, that+allows functions to be defined and called, generating the corresponding LLVM+assembly when run.++## LLVM language feature support++Currently, `llvm-pretty` supports LLVM versions up through 17. As a result of+the broad version coverage, the `llvm-pretty` AST is a superset of all versions+of the LLVM AST. This means that the manner in which certain information is+presented in the `llvm-pretty` AST (e.g., during pretty printing) will be+different depending on the LLVM version used to originate the information.+Conversely, it is possible to construct an `llvm-pretty` AST that cannot be+represented in a specific (or any) LLVM version.++`llvm-pretty` strives to support a reasonable variety of [LLVM language+features](https://llvm.org/docs/LangRef.html), but there are places where our+coverage of the LLVM language is incomplete. If you need a LLVM feature that is+not currently supported by `llvm-pretty`, please [file an+issue](https://github.com/elliottt/llvm-pretty/issues/new).++## `llvm-pretty` versus `llvm-pretty-bc-parser`++`llvm-pretty` supports almost everything that one would want to do with LLVM+ASTs. One notable exception is parsing: `llvm-pretty` deliberately does not+support parsing an LLVM module AST from a bitcode file. This functionality is+factored out into a separate+[`llvm-pretty-bc-parser`](https://github.com/GaloisInc/llvm-pretty-bc-parser)+library. `llvm-pretty-bc-parser` generally tries to stay in sync with all of+the LLVM language features that `llvm-pretty` supports, but it may be the case+that some valid `llvm-pretty` ASTs cannot be parsed by `llvm-pretty-bc-parser`.+If you encounter an occurrence of this issue, please [file an+issue](https://github.com/GaloisInc/llvm-pretty-bc-parser/issues/new) at the+`llvm-pretty-bc-parser` issue tracker.

@@ -1,12 +1,12 @@+Cabal-version:       2.2 Name:                llvm-pretty-Version:             0.11.0-License:             BSD3+Version:             0.12.0.0+License:             BSD-3-Clause License-file:        LICENSE Author:              Trevor Elliott-Maintainer:          awesomelyawesome@gmail.com+Maintainer:          rscott@galois.com, kquick@galois.com Category:            Text Build-type:          Simple-Cabal-version:       >=1.16 Synopsis:            A pretty printing library inspired by the llvm binding. Description:   A pretty printing library that was inspired by the LLVM binding by Lennart@@ -14,15 +14,21 @@   that allows functions to be defined and called, generating the corresponding   LLVM assembly when run. tested-with:         GHC==8.4.3, GHC==8.2.2, GHC==8.0.2+extra-doc-files:     CHANGELOG.md, README.md   source-repository head   type:                 git   location:             http://github.com/elliottt/llvm-pretty -Library+common common   Default-language:    Haskell2010+  Ghc-options:+    -Wall +Library+  Import:              common+   Hs-source-dirs:      src   Exposed-modules:     Text.LLVM                        Text.LLVM.AST@@ -32,16 +38,41 @@                        Text.LLVM.Parser                        Text.LLVM.PP                        Text.LLVM.DebugUtils-  Other-modules:       Text.LLVM.Util+                       Text.LLVM.Triple+                       Text.LLVM.Triple.AST+                       Text.LLVM.Triple.Parse+                       Text.LLVM.Triple.Print+  Other-modules:       Text.LLVM.Triple.Parse.ARM+                       Text.LLVM.Triple.Parse.LookupTable+                       Text.LLVM.Util -  Build-depends:       base             >= 4 && < 5,+  Build-depends:       base             >= 4.9 && < 5,                        containers       >= 0.4,                        parsec           >= 3,                        pretty           >= 1.0.1,                        monadLib         >= 3.6.1,                        microlens        >= 0.4,                        microlens-th     >= 0.4,+                       syb              >= 0.7,                        template-haskell >= 2.7,-                       th-abstraction   >= 0.3.1 && <0.4+                       th-abstraction   >= 0.3.1 && <0.7 -  Ghc-options:         -Wall+Test-suite llvm-pretty-test+  Import: common+  Type: exitcode-stdio-1.0+  Main-is: Main.hs+  Other-modules:+    Output+    Triple+    TQQDefs+  Hs-source-dirs: test+  Ghc-options:+    -threaded+  Build-depends:+    llvm-pretty,+    base,+    pretty,+    tasty,+    tasty-hunit,+    template-haskell,+    text

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeOperators #-}@@ -7,11 +6,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances #-}--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif- module Text.LLVM (     -- * LLVM Monad     LLVM()@@ -120,11 +114,7 @@ import qualified Data.Sequence as Seq import qualified Data.Map.Strict as Map -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative ( Applicative )-#endif - -- Fresh Names -----------------------------------------------------------------  type Names = Map.Map String Int@@ -189,12 +179,14 @@ -- | Emit a declaration. declare :: Type -> Symbol -> [Type] -> Bool -> LLVM (Typed Value) declare rty sym tys va = emitDeclare Declare-  { decRetType = rty-  , decName    = sym-  , decArgs    = tys-  , decVarArgs = va-  , decAttrs   = []-  , decComdat  = Nothing+  { decLinkage    = Nothing+  , decVisibility = Nothing+  , decRetType    = rty+  , decName       = sym+  , decArgs       = tys+  , decVarArgs    = va+  , decAttrs      = []+  , decComdat     = Nothing   }  -- | Emit a global declaration.@@ -222,14 +214,16 @@ -- Function Definition ---------------------------------------------------------  data FunAttrs = FunAttrs-  { funLinkage :: Maybe Linkage-  , funGC      :: Maybe GC+  { funLinkage    :: Maybe Linkage+  , funVisibility :: Maybe Visibility+  , funGC         :: Maybe GC   } deriving (Show)  emptyFunAttrs :: FunAttrs emptyFunAttrs  = FunAttrs-  { funLinkage = Nothing-  , funGC      = Nothing+  { funLinkage    = Nothing+  , funVisibility = Nothing+  , funGC         = Nothing   }  @@ -273,17 +267,18 @@ define attrs rty fun sig k = do   (args,body) <- defineBody [] sig k   emitDefine Define-    { defLinkage  = funLinkage attrs-    , defName     = fun-    , defRetType  = rty-    , defArgs     = args-    , defVarArgs  = False-    , defAttrs    = []-    , defSection  = Nothing-    , defGC       = funGC attrs-    , defBody     = body-    , defMetadata = Map.empty-    , defComdat  = Nothing+    { defLinkage    = funLinkage attrs+    , defVisibility = funVisibility attrs+    , defName       = fun+    , defRetType    = rty+    , defArgs       = args+    , defVarArgs    = False+    , defAttrs      = []+    , defSection    = Nothing+    , defGC         = funGC attrs+    , defBody       = body+    , defMetadata   = Map.empty+    , defComdat     = Nothing     }  -- | A combination of define and @freshSymbol@.@@ -301,17 +296,18 @@ define' attrs rty sym sig va k = do   args <- mapM freshArg sig   emitDefine Define-    { defLinkage  = funLinkage attrs-    , defName     = sym-    , defRetType  = rty-    , defArgs     = args-    , defVarArgs  = va-    , defAttrs    = []-    , defSection  = Nothing-    , defGC       = funGC attrs-    , defBody     = snd (runBB (k (map (fmap toValue) args)))-    , defMetadata = Map.empty-    , defComdat   = Nothing+    { defLinkage    = funLinkage attrs+    , defVisibility = funVisibility attrs+    , defName       = sym+    , defRetType    = rty+    , defArgs       = args+    , defVarArgs    = va+    , defAttrs      = []+    , defSection    = Nothing+    , defGC         = funGC attrs+    , defBody       = snd (runBB (k (map (fmap toValue) args)))+    , defMetadata   = Map.empty+    , defComdat     = Nothing     }  -- Basic Block Monad -----------------------------------------------------------@@ -626,11 +622,8 @@   where   es = fmap toValue `fmap` mb -load :: IsValue a => Typed a -> Maybe Align -> BB (Typed Value)-load tv ma =-  case typedType tv of-    PtrTo ty -> observe ty (Load (toValue `fmap` tv) Nothing ma)-    _        -> error "load not given a pointer"+load :: IsValue a => Type -> Typed a -> Maybe Align -> BB (Typed Value)+load ty ptr ma = observe ty (Load ty (toValue `fmap` ptr) Nothing ma)  store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB () store a ptr ma =@@ -702,7 +695,7 @@  getelementptr :: IsValue a               => Type -> Typed a -> [Typed Value] -> BB (Typed Value)-getelementptr ty ptr ixs = observe ty (GEP False (toValue `fmap` ptr) ixs)+getelementptr ty ptr ixs = observe ty (GEP False ty (toValue `fmap` ptr) ixs)  -- | Emit a call instruction, and generate a new variable for its result. call :: IsValue a => Typed a -> [Typed Value] -> BB (Typed Value)

@@ -1,15 +1,165 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-}--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif--module Text.LLVM.AST where+{-# LANGUAGE DeriveLift #-}+module Text.LLVM.AST+  ( -- * Modules+    Module(..)+  , emptyModule+    -- * Named Metadata+  , NamedMd(..)+    -- * Unnamed Metadata+  , UnnamedMd(..)+    -- * Aliases+  , GlobalAlias(..)+    -- * Data Layout+  , DataLayout+  , LayoutSpec(..)+  , Mangling(..)+  , parseDataLayout+    -- * Inline Assembly+  , InlineAsm+    -- * Comdat+  , SelectionKind(..)+    -- * Identifiers+  , Ident(..)+    -- * Symbols+  , Symbol(..)+    -- * Types+  , PrimType(..)+  , FloatType(..)+  , Type, Type'(..)+  , updateAliasesA, updateAliases+  , isFloatingPoint+  , isAlias+  , isPrimTypeOf+  , isLabel+  , isInteger+  , isVector+  , isVectorOf+  , isArray+  , isPointer+  , eqTypeModuloOpaquePtrs+  , cmpTypeModuloOpaquePtrs+  , fixupOpaquePtrs+    -- * Null values+  , NullResult(..)+  , primTypeNull+  , floatTypeNull+  , typeNull+    -- * Type Elimination+  , elimFunTy+  , elimAlias+  , elimPtrTo+  , elimVector+  , elimArray+  , elimFunPtr+  , elimPrimType+  , elimFloatType+  , elimSequentialType+    -- * Top-level Type Aliases+  , TypeDecl(..)+    -- * Globals+  , Global(..)+  , addGlobal+  , GlobalAttrs(..)+  , emptyGlobalAttrs+    -- * Declarations+  , Declare(..)+  , decFunType+    -- * Function Definitions+  , Define(..)+  , defFunType, addDefine+    -- * Function Attributes and attribute groups+  , FunAttr(..)+    -- * Basic Block Labels+  , BlockLabel(..)+    -- * Basic Blocks+  , BasicBlock'(..), BasicBlock+  , brTargets+    -- * Attributes+  , Linkage(..)+  , Visibility(..)+  , GC(..)+    -- * Typed Things+  , Typed(..)+  , mapMTyped+    -- * Instructions+  , ArithOp(..)+  , isIArith+  , isFArith+  , UnaryArithOp(..)+  , BitOp(..)+  , ConvOp(..)+  , AtomicRWOp(..)+  , AtomicOrdering(..)+  , Align+  , Instr'(..), Instr+  , Clause'(..), Clause+  , isTerminator+  , isComment+  , isPhi+  , ICmpOp(..)+  , FCmpOp(..)+    -- * Values+  , Value'(..), Value+  , FP80Value(..)+  , ValMd'(..), ValMd+  , KindMd+  , FnMdAttachments+  , GlobalMdAttachments+  , DebugLoc'(..), DebugLoc+  , isConst+    -- * Value Elimination+  , elimValSymbol+  , elimValInteger+    -- * Statements+  , Stmt'(..), Stmt+  , stmtInstr+  , stmtMetadata+  , extendMetadata+    -- * Constant Expressions+  , ConstExpr'(..), ConstExpr+    -- * DWARF Debug Info+  , DebugInfo'(..), DebugInfo+  , DILabel, DILabel'(..)+  , DIImportedEntity, DIImportedEntity'(..)+  , DITemplateTypeParameter, DITemplateTypeParameter'(..)+  , DITemplateValueParameter, DITemplateValueParameter'(..)+  , DINameSpace, DINameSpace'(..)+  , DwarfAttrEncoding+  , DwarfLang+  , DwarfTag+  , DwarfVirtuality+  , DIFlags+  , DIEmissionKind+  , DIBasicType(..)+  , DICompileUnit'(..), DICompileUnit+  , DICompositeType'(..), DICompositeType+  , DIDerivedType'(..), DIDerivedType+  , DIExpression(..)+  , DIFile(..)+  , DIGlobalVariable'(..), DIGlobalVariable+  , DIGlobalVariableExpression'(..), DIGlobalVariableExpression+  , DILexicalBlock'(..), DILexicalBlock+  , DILexicalBlockFile'(..), DILexicalBlockFile+  , DILocalVariable'(..), DILocalVariable+  , DISubprogram'(..), DISubprogram+  , DISubrange'(..), DISubrange+  , DISubroutineType'(..), DISubroutineType+  , DIArgList'(..), DIArgList+    -- * Aggregate Utilities+  , IndexResult(..)+  , isInvalid+  , resolveGepFull+  , resolveGep+  , resolveGepBody+  , isGepIndex+  , isGepStructIndex+  , resolveValueIndex+  ) where  import Data.Functor.Identity (Identity(..)) import Data.Coerce (coerce)@@ -17,28 +167,27 @@ import Data.Typeable (Typeable) import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) import Data.Int (Int32,Int64)+import Data.Generics (everywhere, extQ, mkT, something) import Data.List (genericIndex,genericLength) import qualified Data.Map as Map+import Data.Maybe (isJust) import Data.Semigroup as Sem import Data.String (IsString(fromString)) import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic, Generic1)+import Language.Haskell.TH.Syntax (Lift)  import Text.Parsec import Text.Parsec.String -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative ((<$))-import Data.Foldable (Foldable(foldMap))-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(sequenceA))-#endif+import Text.LLVM.Triple.AST (TargetTriple)   -- Modules ---------------------------------------------------------------------  data Module = Module   { modSourceName :: Maybe String+  , modTriple     :: TargetTriple  -- ^ target triple   , modDataLayout :: DataLayout    -- ^ type size and alignment information   , modTypes      :: [TypeDecl]    -- ^ top-level type aliases   , modNamedMd    :: [NamedMd]@@ -51,9 +200,11 @@   , modAliases    :: [GlobalAlias]   } deriving (Data, Eq, Ord, Generic, Show, Typeable) +-- | Combines fields pointwise. instance Sem.Semigroup Module where   m1 <> m2 = Module     { modSourceName = modSourceName m1 `mplus`   modSourceName m2+    , modTriple     = modTriple m1     <> modTriple     m2     , modDataLayout = modDataLayout m1 <> modDataLayout m2     , modTypes      = modTypes      m1 <> modTypes      m2     , modUnnamedMd  = modUnnamedMd  m1 <> modUnnamedMd  m2@@ -68,11 +219,12 @@  instance Monoid Module where   mempty = emptyModule-  mappend m1 m2 = m1 <> m2+  mappend = (<>)  emptyModule :: Module emptyModule  = Module   { modSourceName = mempty+  , modTriple     = mempty   , modDataLayout = mempty   , modTypes      = mempty   , modNamedMd    = mempty@@ -106,9 +258,11 @@ -- Aliases ---------------------------------------------------------------------  data GlobalAlias = GlobalAlias-  { aliasName   :: Symbol-  , aliasType   :: Type-  , aliasTarget :: Value+  { aliasLinkage    :: Maybe Linkage+  , aliasVisibility :: Maybe Visibility+  , aliasName       :: Symbol+  , aliasType       :: Type+  , aliasTarget     :: Value   } deriving (Data, Eq, Generic, Ord, Show, Typeable)  @@ -215,7 +369,7 @@ -- Identifiers -----------------------------------------------------------------  newtype Ident = Ident String-    deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift)  instance IsString Ident where   fromString = Ident@@ -223,7 +377,7 @@ -- Symbols ---------------------------------------------------------------------  newtype Symbol = Symbol String-    deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift)  instance Sem.Semigroup Symbol where   Symbol a <> Symbol b = Symbol (a <> b)@@ -244,7 +398,7 @@   | FloatType FloatType   | X86mmx   | Metadata-    deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable, Lift)  data FloatType   = Half@@ -253,7 +407,7 @@   | Fp128   | X86_fp80   | PPC_fp128-    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable, Lift)  type Type = Type' Ident @@ -263,10 +417,32 @@   | Array Word64 (Type' ident)   | FunTy (Type' ident) [Type' ident] Bool   | PtrTo (Type' ident)+    -- ^ A pointer to a memory location of a particular type. See also+    -- 'PtrOpaque', which represents a pointer without a pointee type.+    --+    -- LLVM pointers can also have an optional address space attribute, but this+    -- is not currently represented in the @llvm-pretty@ AST.+  | PtrOpaque+    -- ^ A pointer to a memory location. Unlike 'PtrTo', a 'PtrOpaque' does not+    -- have a pointee type. Instead, instructions interacting through opaque+    -- pointers specify the type of the underlying memory they are interacting+    -- with.+    --+    -- LLVM pointers can also have an optional address space attribute, but this+    -- is not currently represented in the @llvm-pretty@ AST.+    --+    -- 'PtrOpaque' should not be confused with 'Opaque', which is a completely+    -- separate type with a similar-sounding name.   | Struct [Type' ident]   | PackedStruct [Type' ident]   | Vector Word64 (Type' ident)   | Opaque+    -- ^ An opaque structure type, used to represent structure types that do not+    -- have a body specified. This is similar to C's notion of a+    -- forward-declared structure.+    --+    -- 'Opaque' should not be confused with 'PtrOpaque', which is a completely+    -- separate type with a similar-sounding name.     deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  -- | Applicatively traverse a type, updating or removing aliases.@@ -277,6 +453,7 @@     Array len ety    -> Array len    <$> (loop ety)     FunTy res ps var -> FunTy        <$> (loop res) <*> (traverse loop ps) <*> pure var     PtrTo pty        -> PtrTo        <$> (loop pty)+    PtrOpaque        -> pure PtrOpaque     Struct fs        -> Struct       <$> (traverse loop fs)     PackedStruct fs  -> PackedStruct <$> (traverse loop fs)     Vector len ety   -> Vector       <$> pure len <*> (loop ety)@@ -323,9 +500,100 @@  isPointer :: Type -> Bool isPointer (PtrTo _) = True+isPointer PtrOpaque = True isPointer _         = False  +-- | Like `Type'`, but where the 'PtrTo' and 'PtrOpaque' constructors have been+-- collapsed into a single 'PtrView' constructor. This provides a coarser notion+-- of type equality than what `Type'` provides, which distinguishes the two+-- types of pointers.+--+-- `TypeView'` is not used directly in any of the other AST types. Instead, it+-- is used only as an internal data type to power the 'eqTypeModuloOpaquePtrs'+-- and 'cmpTypeModuloOpaquePtrs' functions.+data TypeView' ident+  = PrimTypeView PrimType+  | AliasView ident+  | ArrayView Word64 (TypeView' ident)+  | FunTyView (TypeView' ident) [TypeView' ident] Bool+  | PtrView+    -- ^ The sole pointer type. Both 'PtrTo' and 'PtrOpaque' are mapped to+    -- 'PtrView'.+  | StructView [TypeView' ident]+  | PackedStructView [TypeView' ident]+  | VectorView Word64 (TypeView' ident)+  | OpaqueView+    -- ^ An opaque structure type, used to represent structure types that do not+    -- forward-declared structure.+    --+    -- 'OpaqueView' should not be confused with opaque pointers, which are+    -- mapped to 'PtrView'.+    deriving (Eq, Ord)++-- | Convert a `Type'` value to a `TypeView'` value.+typeView :: Type' ident -> TypeView' ident+-- The two most important cases. Both forms of pointers are mapped to PtrView.+typeView (PtrTo _)           = PtrView+typeView PtrOpaque           = PtrView+-- All other cases are straightforward.+typeView (PrimType pt)       = PrimTypeView pt+typeView (Alias lab)         = AliasView lab+typeView (Array len et)      = ArrayView len (typeView et)+typeView (FunTy ret args va) = FunTyView (typeView ret) (map typeView args) va+typeView (Struct fs)         = StructView (map typeView fs)+typeView (PackedStruct fs)   = PackedStructView (map typeView fs)+typeView (Vector len et)     = VectorView len (typeView et)+typeView Opaque              = OpaqueView++-- | Check two 'Type's for equality, but treat 'PtrOpaque' types as being equal+-- to @'PtrTo' ty@ types (for any type @ty@). This is a coarser notion of+-- equality than what is provided by the 'Eq' instance for 'Type'.+eqTypeModuloOpaquePtrs :: Eq ident => Type' ident -> Type' ident -> Bool+eqTypeModuloOpaquePtrs x y = typeView x == typeView y++-- | Compare two 'Type's, but treat 'PtrOpaque' types as being equal to+-- @'PtrTo' ty@ types (for any type @ty@). This is a coarser notion of ordering+-- than what is provided by the 'Ord' instance for 'Type'.+cmpTypeModuloOpaquePtrs :: Ord ident => Type' ident -> Type' ident -> Ordering+cmpTypeModuloOpaquePtrs x y = typeView x `compare` typeView y++-- | Ensure that if there are any occurrences of opaque pointers, then all+-- non-opaque pointers are converted to opaque ones.+--+-- This is useful because LLVM tools like @llvm-as@ are stricter than+-- @llvm-pretty@ in that the former forbids mixing opaque and non-opaque+-- pointers, whereas the latter allows this. As a result, the result of+-- pretty-printing an @llvm-pretty@ AST might not be suitable for @llvm-as@'s+-- needs unless you first call this function to ensure that the two types of+-- pointers are not intermixed.+--+-- This is implemented using "Data.Data" combinators under the hood, which could+-- potentially require a full traversal of the AST. Because of the performance+-- implications of this, we do not call 'fixupOpaquePtrs' in @llvm-pretty@'s+-- pretty-printer. If you wish to combine opaque and non-opaque pointers in your+-- AST, the burden is on you to call this function before pretty-printing.+fixupOpaquePtrs :: Data a => a -> a+fixupOpaquePtrs m+    | isJust (gfind isOpaquePtr m)+    = everywhere (mkT opaquifyPtr) m+    | otherwise+    = m+  where+    isOpaquePtr :: Type -> Bool+    isOpaquePtr PtrOpaque = True+    isOpaquePtr _         = False++    opaquifyPtr :: Type -> Type+    opaquifyPtr (PtrTo _) = PtrOpaque+    opaquifyPtr t         = t++    -- Find the first occurrence of a @b@ value within the @a@ value that+    -- satisfies the predicate and return it with 'Just'. Return 'Nothing' if there+    -- are no such occurrences.+    gfind :: (Data a, Typeable b) => (b -> Bool) -> a -> Maybe b+    gfind p = something (const Nothing `extQ` \x -> if p x then Just x else Nothing)+ -- Null Values -----------------------------------------------------------------  data NullResult lab@@ -348,6 +616,7 @@ typeNull :: Type -> NullResult lab typeNull (PrimType pt) = HasNull (primTypeNull pt) typeNull PtrTo{}       = HasNull ValNull+typeNull PtrOpaque     = HasNull ValNull typeNull (Alias i)     = ResolveNull i typeNull _             = HasNull ValZeroInit @@ -432,12 +701,14 @@ -- Declarations ----------------------------------------------------------------  data Declare = Declare-  { decRetType :: Type-  , decName    :: Symbol-  , decArgs    :: [Type]-  , decVarArgs :: Bool-  , decAttrs   :: [FunAttr]-  , decComdat  :: Maybe String+  { decLinkage    :: Maybe Linkage+  , decVisibility :: Maybe Visibility+  , decRetType    :: Type+  , decName       :: Symbol+  , decArgs       :: [Type]+  , decVarArgs    :: Bool+  , decAttrs      :: [FunAttr]+  , decComdat     :: Maybe String   } deriving (Data, Eq, Generic, Ord, Show, Typeable)  -- | The function type of this declaration@@ -448,17 +719,18 @@ -- Function Definitions --------------------------------------------------------  data Define = Define-  { defLinkage  :: Maybe Linkage-  , defRetType  :: Type-  , defName     :: Symbol-  , defArgs     :: [Typed Ident]-  , defVarArgs  :: Bool-  , defAttrs    :: [FunAttr]-  , defSection  :: Maybe String-  , defGC       :: Maybe GC-  , defBody     :: [BasicBlock]-  , defMetadata :: FnMdAttachments-  , defComdat   :: Maybe String+  { defLinkage    :: Maybe Linkage+  , defVisibility :: Maybe Visibility+  , defRetType    :: Type+  , defName       :: Symbol+  , defArgs       :: [Typed Ident]+  , defVarArgs    :: Bool+  , defAttrs      :: [FunAttr]+  , defSection    :: Maybe String+  , defGC         :: Maybe GC+  , defBody       :: [BasicBlock]+  , defMetadata   :: FnMdAttachments+  , defComdat     :: Maybe String   } deriving (Data, Eq, Generic, Ord, Show, Typeable)  defFunType :: Define -> Type@@ -652,6 +924,11 @@ isFArith :: ArithOp -> Bool isFArith  = not . isIArith +data UnaryArithOp+  = FNeg+    -- ^ Floating point negation.+    deriving (Data, Eq, Generic, Ord, Show, Typeable)+ -- | Binary bitwise operators. data BitOp   = Shl Bool Bool@@ -744,6 +1021,11 @@          * Middle of basic block.          * The result is the same as parameters. -} +  | UnaryArith UnaryArithOp (Typed (Value' lab))+    {- ^ * Unary arithmetic operation.+         * Middle of basic block.+         * The result is the same as the parameter. -}+   | Bit BitOp (Typed (Value' lab)) (Value' lab)     {- ^ * Binary bit-vector operation, both operands have the same type.          * Middle of basic block.@@ -760,6 +1042,17 @@          * Middle of basic block.          * The result is as indicated by the provided type. -} +  | CallBr Type (Value' lab) [Typed (Value' lab)] lab [lab]+    {- ^ * Call a function in asm-goto style:+             return type;+             function operand;+             arguments;+             default basic block destination;+             other basic block destinations.+         * Middle of basic block.+         * The result is as indicated by the provided type.+         * Introduced in LLVM 9. -}+   | Alloca Type (Maybe (Typed (Value' lab))) (Maybe Int)     {- ^ * Allocated space on the stack:            type of elements;@@ -768,8 +1061,9 @@          * Middle of basic block.          * Returns a pointer to hold the given number of elements. -} -  | Load (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align)+  | Load Type (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align)     {- ^ * Read a value from the given address:+           type being loaded;            address to read from;            atomic ordering;            assumptions about alignment of the given pointer.@@ -834,10 +1128,11 @@          * Middle of basic block.          * Returns a value of the specified type. -} -  | GEP Bool (Typed (Value' lab)) [Typed (Value' lab)]+  | GEP Bool Type (Typed (Value' lab)) [Typed (Value' lab)]     {- ^ * "Get element pointer",             compute the address of a field in a structure:             inbounds check (value poisoned if this fails);+            type to use as a basis for calculations;             pointer to parent structure;             path to a sub-component of a structure.          * Middle of basic block.@@ -918,6 +1213,10 @@    | Resume (Typed (Value' lab)) +  | Freeze (Typed (Value' lab))+    {- ^ * Used to stop propagation of @undef@ and @poison@ values.+         * Middle of basic block. -}+     deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)  type Instr = Instr' BlockLabel@@ -935,6 +1234,7 @@   Ret{}        -> True   RetVoid      -> True   Jump{}       -> True+  CallBr{}     -> True   Br{}         -> True   Unreachable  -> True   Unwind       -> True@@ -985,6 +1285,7 @@   | ValZeroInit   | ValAsm Bool Bool String String   | ValMd (ValMd' lab)+  | ValPoison     deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type Value = Value' BlockLabel@@ -1065,14 +1366,18 @@ -- Constant Expressions --------------------------------------------------------  data ConstExpr' lab-  = ConstGEP Bool (Maybe Word64) (Maybe Type) [Typed (Value' lab)]-  -- ^ Element type introduced in LLVM 3.7+  = ConstGEP Bool (Maybe Word64) Type (Typed (Value' lab)) [Typed (Value' lab)]+  -- ^ Since LLVM 3.7, constant @getelementptr@ expressions include an explicit+  -- type to use as a basis for calculations. For older versions of LLVM, this+  -- type can be reconstructed by inspecting the pointee type of the parent+  -- pointer value.   | ConstConv ConvOp (Typed (Value' lab)) Type   | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab))-  | ConstBlockAddr Symbol lab+  | ConstBlockAddr (Typed (Value' lab)) lab   | ConstFCmp FCmpOp (Typed (Value' lab)) (Typed (Value' lab))   | ConstICmp ICmpOp (Typed (Value' lab)) (Typed (Value' lab))   | ConstArith ArithOp (Typed (Value' lab)) (Value' lab)+  | ConstUnaryArith UnaryArithOp (Typed (Value' lab))   | ConstBit BitOp (Typed (Value' lab)) (Value' lab)     deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) @@ -1085,7 +1390,8 @@   | DebugInfoCompileUnit (DICompileUnit' lab)   | DebugInfoCompositeType (DICompositeType' lab)   | DebugInfoDerivedType (DIDerivedType' lab)-  | DebugInfoEnumerator String !Int64+  | DebugInfoEnumerator String !Integer Bool+    -- ^ The 'Bool' field represents @isUnsigned@, introduced in LLVM 7.   | DebugInfoExpression DIExpression   | DebugInfoFile DIFile   | DebugInfoGlobalVariable (DIGlobalVariable' lab)@@ -1094,13 +1400,16 @@   | DebugInfoLexicalBlockFile (DILexicalBlockFile' lab)   | DebugInfoLocalVariable (DILocalVariable' lab)   | DebugInfoSubprogram (DISubprogram' lab)-  | DebugInfoSubrange DISubrange+  | DebugInfoSubrange (DISubrange' lab)   | DebugInfoSubroutineType (DISubroutineType' lab)   | DebugInfoNameSpace (DINameSpace' lab)   | DebugInfoTemplateTypeParameter (DITemplateTypeParameter' lab)   | DebugInfoTemplateValueParameter (DITemplateValueParameter' lab)   | DebugInfoImportedEntity (DIImportedEntity' lab)   | DebugInfoLabel (DILabel' lab)+  | DebugInfoArgList (DIArgList' lab)+  | DebugInfoAssignID+    -- ^ Introduced in LLVM 17.     deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DebugInfo = DebugInfo' BlockLabel@@ -1125,16 +1434,18 @@  type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel data DITemplateTypeParameter' lab = DITemplateTypeParameter-    { dittpName :: Maybe String-    , dittpType :: Maybe (ValMd' lab)+    { dittpName      :: Maybe String+    , dittpType      :: Maybe (ValMd' lab)+    , dittpIsDefault :: Maybe Bool         -- since LLVM 11     } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DITemplateValueParameter = DITemplateValueParameter' BlockLabel data DITemplateValueParameter' lab = DITemplateValueParameter-    { ditvpTag   :: DwarfTag-    , ditvpName  :: Maybe String-    , ditvpType  :: Maybe (ValMd' lab)-    , ditvpValue :: ValMd' lab+    { ditvpTag       :: DwarfTag+    , ditvpName      :: Maybe String+    , ditvpType      :: Maybe (ValMd' lab)+    , ditvpIsDefault :: Maybe Bool         -- since LLVM 11+    , ditvpValue     :: ValMd' lab     } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DINameSpace = DINameSpace' BlockLabel@@ -1184,6 +1495,12 @@   , dicuMacros             :: Maybe (ValMd' lab)   , dicuDWOId              :: Word64   , dicuSplitDebugInlining :: Bool+  , dicuDebugInfoForProf   :: Bool+  , dicuNameTableKind      :: Word64+    -- added in LLVM 11: dicuRangesBaseAddress, dicuSysRoot, and dicuSDK+  , dicuRangesBaseAddress  :: Bool+  , dicuSysRoot            :: Maybe String+  , dicuSDK                :: Maybe String   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DICompileUnit = DICompileUnit' BlockLabel@@ -1205,6 +1522,12 @@   , dictTemplateParams :: Maybe (ValMd' lab)   , dictIdentifier     :: Maybe String   , dictDiscriminator  :: Maybe (ValMd' lab)+  , dictDataLocation   :: Maybe (ValMd' lab)+  , dictAssociated     :: Maybe (ValMd' lab)+  , dictAllocated      :: Maybe (ValMd' lab)+  , dictRank           :: Maybe (ValMd' lab)+  , dictAnnotations    :: Maybe (ValMd' lab)+    -- ^ Introduced in LLVM 14.   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DICompositeType = DICompositeType' BlockLabel@@ -1221,6 +1544,13 @@   , didtOffset :: Word64   , didtFlags :: DIFlags   , didtExtraData :: Maybe (ValMd' lab)+  , didtDwarfAddressSpace :: Maybe Word32+  -- ^ Introduced in LLVM 5.+  --+  -- The 'Maybe' encodes the possibility that there is no associated address+  -- space (in LLVM, the sentinel value @0@ is used for this).+  , didtAnnotations :: Maybe (ValMd' lab)+  -- ^ Introduced in LLVM 14   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DIDerivedType = DIDerivedType' BlockLabel@@ -1246,6 +1576,8 @@   , digvVariable             :: Maybe (ValMd' lab)   , digvDeclaration          :: Maybe (ValMd' lab)   , digvAlignment            :: Maybe Word32+  , digvAnnotations          :: Maybe (ValMd' lab)+    -- ^ Introduced in LLVM 14.   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DIGlobalVariable = DIGlobalVariable' BlockLabel@@ -1282,6 +1614,10 @@   , dilvType :: Maybe (ValMd' lab)   , dilvArg :: Word16   , dilvFlags :: DIFlags+  , dilvAlignment :: Maybe Word32+    -- ^ Introduced in LLVM 4.+  , dilvAnnotations :: Maybe (ValMd' lab)+    -- ^ Introduced in LLVM 14.   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DILocalVariable = DILocalVariable' BlockLabel@@ -1305,17 +1641,46 @@   , dispUnit           :: Maybe (ValMd' lab)   , dispTemplateParams :: Maybe (ValMd' lab)   , dispDeclaration    :: Maybe (ValMd' lab)-  , dispVariables      :: Maybe (ValMd' lab)+  , dispRetainedNodes  :: Maybe (ValMd' lab)   , dispThrownTypes    :: Maybe (ValMd' lab)+  , dispAnnotations    :: Maybe (ValMd' lab)+    -- ^ Introduced in LLVM 14.   } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DISubprogram = DISubprogram' BlockLabel -data DISubrange = DISubrange-  { disrCount      :: Int64-  , disrLowerBound :: Int64-  } deriving (Data, Eq, Generic, Ord, Show, Typeable)+-- | The DISubrange is a Value subrange specification, usually associated with+-- arrays or enumerations.+--+-- * Early LLVM: only 'disrCount' and 'disrLowerBound' were present, where both+--   were a direct signed 64-bit value.  This corresponds to "format 0" in the+--   bitcode encoding (see reference below).+--+-- * LLVM 7: 'disrCount' changed to metadata representation ('ValMd').  The+--   metadata representation should only be a signed 64-bit integer, a Variable,+--   or an Expression.  This corresponds to "format 1" in the bitcode encoding.+--+-- * LLVM 11: 'disrLowerBound' was changed to a metadata representation and+--   'disrUpperBound' and 'disrStride' were added (primarily driven by the+--   addition of Fortran support in llvm).  All three should only be represented+--   as a signed 64-bit integer, a Variable, or an Expression.  This corresponds+--   to "format 2" in the bitcode encoding.  See+--   https://github.com/llvm/llvm-project/commit/d20bf5a for this change.+--+-- Also see+-- https://github.com/llvm/llvm-project/blob/bbe8cd1/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1435-L1461+-- for how this is read from the bitcode encoding and the use of the format+-- values mentioned above. +data DISubrange' lab = DISubrange+  { disrCount      :: Maybe (ValMd' lab)+  , disrLowerBound :: Maybe (ValMd' lab)+  , disrUpperBound :: Maybe (ValMd' lab)+  , disrStride     :: Maybe (ValMd' lab)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DISubrange = DISubrange' BlockLabel+ data DISubroutineType' lab = DISubroutineType   { distFlags     :: DIFlags   , distTypeArray :: Maybe (ValMd' lab)@@ -1323,6 +1688,13 @@  type DISubroutineType = DISubroutineType' BlockLabel +-- | See <https://releases.llvm.org/13.0.0/docs/LangRef.html#diarglist>.+newtype DIArgList' lab = DIArgList+  { dialArgs :: [ValMd' lab]+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIArgList = DIArgList' BlockLabel+ -- Aggregate Utilities ---------------------------------------------------------  data IndexResult@@ -1341,10 +1713,11 @@ -- on unknown type aliases will return 'Nothing' resolveGepFull ::   (Ident -> Maybe Type) {- ^ Type alias resolution -} ->-  Type                  {- ^ Pointer type          -} ->+  Type                  {- ^ Base type used for calculations -} ->+  Typed (Value' lab)    {- ^ Pointer value         -} ->   [Typed (Value' lab)]  {- ^ Path                  -} ->   Maybe Type            {- ^ Type of result        -}-resolveGepFull env t ixs = go (resolveGep t ixs)+resolveGepFull env baseTy tv ixs = go (resolveGep baseTy tv ixs)   where   go Invalid                = Nothing   go (HasType result)       = Just result@@ -1353,16 +1726,32 @@  -- | Resolve the type of a GEP instruction.  Note that the type produced is the -- type of the result, not necessarily a pointer.-resolveGep :: Type -> [Typed (Value' lab)] -> IndexResult-resolveGep (PtrTo ty0) (v:ixs0)-  | isGepIndex v =-    resolveGepBody ty0 ixs0-resolveGep ty0@PtrTo{} (v:ixs0)-  | Just i <- elimAlias (typedType v) =-    Resolve i (\ty' -> resolveGep ty0 (Typed ty' (typedValue v):ixs0))-resolveGep (Alias i) ixs =-    Resolve i (\ty' -> resolveGep ty' ixs)-resolveGep _ _ = Invalid+resolveGep :: Type -> Typed (Value' lab) -> [Typed (Value' lab)] -> IndexResult+resolveGep baseTy tv ixs =+  case ixs of+    v:ixs0+      |  -- If headed by a pointer and the first index value has a valid GEP+         -- index type, proceed to resolve the body of the GEP instruction.+         isPointer t+      ,  isGepIndex v+      -> resolveGepBody baseTy ixs0++      |  -- If headed by a pointer and the first index has an alias type,+         -- resolve the alias and try again.+         isPointer t+      ,  Just i <- elimAlias (typedType v)+      -> Resolve i (\ty' -> resolveGep baseTy tv (Typed ty' (typedValue v):ixs0))++    _ |  -- If headed by a value with an alias type, resolve the alias and+         -- try again.+         Alias i <- t+      -> Resolve i (\ty' -> resolveGep baseTy (Typed ty' (typedValue tv)) ixs)++      |  -- Otherwise, the GEP instruction is invalid.+         otherwise+      -> Invalid+  where+    t = typedType tv  -- | Resolve the type of a GEP instruction.  This assumes that the input has -- already been processed as a pointer.

@@ -1,16 +1,17 @@ {-# Language TransformListComp, MonadComprehensions #-} {- |-Module           : $Header$+Module           : Text.LLVM.DebugUtils Description      : This module interprets the DWARF information associated                    with a function's argument and return types in order to                    interpret field name references. License          : BSD3 Stability        : provisional-Point-of-contact : emertens+Maintainer       : emertens@galois.com -} module Text.LLVM.DebugUtils   ( -- * Definition type analyzer-    Info(..), computeFunctionTypes, valMdToInfo+    Info(..), StructFieldInfo(..), BitfieldInfo(..), UnionFieldInfo(..)+  , computeFunctionTypes, valMdToInfo   , localVariableNameDeclarations    -- * Metadata lookup@@ -23,10 +24,19 @@    -- * Info hueristics   , guessAliasInfo+  , guessTypeInfo++  -- * Function arguments+  , debugInfoArgNames++  -- * Line numbers of definitions+  , debugInfoGlobalLines+  , debugInfoDefineLines   ) where  import           Control.Applicative    ((<|>)) import           Control.Monad          ((<=<))+import           Data.Bits              (Bits(..)) import           Data.IntMap            (IntMap) import qualified Data.IntMap as IntMap import           Data.List              (elemIndex, tails, stripPrefix)@@ -56,27 +66,99 @@  data Info   = Pointer Info-  | Structure [(String,Word64,Info)] -- ^ Fields: name, bit-offset, info-  | Union     [(String,Info)]+  | Structure (Maybe String) [StructFieldInfo]+  | Union     (Maybe String) [UnionFieldInfo]+  | Typedef String Info   | ArrInfo Info-  | BaseType String+  | BaseType String DIBasicType   | Unknown   deriving Show -{--import Text.Show.Pretty-import Data.Foldable+-- | Record debug information about a field in a struct type.+data StructFieldInfo = StructFieldInfo+  { sfiName :: String+    -- ^ The field name.+  , sfiOffset :: Word64+    -- ^ The field's offset (in bits) from the start of the struct.+  , sfiBitfield :: Maybe BitfieldInfo+    -- ^ If this field resides within a bitfield, this is+    -- @'Just' bitfieldInfo@. Otherwise, this is 'Nothing'.+  , sfiInfo :: Info+    -- ^ The debug 'Info' associated with the field's type.+  } deriving Show -test =-  do test' "/Users/emertens/Source/saw/saw-script\-           \/examples/llvm/dotprod_struct.bc"-     test' "/Users/emertens/Desktop/temp.bc"+-- | Record debug information about a field within a bitfield. For example,+-- the following C struct:+--+-- @+-- struct s {+--   int32_t w;+--   uint8_t x1:1;+--   uint8_t x2:2;+--   uint8_t y:1;+--   int32_t z;+-- };+-- @+--+-- Corresponds to the following 'Info':+--+-- @+-- 'Structure'+--   [ 'StructFieldInfo' { 'sfiName' = \"w\"+--                       , 'sfiOffset' = 0+--                       , 'sfiBitfield' = Nothing+--                       , 'sfiInfo' = 'BaseType' \"int32_t\"+--                       }+--   , 'StructFieldInfo' { 'sfiName' = \"x1\"+--                       , 'sfiOffset' = 32+--                       , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1+--                                                              , 'biBitfieldOffset' = 32+--                                                              })+--                       , 'sfiInfo' = 'BaseType' \"uint8_t\"+--                       }+--   , 'StructFieldInfo' { 'sfiName' = \"x2\"+--                       , 'sfiOffset' = 33+--                       , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 2+--                                                              , 'biBitfieldOffset' = 32+--                                                              })+--                       , 'sfiInfo' = BaseType \"uint8_t\"+--                       }+--   , 'StructFieldInfo' { 'sfiName' = \"y\"+--                       , 'sfiOffset' = 35+--                       , 'sfiBitfield' = Just ('BitfieldInfo' { 'biFieldSize' = 1+--                                                              , 'biBitfieldOffset' = 32+--                                                              })+--                       , 'sfiInfo' = 'BaseType' \"uint8_t\"+--                       }+--   , 'StructFieldInfo' { 'sfiName' = \"z\"+--                       , 'sfiOffset' = 64+--                       , 'sfiBitfield' = Nothing+--                       , 'sfiInfo' = BaseType \"int32_t\"+--                       }+--   ]+-- @+--+-- Notice that only @x1@, @x2@, and @y@ have 'BitfieldInfo's, as they are the+-- only fields that were declared with bitfield syntax.+data BitfieldInfo = BitfieldInfo+  { biFieldSize :: Word64+    -- ^ The field's size (in bits) within the bitfield. This should not be+    --   confused with the size of the field's declared type. For example, the+    --   'biFieldSize' of the @x1@ field is @1@, despite the fact that its+    --   declared type, @uint8_t@, is otherwise 8 bits in size.+  , biBitfieldOffset :: Word64+    -- ^ The bitfield's offset (in bits) from the start of the struct. Note+    --   that for a given field within a bitfield, its 'sfiOffset' is equal to+    --   the 'biBitfieldOffset' plus the 'biFieldSize'.+  } deriving Show -test' fn =-  do Right bc <- parseBitCodeFromFile fn-     let mdMap = mkMdMap bc-     traverse_ (putStrLn . ppShow . analyzeDefine mdMap) (modDefines bc)--}+-- | Record debug information about a field in a union type.+data UnionFieldInfo = UnionFieldInfo+  { ufiName :: String+    -- ^ The field name.+  , ufiInfo :: Info+    -- ^ The debug 'Info' associated with the field's type.+  } deriving Show  -- | Compute an 'IntMap' of the unnamed metadata in a module mkMdMap :: Module -> IntMap ValMd@@ -89,6 +171,10 @@ getDebugInfo _ (ValMdDebugInfo di) = Just di getDebugInfo _ _                   = Nothing +getInteger :: MdMap -> ValMd -> Maybe Integer+getInteger mdMap (ValMdRef i)                          = getInteger mdMap =<< IntMap.lookup i mdMap+getInteger _     (ValMdValue (Typed _ (ValInteger i))) = Just i+getInteger _     _                                     = Nothing  getList :: MdMap -> ValMd -> Maybe [Maybe ValMd] getList mdMap (ValMdRef i) = getList mdMap =<< IntMap.lookup i mdMap@@ -109,13 +195,15 @@ debugInfoToInfo :: MdMap -> DebugInfo -> Info debugInfoToInfo mdMap (DebugInfoDerivedType dt)   | didtTag dt == dwarfPointer  = Pointer (valMdToInfo' mdMap (didtBaseType dt))-  | didtTag dt == dwarfTypedef  =          valMdToInfo' mdMap (didtBaseType dt)-  | didtTag dt == dwarfConst    =          valMdToInfo' mdMap (didtBaseType dt)+  | didtTag dt == dwarfTypedef  = case didtName dt of+                                    Nothing -> valMdToInfo' mdMap (didtBaseType dt)+                                    Just nm -> Typedef nm (valMdToInfo' mdMap (didtBaseType dt))+  | didtTag dt == dwarfConst    = valMdToInfo' mdMap (didtBaseType dt) debugInfoToInfo _     (DebugInfoBasicType bt)-  | dibtTag bt == dwarfBasetype = BaseType (dibtName bt)+  | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) bt debugInfoToInfo mdMap (DebugInfoCompositeType ct)-  | dictTag ct == dwarfStruct   = maybe Unknown Structure (getStructFields mdMap ct)-  | dictTag ct == dwarfUnion    = maybe Unknown Union     (getUnionFields mdMap ct)+  | dictTag ct == dwarfStruct   = maybe Unknown (Structure (dictName ct)) (getStructFields mdMap ct)+  | dictTag ct == dwarfUnion    = maybe Unknown (Union     (dictName ct)) (getUnionFields mdMap ct)   | dictTag ct == dwarfArray    = ArrInfo (valMdToInfo' mdMap (dictBaseType ct)) debugInfoToInfo _ _             = Unknown @@ -124,26 +212,47 @@ getFieldDIs mdMap =   traverse (getDebugInfo mdMap) <=< sequence <=< getList mdMap <=< dictElements --getStructFields :: MdMap -> DICompositeType -> Maybe [(String, Word64, Info)]+getStructFields :: MdMap -> DICompositeType -> Maybe [StructFieldInfo] getStructFields mdMap = traverse (debugInfoToStructField mdMap) <=< getFieldDIs mdMap -debugInfoToStructField :: MdMap -> DebugInfo -> Maybe (String, Word64, Info)+debugInfoToStructField :: MdMap -> DebugInfo -> Maybe StructFieldInfo debugInfoToStructField mdMap di =   do DebugInfoDerivedType dt <- Just di      fieldName               <- didtName dt-     Just (fieldName, didtOffset dt, valMdToInfo' mdMap (didtBaseType dt))+     -- We check if a struct field resides within a bitfield by checking its+     -- `flags` field sets `BitField`, which has a numeric value of 19.+     -- (https://github.com/llvm/llvm-project/blob/1bebc31c617d1a0773f1d561f02dd17c5e83b23b/llvm/include/llvm/IR/DebugInfoFlags.def#L51)+     --+     -- If so, the `size` field records the size in bits, and the `extraData`+     -- field records the offset of the overall bitfield from the start of the+     -- struct.+     -- (https://github.com/llvm/llvm-project/blob/ee7652569854af567ba83e5255d70e80cc8619a1/llvm/lib/CodeGen/AsmPrinter/CodeViewDebug.cpp#L2489-L2508)+     let bitfield | testBit (didtFlags dt) 19+                  , Just extraData      <- didtExtraData dt+                  , Just bitfieldOffset <- getInteger mdMap extraData+                  = Just $ BitfieldInfo { biFieldSize      = didtSize dt+                                        , biBitfieldOffset = fromInteger bitfieldOffset+                                        }+                  | otherwise+                  = Nothing+     Just (StructFieldInfo { sfiName     = fieldName+                           , sfiOffset   = didtOffset dt+                           , sfiBitfield = bitfield+                           , sfiInfo     = valMdToInfo' mdMap (didtBaseType dt)+                           })  -getUnionFields :: MdMap -> DICompositeType -> Maybe [(String, Info)]+getUnionFields :: MdMap -> DICompositeType -> Maybe [UnionFieldInfo] getUnionFields mdMap = traverse (debugInfoToUnionField mdMap) <=< getFieldDIs mdMap  -debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe (String, Info)+debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe UnionFieldInfo debugInfoToUnionField mdMap di =   do DebugInfoDerivedType dt <- Just di      fieldName               <- didtName dt-     Just (fieldName, valMdToInfo' mdMap (didtBaseType dt))+     Just (UnionFieldInfo { ufiName = fieldName+                          , ufiInfo = valMdToInfo' mdMap (didtBaseType dt)+                          })   @@ -154,9 +263,9 @@ computeFunctionTypes ::   Module       {- ^ module to search                     -} ->   Symbol       {- ^ function symbol                      -} ->-  Maybe [Info] {- ^ return and argument type information -}+  Maybe [Maybe Info] {- ^ return and argument type information -} computeFunctionTypes m sym =-  [ maybe (BaseType "void") (valMdToInfo mdMap) <$> types+  [ fmap (valMdToInfo mdMap) <$> types      | let mdMap = mkMdMap m      , sp <- findSubprogramViaDefine mdMap m sym          <|> findSubprogramViaCu     mdMap m sym@@ -219,9 +328,10 @@   Info {- ^ type information for specified field -} fieldIndexByPosition i info =   case info of-    Structure xs -> go [ x | (_,_,x) <- xs ]-    Union     xs -> go [ x | (_,x)   <- xs ]-    _            -> Unknown+    Typedef _ info' -> fieldIndexByPosition i info'+    Structure _ xs  -> go [ x | StructFieldInfo{sfiInfo = x} <- xs ]+    Union     _ xs  -> go [ x | UnionFieldInfo{ufiInfo = x}  <- xs ]+    _               -> Unknown   where     go xs = case drop i xs of               []  -> Unknown@@ -235,9 +345,10 @@   Maybe Int {- ^ zero-based index of field matching the name -} fieldIndexByName n info =   case info of-    Structure xs -> go [ x | (x,_,_) <- xs ]-    Union     xs -> go [ x | (x,_)   <- xs ]-    _            -> Nothing+    Typedef _ info' -> fieldIndexByName n info'+    Structure _ xs  -> go [ x | StructFieldInfo{sfiName = x} <- xs ]+    Union     _ xs  -> go [ x | UnionFieldInfo{ufiName = x}  <- xs ]+    _               -> Nothing   where     go = elemIndex n @@ -291,21 +402,29 @@ -- because there's no direct mapping between type aliases -- and debug info. The debug information must be search -- for a textual match.+--+-- Compared to @guessTypeInfo@, this function first tries+-- to strip the \"struct.\" and \"union.\" prefixes that are+-- commonly added by clang before searching for the type information. guessAliasInfo ::   IntMap ValMd    {- ^ unnamed metadata      -} ->   Ident           {- ^ alias                 -} ->   Info-guessAliasInfo mdMap (Ident name) =-     -- TODO: Support more categories than struct-  case stripPrefix "struct." name of-    Nothing  -> Unknown-    Just pfx -> guessStructInfo mdMap pfx+guessAliasInfo mdMap (Ident name)+  | Just pfx <- stripPrefix "struct." name = guessTypeInfo mdMap pfx+  | Just pfx <- stripPrefix "union."  name = guessTypeInfo mdMap pfx+  | otherwise = guessTypeInfo mdMap name -guessStructInfo ::+-- | Search the metadata for debug info corresponding+-- to a given type alias. This is considered a heuristic+-- because there's no direct mapping between type aliases+-- and debug info. The debug information must be search+-- for a textual match.+guessTypeInfo ::   IntMap ValMd    {- ^ unnamed metadata      -} ->   String          {- ^ struct alias          -} ->   Info-guessStructInfo mdMap name =+guessTypeInfo mdMap name =   case mapMaybe (go <=< getDebugInfo mdMap) (IntMap.elems mdMap) of     []  -> Unknown     x:_ -> x@@ -319,4 +438,67 @@           , Just name == dictName dict           = Just (debugInfoToInfo mdMap di) +    go _ = Nothing++------------------------------------------------------------------------++-- | Find source-level names of function arguments+debugInfoArgNames :: Module -> Define -> IntMap String+debugInfoArgNames m d =+  case Map.lookup dbgKind $ defMetadata d of+    Just (ValMdRef s) -> scopeArgs s+    _ -> IntMap.empty+  where+    scopeArgs :: Int -> IntMap String+    scopeArgs s = IntMap.fromList . mapMaybe go $ modUnnamedMd m+      where+        go :: UnnamedMd -> Maybe (Int, String)+        go+          ( UnnamedMd+              { umValues =+                  ValMdDebugInfo+                    ( DebugInfoLocalVariable+                        DILocalVariable+                          { dilvScope = Just (ValMdRef s'),+                            dilvArg = a,+                            dilvName = Just n+                          }+                      )+              }) =+            if s == s'+            then Just (fromIntegral a - 1, n)+            else Nothing+        go _ = Nothing++------------------------------------------------------------------------++-- | Map global variable names to the line on which the global is defined+debugInfoGlobalLines :: Module -> Map String Int+debugInfoGlobalLines = Map.fromList . mapMaybe go . modUnnamedMd+  where+    go :: UnnamedMd -> Maybe (String, Int)+    go (UnnamedMd+         { umValues = ValMdDebugInfo+           (DebugInfoGlobalVariable DIGlobalVariable+             { digvName = Just n+             , digvLine = l+             }+           )+         }) = Just (n, (fromIntegral l))+    go _ = Nothing++-- | Map function names to the line on which the function is defined+debugInfoDefineLines :: Module -> Map String Int+debugInfoDefineLines = Map.fromList . mapMaybe go . modUnnamedMd+  where+    go :: UnnamedMd -> Maybe (String, Int)+    go (UnnamedMd+         { umValues = ValMdDebugInfo+           (DebugInfoSubprogram DISubprogram+             { dispName = Just n+             , dispIsDefinition = True+             , dispLine = l+             }+           )+         }) = Just (n, (fromIntegral l))     go _ = Nothing

@@ -1,21 +1,10 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-}--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif- module Text.LLVM.Labels where  import Text.LLVM.AST import Text.LLVM.Labels.TH -#if !(MIN_VERSION_base(4,8,0))-import Control.Applicative ((<$>),Applicative(..))-import Data.Traversable (traverse)-#endif- class Functor f => HasLabel f where   -- | Given a function for resolving labels, where the presence of a symbol   -- denotes a label in a different function, rename all labels in a function.@@ -30,6 +19,8 @@   relabel f (Arith op l r)        = Arith op                                 <$> traverse (relabel f) l                                 <*> relabel f r+  relabel f (UnaryArith op a)     = UnaryArith op+                                <$> traverse (relabel f) a   relabel f (Bit op l r)          = Bit op                                 <$> traverse (relabel f) l                                 <*> relabel f r@@ -37,10 +28,18 @@   relabel f (Call t r n as)       = Call t r                                 <$> relabel f n                                 <*> traverse (traverse (relabel f)) as+  relabel f (CallBr r n as u es)  = CallBr r+                                <$> relabel f n+                                <*> traverse (traverse (relabel f)) as+                                <*> f Nothing u+                                <*> traverse (f Nothing) es   relabel f (Alloca t n a)        = Alloca t                                 <$> traverse (traverse (relabel f)) n                                 <*> pure a-  relabel f (Load a mo ma)        = Load <$> traverse (relabel f) a <*> pure mo <*> pure ma+  relabel f (Load t a mo ma)      = Load t+                                <$> traverse (relabel f) a+                                <*> pure mo+                                <*> pure ma   relabel f (Store d v mo ma)     = Store                                 <$> traverse (relabel f) d                                 <*> traverse (relabel f) v@@ -67,7 +66,7 @@   relabel f (FCmp op l r)         = FCmp op                                 <$> traverse (relabel f) l                                 <*> relabel f r-  relabel f (GEP ib a is)         = GEP ib+  relabel f (GEP ib t a is)       = GEP ib t                                 <$> traverse (relabel f) a                                 <*> traverse (traverse (relabel f)) is   relabel f (Select c l r)        = Select@@ -120,6 +119,7 @@                                   <*> traverse (relabel f) cs    relabel f (Resume tv)           = Resume <$> traverse (relabel f) tv+  relabel f (Freeze tv)           = Freeze <$> traverse (relabel f) tv  instance HasLabel Stmt'                       where relabel = $(generateRelabel 'relabel ''Stmt') instance HasLabel Clause'                     where relabel = $(generateRelabel 'relabel ''Clause')@@ -130,6 +130,7 @@ instance HasLabel DebugInfo'                  where relabel = $(generateRelabel 'relabel ''DebugInfo') instance HasLabel DIDerivedType'              where relabel = $(generateRelabel 'relabel ''DIDerivedType') instance HasLabel DISubroutineType'           where relabel = $(generateRelabel 'relabel ''DISubroutineType')+instance HasLabel DISubrange'                 where relabel = $(generateRelabel 'relabel ''DISubrange') instance HasLabel DIGlobalVariable'           where relabel = $(generateRelabel 'relabel ''DIGlobalVariable') instance HasLabel DIGlobalVariableExpression' where relabel = $(generateRelabel 'relabel ''DIGlobalVariableExpression') instance HasLabel DILocalVariable'            where relabel = $(generateRelabel 'relabel ''DILocalVariable')@@ -142,8 +143,10 @@ instance HasLabel DITemplateTypeParameter'    where relabel = $(generateRelabel 'relabel ''DITemplateTypeParameter') instance HasLabel DITemplateValueParameter'   where relabel = $(generateRelabel 'relabel ''DITemplateValueParameter') instance HasLabel DIImportedEntity'           where relabel = $(generateRelabel 'relabel ''DIImportedEntity')+instance HasLabel DIArgList'                  where relabel = $(generateRelabel 'relabel ''DIArgList')  -- | Clever instance that actually uses the block name instance HasLabel ConstExpr' where-  relabel f (ConstBlockAddr t l) = ConstBlockAddr t <$> f (Just t) l+  relabel f (ConstBlockAddr t@(Typed { typedValue = ValSymbol s }) l) =+    ConstBlockAddr <$> traverse (relabel f) t <*> f (Just s) l   relabel f x = $(generateRelabel 'relabel ''ConstExpr') f x

@@ -30,7 +30,7 @@     , ''DebugLoc'     , ''DebugInfo'     , ''DIFile-    , ''DISubrange+    , ''DISubrange'     , ''DIBasicType     , ''DIExpression     , ''DISubprogram'@@ -43,6 +43,7 @@     , ''DIDerivedType'     , ''DILexicalBlock'     , ''DILexicalBlockFile'+    , ''DIArgList'     , ''Instr'     , ''ValMd'     , ''ConvOp

@@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} @@ -17,9 +18,11 @@ module Text.LLVM.PP where  import Text.LLVM.AST+import Text.LLVM.Triple.AST (TargetTriple)+import Text.LLVM.Triple.Print (printTriple)  import Control.Applicative ((<|>))-import Data.Bits ( shiftR )+import Data.Bits ( shiftR, (.&.) ) import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper) import Data.List (intersperse) import qualified Data.Map as Map@@ -32,53 +35,96 @@  -- Pretty-printer Config ------------------------------------------------------- -type LLVM = ?config :: Config --- | The differences between various versions of the llvm textual AST.-data Config = Config { cfgLoadImplicitType :: Bool-                       -- ^ True when the type of the result of a load is-                       -- derived from its pointer argument, or supplied-                       -- implicitly.+-- | The value used to specify the LLVM major version.  The LLVM text format+-- (i.e. assembly code) changes with different versions of LLVM, so this value is+-- used to select the version the output should be generated for.+--+-- At the current time, changes primarily occur when the LLVM major version+-- changes, and this is expected to be the case going forward, so it is+-- sufficient to reference the LLVM version by the single major version number.+-- There is one exception and one possible future exception to this approach:+--+--  1. During LLVM v3, there were changes in 3.5, 3.6, 3.7, and 3.8.  There are+--     explicit @ppLLVMnn@ function entry points for those versions, but in the+--     event that a numerical value is needed, we note the serendipitous fact+--     that prior to LLVM 4, there are exactly 4 versions we need to+--     differentiate and can therefore assign the values of 0, 1, 2, and 3 to+--     those versions (and we have no intention of supporting any other pre-4.0+--     versions at this point).+--+--  2. If at some future date, there are text format changes associated with a+--     minor version, then the LLVM version designation here will need to be+--     enhanced and made more sophisticated.  At the present time, the likelihood+--     of that is small enough that the current simple implementation is a+--     benefit over a more complex mechanism that might not be needed.+--+type LLVMVer = Int -                     , cfgGEPImplicitType :: Bool-                       -- ^ True when the type of the result of the GEP-                       -- instruction is implied.+-- | Helpers for specifying the LLVM versions prior to v4+llvmV3_5, llvmV3_6, llvmV3_7, llvmV3_8 :: LLVMVer+llvmV3_5 = 0+llvmV3_6 = 1+llvmV3_7 = 2+llvmV3_8 = 3 -                     , cfgUseDILocation :: Bool-                     }+-- | This value should be updated when support is added for new LLVM versions;+-- this is used for defaulting and otherwise reporting the maximum LLVM version+-- known to be supported.+llvmVlatest :: LLVMVer+llvmVlatest = 17 -withConfig :: Config -> (LLVM => a) -> a++-- | The differences between various versions of the llvm textual AST.+newtype Config = Config { cfgVer :: LLVMVer }++withConfig :: Config -> ((?config :: Config) => a) -> a withConfig cfg body = let ?config = cfg in body  -ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: (LLVM => a) -> a+ppLLVM :: LLVMVer -> ((?config :: Config) => a) -> a+ppLLVM llvmver = withConfig Config { cfgVer = llvmver } -ppLLVM = ppLLVM38+ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: ((?config :: Config) => a) -> a -ppLLVM35 = ppLLVM36+ppLLVM35 = withConfig Config { cfgVer = llvmV3_5 }+ppLLVM36 = withConfig Config { cfgVer = llvmV3_6 }+ppLLVM37 = withConfig Config { cfgVer = llvmV3_7 }+ppLLVM38 = withConfig Config { cfgVer = llvmV3_8 } -ppLLVM36 = withConfig Config { cfgLoadImplicitType = True-                             , cfgGEPImplicitType  = True-                             , cfgUseDILocation    = False-                             }-ppLLVM37 = withConfig Config { cfgLoadImplicitType = False-                             , cfgGEPImplicitType  = False-                             , cfgUseDILocation    = True-                             }-ppLLVM38 = withConfig Config { cfgLoadImplicitType = False-                             , cfgGEPImplicitType  = False-                             , cfgUseDILocation    = True-                             }+llvmVer :: (?config :: Config) => LLVMVer+llvmVer = cfgVer ?config -checkConfig :: LLVM => (Config -> Bool) -> Bool-checkConfig p = p ?config+-- | This is a helper function for when a list of parameters is gated by a+-- condition (usually the llvmVer value).+when' :: Monoid a => Bool -> a -> a+when' c l = if c then l else mempty  +-- | This type encapsulates the ability to convert an object into Doc+-- format. Using this abstraction allows for a consolidated representation of the+-- declaration.  Most pretty-printing for LLVM elements will have a @'Fmt' a@+-- function signature for that element.+type Fmt a = (?config :: Config) => a -> Doc+++-- | The LLVMPretty class has instances for most AST elements.  It allows the+-- conversion of an AST element (and its sub-elements) into a Doc assembly format+-- by simply using the 'llvmPP' method rather than needing to explicitly invoke+-- the specific pretty-printing function for that element.+class LLVMPretty a where llvmPP :: Fmt a++instance LLVMPretty Module where llvmPP = ppModule+instance LLVMPretty Symbol where llvmPP = ppSymbol+instance LLVMPretty Ident  where llvmPP = ppIdent++ -- Modules --------------------------------------------------------------------- -ppModule :: LLVM => Module -> Doc+ppModule :: Fmt Module ppModule m = foldr ($+$) empty   $ ppSourceName (modSourceName m)+  : ppTargetTriple (modTriple m)   : ppDataLayout (modDataLayout m)   : ppInlineAsm  (modInlineAsm m)   : concat [ map ppTypeDecl    (modTypes m)@@ -94,18 +140,18 @@  -- Source filename ------------------------------------------------------------- -ppSourceName :: Maybe String -> Doc+ppSourceName :: Fmt (Maybe String) ppSourceName Nothing   = empty ppSourceName (Just sn) = "source_filename" <+> char '=' <+> doubleQuotes (text sn)  -- Metadata -------------------------------------------------------------------- -ppNamedMd :: NamedMd -> Doc+ppNamedMd :: Fmt NamedMd ppNamedMd nm =   sep [ ppMetadata (text (nmName nm)) <+> char '='       , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] -ppUnnamedMd :: LLVM => UnnamedMd -> Doc+ppUnnamedMd :: Fmt UnnamedMd ppUnnamedMd um =   sep [ ppMetadata (int (umIndex um)) <+> char '='       , distinct <+> ppValMd (umValues um) ]@@ -116,8 +162,12 @@  -- Aliases --------------------------------------------------------------------- -ppGlobalAlias :: LLVM => GlobalAlias -> Doc-ppGlobalAlias g = ppSymbol (aliasName g) <+> char '=' <+> body+ppGlobalAlias :: Fmt GlobalAlias+ppGlobalAlias g = ppSymbol (aliasName g)+              <+> char '='+              <+> ppMaybe ppLinkage (aliasLinkage g)+              <+> ppMaybe ppVisibility (aliasVisibility g)+              <+> body   where   val  = aliasTarget g   body = case val of@@ -125,16 +175,23 @@     _              -> ppValue val  +-- Target triple ---------------------------------------------------------------++-- | Pretty print a 'TargetTriple'+ppTargetTriple :: Fmt TargetTriple+ppTargetTriple triple = "target" <+> "triple" <+> char '='+    <+> doubleQuotes (text (printTriple triple))+ -- Data Layout -----------------------------------------------------------------  -- | Pretty print a data layout specification.-ppDataLayout :: DataLayout -> Doc+ppDataLayout :: Fmt DataLayout ppDataLayout [] = empty ppDataLayout ls = "target" <+> "datalayout" <+> char '='     <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls)))  -- | Pretty print a single layout specification.-ppLayoutSpec :: LayoutSpec -> Doc+ppLayoutSpec :: Fmt LayoutSpec ppLayoutSpec ls =   case ls of     BigEndian                 -> char 'E'@@ -153,14 +210,14 @@     Mangling m                -> char 'm' <> char ':' <> ppMangling m  -- | Pretty-print the common case for data layout specifications.-ppLayoutBody :: Int -> Int -> Maybe Int -> Doc+ppLayoutBody :: Int -> Int -> Fmt (Maybe Int) ppLayoutBody size abi mb = int size <> char ':' <> int abi <> pref   where   pref = case mb of     Nothing -> empty     Just p  -> char ':' <> int p -ppMangling :: Mangling -> Doc+ppMangling :: Fmt Mangling ppMangling ElfMangling         = char 'e' ppMangling MipsMangling        = char 'm' ppMangling MachOMangling       = char 'o'@@ -170,7 +227,7 @@ -- Inline Assembly -------------------------------------------------------------  -- | Pretty-print the inline assembly block.-ppInlineAsm :: InlineAsm -> Doc+ppInlineAsm :: Fmt InlineAsm ppInlineAsm  = foldr ($+$) empty . map ppLine   where   ppLine l = "module asm" <+> doubleQuotes (text l)@@ -178,7 +235,7 @@  -- Identifiers ----------------------------------------------------------------- -ppIdent :: Ident -> Doc+ppIdent :: Fmt Ident ppIdent (Ident n)   | validIdentifier n = char '%' <> text n   | otherwise         = char '%' <> ppStringLiteral n@@ -198,7 +255,7 @@  -- Symbols --------------------------------------------------------------------- -ppSymbol :: Symbol -> Doc+ppSymbol :: Fmt Symbol ppSymbol (Symbol n)   | validIdentifier n = char '@' <> text n   | otherwise         = char '@' <> ppStringLiteral n@@ -206,7 +263,7 @@  -- Types ----------------------------------------------------------------------- -ppPrimType :: PrimType -> Doc+ppPrimType :: Fmt PrimType ppPrimType Label          = "label" ppPrimType Void           = "void" ppPrimType (Integer i)    = char 'i' <> integer (toInteger i)@@ -214,7 +271,7 @@ ppPrimType X86mmx         = "x86mmx" ppPrimType Metadata       = "metadata" -ppFloatType :: FloatType -> Doc+ppFloatType :: Fmt FloatType ppFloatType Half      = "half" ppFloatType Float     = "float" ppFloatType Double    = "double"@@ -222,73 +279,79 @@ ppFloatType X86_fp80  = "x86_fp80" ppFloatType PPC_fp128 = "ppc_fp128" -ppType :: Type -> Doc+ppType :: Fmt Type ppType (PrimType pt)     = ppPrimType pt ppType (Alias i)         = ppIdent i ppType (Array len ty)    = brackets (integral len <+> char 'x' <+> ppType ty) ppType (PtrTo ty)        = ppType ty <> char '*'+ppType PtrOpaque         = "ptr" ppType (Struct ts)       = structBraces (commas (map ppType ts)) ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts))) ppType (FunTy r as va)   = ppType r <> ppArgList va (map ppType as) ppType (Vector len pt)   = angles (integral len <+> char 'x' <+> ppType pt) ppType Opaque            = "opaque" -ppTypeDecl :: TypeDecl -> Doc+ppTypeDecl :: Fmt TypeDecl ppTypeDecl td = ppIdent (typeName td) <+> char '='             <+> "type" <+> ppType (typeValue td)   -- Declarations ---------------------------------------------------------------- -ppGlobal :: LLVM => Global -> Doc+ppGlobal :: Fmt Global ppGlobal g = ppSymbol (globalSym g) <+> char '='-         <+> ppTheGlobalAttrs (globalAttrs g)+         <+> ppGlobalAttrs (isJust $ globalValue g) (globalAttrs g)          <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g)           <> ppAlign (globalAlign g)           <> ppAttachedMetadata (Map.toList (globalMetadata g))-  where-  isStruct | Just (ValStruct {}) <- globalValue g = True-           | otherwise = False-  ppTheGlobalAttrs | isStruct = ppStructGlobalAttrs-                    | otherwise = ppGlobalAttrs -ppGlobalAttrs :: GlobalAttrs -> Doc-ppGlobalAttrs ga+-- | Pretty-print Global Attributes (usually associated with a global variable+-- declaration). The first argument to ppGlobalAttrs indicates whether there is a+-- value associated with this global declaration: a global declaration with a+-- value should not be identified as \"external\" and \"default\" visibility,+-- whereas one without a value may have those attributes.++ppGlobalAttrs :: Bool -> Fmt GlobalAttrs+ppGlobalAttrs hasValue ga     -- LLVM 3.8 does not emit or parse linkage information w/ hidden visibility     | Just HiddenVisibility <- gaVisibility ga =             ppVisibility HiddenVisibility <+> constant-    | otherwise = ppMaybe ppLinkage (gaLinkage ga) <+> ppMaybe ppVisibility (gaVisibility ga) <+> constant-  where-  constant | gaConstant ga = "constant"-           | otherwise     = "global"--ppStructGlobalAttrs :: GlobalAttrs -> Doc-ppStructGlobalAttrs ga-    -- LLVM 3.8 does not emit or parse external linkage for-    -- global structs-    | Just External <- gaLinkage ga,-      Just DefaultVisibility <- gaVisibility ga-        = constant-    | otherwise = ppGlobalAttrs ga+    | Just External <- gaLinkage ga+    , Just DefaultVisibility <- gaVisibility ga+    , hasValue =+        -- Just show the value, no "external" or "default".  This is based on+        -- empirical testing as described in the comment above (testing the+        -- following 6 configurations:+        --   * uninitialized scalar+        --   * uninitialized structure+        --   * initialized scalar+        --   * initialized structure+        --   * external scalar+        --   * external structure+        constant+    | otherwise =+        ppMaybe ppLinkage (gaLinkage ga) <+> ppMaybe ppVisibility (gaVisibility ga) <+> constant   where   constant | gaConstant ga = "constant"            | otherwise     = "global" -ppDeclare :: Declare -> Doc+ppDeclare :: Fmt Declare ppDeclare d = "declare"+          <+> ppMaybe ppLinkage (decLinkage d)+          <+> ppMaybe ppVisibility (decVisibility d)           <+> ppType (decRetType d)           <+> ppSymbol (decName d)            <> ppArgList (decVarArgs d) (map ppType (decArgs d))           <+> hsep (ppFunAttr <$> decAttrs d)           <> maybe empty ((char ' ' <>) . ppComdatName) (decComdat d) -ppComdatName :: String -> Doc+ppComdatName :: Fmt String ppComdatName s = "comdat" <> parens (char '$' <> text s) -ppComdat :: (String,SelectionKind) -> Doc+ppComdat :: Fmt (String,SelectionKind) ppComdat (n,k) = ppComdatName n <+> char '=' <+> text "comdat" <+> ppSelectionKind k -ppSelectionKind :: SelectionKind -> Doc+ppSelectionKind :: Fmt SelectionKind ppSelectionKind k =     case k of       ComdatAny             -> "any"@@ -297,9 +360,10 @@       ComdatNoDuplicates    -> "noduplicates"       ComdatSameSize        -> "samesize" -ppDefine :: LLVM => Define -> Doc+ppDefine :: Fmt Define ppDefine d = "define"          <+> ppMaybe ppLinkage (defLinkage d)+         <+> ppMaybe ppVisibility (defVisibility d)          <+> ppType (defRetType d)          <+> ppSymbol (defName d)           <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d))@@ -318,7 +382,7 @@  -- FunAttr --------------------------------------------------------------------- -ppFunAttr :: FunAttr -> Doc+ppFunAttr :: Fmt FunAttr ppFunAttr a =   case a of     AlignStack w    -> text "alignstack" <> parens (int w)@@ -352,28 +416,28 @@  -- Basic Blocks ---------------------------------------------------------------- -ppLabelDef :: BlockLabel -> Doc+ppLabelDef :: Fmt BlockLabel ppLabelDef (Named (Ident l)) = text l <> char ':' ppLabelDef (Anon i)          = char ';' <+> "<label>:" <+> int i -ppLabel :: BlockLabel -> Doc+ppLabel :: Fmt BlockLabel ppLabel (Named l) = ppIdent l ppLabel (Anon i)  = char '%' <> int i -ppBasicBlock :: LLVM => BasicBlock -> Doc+ppBasicBlock :: Fmt BasicBlock ppBasicBlock bb = ppMaybe ppLabelDef (bbLabel bb)               $+$ nest 2 (vcat (map ppStmt (bbStmts bb)))   -- Statements ------------------------------------------------------------------ -ppStmt :: LLVM => Stmt -> Doc+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 -ppAttachedMetadata :: LLVM => [(String,ValMd)] -> Doc+ppAttachedMetadata :: Fmt [(String,ValMd)] ppAttachedMetadata mds   | null mds  = empty   | otherwise = comma <+> commas (map step mds)@@ -383,7 +447,7 @@  -- Linkage --------------------------------------------------------------------- -ppLinkage :: Linkage -> Doc+ppLinkage :: Fmt Linkage ppLinkage linkage = case linkage of   Private                  -> "private"   LinkerPrivate            -> "linker_private"@@ -402,28 +466,28 @@   DLLImport                -> "dllimport"   DLLExport                -> "dllexport" -ppVisibility :: Visibility -> Doc+ppVisibility :: Fmt Visibility ppVisibility v = case v of     DefaultVisibility   -> "default"     HiddenVisibility    -> "hidden"     ProtectedVisibility -> "protected" -ppGC :: GC -> Doc+ppGC :: Fmt GC ppGC  = doubleQuotes . text . getGC   -- Expressions ----------------------------------------------------------------- -ppTyped :: (a -> Doc) -> Typed a -> Doc+ppTyped :: Fmt a -> Fmt (Typed a) ppTyped fmt ty = ppType (typedType ty) <+> fmt (typedValue ty) -ppSignBits :: Bool -> Bool -> Doc+ppSignBits :: Bool -> Fmt Bool ppSignBits nuw nsw = opt nuw "nuw" <+> opt nsw "nsw" -ppExact :: Bool -> Doc+ppExact :: Fmt Bool ppExact e = opt e "exact" -ppArithOp :: ArithOp -> Doc+ppArithOp :: Fmt ArithOp ppArithOp (Add nuw nsw) = "add" <+> ppSignBits nuw nsw ppArithOp FAdd          = "fadd" ppArithOp (Sub nuw nsw) = "sub" <+> ppSignBits nuw nsw@@ -437,7 +501,10 @@ ppArithOp SRem          = "srem" ppArithOp FRem          = "frem" -ppBitOp :: BitOp -> Doc+ppUnaryArithOp :: Fmt UnaryArithOp+ppUnaryArithOp FNeg = "fneg"++ppBitOp :: Fmt BitOp ppBitOp (Shl nuw nsw) = "shl"  <+> ppSignBits nuw nsw ppBitOp (Lshr e)      = "lshr" <+> ppExact e ppBitOp (Ashr e)      = "ashr" <+> ppExact e@@ -445,7 +512,7 @@ ppBitOp Or            = "or" ppBitOp Xor           = "xor" -ppConvOp :: ConvOp -> Doc+ppConvOp :: Fmt ConvOp ppConvOp Trunc    = "trunc" ppConvOp ZExt     = "zext" ppConvOp SExt     = "sext"@@ -459,7 +526,7 @@ ppConvOp IntToPtr = "inttoptr" ppConvOp BitCast  = "bitcast" -ppAtomicOrdering :: AtomicOrdering -> Doc+ppAtomicOrdering :: Fmt AtomicOrdering ppAtomicOrdering Unordered = text "unordered" ppAtomicOrdering Monotonic = text "monotonic" ppAtomicOrdering Acquire   = text "acquire"@@ -467,7 +534,7 @@ ppAtomicOrdering AcqRel    = text "acq_rel" ppAtomicOrdering SeqCst    = text "seq_cst" -ppAtomicOp :: AtomicRWOp -> Doc+ppAtomicOp :: Fmt AtomicRWOp ppAtomicOp AtomicXchg = "xchg" ppAtomicOp AtomicAdd  = "add" ppAtomicOp AtomicSub  = "sub"@@ -480,23 +547,25 @@ ppAtomicOp AtomicUMax = "umax" ppAtomicOp AtomicUMin = "umin" -ppScope ::  Maybe String -> Doc+ppScope ::  Fmt (Maybe String) ppScope Nothing = empty ppScope (Just s) = "syncscope" <> parens (doubleQuotes (text s)) -ppInstr :: LLVM => Instr -> Doc+ppInstr :: Fmt Instr ppInstr instr = case instr of   Ret tv                 -> "ret" <+> ppTyped ppValue tv   RetVoid                -> "ret void"   Arith op l r           -> ppArithOp op <+> ppTyped ppValue l                          <> comma <+> ppValue r+  UnaryArith op a        -> ppUnaryArithOp op <+> ppTyped ppValue a   Bit op l r             -> ppBitOp op <+> ppTyped ppValue l                          <> comma <+> ppValue r   Conv op a ty           -> ppConvOp op <+> ppTyped ppValue a                         <+> "to" <+> ppType ty   Call tc ty f args      -> ppCall tc ty f args+  CallBr ty f args u es  -> ppCallBr ty f args u es   Alloca ty len align    -> ppAlloca ty len align-  Load ptr mo ma         -> ppLoad ptr mo ma+  Load ty ptr mo ma      -> ppLoad ty ptr mo ma   Store a ptr mo ma      -> ppStore a ptr mo ma   Fence scope order      -> "fence" <+> ppScope scope <+> ppAtomicOrdering order   CmpXchg w v p a n s o o' -> "cmpxchg" <+> opt w "weak"@@ -531,7 +600,7 @@   ShuffleVector a b m    -> "shufflevector" <+> ppTyped ppValue a                          <> comma <+> ppTyped ppValue (b <$ a)                          <> comma <+> ppTyped ppValue m-  GEP ib ptr ixs         -> ppGEP ib ptr ixs+  GEP ib ty ptr ixs      -> ppGEP ib ty ptr ixs   Comment str            -> char ';' <+> text str   Jump i                 -> "br"                         <+> ppTypedLabel i@@ -572,11 +641,12 @@                         <+> ppType ty                         $$ nest 2 (ppClauses c cs)   Resume tv           -> "resume" <+> ppTyped ppValue tv+  Freeze tv           -> "freeze" <+> ppTyped ppValue tv -ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe AtomicOrdering -> Maybe Align -> Doc-ppLoad ptr mo ma =+ppLoad :: Type -> Typed (Value' BlockLabel) -> Maybe AtomicOrdering -> Fmt (Maybe Align)+ppLoad ty ptr mo ma =   "load" <+> (if isAtomic   then "atomic" else empty)-         <+> (if isImplicit then empty    else explicit)+         <+> (if isExplicit then explicit else empty)          <+> ppTyped ppValue ptr          <+> ordering           <> ppAlign ma@@ -584,24 +654,19 @@   where   isAtomic = isJust mo -  isImplicit = checkConfig cfgLoadImplicitType+  isExplicit = llvmVer >= llvmV3_7    ordering =     case mo of       Just ao -> ppAtomicOrdering ao       _       -> empty -  explicit =-    case typedType ptr of-      PtrTo ty -> ppType ty <> comma-      ty       -> ppType ty <> comma+  explicit = ppType ty <> comma -ppStore :: LLVM-        => Typed (Value' BlockLabel)+ppStore :: Typed (Value' BlockLabel)         -> Typed (Value' BlockLabel)         -> Maybe AtomicOrdering-        -> Maybe Align-        -> Doc+        -> Fmt (Maybe Align) ppStore ptr val mo ma =   "store" <+> (if isJust mo  then "atomic" else empty)           <+> ppTyped ppValue ptr <> comma@@ -612,32 +677,32 @@           <> ppAlign ma  -ppClauses :: LLVM => Bool -> [Clause] -> Doc+ppClauses :: Bool -> Fmt [Clause] ppClauses isCleanup cs = vcat (cleanup : map ppClause cs)   where   cleanup | isCleanup = "cleanup"           | otherwise = empty -ppClause :: LLVM => Clause -> Doc+ppClause :: Fmt Clause ppClause c = case c of   Catch  tv -> "catch"  <+> ppTyped ppValue tv   Filter tv -> "filter" <+> ppTyped ppValue tv  -ppTypedLabel :: BlockLabel -> Doc+ppTypedLabel :: Fmt BlockLabel ppTypedLabel i = ppType (PrimType Label) <+> ppLabel i -ppSwitchEntry :: Type -> (Integer,BlockLabel) -> Doc+ppSwitchEntry :: Type -> Fmt (Integer,BlockLabel) ppSwitchEntry ty (i,l) = ppType ty <+> integer i <> comma <+> ppTypedLabel l -ppVectorIndex :: LLVM => Value -> Doc+ppVectorIndex :: Fmt Value ppVectorIndex i = ppType (PrimType (Integer 32)) <+> ppValue i -ppAlign :: Maybe Align -> Doc+ppAlign :: Fmt (Maybe Align) ppAlign Nothing      = empty ppAlign (Just align) = comma <+> "align" <+> int align -ppAlloca :: LLVM => Type -> Maybe (Typed Value) -> Maybe Int -> Doc+ppAlloca :: Type -> Maybe (Typed Value) -> Fmt (Maybe Int) ppAlloca ty mbLen mbAlign = "alloca" <+> ppType ty <> len <> align   where   len = fromMaybe empty $ do@@ -647,7 +712,7 @@     a <- mbAlign     return (comma <+> "align" <+> int a) -ppCall :: LLVM => Bool -> Type -> Value -> [Typed Value] -> Doc+ppCall :: Bool -> Type -> Value -> Fmt [Typed Value] ppCall tc ty f args   | tc        = "tail" <+> body   | otherwise = body@@ -655,37 +720,66 @@   body = "call" <+> ppCallSym ty f       <> parens (commas (map (ppTyped ppValue) args)) -ppCallSym :: LLVM => Type -> Value -> Doc-ppCallSym (PtrTo (FunTy res args va))   val        = ppType res <+> ppArgList va (map ppType args) <+> ppValue val-ppCallSym ty              val                      = ppType ty  <+> ppValue val+-- | Note that the textual syntax changed in LLVM 10 (@callbr@ was introduced in+-- LLVM 9).+ppCallBr :: Type -> Value -> [Typed Value] -> BlockLabel -> Fmt [BlockLabel]+ppCallBr ty f args to indirectDests =+  "callbr"+     <+> ppCallSym ty f <> parens (commas (map (ppTyped ppValue) args))+     <+> "to" <+> ppLab to <+> brackets (commas (map ppLab indirectDests))+  where+    ppLab l = ppType (PrimType Label) <+> ppLabel l -ppGEP :: LLVM => Bool -> Typed Value -> [Typed Value] -> Doc-ppGEP ib ptr ixs = "getelementptr" <+> inbounds-               <+> (if isImplicit then empty else explicit)-               <+> commas (map (ppTyped ppValue) (ptr:ixs))+-- | Print out the @<ty>|<fnty> <fnptrval>@ portion of a @call@, @callbr@, or+-- @invoke@ instruction, where:+--+-- * @<ty>@ is the return type.+--+-- * @<fnty>@ is the overall function type.+--+-- * @<fnptrval>@ is a pointer value, where the memory it points to is treated+--   as a value of type @<fnty>@.+--+-- The LLVM Language Reference Manual indicates that either @<ty>@ or @<fnty>@+-- can be used, but in practice, @<ty>@ is typically preferred unless the+-- function type involves varargs. We adopt the same convention here.+ppCallSym :: Type -> Fmt Value+ppCallSym ty val = pp_ty <+> ppValue val   where-  isImplicit = checkConfig cfgGEPImplicitType+    pp_ty =+      case ty of+        FunTy res args va+          |  va+          -> ppType res <+> ppArgList va (map ppType args)+          |  otherwise+          -> ppType res+        _ -> ppType ty -  explicit =-    case typedType ptr of-      PtrTo ty -> ppType ty <> comma-      ty       -> ppType ty <> comma+ppGEP :: Bool -> Type -> Typed Value -> Fmt [Typed Value]+ppGEP ib ty ptr ixs =+  "getelementptr" <+> inbounds+    <+> (if isExplicit then explicit else empty)+    <+> commas (map (ppTyped ppValue) (ptr:ixs))+  where+  isExplicit = llvmVer >= llvmV3_7 +  explicit = ppType ty <> comma+   inbounds | ib        = "inbounds"            | otherwise = empty -ppInvoke :: LLVM => Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc+ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> Fmt BlockLabel ppInvoke ty f args to uw = body   where-  body = "invoke" <+> ppType ty <+> ppValue f+  body = "invoke" <+> ppCallSym ty f       <> parens (commas (map (ppTyped ppValue) args))      <+> "to" <+> ppType (PrimType Label) <+> ppLabel to      <+> "unwind" <+> ppType (PrimType Label) <+> ppLabel uw -ppPhiArg :: LLVM => (Value,BlockLabel) -> Doc+ppPhiArg :: Fmt (Value,BlockLabel) ppPhiArg (v,l) = char '[' <+> ppValue v <> comma <+> ppLabel l <+> char ']' -ppICmpOp :: ICmpOp -> Doc+ppICmpOp :: Fmt ICmpOp ppICmpOp Ieq  = "eq" ppICmpOp Ine  = "ne" ppICmpOp Iugt = "ugt"@@ -697,7 +791,7 @@ ppICmpOp Islt = "slt" ppICmpOp Isle = "sle" -ppFCmpOp :: FCmpOp -> Doc+ppFCmpOp :: Fmt FCmpOp ppFCmpOp Ffalse = "false" ppFCmpOp Foeq   = "oeq" ppFCmpOp Fogt   = "ogt"@@ -715,7 +809,7 @@ ppFCmpOp Funo   = "uno" ppFCmpOp Ftrue  = "true" -ppValue' :: LLVM => (i -> Doc) -> Value' i -> Doc+ppValue' :: Fmt i -> Fmt (Value' i) ppValue' pp val = case val of   ValInteger i       -> integer i   ValBool b          -> ppBool b@@ -726,7 +820,7 @@     -- https://llvm.org/docs/LangRef.html#simple-constants     let pad n | n < 0x10  = shows (0::Int) . showHex n               | otherwise = showHex n-        fld v i = pad $ v `shiftR` (i * 8)+        fld v i = pad ((v `shiftR` (i * 8)) .&. 0xff)     in "0xK" <> text (foldr (fld e) (foldr (fld s) "" $ reverse [0..7::Int]) [1, 0])   ValIdent i         -> ppIdent i   ValSymbol s        -> ppSymbol s@@ -745,11 +839,12 @@   ValZeroInit        -> "zeroinitializer"   ValAsm s a i c     -> ppAsm s a i c   ValMd m            -> ppValMd' pp m+  ValPoison          -> "poison" -ppValue :: LLVM => Value -> Doc+ppValue :: Fmt Value ppValue = ppValue' ppLabel -ppValMd' :: LLVM => (i -> Doc) -> ValMd' i -> Doc+ppValMd' :: Fmt i -> Fmt (ValMd' i) ppValMd' pp m = case m of   ValMdString str   -> ppMetadata (ppStringLiteral str)   ValMdValue tv     -> ppTyped (ppValue' pp) tv@@ -758,12 +853,12 @@   ValMdLoc l        -> ppDebugLoc' pp l   ValMdDebugInfo di -> ppDebugInfo' pp di -ppValMd :: LLVM => ValMd -> Doc+ppValMd :: Fmt ValMd ppValMd = ppValMd' ppLabel -ppDebugLoc' :: LLVM => (i -> Doc) -> DebugLoc' i -> Doc-ppDebugLoc' pp dl = (if cfgUseDILocation ?config then "!DILocation"-                                                 else "!MDLocation")+ppDebugLoc' :: Fmt i -> Fmt (DebugLoc' i)+ppDebugLoc' pp dl = (if llvmVer >= llvmV3_7 then "!DILocation"+                                            else "!MDLocation")              <> parens (commas [ "line:"   <+> integral (dlLine dl)                                , "column:" <+> integral (dlCol dl)                                , "scope:"  <+> ppValMd' pp (dlScope dl)@@ -775,23 +870,23 @@            Nothing -> empty   mbImplicit = if dlImplicit dl then comma <+> "implicit" else empty -ppDebugLoc :: LLVM => DebugLoc -> Doc+ppDebugLoc :: Fmt DebugLoc ppDebugLoc = ppDebugLoc' ppLabel -ppTypedValMd :: LLVM => ValMd -> Doc+ppTypedValMd :: Fmt ValMd ppTypedValMd  = ppTyped ppValMd . Typed (PrimType Metadata) -ppMetadata :: Doc -> Doc+ppMetadata :: Fmt Doc ppMetadata body = char '!' <> body -ppMetadataNode' :: LLVM => (i -> Doc) -> [Maybe (ValMd' i)] -> Doc+ppMetadataNode' :: Fmt i -> Fmt [Maybe (ValMd' i)] ppMetadataNode' pp vs = ppMetadata (braces (commas (map arg vs)))   where arg = maybe ("null") (ppValMd' pp) -ppMetadataNode :: LLVM => [Maybe ValMd] -> Doc+ppMetadataNode :: Fmt [Maybe ValMd] ppMetadataNode = ppMetadataNode' ppLabel -ppStringLiteral :: String -> Doc+ppStringLiteral :: Fmt String ppStringLiteral  = doubleQuotes . text . concatMap escape   where   escape c | c == '"' || c == '\\'  = '\\' : showHex (fromEnum c) ""@@ -801,7 +896,7 @@   pad n | n < 0x10  = '0' : map toUpper (showHex n "")         | otherwise =       map toUpper (showHex n "") -ppAsm :: Bool -> Bool -> String -> String -> Doc+ppAsm :: Bool -> Bool -> String -> Fmt String ppAsm s a i c =   "asm" <+> sideeffect <+> alignstack         <+> ppStringLiteral i <> comma <+> ppStringLiteral c@@ -813,38 +908,39 @@              | otherwise = empty  -ppConstExpr' :: LLVM => (i -> Doc) -> ConstExpr' i -> Doc+ppConstExpr' :: Fmt i -> Fmt (ConstExpr' i) ppConstExpr' pp expr =   case expr of-    ConstGEP inb _mix mp ixs  ->+    ConstGEP inb _mix ty ptr ixs  ->       "getelementptr"         <+> opt inb "inbounds"-        <+> parens (mcommas ((ppType <$> mp) : (map (pure . ppTyp') ixs)))+        <+> parens (commas (ppType ty : map ppTyp' (ptr:ixs)))     ConstConv op tv t  -> ppConvOp op <+> parens (ppTyp' tv <+> "to" <+> ppType t)     ConstSelect c l r  ->       "select" <+> parens (commas [ ppTyp' c, ppTyp' l , ppTyp' r])-    ConstBlockAddr t l -> "blockaddress" <+> parens (ppSymbol t <> comma <+> pp l)-    ConstFCmp  op a b  -> "fcmp" <+> ppFCmpOp op <+> ppTupleT a b-    ConstICmp  op a b  -> "icmp" <+> ppICmpOp op <+> ppTupleT a b-    ConstArith op a b  -> ppArithOp op <+> ppTuple a b-    ConstBit   op a b  -> ppBitOp op   <+> ppTuple a b+    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+    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   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' -ppConstExpr :: LLVM => ConstExpr -> Doc+ppConstExpr :: Fmt ConstExpr ppConstExpr = ppConstExpr' ppLabel  -- DWARF Debug Info ------------------------------------------------------------ -ppDebugInfo' :: LLVM => (i -> Doc) -> DebugInfo' i -> Doc+ppDebugInfo' :: Fmt i -> Fmt (DebugInfo' i) ppDebugInfo' pp di = case di of   DebugInfoBasicType bt         -> ppDIBasicType bt   DebugInfoCompileUnit cu       -> ppDICompileUnit' pp cu   DebugInfoCompositeType ct     -> ppDICompositeType' pp ct   DebugInfoDerivedType dt       -> ppDIDerivedType' pp dt-  DebugInfoEnumerator nm v      -> ppDIEnumerator nm v+  DebugInfoEnumerator nm v u    -> ppDIEnumerator nm v u   DebugInfoExpression e         -> ppDIExpression e   DebugInfoFile f               -> ppDIFile f   DebugInfoGlobalVariable gv    -> ppDIGlobalVariable' pp gv@@ -853,18 +949,20 @@   DebugInfoLexicalBlockFile lbf -> ppDILexicalBlockFile' pp lbf   DebugInfoLocalVariable lv     -> ppDILocalVariable' pp lv   DebugInfoSubprogram sp        -> ppDISubprogram' pp sp-  DebugInfoSubrange sr          -> ppDISubrange sr+  DebugInfoSubrange sr          -> ppDISubrange' pp sr   DebugInfoSubroutineType st    -> ppDISubroutineType' pp st   DebugInfoNameSpace ns         -> ppDINameSpace' pp ns   DebugInfoTemplateTypeParameter dttp  -> ppDITemplateTypeParameter' pp dttp   DebugInfoTemplateValueParameter dtvp -> ppDITemplateValueParameter' pp dtvp   DebugInfoImportedEntity diip         -> ppDIImportedEntity' pp diip   DebugInfoLabel dil            -> ppDILabel' pp dil+  DebugInfoArgList args         -> ppDIArgList' pp args+  DebugInfoAssignID             -> "!DIAssignID()" -ppDebugInfo :: LLVM => DebugInfo -> Doc+ppDebugInfo :: Fmt DebugInfo ppDebugInfo = ppDebugInfo' ppLabel -ppDIImportedEntity' :: LLVM => (i -> Doc) -> DIImportedEntity' i -> Doc+ppDIImportedEntity' :: Fmt i -> Fmt (DIImportedEntity' i) ppDIImportedEntity' pp ie = "!DIImportedEntity"   <> parens (mcommas [ pure ("tag:"    <+> integral (diieTag ie))                      , (("scope:"  <+>) . ppValMd' pp) <$> diieScope ie@@ -874,21 +972,21 @@                      , (("name:"   <+>) . text)        <$> diieName ie                      ]) -ppDIImportedEntity :: LLVM => DIImportedEntity -> Doc+ppDIImportedEntity :: Fmt DIImportedEntity ppDIImportedEntity = ppDIImportedEntity' ppLabel -ppDILabel' :: LLVM => (i -> Doc) -> DILabel' i -> Doc+ppDILabel' :: Fmt i -> Fmt (DILabel' i) ppDILabel' pp ie = "!DILabel"   <> parens (mcommas [ (("scope:"  <+>) . ppValMd' pp) <$> dilScope ie-                     , pure ("name:" <+> text (dilName ie))+                     , pure ("name:" <+> ppStringLiteral (dilName ie))                      , (("file:"   <+>) . ppValMd' pp) <$> dilFile ie                      , pure ("line:"   <+> integral (dilLine ie))                      ]) -ppDILabel :: LLVM => DILabel -> Doc+ppDILabel :: Fmt DILabel ppDILabel = ppDILabel' ppLabel -ppDINameSpace' :: LLVM => (i -> Doc) -> DINameSpace' i -> Doc+ppDINameSpace' :: Fmt i -> Fmt (DINameSpace' i) ppDINameSpace' pp ns = "!DINameSpace"   <> parens (mcommas [ ("name:"   <+>) . text <$> (dinsName ns)                      , pure ("scope:"  <+> ppValMd' pp (dinsScope ns))@@ -896,19 +994,19 @@                      , pure ("line:"   <+> integral (dinsLine ns))                      ]) -ppDINameSpace :: LLVM => DINameSpace -> Doc+ppDINameSpace :: Fmt DINameSpace ppDINameSpace = ppDINameSpace' ppLabel -ppDITemplateTypeParameter' :: LLVM => (i -> Doc) -> DITemplateTypeParameter' i -> Doc+ppDITemplateTypeParameter' :: Fmt i -> Fmt (DITemplateTypeParameter' i) ppDITemplateTypeParameter' pp tp = "!DITemplateTypeParameter"   <> parens (mcommas [ ("name:"  <+>) . text        <$> dittpName tp                      , ("type:"  <+>) . ppValMd' pp <$> dittpType tp                      ]) -ppDITemplateTypeParameter :: LLVM => DITemplateTypeParameter -> Doc+ppDITemplateTypeParameter :: Fmt DITemplateTypeParameter ppDITemplateTypeParameter = ppDITemplateTypeParameter' ppLabel -ppDITemplateValueParameter' :: LLVM => (i -> Doc) -> DITemplateValueParameter' i -> Doc+ppDITemplateValueParameter' :: Fmt i -> Fmt (DITemplateValueParameter' i) ppDITemplateValueParameter' pp vp = "!DITemplateValueParameter"   <> parens (mcommas [ pure ("tag:"   <+> integral (ditvpTag vp))                      , ("name:"  <+>) . text        <$> ditvpName vp@@ -916,10 +1014,10 @@                      , pure ("value:" <+> ppValMd' pp (ditvpValue vp))                      ]) -ppDITemplateValueParameter :: LLVM => DITemplateValueParameter -> Doc+ppDITemplateValueParameter :: Fmt DITemplateValueParameter ppDITemplateValueParameter = ppDITemplateValueParameter' ppLabel -ppDIBasicType :: DIBasicType -> Doc+ppDIBasicType :: Fmt DIBasicType ppDIBasicType bt = "!DIBasicType"   <> parens (commas [ "tag:"      <+> integral (dibtTag bt)                     , "name:"     <+> doubleQuotes (text (dibtName bt))@@ -932,35 +1030,48 @@               Just flags -> comma <+> "flags:" <+> integral flags               Nothing -> empty -ppDICompileUnit' :: LLVM => (i -> Doc) -> DICompileUnit' i -> Doc+ppDICompileUnit' :: Fmt i -> Fmt (DICompileUnit' i) ppDICompileUnit' pp cu = "!DICompileUnit"-  <> parens (mcommas-       [ pure ("language:"           <+> integral (dicuLanguage cu))-       ,     (("file:"               <+>) . ppValMd' pp) <$> (dicuFile cu)-       ,     (("producer:"           <+>) . doubleQuotes . text)+  <> parens (mcommas $+       [ pure ("language:"              <+> integral (dicuLanguage cu))+       ,     (("file:"                  <+>) . ppValMd' pp) <$> (dicuFile cu)+       ,     (("producer:"              <+>) . doubleQuotes . text)              <$> (dicuProducer cu)-       , pure ("isOptimized:"        <+> ppBool (dicuIsOptimized cu))-       , pure ("flags:"              <+> ppFlags (dicuFlags cu))-       , pure ("runtimeVersion:"     <+> integral (dicuRuntimeVersion cu))-       ,     (("splitDebugFilename:" <+>) . doubleQuotes . text)+       , pure ("isOptimized:"           <+> ppBool (dicuIsOptimized cu))+       , pure ("flags:"                 <+> ppFlags (dicuFlags cu))+       , pure ("runtimeVersion:"        <+> integral (dicuRuntimeVersion cu))+       ,     (("splitDebugFilename:"    <+>) . doubleQuotes . text)              <$> (dicuSplitDebugFilename cu)-       , pure ("emissionKind:"       <+> integral (dicuEmissionKind cu))-       ,     (("enums:"              <+>) . ppValMd' pp) <$> (dicuEnums cu)-       ,     (("retainedTypes:"      <+>) . ppValMd' pp) <$> (dicuRetainedTypes cu)-       ,     (("subprograms:"        <+>) . ppValMd' pp) <$> (dicuSubprograms cu)-       ,     (("globals:"            <+>) . ppValMd' pp) <$> (dicuGlobals cu)-       ,     (("imports:"            <+>) . ppValMd' pp) <$> (dicuImports cu)-       ,     (("macros:"             <+>) . ppValMd' pp) <$> (dicuMacros cu)-       , pure ("dwoId:"              <+> integral (dicuDWOId cu))-       ])+       , pure ("emissionKind:"          <+> integral (dicuEmissionKind cu))+       ,     (("enums:"                 <+>) . ppValMd' pp) <$> (dicuEnums cu)+       ,     (("retainedTypes:"         <+>) . ppValMd' pp) <$> (dicuRetainedTypes cu)+       ,     (("subprograms:"           <+>) . ppValMd' pp) <$> (dicuSubprograms cu)+       ,     (("globals:"               <+>) . ppValMd' pp) <$> (dicuGlobals cu)+       ,     (("imports:"               <+>) . ppValMd' pp) <$> (dicuImports cu)+       ,     (("macros:"                <+>) . ppValMd' pp) <$> (dicuMacros cu)+       , pure ("dwoId:"                 <+> integral (dicuDWOId cu))+       , pure ("splitDebugInlining:"    <+> ppBool (dicuSplitDebugInlining cu))+       , pure ("debugInfoForProfiling:" <+> ppBool (dicuDebugInfoForProf cu))+       , pure ("nameTableKind:"         <+> integral (dicuNameTableKind cu))+       ]+       +++       when' (llvmVer >= 11)+       [ pure ("rangesBaseAddress:"     <+> ppBool (dicuRangesBaseAddress cu))+       ,     (("sysroot:"               <+>) . doubleQuotes . text)+             <$> (dicuSysRoot cu)+       ,     (("sdk:"                   <+>) . doubleQuotes . text)+             <$> (dicuSDK cu)+       ]+       ) -ppDICompileUnit :: LLVM => DICompileUnit -> Doc++ppDICompileUnit :: Fmt DICompileUnit ppDICompileUnit = ppDICompileUnit' ppLabel -ppFlags :: Maybe String -> Doc+ppFlags :: Fmt (Maybe String) ppFlags mb = doubleQuotes (maybe empty text mb) -ppDICompositeType' :: LLVM => (i -> Doc) -> DICompositeType' i -> Doc+ppDICompositeType' :: Fmt i -> Fmt (DICompositeType' i) ppDICompositeType' pp ct = "!DICompositeType"   <> parens (mcommas        [ pure ("tag:"            <+> integral (dictTag ct))@@ -979,46 +1090,54 @@        ,     (("identifier:"     <+>) . doubleQuotes . text)              <$> (dictIdentifier ct)        ,     (("discriminator:"  <+>) . ppValMd' pp) <$> (dictDiscriminator ct)+       ,     (("associated:"     <+>) . ppValMd' pp) <$> (dictAssociated ct)+       ,     (("allocated:"      <+>) . ppValMd' pp) <$> (dictAllocated ct)+       ,     (("rank:"           <+>) . ppValMd' pp) <$> (dictRank ct)+       ,     (("annotations:"    <+>) . ppValMd' pp) <$> (dictAnnotations ct)        ]) -ppDICompositeType :: LLVM => DICompositeType -> Doc+ppDICompositeType :: Fmt DICompositeType ppDICompositeType = ppDICompositeType' ppLabel -ppDIDerivedType' :: LLVM => (i -> Doc) -> DIDerivedType' i -> Doc+ppDIDerivedType' :: Fmt i -> Fmt (DIDerivedType' i) ppDIDerivedType' pp dt = "!DIDerivedType"   <> parens (mcommas        [ pure ("tag:"       <+> integral (didtTag dt))        ,     (("name:"      <+>) . doubleQuotes . text) <$> (didtName dt)        ,     (("file:"      <+>) . ppValMd' pp) <$> (didtFile dt)        , pure ("line:"      <+> integral (didtLine dt))+       ,     (("scope:"     <+>) . ppValMd' pp) <$> (didtScope dt)        ,      ("baseType:"  <+>) <$> (ppValMd' pp <$> didtBaseType dt <|> Just "null")        , pure ("size:"      <+> integral (didtSize dt))        , pure ("align:"     <+> integral (didtAlign dt))        , pure ("offset:"    <+> integral (didtOffset dt))        , pure ("flags:"     <+> integral (didtFlags dt))        ,     (("extraData:" <+>) . ppValMd' pp) <$> (didtExtraData dt)+       ,     (("dwarfAddressSpace:" <+>) . integral) <$> didtDwarfAddressSpace dt+       ,     (("annotations:" <+>) . ppValMd' pp) <$> (didtAnnotations dt)        ]) -ppDIDerivedType :: LLVM => DIDerivedType -> Doc+ppDIDerivedType :: Fmt DIDerivedType ppDIDerivedType = ppDIDerivedType' ppLabel -ppDIEnumerator :: String -> Int64 -> Doc-ppDIEnumerator n v = "!DIEnumerator"+ppDIEnumerator :: String -> Integer -> Fmt Bool+ppDIEnumerator n v u = "!DIEnumerator"   <> parens (commas [ "name:"  <+> doubleQuotes (text n)                     , "value:" <+> integral v+                    , "isUnsigned:" <+> ppBool u                     ]) -ppDIExpression :: DIExpression -> Doc+ppDIExpression :: Fmt DIExpression ppDIExpression e = "!DIExpression"   <> parens (commas (map integral (dieElements e))) -ppDIFile :: DIFile -> Doc+ppDIFile :: Fmt DIFile ppDIFile f = "!DIFile"   <> parens (commas [ "filename:"  <+> doubleQuotes (text (difFilename f))                     , "directory:" <+> doubleQuotes (text (difDirectory f))                     ]) -ppDIGlobalVariable' :: LLVM => (i -> Doc) -> DIGlobalVariable' i -> Doc+ppDIGlobalVariable' :: Fmt i -> Fmt (DIGlobalVariable' i) ppDIGlobalVariable' pp gv = "!DIGlobalVariable"   <> parens (mcommas        [      (("scope:"       <+>) . ppValMd' pp) <$> (digvScope gv)@@ -1033,22 +1152,23 @@        ,      (("variable:"    <+>) . ppValMd' pp) <$> (digvVariable gv)        ,      (("declaration:" <+>) . ppValMd' pp) <$> (digvDeclaration gv)        ,      (("align:"       <+>) . integral) <$> digvAlignment gv+       ,      (("annotations:" <+>) . ppValMd' pp) <$> (digvAnnotations gv)        ]) -ppDIGlobalVariable :: LLVM => DIGlobalVariable -> Doc+ppDIGlobalVariable :: Fmt DIGlobalVariable ppDIGlobalVariable = ppDIGlobalVariable' ppLabel -ppDIGlobalVariableExpression' :: LLVM => (i -> Doc) -> DIGlobalVariableExpression' i -> Doc+ppDIGlobalVariableExpression' :: Fmt i -> Fmt (DIGlobalVariableExpression' i) ppDIGlobalVariableExpression' pp gve = "!DIGlobalVariableExpression"   <> parens (mcommas        [      (("var:"  <+>) . ppValMd' pp) <$> (digveVariable gve)        ,      (("expr:" <+>) . ppValMd' pp) <$> (digveExpression gve)        ]) -ppDIGlobalVariableExpression :: LLVM => DIGlobalVariableExpression -> Doc+ppDIGlobalVariableExpression :: Fmt DIGlobalVariableExpression ppDIGlobalVariableExpression = ppDIGlobalVariableExpression' ppLabel -ppDILexicalBlock' :: LLVM => (i -> Doc) -> DILexicalBlock' i -> Doc+ppDILexicalBlock' :: Fmt i -> Fmt (DILexicalBlock' i) ppDILexicalBlock' pp ct = "!DILexicalBlock"   <> parens (mcommas        [     (("scope:"  <+>) . ppValMd' pp) <$> (dilbScope ct)@@ -1057,10 +1177,10 @@        , pure ("column:" <+> integral (dilbColumn ct))        ]) -ppDILexicalBlock :: LLVM => DILexicalBlock -> Doc+ppDILexicalBlock :: Fmt DILexicalBlock ppDILexicalBlock = ppDILexicalBlock' ppLabel -ppDILexicalBlockFile' :: LLVM => (i -> Doc) -> DILexicalBlockFile' i -> Doc+ppDILexicalBlockFile' :: Fmt i -> Fmt (DILexicalBlockFile' i) ppDILexicalBlockFile' pp lbf = "!DILexicalBlockFile"   <> parens (mcommas        [ pure ("scope:"         <+> ppValMd' pp (dilbfScope lbf))@@ -1068,10 +1188,10 @@        , pure ("discriminator:" <+> integral (dilbfDiscriminator lbf))        ]) -ppDILexicalBlockFile :: LLVM => DILexicalBlockFile -> Doc+ppDILexicalBlockFile :: Fmt DILexicalBlockFile ppDILexicalBlockFile = ppDILexicalBlockFile' ppLabel -ppDILocalVariable' :: LLVM => (i -> Doc) -> DILocalVariable' i -> Doc+ppDILocalVariable' :: Fmt i -> Fmt (DILocalVariable' i) ppDILocalVariable' pp lv = "!DILocalVariable"   <> parens (mcommas        [      (("scope:" <+>) . ppValMd' pp) <$> (dilvScope lv)@@ -1081,13 +1201,18 @@        ,      (("type:"  <+>) . ppValMd' pp) <$> (dilvType lv)        , pure ("arg:"    <+> integral (dilvArg lv))        , pure ("flags:"  <+> integral (dilvFlags lv))+       ,      (("align:" <+>) . integral) <$> dilvAlignment lv+       ,      (("annotations:" <+>) . ppValMd' pp) <$> (dilvAnnotations lv)        ]) -ppDILocalVariable :: LLVM => DILocalVariable -> Doc+ppDILocalVariable :: Fmt DILocalVariable ppDILocalVariable = ppDILocalVariable' ppLabel  -- | See @writeDISubprogram@ in the LLVM source, in the file @AsmWriter.cpp@-ppDISubprogram' :: LLVM => (i -> Doc) -> DISubprogram' i -> Doc+--+-- Note that the textual syntax changed in LLVM 7, as the @retainedNodes@ field+-- was called @variables@ in previous LLVM versions.+ppDISubprogram' :: Fmt i -> Fmt (DISubprogram' i) ppDISubprogram' pp sp = "!DISubprogram"   <> parens (mcommas        [      (("scope:"          <+>) . ppValMd' pp) <$> (dispScope sp)@@ -1108,63 +1233,115 @@        ,      (("unit:"           <+>) . ppValMd' pp) <$> (dispUnit sp)        ,      (("templateParams:" <+>) . ppValMd' pp) <$> (dispTemplateParams sp)        ,      (("declaration:"    <+>) . ppValMd' pp) <$> (dispDeclaration sp)-       ,      (("variables:"      <+>) . ppValMd' pp) <$> (dispVariables sp)+       ,      (("retainedNodes:"  <+>) . ppValMd' pp) <$> (dispRetainedNodes sp)        ,      (("thrownTypes:"    <+>) . ppValMd' pp) <$> (dispThrownTypes sp)+       ,      (("annotations:"    <+>) . ppValMd' pp) <$> (dispAnnotations sp)        ]) -ppDISubprogram :: LLVM => DISubprogram -> Doc+ppDISubprogram :: Fmt DISubprogram ppDISubprogram = ppDISubprogram' ppLabel -ppDISubrange :: DISubrange -> Doc-ppDISubrange sr = "!DISubrange"-  <> parens (commas [ "count:" <+> integral (disrCount sr)-                    , "lowerBound:" <+> integral (disrLowerBound sr)-                    ])+ppDISubrange' :: Fmt i -> Fmt (DISubrange' i)+ppDISubrange' pp sr =+  "!DISubrange"+  <> parens+  (mcommas+   -- LLVM < 7: count and lowerBound as signed int 64+   -- LLVM < 11: count as ValMd, lowerBound as signed in 64+   -- LLVM >= 11: ValMd of count, lowerBound, upperBound, and stride+   -- Valid through LLVM 17.+   -- See AST.hs description for more details on the structure.+   -- See https://github.com/llvm/llvm-project/blob/431969e/llvm/lib/IR/AsmWriter.cpp#L1888-L1927+   -- for more details on output generation.+   [+     (("count:" <+>) . ppInt64ValMd' (llvmVer >= 7) pp) <$> disrCount sr+   , (("lowerBound:" <+>) . ppInt64ValMd' (llvmVer >= 11) pp) <$> disrLowerBound sr+   , when' (llvmVer >= 11)+     $ (("upperBound:" <+>) . ppInt64ValMd' True pp) <$> disrUpperBound sr+   , when' (llvmVer >= 11)+     $ (("stride:" <+>) . ppInt64ValMd' True pp) <$> disrStride sr+   ]) -ppDISubroutineType' :: LLVM => (i -> Doc) -> DISubroutineType' i -> Doc+ppDISubrange :: Fmt DISubrange+ppDISubrange = ppDISubrange' ppLabel++ppDISubroutineType' :: Fmt i -> Fmt (DISubroutineType' i) ppDISubroutineType' pp st = "!DISubroutineType"   <> parens (commas        [ "flags:" <+> integral (distFlags st)        , "types:" <+> fromMaybe "null" (ppValMd' pp <$> (distTypeArray st))        ]) -ppDISubroutineType :: LLVM => DISubroutineType -> Doc+ppDISubroutineType :: Fmt DISubroutineType ppDISubroutineType = ppDISubroutineType' ppLabel +ppDIArgList' :: Fmt i -> Fmt (DIArgList' i)+ppDIArgList' pp args = "!DIArgList"+  <> parens (commas (map (ppValMd' pp) (dialArgs args)))++ppDIArgList :: Fmt DIArgList+ppDIArgList = ppDIArgList' ppLabel+ -- Utilities ------------------------------------------------------------------- -ppBool :: Bool -> Doc+ppBool :: Fmt Bool ppBool b | b         = "true"          | otherwise = "false"  -- | Build a variable-argument argument list.-ppArgList :: Bool -> [Doc] -> Doc+ppArgList :: Bool -> Fmt [Doc] ppArgList True  ds = parens (commas (ds ++ ["..."])) ppArgList False ds = parens (commas ds) -integral :: Integral i => i -> Doc+integral :: Integral i => Fmt i integral  = integer . fromIntegral -hex :: (Integral i, Show i) => i -> Doc+hex :: (Integral i, Show i) => Fmt i hex i = text (showHex i "0x") -opt :: Bool -> Doc -> Doc+opt :: Bool -> Fmt Doc opt True  = id opt False = const empty -commas :: [Doc] -> Doc+-- | Print a ValMd' value as a plain signed integer (Int64) if possible.  If the+-- ValMd' is not representable as an Int64, defer to ValMd' printing (if+-- canFallBack is True) or print nothing (for when a ValMd is not a valid+-- representation).++ppInt64ValMd' :: Bool -> Fmt i -> Fmt (ValMd' i)+ppInt64ValMd' canFallBack pp = go+  where go = \case+          ValMdValue tv+            | PrimType (Integer _) <- typedType tv+            , ValInteger i <- typedValue tv+              -> 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+              Just v -> go v+          o@(ValMdDebugInfo (DebugInfoGlobalVariableExpression expr)) ->+            case digveExpression expr of+              Nothing -> when' canFallBack $ ppValMd' pp o+              Just e -> go e+          ValMdDebugInfo (DebugInfoLocalVariable lv) ->+            integer $ fromIntegral $ dilvArg lv  -- ??+          -- ValMdRef _idx -> mempty -- no table here to look this up...+          o -> when' canFallBack $ ppValMd' pp o+++commas :: Fmt [Doc] commas  = fsep . punctuate comma  -- | Helpful for all of the optional fields that appear in the -- metadata values-mcommas :: [Maybe Doc] -> Doc+mcommas :: Fmt [Maybe Doc] mcommas = commas . catMaybes -angles :: Doc -> Doc+angles :: Fmt Doc angles d = char '<' <> d <> char '>' -structBraces :: Doc -> Doc+structBraces :: Fmt Doc structBraces body = char '{' <+> body <+> char '}' -ppMaybe :: (a -> Doc) -> Maybe a -> Doc+ppMaybe :: Fmt a -> Fmt (Maybe a) ppMaybe  = maybe empty

@@ -73,6 +73,7 @@       , angles (braces (PackedStruct <$> pTypeList) <|> spaced (pNumType Vector))       , string "opaque" >> return Opaque       , PrimType <$> pPrimType+      , string "ptr" >> return PtrOpaque       ]      pTypeList :: Parser [Type]

@@ -0,0 +1,17 @@+{- |+Module      : Text.LLVM.Triple+Description : AST, parsing, and printing of LLVM target triples.+License     : BSD3+Maintainer  : Langston Barrett+Stability   : experimental+-}++module Text.LLVM.Triple+  ( module Text.LLVM.Triple.AST+  , module Text.LLVM.Triple.Parse+  , module Text.LLVM.Triple.Print+  ) where++import Text.LLVM.Triple.AST+import Text.LLVM.Triple.Parse+import Text.LLVM.Triple.Print

@@ -0,0 +1,467 @@+{- |+Module      : Text.LLVM.Triple.AST+Description : AST of LLVM target triples.+License     : BSD3+Maintainer  : Langston Barrett+Stability   : experimental+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData #-}++module Text.LLVM.Triple.AST+  ( Arch(..)+  , SubArch(..)+  , Vendor(..)+  , OS(..)+  , Environment(..)+  , ObjectFormat(..)+  , TargetTriple(..)+  ) where++import Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++-- | The constructors of this type exactly mirror the LLVM @enum ArchType@,+-- including inconsistent labeling of endianness. Capitalization is taken from+-- the LLVM comments, which are reproduced below.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L46+data Arch+  = UnknownArch+    -- | ARM (little endian): arm armv.* xscale+  | ARM+    -- | ARM (big endian): armeb+  | ARMEB+    -- | AArch64 (little endian): aarch64+  | AArch64+    -- | AArch64 (big endian): aarch64_be+  | AArch64_BE+    -- | AArch64 (little endian) ILP32: aarch64_32+  | AArch64_32+    -- | ARC: Synopsys ARC+  | ARC+    -- | AVR: Atmel AVR microcontroller+  | AVR+    -- | eBPF or extended BPF or 64-bit BPF (little endian)+  | BPFEL+    -- | eBPF or extended BPF or 64-bit BPF (big endian)+  | BPFEB+    -- | CSKY: csky+  | CSKY+    -- | DXIL 32-bit DirectX bytecode+  | DXIL+    -- | Hexagon: hexagon+  | Hexagon+    -- | LoongArch (32-bit): loongarch32+  | LoongArch32+    -- | LoongArch (64-bit): loongarch64+  | LoongArch64+    -- | M68k: Motorola 680x0 family+  | M68k+    -- | MIPS: mips mipsallegrex mipsr6+  | MIPS+    -- | MIPSEL: mipsel mipsallegrexe mipsr6el+  | MIPSEL+    -- | MIPS64: mips64 mips64r6 mipsn32 mipsn32r6+  | MIPS64+    -- | MIPS64EL: mips64el mips64r6el mipsn32el mipsn32r6el+  | MIPS64EL+    -- | MSP430: msp430+  | MSP430+    -- | PPC: powerpc+  | PPC+    -- | PPCLE: powerpc (little endian)+  | PPCLE+    -- | PPC64: powerpc64 ppu+  | PPC64+    -- | PPC64LE: powerpc64le+  | PPC64LE+    -- | R600: AMD GPUs HD2XXX - HD6XXX+  | R600+    -- | AMDGCN: AMD GCN GPUs+  | AMDGCN+    -- | RISC-V (32-bit): riscv32+  | RISCV32+    -- | RISC-V (64-bit): riscv64+  | RISCV64+    -- | Sparc: sparc+  | Sparc+    -- | Sparcv9: Sparcv9+  | Sparcv9+    -- | Sparc: (endianness = little). NB: 'Sparcle' is a CPU variant+  | SparcEL+    -- | SystemZ: s390x+  | SystemZ+    -- | TCE (http://tce.cs.tut.fi/): tce+  | TCE+    -- | TCE little endian (http://tce.cs.tut.fi/): tcele+  | TCELE+    -- | Thumb (little endian): thumb thumbv.*+  | Thumb+    -- | Thumb (big endian): thumbeb+  | ThumbEB+    -- | X86: i[3-9]86+  | X86+    -- | X86-64: amd64 x86_64+  | X86_64+    -- | XCore: xcore+  | XCore+    -- | NVPTX: 32-bit+  | NVPTX+    -- | NVPTX: 64-bit+  | NVPTX64+    -- | le32: generic little-endian 32-bit CPU (PNaCl)+  | Le32+    -- | le64: generic little-endian 64-bit CPU (PNaCl)+  | Le64+    -- | AMDIL+  | AMDIL+    -- | AMDIL with 64-bit pointers+  | AMDIL64+    -- | AMD HSAIL+  | HSAIL+    -- | AMD HSAIL with 64-bit pointers+  | HSAIL64+    -- | SPIR: standard portable IR for OpenCL 32-bit version+  | SPIR+    -- | SPIR: standard portable IR for OpenCL 64-bit version+  | SPIR64+    -- | SPIR-V with 32-bit pointers+  | SPIRV32+    -- | SPIR-V with 64-bit pointers+  | SPIRV64+    -- | Kalimba: generic kalimba+  | Kalimba+    -- | SHAVE: Movidius vector VLIW processors+  | SHAVE+    -- | Lanai: Lanai 32-bit+  | Lanai+    -- | WebAssembly with 32-bit pointers+  | Wasm32+    -- | WebAssembly with 64-bit pointers+  | Wasm64+    -- | 32-bit RenderScript+  | RenderScript32 -- 32-bit RenderScript+    -- | 64-bit RenderScript+  | RenderScript64+    -- | NEC SX-Aurora Vector Engine+  | VE+  deriving (Bounded, Data, Eq, Enum, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownArch'.+instance Semigroup Arch where+  a <> UnknownArch{} = a+  UnknownArch{} <> b = b+  a <> _ = a++-- | @'mempty' == 'UnknownArch'@+instance Monoid Arch where+  mempty = UnknownArch++-- | The constructors of this type exactly mirror the LLVM @enum SubArchType@.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L110+data SubArch+  = NoSubArch+  | ARMSubArch_v9_3a+  | ARMSubArch_v9_2a+  | ARMSubArch_v9_1a+  | ARMSubArch_v9+  | ARMSubArch_v8_8a+  | ARMSubArch_v8_7a+  | ARMSubArch_v8_6a+  | ARMSubArch_v8_5a+  | ARMSubArch_v8_4a+  | ARMSubArch_v8_3a+  | ARMSubArch_v8_2a+  | ARMSubArch_v8_1a+  | ARMSubArch_v8+  | ARMSubArch_v8r+  | ARMSubArch_v8m_baseline+  | ARMSubArch_v8m_mainline+  | ARMSubArch_v8_1m_mainline+  | ARMSubArch_v7+  | ARMSubArch_v7em+  | ARMSubArch_v7m+  | ARMSubArch_v7s+  | ARMSubArch_v7k+  | ARMSubArch_v7ve+  | ARMSubArch_v6+  | ARMSubArch_v6m+  | ARMSubArch_v6k+  | ARMSubArch_v6t2+  | ARMSubArch_v5+  | ARMSubArch_v5te+  | ARMSubArch_v4t++  | AArch64SubArch_arm64e++  | KalimbaSubArch_v3+  | KalimbaSubArch_v4+  | KalimbaSubArch_v5++  | MipsSubArch_r6++  | PPCSubArch_spe++  | SPIRVSubArch_v10+  | SPIRVSubArch_v11+  | SPIRVSubArch_v12+  | SPIRVSubArch_v13+  | SPIRVSubArch_v14+  | SPIRVSubArch_v15+  deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'NoSubArch'.+instance Semigroup SubArch where+  a <> NoSubArch{} = a+  NoSubArch{} <> b = b+  a <> _ = a++-- | @'mempty' == 'NoSubArch'@+instance Monoid SubArch where+  mempty = NoSubArch++-- | The constructors of this type exactly mirror the LLVM @enum VendorType@,+-- including ordering and grouping.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L162+data Vendor+  = UnknownVendor+  | Apple+  | PC+  | SCEI+  | Freescale+  | IBM+  | ImaginationTechnologies+  | MipsTechnologies+  | NVIDIA+  | CSR+  | Myriad+  | AMD+  | Mesa+  | SUSE+  | OpenEmbedded+  deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownVendor'.+instance Semigroup Vendor where+  a <> UnknownVendor{} = a+  UnknownVendor{} <> b = b+  a <> _ = a++-- | @'mempty' == 'UnknownVendor'@+instance Monoid Vendor where+  mempty = UnknownVendor++-- | The constructors of this type exactly mirror the LLVM @enum OSType@,+-- including ordering and grouping.+--+-- End-of-line comments from LLVM are reproduced as constructor comments.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L181+data OS+  = UnknownOS+  | Ananas+  | CloudABI+  | Darwin+  | DragonFly+  | FreeBSD+  | Fuchsia+  | IOS+  | KFreeBSD+  | Linux+    -- | PS3+  | Lv2+  | MacOSX+  | NetBSD+  | OpenBSD+  | Solaris+  | Win32+  | ZOS+  | Haiku+  | Minix+  | RTEMS+    -- | Native Client+  | NaCl+  | AIX+    -- | NVIDIA CUDA+  | CUDA+    -- | NVIDIA OpenCL+  | NVCL+    -- | AMD HSA Runtime+  | AMDHSA+  | PS4+  | PS5+  | ELFIAMCU+    -- | Apple tvOS+  | TvOS+    -- | Apple watchOS+  | WatchOS+    -- | Apple DriverKit+  | DriverKit+  | Mesa3D+  | Contiki+    -- | AMD PAL Runtime+  | AMDPAL+    -- | HermitCore Unikernel/Multikernel+  | HermitCore+    -- | GNU/Hurd+  | Hurd+    -- | Experimental WebAssembly OS+  | WASI+  | Emscripten+    -- | DirectX ShaderModel+  | ShaderModel+  deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownOS'.+instance Semigroup OS where+  a <> UnknownOS{} = a+  UnknownOS{} <> b = b+  a <> _ = a++-- | @'mempty' == 'UnknownOS'@+instance Monoid OS where+  mempty = UnknownOS++-- | The constructors of this type exactly mirror the LLVM @enum+-- EnvironmentType@, including ordering and grouping.+--+-- End-of-line comments from LLVM are reproduced as constructor comments.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L224+data Environment+  = UnknownEnvironment++  | GNU+  | GNUABIN32+  | GNUABI64+  | GNUEABI+  | GNUEABIHF+  | GNUX32+  | GNUILP32+  | CODE16+  | EABI+  | EABIHF+  | Android+  | Musl+  | MuslEABI+  | MuslEABIHF+  | MuslX32++  | MSVC+  | Itanium+  | Cygnus+  | CoreCLR+    -- | Simulator variants of other systems e.g. Apple's iOS+  | Simulator+    -- | Mac Catalyst variant of Apple's iOS deployment target.+  | MacABI++  | Pixel+  | Vertex+  | Geometry+  | Hull+  | Domain+  | Compute+  | Library+  | RayGeneration+  | Intersection+  | AnyHit+  | ClosestHit+  | Miss+  | Callable+  | Mesh+  | Amplification+  deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownEnvironment'.+instance Semigroup Environment where+  a <> UnknownEnvironment{} = a+  UnknownEnvironment{} <> b = b+  a <> _ = a++-- | @'mempty' == 'UnknownEnvironment'@+instance Monoid Environment where+  mempty = UnknownEnvironment++-- | The constructors of this type exactly mirror the LLVM @enum+-- ObjectFormatType@, including ordering.+--+-- Last updated: LLVM 15.0.1:+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/ADT/Triple.h#L269+data ObjectFormat+  = UnknownObjectFormat+  | COFF+  | DXContainer+  | ELF+  | GOFF+  | MachO+  | SPIRV+  | Wasm+  | XCOFF+  deriving (Bounded, Data, Enum, Eq, Generic, Ord, Read, Show, Typeable)++-- | A 'First'-like semigroup instance that simply drops the RHS, unless the LHS+-- is 'UnknownObjectFormat'.+instance Semigroup ObjectFormat where+  a <> UnknownObjectFormat{} = a+  UnknownObjectFormat{} <> b = b+  a <> _ = a++-- | @'mempty' == 'UnknownObjectFormat'@+instance Monoid ObjectFormat where+  mempty = UnknownObjectFormat++-- | More like a sextuple than a triple, if you think about it.+--+-- The LLVM version of this holds onto the un-normalized string representation.+-- We discard it.+data TargetTriple+  = TargetTriple+    { ttArch :: Arch+    , ttSubArch :: SubArch+    , ttVendor :: Vendor+    , ttOS :: OS+    , ttEnv :: Environment+    , ttObjFmt :: ObjectFormat+    }+  deriving (Bounded, Data, Eq, Generic, Ord, Read, Show, Typeable)++-- | Combines fields pointwise.+instance Semigroup TargetTriple where+  tt <> tt' =+    TargetTriple+    { ttArch = ttArch tt <> ttArch tt'+    , ttSubArch = ttSubArch tt <> ttSubArch tt'+    , ttVendor = ttVendor tt <> ttVendor tt'+    , ttOS = ttOS tt <> ttOS tt'+    , ttEnv = ttEnv tt <> ttEnv tt'+    , ttObjFmt = ttObjFmt tt <> ttObjFmt tt'+    }++-- | Pointwise 'mempty'.+instance Monoid TargetTriple where+  mempty =+    TargetTriple+    { ttArch = mempty+    , ttSubArch = mempty+    , ttVendor = mempty+    , ttOS = mempty+    , ttEnv = mempty+    , ttObjFmt = mempty+    }

@@ -0,0 +1,294 @@+{- |+Module      : Text.LLVM.Triple.Parse+Description : Parsing of LLVM target triples.+License     : BSD3+Maintainer  : Langston Barrett+Stability   : experimental++The declarations appear in this module in the same order as in the LLVM source.+-}++{- Note [Implementation]++The very simplest parsing functions are implemented with the 'LookupTable'+structure. For anything more complex, we endeavor to closely mirror the+structure of LLVM's implementation. This will make the code more maintainable+when updating to newer versions of LLVM.++-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}++module Text.LLVM.Triple.Parse+  ( parseArch+  , parseVendor+  , parseOS+  , parseEnv+  , parseObjFmt+  , parseSubArch+  , parseTriple+  ) where++import qualified Data.List as List++import qualified MonadLib as M+import qualified MonadLib.Monads as M++import Text.LLVM.Triple.AST+import qualified Text.LLVM.Triple.Print as Print+import Text.LLVM.Triple.Parse.LookupTable+import qualified Text.LLVM.Triple.Parse.ARM as ARM++-- | @llvm::parseArch@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L442+parseArch :: String -> Arch+parseArch s =+  let mArch =+        -- See Note [Implementation] for the reasoning behind the strange structure.+        --+        -- It would be easy to forget to add patterns here when adding a new+        -- constructor to Arch, but we have exhaustive print-then-parse+        -- roundtrip tests to mitigate this risk.+        if | cases ["i386", "i486", "i586", "i686"] -> X86+           | cases ["i786", "i886", "i986"] -> X86+           | cases ["amd64", "x86_64", "x86_64h"] -> X86_64+           | cases ["powerpc", "powerpcspe", "ppc", "ppc32"] -> PPC+           | cases ["powerpcle", "ppcle", "ppc32le"] -> PPCLE+           | cases ["powerpc64", "ppu", "ppc64"] -> PPC64+           | cases ["powerpc64le", "ppc64le"] -> PPC64LE+           | cases ["xscale"] -> ARM+           | cases ["xscaleeb"] -> ARMEB+           | cases ["aarch64"] -> AArch64+           | cases ["aarch64_be"] -> AArch64_BE+           | cases ["aarch64_32"] -> AArch64_32+           | cases ["arc"] -> ARC+           | cases ["arm64"] -> AArch64+           | cases ["arm64_32"] -> AArch64_32+           | cases ["arm64e"] -> AArch64+           | cases ["arm"] -> ARM+           | cases ["armeb"] -> ARMEB+           | cases ["thumb"] -> Thumb+           | cases ["thumbeb"] -> ThumbEB+           | cases ["avr"] -> AVR+           | cases ["m68k"] -> M68k+           | cases ["msp430"] -> MSP430+           | cases ["mips", "mipseb", "mipsallegrex", "mipsisa32r6"+                   , "mipsr6"] -> MIPS+           | cases ["mipsel", "mipsallegrexel", "mipsisa32r6el", "mipsr6el"] -> MIPSEL+           | cases ["mips64", "mips64eb", "mipsn32", "mipsisa64r6"+                   , "mips64r6", "mipsn32r6"] -> MIPS64+           | cases ["mips64el", "mipsn32el", "mipsisa64r6el", "mips64r6el"+                   , "mipsn32r6el"] -> MIPS64EL+           | cases ["r600"] -> R600+           | cases ["amdgcn"] -> AMDGCN+           | cases ["riscv32"] -> RISCV32+           | cases ["riscv64"] -> RISCV64+           | cases ["hexagon"] -> Hexagon+           | cases ["s390x", "systemz"] -> SystemZ+           | cases ["sparc"] -> Sparc+           | cases ["sparcel"] -> SparcEL+           | cases ["sparcv9", "sparc64"] -> Sparcv9+           | cases ["tce"] -> TCE+           | cases ["tcele"] -> TCELE+           | cases ["xcore"] -> XCore+           | cases ["nvptx"] -> NVPTX+           | cases ["nvptx64"] -> NVPTX64+           | cases ["le32"] -> Le32+           | cases ["le64"] -> Le64+           | cases ["amdil"] -> AMDIL+           | cases ["amdil64"] -> AMDIL64+           | cases ["hsail"] -> HSAIL+           | cases ["hsail64"] -> HSAIL64+           | cases ["spir"] -> SPIR+           | cases ["spir64"] -> SPIR64+           | cases ["spirv32", "spirv32v1.0", "spirv32v1.1", "spirv32v1.2"+                   , "spirv32v1.3", "spirv32v1.4", "spirv32v1.5"] -> SPIRV32+           | cases ["spirv64", "spirv64v1.0", "spirv64v1.1", "spirv64v1.2"+                   , "spirv64v1.3", "spirv64v1.4", "spirv64v1.5"] -> SPIRV64+           | archPfx Kalimba -> Kalimba+           | cases ["lanai"] -> Lanai+           | cases ["renderscript32"] -> RenderScript32+           | cases ["renderscript64"] -> RenderScript64+           | cases ["shave"] -> SHAVE+           | cases ["ve"] -> VE+           | cases ["wasm32"] -> Wasm32+           | cases ["wasm64"] -> Wasm64+           | cases ["csky"] -> CSKY+           | cases ["loongarch32"] -> LoongArch32+           | cases ["loongarch64"] -> LoongArch64+           | cases ["dxil"] -> DXIL+           | otherwise -> UnknownArch+  in case mArch of+        UnknownArch ->+          if | archPfx ARM || archPfx Thumb || archPfx AArch64 ->+                 ARM.parseARMArch (ARM.ArchName s)+             | "bpf" `List.isPrefixOf` s -> parseBPFArch s+             | otherwise -> UnknownArch+        arch -> arch+  where+    cases = any (== s)+    archPfx arch = Print.archName arch `List.isPrefixOf` s++    -- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L292+    parseBPFArch arch =+      if arch == "bpf"+      -- The way that LLVM parses the arch for BPF depends on the endianness of+      -- the host in this case, which feels deeply wrong. We don't do that, not+      -- least since we're not in IO. We default to little-endian instead.+      then BPFEL+      else if | arch == "bpf_be" || arch == "bpfeb" -> BPFEB+              | arch == "bpf_le" || arch == "bpfel" -> BPFEL+              | otherwise -> UnknownArch++-- | @llvm::parseVendor@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L529+parseVendor :: String -> Vendor+parseVendor = lookupWithDefault table UnknownVendor+  where table = enumTable Print.vendorName++-- | @llvm::parseOS@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L549+parseOS :: String -> OS+parseOS = lookupByPrefixWithDefault table UnknownOS+  where table = enumTable Print.osName++-- | @llvm::parseEnvironment@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L593+parseEnv :: String -> Environment+parseEnv = lookupByPrefixWithDefault table UnknownEnvironment+  where table = enumTable Print.envName++-- | @llvm::parseFormat@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L634+parseObjFmt :: String -> ObjectFormat+parseObjFmt = lookupBySuffixWithDefault table UnknownObjectFormat+  where table = enumTable Print.objFmtName++-- | @llvm::parseSubArch@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L648+parseSubArch :: String -> SubArch+parseSubArch subArchName =+  if | startsWith "mips" && (endsWith "r6el" || endsWith "r6") -> MipsSubArch_r6++     | subArchName == "powerpcspe" -> PPCSubArch_spe++     | subArchName == "arm64e" -> AArch64SubArch_arm64e++     | startsWith "arm64e" -> AArch64SubArch_arm64e++     | startsWith "spirv" ->+         if | endsWith "v1.0" -> SPIRVSubArch_v10+            | endsWith "v1.1" -> SPIRVSubArch_v11+            | endsWith "v1.2" -> SPIRVSubArch_v12+            | endsWith "v1.3" -> SPIRVSubArch_v13+            | endsWith "v1.4" -> SPIRVSubArch_v14+            | endsWith "v1.5" -> SPIRVSubArch_v15+            | otherwise -> NoSubArch+     | otherwise ->+         case ARM.parseArch <$> armSubArch of+           Nothing ->+             if | endsWith "kalimba3" -> KalimbaSubArch_v3+                | endsWith "kalimba4" -> KalimbaSubArch_v4+                | endsWith "kalimba5" -> KalimbaSubArch_v5+                | otherwise -> NoSubArch+           Just armArch ->+             if | armArch == ARM.ARMV4 -> NoSubArch+                | armArch == ARM.ARMV4T -> ARMSubArch_v4t+                | armArch == ARM.ARMV5T -> ARMSubArch_v5+                | armArch == ARM.ARMV5TE ||+                  armArch == ARM.IWMMXT ||+                  armArch == ARM.IWMMXT2 ||+                  armArch == ARM.XSCALE ||+                  armArch == ARM.ARMV5TEJ -> ARMSubArch_v5te+                | armArch == ARM.ARMV6 ->  ARMSubArch_v6+                | armArch == ARM.ARMV6K ||+                  armArch == ARM.ARMV6KZ -> ARMSubArch_v6k+                | armArch == ARM.ARMV6T2 ->  ARMSubArch_v6t2+                | armArch == ARM.ARMV6M ->  ARMSubArch_v6m+                | armArch == ARM.ARMV7A ||+                  armArch == ARM.ARMV7R -> ARMSubArch_v7+                | armArch == ARM.ARMV7VE -> ARMSubArch_v7ve+                | armArch == ARM.ARMV7K -> ARMSubArch_v7k+                | armArch == ARM.ARMV7M -> ARMSubArch_v7m+                | armArch == ARM.ARMV7S -> ARMSubArch_v7s+                | armArch == ARM.ARMV7EM -> ARMSubArch_v7em+                | armArch == ARM.ARMV8A -> ARMSubArch_v8+                | armArch == ARM.ARMV8_1A -> ARMSubArch_v8_1a+                | armArch == ARM.ARMV8_2A -> ARMSubArch_v8_2a+                | armArch == ARM.ARMV8_3A -> ARMSubArch_v8_3a+                | armArch == ARM.ARMV8_4A -> ARMSubArch_v8_4a+                | armArch == ARM.ARMV8_5A -> ARMSubArch_v8_5a+                | armArch == ARM.ARMV8_6A -> ARMSubArch_v8_6a+                | armArch == ARM.ARMV8_7A -> ARMSubArch_v8_7a+                | armArch == ARM.ARMV8_8A -> ARMSubArch_v8_8a+                | armArch == ARM.ARMV9A -> ARMSubArch_v9+                | armArch == ARM.ARMV9_1A -> ARMSubArch_v9_1a+                | armArch == ARM.ARMV9_2A -> ARMSubArch_v9_2a+                | armArch == ARM.ARMV9_3A -> ARMSubArch_v9_3a+                | armArch == ARM.ARMV8R -> ARMSubArch_v8r+                | armArch == ARM.ARMV8MBaseline -> ARMSubArch_v8m_baseline+                | armArch == ARM.ARMV8MMainline -> ARMSubArch_v8m_mainline+                | armArch == ARM.ARMV8_1MMainline -> ARMSubArch_v8_1m_mainline+                | otherwise -> NoSubArch+  where+    startsWith = (`List.isPrefixOf` subArchName)+    endsWith = (`List.isSuffixOf` subArchName)+    armSubArch = ARM.getCanonicalArchName (ARM.ArchName subArchName)++-- | @llvm::Triple::getDefaultFormat@+--+-- TODO(#97): Implement me!+defaultObjFmt :: TargetTriple -> ObjectFormat+defaultObjFmt _tt = UnknownObjectFormat++-- | @llvm::Triple::Triple@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L869+parseTriple :: String -> TargetTriple+parseTriple str =+  execState (split '-' str) $ do+    let pop def f =+          M.sets $+            \case+              (hd:rest) -> (f hd, rest)+              [] -> (def, [])+    (arch, subArch) <-+      pop (UnknownArch, NoSubArch) (\s -> (parseArch s, parseSubArch s))+    vendor <- pop UnknownVendor parseVendor+    os <- pop UnknownOS parseOS+    (env, objFmt) <-+      pop (UnknownEnvironment, UnknownObjectFormat) (\s -> (parseEnv s, parseObjFmt s))+    let tt =+          TargetTriple+          { ttArch = arch+          , ttSubArch = subArch+          , ttVendor = vendor+          , ttOS = os+          , ttEnv = env+          , ttObjFmt = objFmt+          }+    return (tt { ttObjFmt =+                   if ttObjFmt tt == UnknownObjectFormat+                   then defaultObjFmt tt+                   else ttObjFmt tt+               })+  where++    -- > split '-' "foo-bar" == ["foo", "bar"]+    split :: Char -> String -> [String]+    split splitter =+      foldr (\c strs -> if c == splitter then ([]:strs) else push c strs) [[]]+      where+        push c [] = [[c]]+        push c (s:strs) = (c:s):strs++    -- Not in MonadLib...+    execState s = fst . M.runState s

@@ -0,0 +1,347 @@+{- |+Module      : Text.LLVM.Triple.Parse.ARM+Description : ARM utilities used in target triple parsing.+License     : BSD3+Maintainer  : Langston Barrett+Stability   : experimental++This module is not exposed as part of the library API.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE StrictData #-}++module Text.LLVM.Triple.Parse.ARM+  ( ArchName(..)+    -- * Endianness+  , EndianKind(..)+  , parseEndianKind+    -- * ISA+  , ISAKind(..)+  , parseISAKind+    -- * Arch+  , getCanonicalArchName+  , parseARMArch+  , ARMArch(..)+  , armArchName+  , parseArch+  ) where++import qualified Data.Char as Char+import           Control.Monad (liftM2, when)+import qualified MonadLib as M+import qualified MonadLib.Monads as M+import qualified Data.List as List++import           Text.LLVM.Triple.AST+import qualified Text.LLVM.Triple.Parse.LookupTable as Lookup++-- | The "arch" portion of a target triple+newtype ArchName = ArchName { getArchName :: String }++--------------------------------------------------------------------------------+-- Endianness++-- | @llvm::EndianKind@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/Support/ARMTargetParser.h#L166+data EndianKind+  = Little+  | Big+  deriving (Bounded, Enum, Eq, Ord)++-- | @llvm::ARM::parseArchEndian@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/ARMTargetParser.cpp#L248+parseEndianKind :: ArchName -> Maybe EndianKind+parseEndianKind (ArchName arch) =+  if | hasPfx "armeb" || hasPfx "thumbeb" || hasPfx "aarch64_be" -> Just Big+     | hasPfx "arm" || hasPfx "thumb" ->+         if hasSfx "eb"+         then Just Big+         else Just Little+     | hasPfx "aarch64" || hasPfx "aarch64_32" -> Just Little+     | otherwise -> Nothing+  where+    hasPfx = (`List.isPrefixOf` arch)+    hasSfx = (`List.isSuffixOf` arch)++--------------------------------------------------------------------------------+-- ISA++-- | @llvm::ISAKind@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/Support/ARMTargetParser.h#L162+data ISAKind+  = ISAArm+  | ISAThumb+  | ISAAArch64+  deriving (Bounded, Enum, Eq, Ord)++-- | @llvm::ARM::parseArchISA@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/ARMTargetParser.cpp#L267+parseISAKind :: ArchName -> Maybe ISAKind+parseISAKind (ArchName arch) = Lookup.lookupByPrefix arch table+  where+    table =+      Lookup.makeTable+        [ ("aarch64", ISAAArch64)+        , ("arm64", ISAAArch64)+        , ("thumb", ISAThumb)+        , ("arm", ISAArm)+        ]++--------------------------------------------------------------------------------+-- Arch++-- | @llvm::ARM::getArchSynonym@+getArchSynonym :: ArchName -> ArchName+getArchSynonym (ArchName arch) =+  ArchName $+    if | cases ["v5"] -> "v5t"+       | cases ["v5e"] -> "v5te"+       | cases ["v6j"] -> "v6"+       | cases ["v6hl"] -> "v6k"+       | cases ["v6m", "v6sm", "v6s-m"] -> "v6-m"+       | cases ["v6z", "v6zk"] -> "v6kz"+       | cases ["v7", "v7a", "v7hl", "v7l"] -> "v7-a"+       | cases ["v7r"] -> "v7-r"+       | cases ["v7m"] -> "v7-m"+       | cases ["v7em"] -> "v7e-m"+       | cases ["v8", "v8a", "v8l", "aarch64", "arm64"] -> "v8-a"+       | cases ["v8.1a"] -> "v8.1-a"+       | cases ["v8.2a"] -> "v8.2-a"+       | cases ["v8.3a"] -> "v8.3-a"+       | cases ["v8.4a"] -> "v8.4-a"+       | cases ["v8.5a"] -> "v8.5-a"+       | cases ["v8.6a"] -> "v8.6-a"+       | cases ["v8.7a"] -> "v8.7-a"+       | cases ["v8.8a"] -> "v8.8-a"+       | cases ["v8r"] -> "v8-r"+       | cases ["v9", "v9a"] -> "v9-a"+       | cases ["v9.1a"] -> "v9.1-a"+       | cases ["v9.2a"] -> "v9.2-a"+       | cases ["v9.3a"] -> "v9.3-a"+       | cases ["v8m.base"] -> "v8-m.base"+       | cases ["v8m.main"] -> "v8-m.main"+       | cases ["v8.1m.main"] -> "v8.1-m.main"+       | otherwise -> arch+  where+    cases = any (== arch)++data CanonicalArchNameState+  = CanonicalArchNameState+    { offset :: Int+    , archStr :: String -- ^ @A@ in the LLVM+    }++-- | @llvm::ARM::getCanonicalArchName@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/ARMTargetParser.cpp#L295+getCanonicalArchName :: ArchName -> Maybe ArchName+getCanonicalArchName (ArchName arch) =+  -- See Note [Implementation] for the reasoning behind the strange structure.+  --+  -- Could probably be translated even more directly using ContT, but that feels+  -- like a bit much.+  execState (CanonicalArchNameState 0 arch) $ do+    ifM (liftM2 (&&) (startsWith "aarch64") (contains "eb")) (return Nothing) $ do+      whenM (startsWith "arm64_32") $+        setOffset 8+      whenM (startsWith "arm64e") $+        setOffset 6+      whenM (startsWith "arm64") $+        setOffset 5+      whenM (startsWith "aarch64_32") $+        setOffset 10+      whenM (startsWith "arm") $+        setOffset 3+      whenM (startsWith "thumb") $+        setOffset 5+      whenM (startsWith "aarch64") $ do+        setOffset 7+        whenM ((== "_be") <$> archOffSubstr 3) $+          addOffset 3++      off <- offset <$> M.get+      sub <- archOffSubstr 2+      when (off /= npos && sub == "eb") $+        addOffset 2+      whenM (endsWith "eb") $ do+        changeArch (\arch' -> substr 0 (length arch' - 2) arch')+      off' <- offset <$> M.get+      when (off' /= npos) $+        changeArch (drop off')++      arch' <- archStr <$> M.get+      if | length arch' == 0 -> return Nothing+         | off' /= npos && length arch' > 2 &&+             (take 1 arch' /= "v" || not (all Char.isDigit (substr 1 1 arch'))) ->+               return Nothing+         | off' /= npos && "eb" `List.isInfixOf` arch' -> return Nothing+         | otherwise -> return (Just (ArchName arch'))+  where+    npos = 0++    ifM b thn els = b >>= \b' -> if b' then thn else els+    whenM b k = ifM b k (return ())+    startsWith pfx = (pfx `List.isPrefixOf`) . archStr <$> M.get+    endsWith sfx = (sfx `List.isSuffixOf`) . archStr <$> M.get+    contains ifx = (ifx `List.isInfixOf`) . archStr <$> M.get++    substr start sz = take sz . drop start+    archSubstr begin sz = substr begin sz . archStr <$> M.get+    archOffSubstr sz = do+      off <- offset <$> M.get+      archSubstr off sz++    changeOffset f = do+      s <- M.get+      M.set (s { offset = f (offset s) })+    addOffset n = changeOffset (n+)+    setOffset n = changeOffset (const n)++    changeArch f = M.set . (\s -> s { archStr = f (archStr s) }) =<< M.get++    -- Not in MonadLib...+    execState s = fst . M.runState s++-- | @llvm::parseARMArch@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/lib/Support/Triple.cpp#L377+parseARMArch :: ArchName -> Arch+parseARMArch archName =+  let+    isa = parseISAKind archName+    endian = parseEndianKind archName+    arch =+      case endian of+        Just Little ->+          case isa of+            Just ISAArm -> ARM+            Just ISAThumb -> Thumb+            Just ISAAArch64 -> AArch64+            Nothing -> UnknownArch+        Just Big ->+          case isa of+            Just ISAArm -> ARMEB+            Just ISAThumb -> ThumbEB+            Just ISAAArch64 -> AArch64_BE+            Nothing -> UnknownArch+        Nothing -> UnknownArch+    mArchName = getCanonicalArchName archName+  in case mArchName of+      Nothing -> UnknownArch+      Just (ArchName archNm) ->+        if | isa == Just ISAThumb &&+             ("v2" `List.isPrefixOf` archNm || "v3" `List.isPrefixOf` archNm) -> UnknownArch+            -- TODO(#98): LLVM has one more check here involving the "arch+            -- profile" that's not yet implemented here... Probably not a big+            -- deal because this case is only executed when the target arch+            -- doesn't match the "canonical" versions like "arm", "thumb", and+            -- "aarch64".+           | otherwise -> arch++-- | See LLVM's @ARMTargetParser.def@+--+-- https://github.com/llvm/llvm-project/blob/llvmorg-15.0.1/llvm/include/llvm/Support/ARMTargetParser.def#L48+data ARMArch+  = ARMArchInvalid+  | ARMV2+  | ARMV2A+  | ARMV3+  | ARMV3M+  | ARMV4+  | ARMV4T+  | ARMV5T+  | ARMV5TE+  | ARMV5TEJ+  | ARMV6+  | ARMV6K+  | ARMV6T2+  | ARMV6KZ+  | ARMV6M+  | ARMV7A+  | ARMV7VE+  | ARMV7R+  | ARMV7M+  | ARMV7EM+  | ARMV8A+  | ARMV8_1A+  | ARMV8_2A+  | ARMV8_3A+  | ARMV8_4A+  | ARMV8_5A+  | ARMV8_6A+  | ARMV8_7A+  | ARMV8_8A+  | ARMV9A+  | ARMV9_1A+  | ARMV9_2A+  | ARMV9_3A+  | ARMV8R+  | ARMV8MBaseline+  | ARMV8MMainline+  | ARMV8_1MMainline+  | IWMMXT+  | IWMMXT2+  | XSCALE+  | ARMV7S+  | ARMV7K+  deriving (Bounded, Enum, Eq, Ord)++armArchName :: ARMArch -> String+armArchName =+  \case+    ARMArchInvalid -> "invalid"+    ARMV2 -> "armv2"+    ARMV2A -> "armv2a"+    ARMV3 -> "armv3"+    ARMV3M -> "armv3m"+    ARMV4 -> "armv4"+    ARMV4T -> "armv4t"+    ARMV5T -> "armv5t"+    ARMV5TE -> "armv5te"+    ARMV5TEJ -> "armv5tej"+    ARMV6 -> "armv6"+    ARMV6K -> "armv6k"+    ARMV6T2 -> "armv6t2"+    ARMV6KZ -> "armv6kz"+    ARMV6M -> "armv6-m"+    ARMV7A -> "armv7-a"+    ARMV7VE -> "armv7ve"+    ARMV7R -> "armv7-r"+    ARMV7M -> "armv7-m"+    ARMV7EM -> "armv7e-m"+    ARMV8A -> "armv8-a"+    ARMV8_1A -> "armv8.1-a"+    ARMV8_2A -> "armv8.2-a"+    ARMV8_3A -> "armv8.3-a"+    ARMV8_4A -> "armv8.4-a"+    ARMV8_5A -> "armv8.5-a"+    ARMV8_6A -> "armv8.6-a"+    ARMV8_7A -> "armv8.7-a"+    ARMV8_8A -> "armv8.8-a"+    ARMV9A -> "armv9-a"+    ARMV9_1A -> "armv9.1-a"+    ARMV9_2A -> "armv9.2-a"+    ARMV9_3A -> "armv9.3-a"+    ARMV8R -> "armv8-r"+    ARMV8MBaseline -> "armv8-m.base"+    ARMV8MMainline -> "armv8-m.main"+    ARMV8_1MMainline -> "armv8.1-m.main"+    IWMMXT -> "iwmmxt"+    IWMMXT2 -> "iwmmxt2"+    XSCALE -> "xscale"+    ARMV7S -> "armv7s"+    ARMV7K -> "armv7k"++-- | @llvm::ARM::parseArch@+parseArch :: ArchName -> ARMArch+parseArch arch =+  let ArchName syn = getArchSynonym arch+      table = Lookup.enumTable armArchName+  in Lookup.lookupBySuffixWithDefault table ARMArchInvalid syn

@@ -0,0 +1,77 @@+{- |+Module      : Text.LLVM.Triple.Parse.LookupTable+Description : Helpers for parsing a finite set of strings.+License     : BSD3+Maintainer  : Langston Barrett+Stability   : experimental++This module is not exposed as part of the library API.+-}++{-# LANGUAGE TupleSections #-}++module Text.LLVM.Triple.Parse.LookupTable+  ( -- * Construction+    LookupTable+  , makeTable+  , enumTable+  , enumTableVariants+    -- * Queries+  , lookupBy+  , lookup+  , lookupByPrefix+  , lookupByWithDefault+  , lookupWithDefault+  , lookupByPrefixWithDefault+  , lookupBySuffixWithDefault+  ) where++import           Prelude hiding (lookup)+import qualified Data.Maybe as Maybe+import qualified Data.List as List++--------------------------------------------------------------------------------+-- Construction++-- | A table from constrant strings to values, to be used in parsing a finite+-- set of possibilities. Could be replaced by a fancier data structure, but+-- there's only one target triple per module, after all.+--+-- Hopefully, GHC is smart enough to construct these at compile-time.+newtype LookupTable a = LookupTable { getLookupTable :: [(String, a)] }++makeTable :: [(String, a)] -> LookupTable a+makeTable = LookupTable++enumTable :: Bounded a => Enum a => (a -> String) -> LookupTable a+enumTable prnt = makeTable [(prnt a, a) | a <- enumFrom minBound]++enumTableVariants :: Bounded a => Enum a => (a -> [String]) -> LookupTable a+enumTableVariants prnt =+  makeTable (concatMap (\a -> map (,a) (prnt a)) (enumFrom minBound))++--------------------------------------------------------------------------------+-- Queries++lookupBy :: (String -> Bool) -> LookupTable a -> Maybe a+lookupBy p = Maybe.listToMaybe . map snd . filter (p . fst) . getLookupTable++lookup :: String -> LookupTable a -> Maybe a+lookup s = lookupBy (== s)++lookupByPrefix :: String -> LookupTable a -> Maybe a+lookupByPrefix pfx = lookupBy (pfx `List.isPrefixOf`)++lookupByWithDefault :: a -> (String -> Bool) -> LookupTable a -> a+lookupByWithDefault def p = Maybe.fromMaybe def . lookupBy p++lookupWithDefault :: LookupTable a -> a -> String -> a+lookupWithDefault table def val = lookupByWithDefault def (== val) table++lookupByPrefixWithDefault :: LookupTable a -> a -> String -> a+lookupByPrefixWithDefault table def pfx =+  lookupByWithDefault def (pfx `List.isPrefixOf`) table++lookupBySuffixWithDefault :: LookupTable a -> a -> String -> a+lookupBySuffixWithDefault table def sfx =+  lookupByWithDefault def (sfx `List.isSuffixOf`) table

@@ -0,0 +1,229 @@+{- |+Module      : Text.LLVM.Triple.Print+Description : Printing of LLVM target triples.+License     : BSD3+Maintainer  : Langston Barrett+Stability   : experimental+-}++{-# LANGUAGE LambdaCase #-}++module Text.LLVM.Triple.Print+  ( archName+  , vendorName+  , osName+  , envName+  , objFmtName+  , printTriple+  ) where++import qualified Data.List as List++import Text.LLVM.Triple.AST++-- | @llvm::Triple::getArchTypeName@.+--+-- Retained in the order in which they appear in the LLVM source, rather than an+-- order consistent with the constructors of 'Arch'.+archName :: Arch -> String+archName =+  \case+    UnknownArch -> "unknown"+    AArch64 -> "aarch64"+    AArch64_32 -> "aarch64_32"+    AArch64_BE -> "aarch64_be"+    AMDGCN -> "amdgcn"+    AMDIL64 -> "amdil64"+    AMDIL -> "amdil"+    ARC -> "arc"+    ARM -> "arm"+    ARMEB -> "armeb"+    AVR -> "avr"+    BPFEB -> "bpfeb"+    BPFEL -> "bpfel"+    CSKY -> "csky"+    DXIL -> "dxil"+    Hexagon -> "hexagon"+    HSAIL64 -> "hsail64"+    HSAIL -> "hsail"+    Kalimba -> "kalimba"+    Lanai -> "lanai"+    Le32 -> "le32"+    Le64 -> "le64"+    LoongArch32 -> "loongarch32"+    LoongArch64 -> "loongarch64"+    M68k -> "m68k"+    MIPS64 -> "mips64"+    MIPS64EL -> "mips64el"+    MIPS -> "mips"+    MIPSEL -> "mipsel"+    MSP430 -> "msp430"+    NVPTX64 -> "nvptx64"+    NVPTX -> "nvptx"+    PPC64 -> "powerpc64"+    PPC64LE -> "powerpc64le"+    PPC -> "powerpc"+    PPCLE -> "powerpcle"+    R600 -> "r600"+    RenderScript32 -> "renderscript32"+    RenderScript64 -> "renderscript64"+    RISCV32 -> "riscv32"+    RISCV64 -> "riscv64"+    SHAVE -> "shave"+    Sparc -> "sparc"+    SparcEL -> "sparcel"+    Sparcv9 -> "sparcv9"+    SPIR64 -> "spir64"+    SPIR -> "spir"+    SPIRV32 -> "spirv32"+    SPIRV64 -> "spirv64"+    SystemZ -> "s390x"+    TCE -> "tce"+    TCELE -> "tcele"+    Thumb -> "thumb"+    ThumbEB -> "thumbeb"+    VE -> "ve"+    Wasm32 -> "wasm32"+    Wasm64 -> "wasm64"+    X86 -> "i386"+    X86_64 -> "x86_64"+    XCore -> "xcore"++-- | @llvm::Triple::getVendorTypeName@.+--+-- Retained in the order in which they appear in the LLVM source.+vendorName :: Vendor -> String+vendorName =+  \case+    UnknownVendor -> "unknown"+    AMD -> "amd"+    Apple -> "apple"+    CSR -> "csr"+    Freescale -> "fsl"+    IBM -> "ibm"+    ImaginationTechnologies -> "img"+    Mesa -> "mesa"+    MipsTechnologies -> "mti"+    Myriad -> "myriad"+    NVIDIA -> "nvidia"+    OpenEmbedded -> "oe"+    PC -> "pc"+    SCEI -> "scei"+    SUSE -> "suse"++-- | @llvm::Triple::getOSTypeName@.+--+-- Retained in the order in which they appear in the LLVM source.+osName :: OS -> String+osName =+  \case+    UnknownOS -> "unknown"+    AIX -> "aix"+    AMDHSA -> "amdhsa"+    AMDPAL -> "amdpal"+    Ananas -> "ananas"+    CUDA -> "cuda"+    CloudABI -> "cloudabi"+    Contiki -> "contiki"+    Darwin -> "darwin"+    DragonFly -> "dragonfly"+    DriverKit -> "driverkit"+    ELFIAMCU -> "elfiamcu"+    Emscripten -> "emscripten"+    FreeBSD -> "freebsd"+    Fuchsia -> "fuchsia"+    Haiku -> "haiku"+    HermitCore -> "hermit"+    Hurd -> "hurd"+    IOS -> "ios"+    KFreeBSD -> "kfreebsd"+    Linux -> "linux"+    Lv2 -> "lv2"+    MacOSX -> "macosx"+    Mesa3D -> "mesa3d"+    Minix -> "minix"+    NVCL -> "nvcl"+    NaCl -> "nacl"+    NetBSD -> "netbsd"+    OpenBSD -> "openbsd"+    PS4 -> "ps4"+    PS5 -> "ps5"+    RTEMS -> "rtems"+    Solaris -> "solaris"+    TvOS -> "tvos"+    WASI -> "wasi"+    WatchOS -> "watchos"+    Win32 -> "windows"+    ZOS -> "zos"+    ShaderModel -> "shadermodel"++-- | @llvm::Triple::getEnvironmentName@.+--+-- Retained in the order in which they appear in the LLVM source.+envName :: Environment -> String+envName =+  \case+  UnknownEnvironment -> "unknown"+  Android -> "android"+  CODE16 -> "code16"+  CoreCLR -> "coreclr"+  Cygnus -> "cygnus"+  EABI -> "eabi"+  EABIHF -> "eabihf"+  GNU -> "gnu"+  GNUABI64 -> "gnuabi64"+  GNUABIN32 -> "gnuabin32"+  GNUEABI -> "gnueabi"+  GNUEABIHF -> "gnueabihf"+  GNUX32 -> "gnux32"+  GNUILP32 -> "gnu_ilp32"+  Itanium -> "itanium"+  MSVC -> "msvc"+  MacABI -> "macabi"+  Musl -> "musl"+  MuslEABI -> "musleabi"+  MuslEABIHF -> "musleabihf"+  MuslX32 -> "muslx32"+  Simulator -> "simulator"+  Pixel -> "pixel"+  Vertex -> "vertex"+  Geometry -> "geometry"+  Hull -> "hull"+  Domain -> "domain"+  Compute -> "compute"+  Library -> "library"+  RayGeneration -> "raygeneration"+  Intersection -> "intersection"+  AnyHit -> "anyhit"+  ClosestHit -> "closesthit"+  Miss -> "miss"+  Callable -> "callable"+  Mesh -> "mesh"+  Amplification -> "amplification"++-- | @llvm::Triple::getObjectFormatTypeName@+--+-- Retained in the order in which they appear in the LLVM source.+objFmtName :: ObjectFormat -> String+objFmtName =+  \case+    UnknownObjectFormat -> ""  -- NB: Not "unknown"+    COFF -> "coff"+    ELF -> "elf"+    GOFF -> "goff"+    MachO -> "macho"+    Wasm -> "wasm"+    XCOFF -> "xcoff"+    DXContainer -> "dxcontainer"+    SPIRV -> "spirv"++printTriple :: TargetTriple -> String+printTriple tt =+  List.intercalate+    "-"+    [ archName (ttArch tt)+    , vendorName (ttVendor tt)+    , osName (ttOS tt)+    , envName (ttEnv tt)+    , objFmtName (ttObjFmt tt)+    ]

@@ -0,0 +1,13 @@+module Main (main) where++import qualified Test.Tasty as Tasty++import qualified Triple+import qualified Output++main :: IO ()+main = Tasty.defaultMain $ Tasty.testGroup "LLVM tests"+       [+         Output.tests+       , Triple.tests+       ]

@@ -0,0 +1,302 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++-- | This module provides some simple pretty-printing output verification tests.+-- This amounts to spot-checking a few places in the pretty printing that are+-- examined by hand: in general, it its much more effective to do round-trip+-- testing using AST's parsed from bitcode generated by actual programs, which is+-- what occurs in the llvm-pretty-bc-parser package (i.e. much more comprehensive+-- testing is deferred to the llvm-pretty-bc-parser package, which might then+-- reveal issues that need to be fixed in this llvm-pretty package).++module Output ( tests ) where++import           Control.Monad ( unless )+import qualified Data.Text as T+import qualified Test.Tasty as Tasty+import           Test.Tasty.HUnit+import qualified Text.PrettyPrint as PP++import           Text.LLVM.AST+import           Text.LLVM.PP++import           TQQDefs++tests :: Tasty.TestTree+tests = Tasty.testGroup "LLVM pretty-printing output tests"+  $ let -- s1 is a non-sensical construct whose primary intention is to hold two+        -- sub-structures that change their pretty representations at different+        -- LLVM versions.  The pretty output will be checked at different LLVM+        -- versions to ensure that the desired version-specific changes in the+        -- output are seen.+        s1, s2 :: Stmt+        s1 = Effect+             (GEP True (Alias (Ident "hi")) (Typed Opaque dcu) [])+             []+        s2 = Effect (Load PtrOpaque (Typed Opaque ValNull) Nothing Nothing)+             [ ("location", ValMdLoc $ DebugLoc { dlLine = 12+                                                , dlCol = 34+                                                , dlScope = ValMdRef 5+                                                , dlIA = Nothing+                                                , dlImplicit = True })+             ]+        dcu :: Value+        dcu = ValMd+              $ ValMdDebugInfo+              $ DebugInfoCompileUnit+              $ DICompileUnit { dicuLanguage = 12+                              , dicuFile = Nothing+                              , dicuProducer = Just "llvm-pretty-test"+                              , dicuIsOptimized = True+                              , dicuFlags = Just "some flags"+                              , dicuRuntimeVersion = 3+                              , dicuSplitDebugFilename = Nothing+                              , dicuEmissionKind = 1+                              , dicuEnums = Just dtt+                              , dicuRetainedTypes = Nothing+                              , dicuSubprograms = Nothing+                              , dicuGlobals = Nothing+                              , dicuImports = Nothing+                              , dicuMacros = Nothing+                              , dicuDWOId = 2+                              , dicuSplitDebugInlining = False+                              , dicuDebugInfoForProf = True+                              , dicuNameTableKind = 4+                              , dicuRangesBaseAddress = True+                              , dicuSysRoot = Just "the root"+                              , dicuSDK = Just "SDK"+                              }+        dtt = ValMdDebugInfo+              $ DebugInfoTemplateTypeParameter+              $ DITemplateTypeParameter { dittpName = Just "ttp"+                                        , dittpType = Nothing+                                        , dittpIsDefault = Just True+                                        }+        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")) []+                            ]+                          }+        blk2 = BasicBlock { bbLabel = Just $ Anon 123+                          , bbStmts = []+                          }+        ppToText = T.pack+                   -- render with a line-length of 30 to encourage wrapping on+                   -- most list elements or arguments for consistent output to+                   -- verify against any changes.+                   . PP.renderStyle (PP.Style PP.PageMode 30 1.0)+  in+  [+    testCase "Stmt 1, LLVM 3.5" $+    assertEqLines [sq|+      ----+      getelementptr inbounds 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)+      ----+      |]+      (ppToText $ ppLLVM35 ppStmt s1)++  , testCase "Stmt 1, LLVM 3.7" $+    assertEqLines [sq|+      In LLVM 3.7, the GEP instruction output shows the additional type+      ----+      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)+      ----+      |]+      (ppToText $ ppLLVM37 ppStmt s1)++  , testCase "Stmt 1, LLVM 10" $+    assertEqLines (ppToText $ ppLLVM 10 $ ppStmt s1) [sq|+      No change from LLVM 3.7 through LLVM 10+      ----+      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)+      ----+      |]++  , testCase "Stmt 1, LLVM 11" $+    assertEqLines (ppToText $ ppLLVM 11 $ ppStmt s1) [sq|+      In LLVM 11, DICompileUnit adds rangesBaseAddress, sysroot, and sdk+      ----+      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" $+    assertEqLines [sq|+      ----+      load opaque null, !location !MDLocation(line: 12,+                                              column: 34,+                                              scope: !5, implicit)+      ----+      |]+      (ppToText $ ppLLVM35 ppStmt s2)++  , testCase "Stmt 2, LLVM 3.7" $+    assertEqLines [sq|+      Beginning in LLVM 3.7, the type is no longer implicit and is explicitly+      shown, and the DebugLoc metadata is DILocation instead of MDLocation+      ----+      load ptr, opaque null, !location !DILocation(line: 12,+                                                   column: 34,+                                                   scope: !5, implicit)+      ----+      |]+      (ppToText $ ppLLVM37 ppStmt s2)++  , testCase "Stmt 2, LLVM 10" $+    assertEqLines [sq|+      No change since LLVM 3.7+      ----+      load ptr, opaque null, !location !DILocation(line: 12,+                                                   column: 34,+                                                   scope: !5, implicit)+      ----+      |]+      (ppToText $ ppLLVM 10 $ ppStmt s2)++  ------------------------------------------------------------+  -- Verify named labels and label targets are emitted correctly++  , testCase "Blk 1, LLVM 3.5" $+    assertEqLines (ppToText $ ppLLVM35 ppBasicBlock blk1) [sq|+      --------+      blk1:+        %r1 = ; insanity follows...+        br label %blk1+        %"oh no" = ret void+        br metadata zeroinitializer, label %3, label %"oh no"+      --------+      |]++  , testCase "Blk 1, LLVM 3.7" $+    assertEqLines (ppToText $ ppLLVM37 ppBasicBlock blk1) [sq|+      --------+      blk1:+        %r1 = ; insanity follows...+        br label %blk1+        %"oh no" = ret void+        br metadata zeroinitializer, label %3, label %"oh no"+      --------+      |]++  ------------------------------------------------------------+  -- Verify anonymous labels are emitted correctly++  , testCase "Blk 2, LLVM 3.5" $+    assertEqLines (ppToText $ ppLLVM35 ppBasicBlock blk2) [sq|+      --------+      ; <label>: 123+      --------+      |]++  , testCase "Blk 2, LLVM 3.7" $+    assertEqLines (ppToText $ ppLLVM37 ppBasicBlock blk2) [sq|+      --------+      ; <label>: 123+      --------+      |]++  ]++----------------------------------------------------------------------++assertEqLines :: T.Text -> T.Text -> IO ()+assertEqLines t1 t2 =+  unless (t1 == t2) $ assertFailure $ multiLineDiff t1 t2++-- | The multiLineDiff is another helper function that can be used to+-- format a line-by-line difference display of two Text+-- representations.  This is provided as a convenience function to+-- help format large text regions for easier comparison.++multiLineDiff :: T.Text -> T.Text -> String+multiLineDiff expected actual =+  let dl (e,a) = if e == a then db e else de " ↱" e <> "\n    " <> da " ↳" a+      db b = "|        > " <> b+      de m e = "|" <> m <> "expect> " <> e+      da m a = "|" <> m <> "actual> " <> a+      el = take 1450 (visible <$> T.lines expected)+      al = take 1450 (visible <$> T.lines actual)+      visible = T.replace " " "␠"+                . T.replace "\n" "␤"+                . T.replace "\t" "␉"+                . T.replace "\012" "␍"+      addnum :: Int -> T.Text -> T.Text+      addnum n l = let nt = T.pack (show n)+                       nl = T.length nt+                   in T.take (4 - nl) "    " <> nt <> l+      ll = T.pack . show . length+      tl = T.pack . show . T.length+      banner = "MISMATCH between "+               <> ll el <> "l/" <> tl expected <> "c expected and "+               <> ll al <> "l/" <> tl actual <> "c actual"+      diffReport = fmap (uncurry addnum) $+                   zip [1..] $ concat $+                   -- Highly simplistic "diff" output assumes+                   -- correlated lines: added or removed lines just+                   -- cause everything to shown as different from that+                   -- point forward.+                   [ fmap dl $ zip el al+                   , fmap (de "∌ ") $ drop (length al) el+                   , fmap (da "∹ ") $ drop (length el) al+                   ]+                   -- n.b. T.lines seems to consume trailing whitespace before+                   -- newlines as well.  This will show any of this whitespace+                   -- difference on the last line, but not for other lines with+                   -- whitespace.+                   <> if el == al+                      then let maxlen = max (T.length expected) (T.length actual)+                               end x = T.drop (maxlen - 5) x+                           in [ [ de "∌ ending " $ visible $ end expected ]+                              , [ da "∹ ending " $ visible $ end actual ]+                              ]+                      else mempty+      details = banner : diffReport+  in if expected == actual then "<no difference>" else T.unpack (T.unlines details)

@@ -0,0 +1,62 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module TQQDefs where++import Data.String+import Language.Haskell.TH ( ExpQ )+import Language.Haskell.TH.Quote+import Numeric.Natural+++sq :: QuasiQuoter+sq = QuasiQuoter extractor+     (error "no q patterns")+     (error "no q types")+     (error "no q dec")++extractor :: String -> ExpQ+extractor s =+  case inSeps $ filter (/= '\r') s of+    Post a -> [|fromString a|]+    Pre _ -> error $ "No starting line found"+    MatchLine _ -> error $ "Only starting line found"+    Pass _ _ _ -> error $ "No ending line found"+++data QState = Pre String+            | MatchLine Natural+            | Pass Natural Natural String+            | Post String++inSeps :: String -> QState+inSeps =+  let sep = "----"+      sepl = length sep+      matchSep s = if take sepl s == reverse sep+                   then let ss n = \case+                              [] -> Nothing+                              ('\n':_) -> Just n+                              (' ':cs) -> ss (n+1) cs+                              _ -> Nothing+                        in ss 0 $ drop sepl s+                   else Nothing+      nxtC :: QState -> Char -> QState+      nxtC = \case+        (Post s) -> const $ Post s+        (Pre p) -> \c -> let p' = c : p+                         in case matchSep p' of+                              Just n -> MatchLine n+                              Nothing -> Pre p'+        (MatchLine n) -> \c -> if '\n' == c then Pass n n "" else MatchLine n+        (Pass n p s) -> \c ->+          let s' = c : s+          in if p == 0+             then if c == '\n' && n > 0+                  then Pass n n s'+                  else if take sepl s' == reverse sep+                       then Post $ reverse $ drop (sepl + 1) s'+                       else Pass n 0 s'+             else Pass n (p-1) s+    in foldl nxtC (Pre "")

@@ -0,0 +1,72 @@+module Triple (tests) where++import           Control.Monad (forM_)++import qualified Text.LLVM.Triple.AST as AST+import qualified Text.LLVM.Triple.Parse as Parse+import qualified Text.LLVM.Triple.Print as Print++import qualified Test.Tasty as Tasty+import qualified Test.Tasty.HUnit as TastyH++each :: Bounded a => Enum a => (a -> String) -> (a -> Bool) -> IO ()+each name test =+  forM_ (enumFrom minBound) $ \e ->+    TastyH.assertBool (name e) (test e)++tests :: Tasty.TestTree+tests =+  Tasty.testGroup+    "Triple parse/print"+    [ TastyH.testCase+        "parse . print == id :: Arch -> Arch"+        (roundtrip Parse.parseArch Print.archName)+    , TastyH.testCase+        "parse . print == id :: Vendor -> Vendor"+        (roundtrip Parse.parseVendor Print.vendorName)+    , TastyH.testCase+        "parse . print == id :: OS -> OS"+        (roundtrip Parse.parseOS Print.osName)+    , TastyH.testCase+        "parse . print == id :: Environment -> Environment"+        (roundtrip Parse.parseEnv Print.envName)+    , TastyH.testCase+        "parse . print == id :: ObjectFormat -> ObjectFormat"+        (roundtrip Parse.parseObjFmt Print.objFmtName)+    , triple "aarch64-unknown-linux-gnu" $+        AST.TargetTriple+        { AST.ttArch = AST.AArch64+        , AST.ttSubArch = AST.NoSubArch+        , AST.ttVendor = AST.UnknownVendor+        , AST.ttOS = AST.Linux+        , AST.ttEnv = AST.GNU+        , AST.ttObjFmt = AST.UnknownObjectFormat+        }+    , triple "x86_64-unknown-linux-gnu" $+        AST.TargetTriple+        { AST.ttArch = AST.X86_64+        , AST.ttSubArch = AST.NoSubArch+        , AST.ttVendor = AST.UnknownVendor+        , AST.ttOS = AST.Linux+        , AST.ttEnv = AST.GNU+        , AST.ttObjFmt = AST.UnknownObjectFormat+        }+    , triple "i386-unknown-linux-elf" $+        AST.TargetTriple+        { AST.ttArch = AST.X86+        , AST.ttSubArch = AST.NoSubArch+        , AST.ttVendor = AST.UnknownVendor+        , AST.ttOS = AST.Linux+        , AST.ttEnv = AST.UnknownEnvironment+        , AST.ttObjFmt = AST.ELF+        }+    ]+  where+    triple s t =+      TastyH.testCase+        ("parse '" ++ s ++ "'")+        (t TastyH.@=? Parse.parseTriple s)+    roundtrip pars prnt =+      each+        (\a -> "parse (print " ++ prnt a ++ ") == " ++ prnt a)+        (\a -> a == pars (prnt a))