llvm-pretty 0.7.1.1 → 0.11.0

raw patch · 9 files changed

+1021/−358 lines, 9 filesdep +microlensdep +microlens-thdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: microlens, microlens-th, template-haskell, th-abstraction

API changes (from Hackage documentation)

Files

• llvm-pretty.cabal +14/−6
• src/Text/LLVM.hs +10/−6
• src/Text/LLVM/AST.hs +277/−121
• src/Text/LLVM/DebugUtils.hs +80/−21
• src/Text/LLVM/Labels.hs +43/−64
• src/Text/LLVM/Labels/TH.hs +125/−0
• src/Text/LLVM/Lens.hs +56/−0
• src/Text/LLVM/PP.hs +388/−132
• src/Text/LLVM/Parser.hs +28/−8

@@ -1,5 +1,5 @@ Name:                llvm-pretty-Version:             0.7.1.1+Version:             0.11.0 License:             BSD3 License-file:        LICENSE Author:              Trevor Elliott@@ -13,7 +13,9 @@   Augustsson.  The library provides a monadic interface to a pretty printer,   that allows functions to be defined and called, generating the corresponding   LLVM assembly when run.+tested-with:         GHC==8.4.3, GHC==8.2.2, GHC==8.0.2 + source-repository head   type:                 git   location:             http://github.com/elliottt/llvm-pretty@@ -25,15 +27,21 @@   Exposed-modules:     Text.LLVM                        Text.LLVM.AST                        Text.LLVM.Labels+                       Text.LLVM.Labels.TH+                       Text.LLVM.Lens                        Text.LLVM.Parser                        Text.LLVM.PP                        Text.LLVM.DebugUtils   Other-modules:       Text.LLVM.Util -  Build-depends:       base       >= 4 && < 5,-                       containers >= 0.4,-                       parsec     >= 3,-                       pretty     >= 1.0.1,-                       monadLib   >= 3.6.1+  Build-depends:       base             >= 4 && < 5,+                       containers       >= 0.4,+                       parsec           >= 3,+                       pretty           >= 1.0.1,+                       monadLib         >= 3.6.1,+                       microlens        >= 0.4,+                       microlens-th     >= 0.4,+                       template-haskell >= 2.7,+                       th-abstraction   >= 0.3.1 && <0.4    Ghc-options:         -Wall

@@ -112,6 +112,7 @@ import Control.Monad.Fix (MonadFix) import Data.Char (ord) import Data.Int (Int8,Int16,Int32,Int64)+import Data.Word (Word32, Word64) import Data.Maybe (maybeToList) import Data.String (IsString(..)) import MonadLib hiding (jump,Label)@@ -193,6 +194,7 @@   , decArgs    = tys   , decVarArgs = va   , decAttrs   = []+  , decComdat  = Nothing   }  -- | Emit a global declaration.@@ -281,6 +283,7 @@     , defGC       = funGC attrs     , defBody     = body     , defMetadata = Map.empty+    , defComdat  = Nothing     }  -- | A combination of define and @freshSymbol@.@@ -308,6 +311,7 @@     , defGC       = funGC attrs     , defBody     = snd (runBB (k (map (fmap toValue) args)))     , defMetadata = Map.empty+    , defComdat   = Nothing     }  -- Basic Block Monad -----------------------------------------------------------@@ -321,7 +325,7 @@   rw <- get   case avoid name (rwNames rw) of     Just ns' -> set rw { rwNames = ns' }-    Nothing  -> fail ("avoidName: " ++ name ++ " already registered")+    Nothing  -> error ("avoidName: " ++ name ++ " already registered")  freshNameBB :: String -> BB String freshNameBB pfx = BB $ do@@ -410,7 +414,7 @@  -- Type Helpers ---------------------------------------------------------------- -iT :: Int32 -> Type+iT :: Word32 -> Type iT  = PrimType . Integer  ptrT :: Type -> Type@@ -419,7 +423,7 @@ voidT :: Type voidT  = PrimType Void -arrayT :: Int32 -> Type -> Type+arrayT :: Word64 -> Type -> Type arrayT  = Array  @@ -511,7 +515,7 @@       do BB (set rw { rwStmts = stmts Seq.|> Result r i m })          return (const (ValIdent r) `fmap` tv) -    _ -> fail "assign: invalid argument"+    _ -> error "assign: invalid argument"  -- | Emit the ``ret'' instruction and terminate the current basic block. ret :: IsValue a => Typed a -> BB ()@@ -625,13 +629,13 @@ 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) ma)+    PtrTo ty -> observe ty (Load (toValue `fmap` tv) Nothing ma)     _        -> error "load not given a pointer"  store :: (IsValue a, IsValue b) => a -> Typed b -> Maybe Align -> BB () store a ptr ma =   case typedType ptr of-    PtrTo ty -> effect (Store (ty -: a) (toValue `fmap` ptr) ma)+    PtrTo ty -> effect (Store (ty -: a) (toValue `fmap` ptr) Nothing ma)     _        -> error "store not given a pointer"  nullPtr :: Type -> Typed Value

@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveFunctor, DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-}@@ -11,10 +11,15 @@  module Text.LLVM.AST where +import Data.Functor.Identity (Identity(..))+import Data.Coerce (coerce)+import Data.Data (Data)+import Data.Typeable (Typeable) import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) import Data.Int (Int32,Int64) import Data.List (genericIndex,genericLength) import qualified Data.Map as Map+import Data.Semigroup as Sem import Data.String (IsString(fromString)) import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic, Generic1)@@ -38,28 +43,33 @@   , modTypes      :: [TypeDecl]    -- ^ top-level type aliases   , modNamedMd    :: [NamedMd]   , modUnnamedMd  :: [UnnamedMd]+  , modComdat     :: Map.Map String SelectionKind   , modGlobals    :: [Global]      -- ^ global value declarations   , modDeclares   :: [Declare]     -- ^ external function declarations (without definitions)   , modDefines    :: [Define]      -- ^ internal function declarations (with definitions)   , modInlineAsm  :: InlineAsm   , modAliases    :: [GlobalAlias]-  } deriving (Show,Generic)+  } deriving (Data, Eq, Ord, Generic, Show, Typeable) -instance Monoid Module where-  mempty = emptyModule-  mappend m1 m2 = Module+instance Sem.Semigroup Module where+  m1 <> m2 = Module     { modSourceName = modSourceName m1 `mplus`   modSourceName m2-    , modDataLayout = modDataLayout m1 `mappend` modDataLayout m2-    , modTypes      = modTypes      m1 `mappend` modTypes      m2-    , modUnnamedMd  = modUnnamedMd  m1 `mappend` modUnnamedMd  m2-    , modNamedMd    = modNamedMd    m1 `mappend` modNamedMd    m2-    , modGlobals    = modGlobals    m1 `mappend` modGlobals    m2-    , modDeclares   = modDeclares   m1 `mappend` modDeclares   m2-    , modDefines    = modDefines    m1 `mappend` modDefines    m2-    , modInlineAsm  = modInlineAsm  m1 `mappend` modInlineAsm  m2-    , modAliases    = modAliases    m1 `mappend` modAliases    m2+    , modDataLayout = modDataLayout m1 <> modDataLayout m2+    , modTypes      = modTypes      m1 <> modTypes      m2+    , modUnnamedMd  = modUnnamedMd  m1 <> modUnnamedMd  m2+    , modNamedMd    = modNamedMd    m1 <> modNamedMd    m2+    , modGlobals    = modGlobals    m1 <> modGlobals    m2+    , modDeclares   = modDeclares   m1 <> modDeclares   m2+    , modDefines    = modDefines    m1 <> modDefines    m2+    , modInlineAsm  = modInlineAsm  m1 <> modInlineAsm  m2+    , modAliases    = modAliases    m1 <> modAliases    m2+    , modComdat     = modComdat     m1 <> modComdat     m2     } +instance Monoid Module where+  mempty = emptyModule+  mappend m1 m2 = m1 <> m2+ emptyModule :: Module emptyModule  = Module   { modSourceName = mempty@@ -72,6 +82,7 @@   , modDefines    = mempty   , modInlineAsm  = mempty   , modAliases    = mempty+  , modComdat     = mempty   }  @@ -80,16 +91,16 @@ data NamedMd = NamedMd   { nmName   :: String   , nmValues :: [Int]-  } deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)   -- Unnamed Metadata ------------------------------------------------------------  data UnnamedMd = UnnamedMd-  { umIndex  :: !Int-  , umValues :: ValMd+  { umIndex    :: !Int+  , umValues   :: ValMd   , umDistinct :: Bool-  } deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)   -- Aliases ---------------------------------------------------------------------@@ -98,7 +109,7 @@   { aliasName   :: Symbol   , aliasType   :: Type   , aliasTarget :: Value-  } deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)   -- Data Layout -----------------------------------------------------------------@@ -117,13 +128,13 @@   | NativeIntSize [Int]   | StackAlign    !Int -- ^ size   | Mangling Mangling-    deriving (Show,Generic)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  data Mangling = ElfMangling               | MipsMangling               | MachOMangling               | WindowsCoffMangling-                deriving (Show,Generic,Eq)+                deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)  -- | Parse the data layout string. parseDataLayout :: MonadPlus m => String -> m DataLayout@@ -145,7 +156,21 @@            'p' -> PointerSize   <$> pInt0 <*> pCInt <*> pCInt <*> pPref            'i' -> IntegerSize   <$> pInt <*> pCInt <*> pPref            'v' -> VectorSize    <$> pInt <*> pCInt <*> pPref-           'f' -> FloatSize     <$> pInt <*> pCInt <*> pPref+           'f' -> FloatSize     <$> pInt <*> pCInt <*> pPref  -- size of float, abi-align, pref-align+                  -- Note that the data layout specified in the LLVM+                  -- BC/IR file is not a directive to the backend, but+                  -- is instead an indication of what the particular+                  -- backend chosen expects to receive.  The actual+                  -- floating point size and alignment is specified as+                  -- zero or more "fSZ:A1:A2" portions of the+                  -- datawidth, where SZ is the size, A1 is the ABI+                  -- alignment, and A2 is the preferred alignment+                  -- (defaulting to A1 if not specified).  Not+                  -- included in the data layout is the actual width,+                  -- alignment, and format for implementation.  See+                  -- (for example) references to LongDoubleWidth and+                  -- LongDoubleFormat in+                  -- https://github.com/llvm/llvm-project/blob/release_60/clang/lib/Basic/Targets/X86.h            's' -> StackObjSize  <$> pInt <*> pCInt <*> pPref            'a' -> AggregateSize <$> pInt <*> pCInt <*> pPref            'n' -> NativeIntSize <$> sepBy pInt (char ':')@@ -178,10 +203,19 @@  type InlineAsm = [String] +-- Comdat ----------------------------------------------------------------------++data SelectionKind = ComdatAny+                   | ComdatExactMatch+                   | ComdatLargest+                   | ComdatNoDuplicates+                   | ComdatSameSize+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)+ -- Identifiers -----------------------------------------------------------------  newtype Ident = Ident String-    deriving (Show,Generic,Eq,Ord)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  instance IsString Ident where   fromString = Ident@@ -189,11 +223,14 @@ -- Symbols ---------------------------------------------------------------------  newtype Symbol = Symbol String-    deriving (Show,Generic,Eq,Ord)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) +instance Sem.Semigroup Symbol where+  Symbol a <> Symbol b = Symbol (a <> b)+ instance Monoid Symbol where-  mappend (Symbol a) (Symbol b) = Symbol (mappend a b)-  mempty                        = Symbol mempty+  mappend = (<>)+  mempty  = Symbol mempty  instance IsString Symbol where   fromString = Symbol@@ -203,11 +240,11 @@ data PrimType   = Label   | Void-  | Integer Int32+  | Integer Word32   | FloatType FloatType   | X86mmx   | Metadata-    deriving (Eq, Generic, Ord, Show)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  data FloatType   = Half@@ -216,37 +253,40 @@   | Fp128   | X86_fp80   | PPC_fp128-    deriving (Eq, Generic, Ord, Show)+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)  type Type = Type' Ident  data Type' ident   = PrimType PrimType   | Alias ident-  | Array Int32 (Type' ident)+  | Array Word64 (Type' ident)   | FunTy (Type' ident) [Type' ident] Bool   | PtrTo (Type' ident)   | Struct [Type' ident]   | PackedStruct [Type' ident]-  | Vector Int32 (Type' ident)+  | Vector Word64 (Type' ident)   | Opaque-    deriving (Eq, Generic, Ord, Show, Functor)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable) --- | Traverse a type, updating or removing aliases.-updateAliases :: (a -> Type' b) -> (Type' a -> Type' b)-updateAliases f = loop+-- | Applicatively traverse a type, updating or removing aliases.+updateAliasesA :: (Applicative f) => (a -> f (Type' b)) -> Type' a -> f (Type' b)+updateAliasesA f = loop   where   loop ty = case ty of-    Array len ety    -> Array len    (loop ety)-    FunTy res ps var -> FunTy        (loop res) (map loop ps) var-    PtrTo pty        -> PtrTo        (loop pty)-    Struct fs        -> Struct       (map loop fs)-    PackedStruct fs  -> PackedStruct (map loop fs)+    Array len ety    -> Array len    <$> (loop ety)+    FunTy res ps var -> FunTy        <$> (loop res) <*> (traverse loop ps) <*> pure var+    PtrTo pty        -> PtrTo        <$> (loop pty)+    Struct fs        -> Struct       <$> (traverse loop fs)+    PackedStruct fs  -> PackedStruct <$> (traverse loop fs)+    Vector len ety   -> Vector       <$> pure len <*> (loop ety)+    PrimType pty     -> pure $ PrimType pty+    Opaque           -> pure $ Opaque     Alias lab        -> f lab-    PrimType pty     -> PrimType pty-    Vector len ety   -> Vector len (loop ety)-    Opaque           -> Opaque +-- | Traverse a type, updating or removing aliases.+updateAliases :: (a -> Type' b) -> Type' a -> Type' b+updateAliases f = coerce $ updateAliasesA (Identity . f)  isFloatingPoint :: PrimType -> Bool isFloatingPoint (FloatType _) = True@@ -291,6 +331,7 @@ data NullResult lab   = HasNull (Value' lab)   | ResolveNull Ident+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  primTypeNull :: PrimType -> Value' lab primTypeNull (Integer 1)    = ValBool False@@ -299,8 +340,10 @@ primTypeNull _              = ValZeroInit  floatTypeNull :: FloatType -> Value' lab-floatTypeNull Float = ValFloat 0-floatTypeNull _     = ValDouble 0 -- XXX not sure about this+floatTypeNull Float    = ValFloat 0+floatTypeNull Double   = ValDouble 0 -- XXX not sure about this+floatTypeNull X86_fp80 = ValFP80 $ FP80_LongDouble 0 0+floatTypeNull _        = error "must be a float type"  typeNull :: Type -> NullResult lab typeNull (PrimType pt) = HasNull (primTypeNull pt)@@ -322,11 +365,11 @@ elimPtrTo (PtrTo ty) = return ty elimPtrTo _          = mzero -elimVector :: MonadPlus m => Type -> m (Int32,Type)+elimVector :: MonadPlus m => Type -> m (Word64,Type) elimVector (Vector n pty) = return (n,pty) elimVector _              = mzero -elimArray :: MonadPlus m => Type -> m (Int32, Type)+elimArray :: MonadPlus m => Type -> m (Word64, Type) elimArray (Array n ety) = return (n, ety) elimArray _             = mzero @@ -355,32 +398,34 @@ data TypeDecl = TypeDecl   { typeName  :: Ident   , typeValue :: Type-  } deriving (Show, Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)   -- Globals ---------------------------------------------------------------------  data Global = Global-  { globalSym   :: Symbol-  , globalAttrs :: GlobalAttrs-  , globalType  :: Type-  , globalValue :: Maybe Value-  , globalAlign :: Maybe Align+  { globalSym      :: Symbol+  , globalAttrs    :: GlobalAttrs+  , globalType     :: Type+  , globalValue    :: Maybe Value+  , globalAlign    :: Maybe Align   , globalMetadata :: GlobalMdAttachments-  } deriving (Show, Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  addGlobal :: Global -> Module -> Module addGlobal g m = m { modGlobals = g : modGlobals m }  data GlobalAttrs = GlobalAttrs   { gaLinkage    :: Maybe Linkage+  , gaVisibility :: Maybe Visibility   , gaConstant   :: Bool-  } deriving (Show, Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  emptyGlobalAttrs :: GlobalAttrs emptyGlobalAttrs  = GlobalAttrs-  { gaLinkage  = Nothing-  , gaConstant = False+  { gaLinkage    = Nothing+  , gaVisibility = Nothing+  , gaConstant   = False   }  @@ -392,7 +437,8 @@   , decArgs    :: [Type]   , decVarArgs :: Bool   , decAttrs   :: [FunAttr]-  } deriving (Show, Generic)+  , decComdat  :: Maybe String+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  -- | The function type of this declaration decFunType :: Declare -> Type@@ -412,7 +458,8 @@   , defGC       :: Maybe GC   , defBody     :: [BasicBlock]   , defMetadata :: FnMdAttachments-  } deriving (Show, Generic)+  , defComdat   :: Maybe String+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  defFunType :: Define -> Type defFunType Define { .. } =@@ -453,14 +500,14 @@    | SSPreq    | SSPstrong    | UWTable-  deriving (Show, Generic)+  deriving (Data, Eq, Generic, Ord, Show, Typeable)  -- Basic Block Labels ----------------------------------------------------------  data BlockLabel   = Named Ident   | Anon Int-    deriving (Eq,Ord,Show, Generic)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  instance IsString BlockLabel where   fromString str = Named (fromString str)@@ -470,7 +517,7 @@ data BasicBlock' lab = BasicBlock   { bbLabel :: Maybe lab   , bbStmts :: [Stmt' lab]-  } deriving (Show, Generic)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type BasicBlock = BasicBlock' BlockLabel @@ -504,18 +551,23 @@   | External   | DLLImport   | DLLExport-    deriving (Eq,Show,Generic)+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) +data Visibility = DefaultVisibility+                | HiddenVisibility+                | ProtectedVisibility+    deriving (Data, Eq, Generic, Ord, Show, Typeable)+ newtype GC = GC   { getGC :: String-  } deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  -- Typed Things ----------------------------------------------------------------  data Typed a = Typed   { typedType  :: Type   , typedValue :: a-  } deriving (Show,Generic,Functor)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  instance Foldable Typed where   foldMap f t = f (typedValue t)@@ -585,7 +637,7 @@     -- ^ * Floating point reminder resulting from floating point division.     --   * The reminder has the same sign as the divident (first parameter). -    deriving (Eq,Generic,Show)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  isIArith :: ArithOp -> Bool isIArith Add{}  = True@@ -635,7 +687,7 @@   | And   | Or   | Xor-    deriving (Show,Generic)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  -- | Conversions from one type to another. data ConvOp@@ -651,8 +703,31 @@   | PtrToInt   | IntToPtr   | BitCast-    deriving (Show,Generic)+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable) +data AtomicRWOp+  = AtomicXchg+  | AtomicAdd+  | AtomicSub+  | AtomicAnd+  | AtomicNand+  | AtomicOr+  | AtomicXor+  | AtomicMax+  | AtomicMin+  | AtomicUMax+  | AtomicUMin+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)++data AtomicOrdering+  = Unordered+  | Monotonic+  | Acquire+  | Release+  | AcqRel+  | SeqCst+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)+ type Align = Int  data Instr' lab@@ -693,21 +768,56 @@          * Middle of basic block.          * Returns a pointer to hold the given number of elements. -} -  | Load (Typed (Value' lab)) (Maybe Align)+  | Load (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align)     {- ^ * Read a value from the given address:            address to read from;+           atomic ordering;            assumptions about alignment of the given pointer.          * Middle of basic block.          * Returns a value of type matching the pointer. -} -  | Store (Typed (Value' lab)) (Typed (Value' lab)) (Maybe Align)+  | Store (Typed (Value' lab)) (Typed (Value' lab)) (Maybe AtomicOrdering) (Maybe Align)     {- ^ * Write a value to memory:              value to store;              pointer to location where to store;+             atomic ordering;              assumptions about the alignment of the given pointer.          * Middle of basic block.          * Effect. -} ++  | Fence (Maybe String) AtomicOrdering+    {- ^ * Introduce a happens-before relationship between operations:+             synchronization scope;+             type of ordering.+         * Middle of basic block. -}++  | CmpXchg Bool Bool (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab)) (Maybe String) AtomicOrdering AtomicOrdering+    {- ^ * Atomically compare and maybe exchange values in memory:+             whether the exchange is weak;+             whether the exchange is volatile;+             pointer to read;+             value to compare it with;+             new value to write if the two prior values are equal;+             synchronization scope;+             synchronization ordering on success;+             synchronization ordering on failure.+         * Returns a pair of the original value and whether an exchange occurred.+         * Middle of basic block.+         * Effect. -}++  | AtomicRW Bool AtomicRWOp (Typed (Value' lab)) (Typed (Value' lab)) (Maybe String) AtomicOrdering+    {- ^ * Perform an atomic load, operation, and store:+             whether the operation is volatile;+             operation to apply to the read value and the provided value;+             pointer to read;+             value to combine it with, using the given operation;+             synchronization scope;+             synchronization ordering.+         * Returns the original value at the given location.+         * Middle of basic block.+         * Effect. -}+   | ICmp ICmpOp (Typed (Value' lab)) (Value' lab)     {- ^ * Compare two integral values.          * Middle of basic block.@@ -728,14 +838,14 @@     {- ^ * "Get element pointer",             compute the address of a field in a structure:             inbounds check (value poisoned if this fails);-            pointer to parent strucutre;-            path to a sub-component of a strucutre.+            pointer to parent structure;+            path to a sub-component of a structure.          * Middle of basic block.-         * Returns the address of the requiested member.+         * Returns the address of the requested member.      The types in path are the types of the index, not the fields. -    The indexes are in units of a fields (i.e., the first element in+    The indexes are in units of fields (i.e., the first element in     a struct is field 0, the next one is 1, etc., regardless of the size     of the fields in bytes). -} @@ -804,18 +914,18 @@            jump table.          * Ends basic block. -} -  | LandingPad Type (Typed (Value' lab)) Bool [Clause' lab]+  | LandingPad Type (Maybe (Typed (Value' lab))) Bool [Clause' lab]    | Resume (Typed (Value' lab)) -    deriving (Show,Functor,Generic)+    deriving (Data, Eq, Functor, Generic, Ord, Show, Typeable)  type Instr = Instr' BlockLabel  data Clause' lab   = Catch  (Typed (Value' lab))   | Filter (Typed (Value' lab))-    deriving (Show,Functor,Generic,Generic1)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type Clause = Clause' BlockLabel @@ -844,13 +954,13 @@  -- | Integer comparison operators. data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle-    deriving (Show, Generic)+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)  -- | Floating-point comparison operators. data FCmpOp = Ffalse  | Foeq | Fogt | Foge | Folt | Fole | Fone             | Ford    | Fueq | Fugt | Fuge | Fult | Fule | Fune             | Funo    | Ftrue-    deriving (Show, Generic)+    deriving (Data, Eq, Enum, Generic, Ord, Show, Typeable)   -- Values ----------------------------------------------------------------------@@ -860,6 +970,7 @@   | ValBool Bool   | ValFloat Float   | ValDouble Double+  | ValFP80 FP80Value   | ValIdent Ident   | ValSymbol Symbol   | ValNull@@ -867,17 +978,20 @@   | ValVector Type [Value' lab]   | ValStruct [Typed (Value' lab)]   | ValPackedStruct [Typed (Value' lab)]-  | ValString String+  | ValString [Word8]   | ValConstExpr (ConstExpr' lab)   | ValUndef   | ValLabel lab   | ValZeroInit   | ValAsm Bool Bool String String   | ValMd (ValMd' lab)-    deriving (Show,Functor,Generic,Generic1)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type Value = Value' BlockLabel +data FP80Value = FP80_LongDouble Word16 Word64+               deriving (Data, Eq, Ord, Generic, Show, Typeable)+ data ValMd' lab   = ValMdString String   | ValMdValue (Typed (Value' lab))@@ -885,7 +999,7 @@   | ValMdNode [Maybe (ValMd' lab)]   | ValMdLoc (DebugLoc' lab)   | ValMdDebugInfo (DebugInfo' lab)-    deriving (Show,Functor,Generic,Generic1)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type ValMd = ValMd' BlockLabel @@ -898,7 +1012,8 @@   , dlCol   :: Word32   , dlScope :: ValMd' lab   , dlIA    :: Maybe (ValMd' lab)-  } deriving (Show,Functor,Generic,Generic1)+  , dlImplicit :: Bool+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DebugLoc = DebugLoc' BlockLabel @@ -907,6 +1022,7 @@ isConst ValBool{}      = True isConst ValFloat{}     = True isConst ValDouble{}    = True+isConst ValFP80{}      = True isConst ValConstExpr{} = True isConst ValZeroInit    = True isConst ValNull        = True@@ -927,7 +1043,7 @@ data Stmt' lab   = Result Ident (Instr' lab) [(String,ValMd' lab)]   | Effect (Instr' lab) [(String,ValMd' lab)]-    deriving (Show,Functor,Generic,Generic1)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type Stmt = Stmt' BlockLabel @@ -949,7 +1065,7 @@ -- Constant Expressions --------------------------------------------------------  data ConstExpr' lab-  = ConstGEP Bool (Maybe Type) [Typed (Value' lab)]+  = ConstGEP Bool (Maybe Word64) (Maybe Type) [Typed (Value' lab)]   -- ^ Element type introduced in LLVM 3.7   | ConstConv ConvOp (Typed (Value' lab)) Type   | ConstSelect (Typed (Value' lab)) (Typed (Value' lab)) (Typed (Value' lab))@@ -958,7 +1074,7 @@   | ConstICmp ICmpOp (Typed (Value' lab)) (Typed (Value' lab))   | ConstArith ArithOp (Typed (Value' lab)) (Value' lab)   | ConstBit BitOp (Typed (Value' lab)) (Value' lab)-    deriving (Show,Functor,Generic,Generic1)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type ConstExpr = ConstExpr' BlockLabel @@ -980,13 +1096,58 @@   | DebugInfoSubprogram (DISubprogram' lab)   | DebugInfoSubrange DISubrange   | DebugInfoSubroutineType (DISubroutineType' lab)-  deriving (Show,Functor,Generic,Generic1)+  | DebugInfoNameSpace (DINameSpace' lab)+  | DebugInfoTemplateTypeParameter (DITemplateTypeParameter' lab)+  | DebugInfoTemplateValueParameter (DITemplateValueParameter' lab)+  | DebugInfoImportedEntity (DIImportedEntity' lab)+  | DebugInfoLabel (DILabel' lab)+    deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DebugInfo = DebugInfo' BlockLabel +type DILabel = DILabel' BlockLabel+data DILabel' lab = DILabel+    { dilScope :: Maybe (ValMd' lab)+    , dilName  :: String+    , dilFile  :: Maybe (ValMd' lab)+    , dilLine  :: Word32+    } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DIImportedEntity = DIImportedEntity' BlockLabel+data DIImportedEntity' lab = DIImportedEntity+    { diieTag    :: DwarfTag+    , diieScope  :: Maybe (ValMd' lab)+    , diieEntity :: Maybe (ValMd' lab)+    , diieFile   :: Maybe (ValMd' lab)+    , diieLine   :: Word32+    , diieName   :: Maybe String+    } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DITemplateTypeParameter = DITemplateTypeParameter' BlockLabel+data DITemplateTypeParameter' lab = DITemplateTypeParameter+    { dittpName :: Maybe String+    , dittpType :: Maybe (ValMd' lab)+    } 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+    } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)++type DINameSpace = DINameSpace' BlockLabel+data DINameSpace' lab = DINameSpace+    { dinsName  :: Maybe String+    , dinsScope :: ValMd' lab+    , dinsFile  :: ValMd' lab+    , dinsLine  :: Word32+    } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)+ -- TODO: Turn these into sum types -- See https://github.com/llvm-mirror/llvm/blob/release_38/include/llvm/Support/Dwarf.def-type DwarfAttrEncoding = Word8+type DwarfAttrEncoding = Word16 type DwarfLang = Word16 type DwarfTag = Word16 type DwarfVirtuality = Word8@@ -998,12 +1159,13 @@ type DIEmissionKind = Word8  data DIBasicType = DIBasicType-  { dibtTag :: DwarfTag-  , dibtName :: String-  , dibtSize :: Word64-  , dibtAlign :: Word64+  { dibtTag      :: DwarfTag+  , dibtName     :: String+  , dibtSize     :: Word64+  , dibtAlign    :: Word64   , dibtEncoding :: DwarfAttrEncoding-  } deriving (Show,Generic)+  , dibtFlags    :: Maybe DIFlags+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  data DICompileUnit' lab = DICompileUnit   { dicuLanguage           :: DwarfLang@@ -1022,8 +1184,7 @@   , dicuMacros             :: Maybe (ValMd' lab)   , dicuDWOId              :: Word64   , dicuSplitDebugInlining :: Bool-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DICompileUnit = DICompileUnit' BlockLabel @@ -1043,8 +1204,8 @@   , dictVTableHolder   :: Maybe (ValMd' lab)   , dictTemplateParams :: Maybe (ValMd' lab)   , dictIdentifier     :: Maybe String-  }-  deriving (Show,Functor,Generic,Generic1)+  , dictDiscriminator  :: Maybe (ValMd' lab)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DICompositeType = DICompositeType' BlockLabel @@ -1060,20 +1221,18 @@   , didtOffset :: Word64   , didtFlags :: DIFlags   , didtExtraData :: Maybe (ValMd' lab)-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DIDerivedType = DIDerivedType' BlockLabel  data DIExpression = DIExpression   { dieElements :: [Word64]-  }-  deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  data DIFile = DIFile   { difFilename  :: FilePath   , difDirectory :: FilePath-  } deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  data DIGlobalVariable' lab = DIGlobalVariable   { digvScope                :: Maybe (ValMd' lab)@@ -1087,16 +1246,14 @@   , digvVariable             :: Maybe (ValMd' lab)   , digvDeclaration          :: Maybe (ValMd' lab)   , digvAlignment            :: Maybe Word32-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DIGlobalVariable = DIGlobalVariable' BlockLabel  data DIGlobalVariableExpression' lab = DIGlobalVariableExpression   { digveVariable   :: Maybe (ValMd' lab)   , digveExpression :: Maybe (ValMd' lab)-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DIGlobalVariableExpression = DIGlobalVariableExpression' BlockLabel @@ -1105,8 +1262,7 @@   , dilbFile   :: Maybe (ValMd' lab)   , dilbLine   :: Word32   , dilbColumn :: Word16-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DILexicalBlock = DILexicalBlock' BlockLabel @@ -1114,8 +1270,7 @@   { dilbfScope         :: ValMd' lab   , dilbfFile          :: Maybe (ValMd' lab)   , dilbfDiscriminator :: Word32-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DILexicalBlockFile = DILexicalBlockFile' BlockLabel @@ -1127,8 +1282,7 @@   , dilvType :: Maybe (ValMd' lab)   , dilvArg :: Word16   , dilvFlags :: DIFlags-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DILocalVariable = DILocalVariable' BlockLabel @@ -1148,25 +1302,24 @@   , dispThisAdjustment :: Int64   , dispFlags          :: DIFlags   , dispIsOptimized    :: Bool+  , dispUnit           :: Maybe (ValMd' lab)   , dispTemplateParams :: Maybe (ValMd' lab)   , dispDeclaration    :: Maybe (ValMd' lab)   , dispVariables      :: Maybe (ValMd' lab)-  }-  deriving (Show,Functor,Generic,Generic1)+  , dispThrownTypes    :: Maybe (ValMd' lab)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DISubprogram = DISubprogram' BlockLabel  data DISubrange = DISubrange-  { disrCount :: Int64+  { disrCount      :: Int64   , disrLowerBound :: Int64-  }-  deriving (Show,Generic)+  } deriving (Data, Eq, Generic, Ord, Show, Typeable)  data DISubroutineType' lab = DISubroutineType-  { distFlags :: DIFlags+  { distFlags     :: DIFlags   , distTypeArray :: Maybe (ValMd' lab)-  }-  deriving (Show,Functor,Generic,Generic1)+  } deriving (Data, Eq, Functor, Generic, Generic1, Ord, Show, Typeable)  type DISubroutineType = DISubroutineType' BlockLabel @@ -1176,6 +1329,7 @@   = Invalid                             -- ^ An invalid use of GEP   | HasType Type                        -- ^ A resolved type   | Resolve Ident (Type -> IndexResult) -- ^ Continue, after resolving an alias+  deriving (Generic, Typeable)  isInvalid :: IndexResult -> Bool isInvalid ir = case ir of@@ -1237,7 +1391,9 @@     Invalid  isGepIndex :: Typed (Value' lab) -> Bool-isGepIndex tv = isPrimTypeOf isInteger (typedType tv)+isGepIndex tv =+  isPrimTypeOf isInteger (typedType tv) ||+  isVectorOf (isPrimTypeOf isInteger) (typedType tv)  isGepStructIndex :: Typed (Value' lab) -> Maybe Integer isGepStructIndex tv = do

@@ -20,17 +20,20 @@   , derefInfo   , fieldIndexByPosition   , fieldIndexByName++  -- * Info hueristics+  , guessAliasInfo   ) where  import           Control.Applicative    ((<|>)) import           Control.Monad          ((<=<)) import           Data.IntMap            (IntMap) import qualified Data.IntMap as IntMap-import           Data.List              (elemIndex, tails)+import           Data.List              (elemIndex, tails, stripPrefix) import           Data.Map               (Map) import qualified Data.Map    as Map-import           Data.Maybe             (fromMaybe, listToMaybe, maybeToList)-import           Data.Word              (Word16)+import           Data.Maybe             (fromMaybe, listToMaybe, maybeToList, mapMaybe)+import           Data.Word              (Word16, Word64) import           Text.LLVM.AST  dbgKind :: String@@ -40,10 +43,11 @@ llvmDbgCuKey = "llvm.dbg.cu"  dwarfPointer, dwarfStruct, dwarfTypedef, dwarfUnion, dwarfBasetype,-  dwarfConst :: Word16+  dwarfConst, dwarfArray :: Word16 dwarfPointer  = 0x0f dwarfStruct   = 0x13 dwarfTypedef  = 0x16+dwarfArray    = 0x01 dwarfUnion    = 0x17 dwarfBasetype = 0x24 dwarfConst    = 0x26@@ -52,8 +56,9 @@  data Info   = Pointer Info-  | Structure [(String,Info)]+  | Structure [(String,Word64,Info)] -- ^ Fields: name, bit-offset, info   | Union     [(String,Info)]+  | ArrInfo Info   | BaseType String   | Unknown   deriving Show@@ -109,24 +114,39 @@ debugInfoToInfo _     (DebugInfoBasicType bt)   | dibtTag bt == dwarfBasetype = BaseType (dibtName bt) debugInfoToInfo mdMap (DebugInfoCompositeType ct)-  | dictTag ct == dwarfStruct   = maybe Unknown Structure (getFields mdMap ct)-  | dictTag ct == dwarfUnion    = maybe Unknown Union     (getFields mdMap ct)+  | dictTag ct == dwarfStruct   = maybe Unknown Structure (getStructFields mdMap ct)+  | dictTag ct == dwarfUnion    = maybe Unknown Union     (getUnionFields mdMap ct)+  | dictTag ct == dwarfArray    = ArrInfo (valMdToInfo' mdMap (dictBaseType ct)) debugInfoToInfo _ _             = Unknown  -getFields :: MdMap -> DICompositeType -> Maybe [(String, Info)]-getFields mdMap ct =-  traverse (debugInfoToField mdMap <=< getDebugInfo mdMap)-       =<< sequence =<< getList mdMap =<< dictElements ct+getFieldDIs :: MdMap -> DICompositeType -> Maybe [DebugInfo]+getFieldDIs mdMap =+  traverse (getDebugInfo mdMap) <=< sequence <=< getList mdMap <=< dictElements  -debugInfoToField :: MdMap -> DebugInfo -> Maybe (String, Info)-debugInfoToField mdMap di =+getStructFields :: MdMap -> DICompositeType -> Maybe [(String, Word64, Info)]+getStructFields mdMap = traverse (debugInfoToStructField mdMap) <=< getFieldDIs mdMap++debugInfoToStructField :: MdMap -> DebugInfo -> Maybe (String, Word64, Info)+debugInfoToStructField mdMap di =   do DebugInfoDerivedType dt <- Just di      fieldName               <- didtName dt+     Just (fieldName, didtOffset dt, valMdToInfo' mdMap (didtBaseType dt))+++getUnionFields :: MdMap -> DICompositeType -> Maybe [(String, Info)]+getUnionFields mdMap = traverse (debugInfoToUnionField mdMap) <=< getFieldDIs mdMap+++debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe (String, Info)+debugInfoToUnionField mdMap di =+  do DebugInfoDerivedType dt <- Just di+     fieldName               <- didtName dt      Just (fieldName, valMdToInfo' mdMap (didtBaseType dt))  + -- | Compute the structures of a function's return and argument types -- using DWARF information metadata of the LLVM module. Different -- versions of LLVM make this information available via different@@ -182,11 +202,13 @@ ------------------------------------------------------------------------  -- | If the argument describes a pointer, return the information for the--- type that it points do.+-- type that it points do. If the argument describes an array, return+-- information about the element type. derefInfo ::   Info {- ^ pointer type information                -} ->   Info {- ^ type information of pointer's base type -} derefInfo (Pointer x) = x+derefInfo (ArrInfo x) = x derefInfo _           = Unknown  -- | If the argument describes a composite type, returns the type of the@@ -197,13 +219,13 @@   Info {- ^ type information for specified field -} fieldIndexByPosition i info =   case info of-    Structure xs -> go xs-    Union     xs -> go xs+    Structure xs -> go [ x | (_,_,x) <- xs ]+    Union     xs -> go [ x | (_,x)   <- xs ]     _            -> Unknown   where     go xs = case drop i xs of               []  -> Unknown-              x:_ -> snd x+              x:_ -> x  -- | If the argument describes a composite type, return the first, zero-based -- index of the field in that type that matches the given name.@@ -213,11 +235,11 @@   Maybe Int {- ^ zero-based index of field matching the name -} fieldIndexByName n info =   case info of-    Structure xs -> go xs-    Union     xs -> go xs+    Structure xs -> go [ x | (x,_,_) <- xs ]+    Union     xs -> go [ x | (x,_)   <- xs ]     _            -> Nothing   where-    go = elemIndex n . map fst+    go = elemIndex n  ------------------------------------------------------------------------ @@ -232,7 +254,7 @@   where      aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident-    aux ( Effect (Store src dst _) _+    aux ( Effect (Store src dst _ _) _         : Effect (Call _ _ (ValSymbol (Symbol what)) [var,md,_]) _         : _) sofar       | what == "llvm.dbg.declare"@@ -261,3 +283,40 @@       do ValMd md                    <- Just (typedValue mdArg)          DebugInfoLocalVariable dilv <- getDebugInfo mdMap md          Ident <$> dilvName dilv++------------------------------------------------------------------------++-- | 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.+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++guessStructInfo ::+  IntMap ValMd    {- ^ unnamed metadata      -} ->+  String          {- ^ struct alias          -} ->+  Info+guessStructInfo mdMap name =+  case mapMaybe (go <=< getDebugInfo mdMap) (IntMap.elems mdMap) of+    []  -> Unknown+    x:_ -> x++  where+    go di | DebugInfoDerivedType didt <- di+          , Just name == didtName didt+          = Just (debugInfoToInfo mdMap di)++    go di | DebugInfoCompositeType dict <- di+          , Just name == dictName dict+          = Just (debugInfoToInfo mdMap di)++    go _ = Nothing

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE EmptyCase, TypeOperators, FlexibleContexts #-}  #ifndef MIN_VERSION_base@@ -8,62 +9,18 @@ module Text.LLVM.Labels where  import Text.LLVM.AST-import GHC.Generics+import Text.LLVM.Labels.TH  #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<$>),Applicative(..)) import Data.Traversable (traverse) #endif ----------------------------------------------------------------------------- | Generic implementation of 'relabel' the never provides symbols-genericRelabel ::-  (Applicative m, Generic1 f, GHasLabel (Rep1 f)) =>-  (Maybe Symbol -> a -> m b) -> f a -> m (f b)-genericRelabel f x = to1 <$> grelabel f (from1 x)---- | Implementation details for 'genericRelabel'-class GHasLabel f where-  grelabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b)--instance GHasLabel f => GHasLabel (M1 i c f) where-  grelabel f (M1 x) = M1 <$> grelabel f x--instance (GHasLabel f, GHasLabel g) => GHasLabel (f :*: g) where-  grelabel f (x :*: y) = (:*:) <$> grelabel f x <*> grelabel f y--instance (GHasLabel f, GHasLabel g) => GHasLabel (f :+: g) where-  grelabel f (L1 x) = L1 <$> grelabel f x-  grelabel f (R1 x) = R1 <$> grelabel f x--instance GHasLabel U1 where-  grelabel _ U1 = pure U1--instance GHasLabel V1 where-  grelabel _ v1 = case v1 of {}--instance GHasLabel Par1 where-  grelabel f (Par1 x) = Par1 <$> f Nothing x--instance GHasLabel (K1 i a) where-  grelabel _ (K1 a) = pure (K1 a)--instance HasLabel f => GHasLabel (Rec1 f) where-  grelabel f (Rec1 x) = Rec1 <$> relabel f x--instance (Traversable f, GHasLabel g) => GHasLabel (f :.: g) where-  grelabel f (Comp1 x) = Comp1 <$> traverse (grelabel f) x--------------------------------------------------------------------------- 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.   relabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b) -instance HasLabel Stmt' where relabel = genericRelabel- instance HasLabel Instr' where   relabel _ RetVoid               = pure  RetVoid   relabel _ Unreachable           = pure  Unreachable@@ -83,11 +40,27 @@   relabel f (Alloca t n a)        = Alloca t                                 <$> traverse (traverse (relabel f)) n                                 <*> pure a-  relabel f (Load a ma)           = Load <$> traverse (relabel f) a <*> pure ma-  relabel f (Store d v ma)        = Store+  relabel f (Load a mo ma)        = Load <$> traverse (relabel f) a <*> pure mo <*> pure ma+  relabel f (Store d v mo ma)     = Store                                 <$> traverse (relabel f) d                                 <*> traverse (relabel f) v+                                <*> pure mo                                 <*> pure ma+  relabel _ (Fence s o)           = pure (Fence s o)+  relabel f (CmpXchg w v p a n s o o')+                                  = CmpXchg w v+                                <$> traverse (relabel f) p+                                <*> traverse (relabel f) a+                                <*> traverse (relabel f) n+                                <*> pure s+                                <*> pure o+                                <*> pure o'+  relabel f (AtomicRW v op p a s o)+                                  = AtomicRW v op+                                <$> traverse (relabel f) p+                                <*> traverse (relabel f) a+                                <*> pure s+                                <*> pure o   relabel f (ICmp op l r)         = ICmp op                                 <$> traverse (relabel f) l                                 <*> relabel f r@@ -142,29 +115,35 @@      in Phi t <$> traverse step ls    relabel f (LandingPad ty fn c cs) = LandingPad ty-                                  <$> traverse (relabel f) fn+                                  <$> traverse (traverse (relabel f)) fn                                   <*> pure c                                   <*> traverse (relabel f) cs    relabel f (Resume tv)           = Resume <$> traverse (relabel f) tv -instance HasLabel Clause'                     where relabel = genericRelabel-instance HasLabel Value'                      where relabel = genericRelabel-instance HasLabel ValMd'                      where relabel = genericRelabel-instance HasLabel DebugLoc'                   where relabel = genericRelabel-instance HasLabel DebugInfo'                  where relabel = genericRelabel-instance HasLabel DIDerivedType'              where relabel = genericRelabel-instance HasLabel DISubroutineType'           where relabel = genericRelabel-instance HasLabel DIGlobalVariable'           where relabel = genericRelabel-instance HasLabel DIGlobalVariableExpression' where relabel = genericRelabel-instance HasLabel DILocalVariable'            where relabel = genericRelabel-instance HasLabel DISubprogram'               where relabel = genericRelabel-instance HasLabel DICompositeType'            where relabel = genericRelabel-instance HasLabel DILexicalBlock'             where relabel = genericRelabel-instance HasLabel DICompileUnit'              where relabel = genericRelabel-instance HasLabel DILexicalBlockFile'         where relabel = genericRelabel+instance HasLabel Stmt'                       where relabel = $(generateRelabel 'relabel ''Stmt')+instance HasLabel Clause'                     where relabel = $(generateRelabel 'relabel ''Clause')+instance HasLabel Value'                      where relabel = $(generateRelabel 'relabel ''Value')+instance HasLabel ValMd'                      where relabel = $(generateRelabel 'relabel ''ValMd')+instance HasLabel DILabel'                    where relabel = $(generateRelabel 'relabel ''DILabel')+instance HasLabel DebugLoc'                   where relabel = $(generateRelabel 'relabel ''DebugLoc')+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 DIGlobalVariable'           where relabel = $(generateRelabel 'relabel ''DIGlobalVariable')+instance HasLabel DIGlobalVariableExpression' where relabel = $(generateRelabel 'relabel ''DIGlobalVariableExpression')+instance HasLabel DILocalVariable'            where relabel = $(generateRelabel 'relabel ''DILocalVariable')+instance HasLabel DISubprogram'               where relabel = $(generateRelabel 'relabel ''DISubprogram')+instance HasLabel DICompositeType'            where relabel = $(generateRelabel 'relabel ''DICompositeType')+instance HasLabel DILexicalBlock'             where relabel = $(generateRelabel 'relabel ''DILexicalBlock')+instance HasLabel DICompileUnit'              where relabel = $(generateRelabel 'relabel ''DICompileUnit')+instance HasLabel DILexicalBlockFile'         where relabel = $(generateRelabel 'relabel ''DILexicalBlockFile')+instance HasLabel DINameSpace'                where relabel = $(generateRelabel 'relabel ''DINameSpace')+instance HasLabel DITemplateTypeParameter'    where relabel = $(generateRelabel 'relabel ''DITemplateTypeParameter')+instance HasLabel DITemplateValueParameter'   where relabel = $(generateRelabel 'relabel ''DITemplateValueParameter')+instance HasLabel DIImportedEntity'           where relabel = $(generateRelabel 'relabel ''DIImportedEntity')  -- | 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 x = genericRelabel f x+  relabel f x = $(generateRelabel 'relabel ''ConstExpr') f x

@@ -0,0 +1,125 @@+{-# Language TemplateHaskell #-}+module Text.LLVM.Labels.TH (generateRelabel) where++import Control.Monad (zipWithM)+import Language.Haskell.TH+import Language.Haskell.TH.Datatype++generateRelabel :: Name -> Name -> ExpQ+generateRelabel relabel dataCon =+  do di <- reifyDatatype dataCon+     generateRelabelData di (varE relabel)++generateRelabelData :: DatatypeInfo -> ExpQ -> ExpQ+generateRelabelData di relabelE =+  [| \f x -> $(caseE [| x |] (mkMatch [| f |] <$> cons)) |]+  where+    mkMatch = generateRelabelCon lastArg relabelE+    lastArg = tvName (last (datatypeVars di))+    cons    = datatypeCons di++-- | Generates the case arm for the given constructor that+-- relabels values using this constructor given a relabeling+-- function.+generateRelabelCon ::+  Name            {- ^ last type parameter            -} ->+  ExpQ            {- ^ recusive relabel expression    -} ->+  ExpQ            {- ^ function expression            -} ->+  ConstructorInfo {- ^ current constructor            -} ->+  MatchQ          {- ^ match arm for this constructor -}+generateRelabelCon lastArg relabelE fE ci =+  do names <- nameThings "x" (constructorFields ci)+     match+      (conP cn (map (varP . fst) names))+      (normalB (bodyExp cn (map gen names)))+      []+  where+    cn = constructorName ci++    -- Give a field name and type returns:+    -- Left for a pure field+    -- Right for a field using the Applicative instance+    gen :: (Name, Type) -> Either ExpQ ExpQ+    gen (n,t) =+      let nE = varE n in+      case generateRelabelField lastArg fE relabelE t of+        Just f  -> Right [| $f $nE |]+        Nothing -> Left nE++-- | Given a constructor and a list of pure and updated fields,+-- build syntax that rebuilds the expression.+bodyExp ::+  Name               {- ^ constructor                         -} ->+  [Either ExpQ ExpQ] {- ^ list of pure and applicative fields -} ->+  ExpQ               {- ^ applicative result                  -}+bodyExp conname fields = liftAE conLike updates+  where+    updates = [r | Right r <- fields]++    -- Builds a value suitable to be the argument to liftAE that can+    -- combine all of the updated field values+    conLike =+      do names <- map fst <$> nameThings "y" updates+         lamE+           (map varP names)+           (appsE (conE conname : replaceRights (map varE names) fields))++-- | Replaces all of the 'Right' values in the given list with elements+-- from the first list. The number of replacements must exactly match+-- the number of 'Right' values.+replaceRights ::+  [a]          {- ^ replacements  -} ->+  [Either a b] {- ^ source list   -} ->+  [a]          {- ^ replaced list -}+replaceRights xs     (Left y  : ys) = y : replaceRights xs ys+replaceRights (x:xs) (Right _ : ys) = x : replaceRights xs ys+replaceRights []     []             = []+replaceRights _      _              = error "Text.LLVM.Labels.TH.replaceRights: PANIC"++-- | Generate the applicative update value for a field if it+-- has an appropriate type otherwise return nothing if it+-- should be left unchagned.+generateRelabelField ::+  Name       {- ^ last type parameter         -} ->+  ExpQ       {- ^ function expression         -} ->+  ExpQ       {- ^ relabel expression          -} ->+  Type       {- ^ field type                  -} ->+  Maybe ExpQ {- ^ applicative update function -}+generateRelabelField lastArg fE relabelE t =+  case typeDepth t of+    (n, VarT tn) | tn == lastArg -> Just (exprs !! n)+    _                            -> Nothing+  where+    exprs = [| $fE Nothing |] : iterate traverseE [| $relabelE $fE |]++-- | Figure out the depth of the outer type applications and+-- return the type at the bottom of the stack+typeDepth ::+  Type        {- ^ target type                                     -} ->+  (Int, Type) {- ^ number of type applications and right-most type -}+typeDepth = go 0+  where+    go i (AppT _ x) = go (i+1) x+    go i t          = (i, t)++-- | Associate each element in a list of things with a unique name+-- derived from a given name stem.+nameThings ::+  String        {- ^ base name                       -} ->+  [a]           {- ^ things to name                  -} ->+  Q [(Name, a)] {- ^ things paired with unique names -}+nameThings base xs = zipWithM nameThing [0 :: Int ..] xs+  where+    nameThing i x = do n <- newName (base ++ show i); return (n,x)++-- | Apply 'traverse' to an expression+traverseE ::+  ExpQ {- ^ f          -} ->+  ExpQ {- ^ traverse f -}+traverseE e = [| traverse $e |]++-- Applies a pure value to zero or more applicative things to be combined+-- with (<$>) and (<*>)+liftAE :: ExpQ -> [ExpQ] -> ExpQ+liftAE c []     = [| pure $c |]+liftAE c (x:xs) = foldl (\f e -> [| $f <*> $e |]) [| $c <$> $x |] xs

@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell #-}+module Text.LLVM.Lens where++import Text.LLVM+import Lens.Micro.TH+import Lens.Micro+import Language.Haskell.TH.Syntax (mkName, nameBase)++concat <$> mapM (makeLensesWith (lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "Lens"])))+    [ ''Module+    , ''LayoutSpec+    , ''TypeDecl+    , ''GlobalAlias+    , ''ConstExpr'+    , ''Type'+    , ''Mangling+    , ''NamedMd+    , ''Value'+    , ''BlockLabel+    , ''UnnamedMd+    , ''Typed+    , ''Global+    , ''Declare+    , ''Clause'+    , ''FunAttr+    , ''GlobalAttrs+    , ''BasicBlock'+    , ''Stmt'+    , ''Linkage+    , ''DebugLoc'+    , ''DebugInfo'+    , ''DIFile+    , ''DISubrange+    , ''DIBasicType+    , ''DIExpression+    , ''DISubprogram'+    , ''DISubroutineType'+    , ''DILocalVariable'+    , ''DIGlobalVariableExpression'+    , ''DIGlobalVariable'+    , ''DICompileUnit'+    , ''DICompositeType'+    , ''DIDerivedType'+    , ''DILexicalBlock'+    , ''DILexicalBlockFile'+    , ''Instr'+    , ''ValMd'+    , ''ConvOp+    , ''BitOp+    , ''ArithOp+    , ''FCmpOp+    , ''ICmpOp+    , ''GC+    , ''Define+    , ''PrimType+    ]

@@ -19,13 +19,15 @@ import Text.LLVM.AST  import Control.Applicative ((<|>))-import Data.Char (isAscii,isPrint,ord,toUpper)+import Data.Bits ( shiftR )+import Data.Char (isAlphaNum,isAscii,isDigit,isPrint,ord,toUpper) import Data.List (intersperse) import qualified Data.Map as Map-import Data.Maybe (catMaybes,fromMaybe)+import Data.Maybe (catMaybes,fromMaybe,isJust) import Numeric (showHex) import Text.PrettyPrint.HughesPJ import Data.Int+import Prelude hiding ((<>))   -- Pretty-printer Config -------------------------------------------------------@@ -76,7 +78,8 @@  ppModule :: LLVM => Module -> Doc ppModule m = foldr ($+$) empty-  $ ppDataLayout (modDataLayout m)+  $ ppSourceName (modSourceName m)+  : ppDataLayout (modDataLayout m)   : ppInlineAsm  (modInlineAsm m)   : concat [ map ppTypeDecl    (modTypes m)            , map ppGlobal      (modGlobals m)@@ -85,9 +88,16 @@            , map ppDefine      (modDefines m)            , map ppNamedMd     (modNamedMd m)            , map ppUnnamedMd   (modUnnamedMd m)+           , map ppComdat      (Map.toList (modComdat m))            ]  +-- Source filename -------------------------------------------------------------++ppSourceName :: Maybe String -> Doc+ppSourceName Nothing   = empty+ppSourceName (Just sn) = "source_filename" <+> char '=' <+> doubleQuotes (text sn)+ -- Metadata --------------------------------------------------------------------  ppNamedMd :: NamedMd -> Doc@@ -169,13 +179,29 @@ -- Identifiers -----------------------------------------------------------------  ppIdent :: Ident -> Doc-ppIdent (Ident n) = char '%' <> text n+ppIdent (Ident n)+  | validIdentifier n = char '%' <> text n+  | otherwise         = char '%' <> ppStringLiteral n +-- | According to the LLVM Language Reference Manual, the regular+-- expression for LLVM identifiers is "[-a-zA-Z$._][-a-zA-Z$._0-9]".+-- Identifiers may also be strings of one or more decimal digits.+validIdentifier :: String -> Bool+validIdentifier [] = False+validIdentifier s@(c0 : cs)+  | isDigit c0 = all isDigit cs+  | otherwise  = all isIdentChar s+  where+  isIdentChar :: Char -> Bool+  isIdentChar c = isAlphaNum c || c `elem` ("-$._" :: [Char]) + -- Symbols ---------------------------------------------------------------------  ppSymbol :: Symbol -> Doc-ppSymbol (Symbol n) = char '@' <> text n+ppSymbol (Symbol n)+  | validIdentifier n = char '@' <> text n+  | otherwise         = char '@' <> ppStringLiteral n   -- Types -----------------------------------------------------------------------@@ -216,17 +242,37 @@  ppGlobal :: LLVM => Global -> Doc ppGlobal g = ppSymbol (globalSym g) <+> char '='-         <+> ppGlobalAttrs (globalAttrs g)+         <+> ppTheGlobalAttrs (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 = ppMaybe ppLinkage (gaLinkage ga) <+> constant+ppGlobalAttrs 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+  where+  constant | gaConstant ga = "constant"+           | otherwise     = "global"  ppDeclare :: Declare -> Doc ppDeclare d = "declare"@@ -234,9 +280,23 @@           <+> ppSymbol (decName d)            <> ppArgList (decVarArgs d) (map ppType (decArgs d))           <+> hsep (ppFunAttr <$> decAttrs d)+          <> maybe empty ((char ' ' <>) . ppComdatName) (decComdat d) +ppComdatName :: String -> Doc+ppComdatName s = "comdat" <> parens (char '$' <> text s) +ppComdat :: (String,SelectionKind) -> Doc+ppComdat (n,k) = ppComdatName n <+> char '=' <+> text "comdat" <+> ppSelectionKind k +ppSelectionKind :: SelectionKind -> Doc+ppSelectionKind k =+    case k of+      ComdatAny             -> "any"+      ComdatExactMatch      -> "exactmatch"+      ComdatLargest         -> "largest"+      ComdatNoDuplicates    -> "noduplicates"+      ComdatSameSize        -> "samesize"+ ppDefine :: LLVM => Define -> Doc ppDefine d = "define"          <+> ppMaybe ppLinkage (defLinkage d)@@ -342,6 +402,12 @@   DLLImport                -> "dllimport"   DLLExport                -> "dllexport" +ppVisibility :: Visibility -> Doc+ppVisibility v = case v of+    DefaultVisibility   -> "default"+    HiddenVisibility    -> "hidden"+    ProtectedVisibility -> "protected"+ ppGC :: GC -> Doc ppGC  = doubleQuotes . text . getGC @@ -393,6 +459,31 @@ ppConvOp IntToPtr = "inttoptr" ppConvOp BitCast  = "bitcast" +ppAtomicOrdering :: AtomicOrdering -> Doc+ppAtomicOrdering Unordered = text "unordered"+ppAtomicOrdering Monotonic = text "monotonic"+ppAtomicOrdering Acquire   = text "acquire"+ppAtomicOrdering Release   = text "release"+ppAtomicOrdering AcqRel    = text "acq_rel"+ppAtomicOrdering SeqCst    = text "seq_cst"++ppAtomicOp :: AtomicRWOp -> Doc+ppAtomicOp AtomicXchg = "xchg"+ppAtomicOp AtomicAdd  = "add"+ppAtomicOp AtomicSub  = "sub"+ppAtomicOp AtomicAnd  = "and"+ppAtomicOp AtomicNand = "nand"+ppAtomicOp AtomicOr   = "or"+ppAtomicOp AtomicXor  = "xor"+ppAtomicOp AtomicMax  = "max"+ppAtomicOp AtomicMin  = "min"+ppAtomicOp AtomicUMax = "umax"+ppAtomicOp AtomicUMin = "umin"++ppScope ::  Maybe String -> Doc+ppScope Nothing = empty+ppScope (Just s) = "syncscope" <> parens (doubleQuotes (text s))+ ppInstr :: LLVM => Instr -> Doc ppInstr instr = case instr of   Ret tv                 -> "ret" <+> ppTyped ppValue tv@@ -405,10 +496,24 @@                         <+> "to" <+> ppType ty   Call tc ty f args      -> ppCall tc ty f args   Alloca ty len align    -> ppAlloca ty len align-  Load ptr ma            -> ppLoad ptr ma-  Store a ptr ma         -> "store" <+> ppTyped ppValue a-                         <> comma <+> ppTyped ppValue ptr-                         <> ppAlign ma+  Load ptr mo ma         -> ppLoad 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"+                         <+> opt v "volatile"+                         <+> ppTyped ppValue p+                         <> comma <+> ppTyped ppValue a+                         <> comma <+> ppTyped ppValue n+                         <+> ppScope s+                         <+> ppAtomicOrdering o+                         <+> ppAtomicOrdering o'+  AtomicRW v op p a s o  -> "atomicrmw"+                         <+> opt v "volatile"+                         <+> ppAtomicOp op+                         <+> ppTyped ppValue p+                         <> comma <+> ppTyped ppValue a+                         <+> ppScope s+                         <+> ppAtomicOrdering o   ICmp op l r            -> "icmp" <+> ppICmpOp op                         <+> ppTyped ppValue l <> comma <+> ppValue r   FCmp op l r            -> "fcmp" <+> ppFCmpOp op@@ -456,27 +561,57 @@                         <+> char '['                          $$ nest 2 (vcat (map (ppSwitchEntry (typedType c)) ls))                          $$ char ']'-  LandingPad ty fn c cs  -> "landingpad"+  LandingPad ty mfn c cs  ->+        case mfn of+            Just fn -> "landingpad"                         <+> ppType ty                         <+> "personality"                         <+> ppTyped ppValue fn-                         $$ nest 2 (ppClauses c cs)-  Resume tv              -> "resume" <+> ppTyped ppValue tv+                        $$ nest 2 (ppClauses c cs)+            Nothing -> "landingpad"+                        <+> ppType ty+                        $$ nest 2 (ppClauses c cs)+  Resume tv           -> "resume" <+> ppTyped ppValue tv -ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe Align -> Doc-ppLoad ptr ma =-  "load" <+> (if isImplicit then empty else explicit)+ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe AtomicOrdering -> Maybe Align -> Doc+ppLoad ptr mo ma =+  "load" <+> (if isAtomic   then "atomic" else empty)+         <+> (if isImplicit then empty    else explicit)          <+> ppTyped ppValue ptr+         <+> ordering           <> ppAlign ma    where+  isAtomic = isJust mo+   isImplicit = checkConfig cfgLoadImplicitType +  ordering =+    case mo of+      Just ao -> ppAtomicOrdering ao+      _       -> empty+   explicit =     case typedType ptr of       PtrTo ty -> ppType ty <> comma       ty       -> ppType ty <> comma +ppStore :: LLVM+        => Typed (Value' BlockLabel)+        -> Typed (Value' BlockLabel)+        -> Maybe AtomicOrdering+        -> Maybe Align+        -> Doc+ppStore ptr val mo ma =+  "store" <+> (if isJust mo  then "atomic" else empty)+          <+> ppTyped ppValue ptr <> comma+          <+> ppTyped ppValue val+          <+> case mo of+                Just ao -> ppAtomicOrdering ao+                _       -> empty+          <> ppAlign ma++ ppClauses :: LLVM => Bool -> [Clause] -> Doc ppClauses isCleanup cs = vcat (cleanup : map ppClause cs)   where@@ -580,62 +715,81 @@ ppFCmpOp Funo   = "uno" ppFCmpOp Ftrue  = "true" -ppValue :: LLVM => Value -> Doc-ppValue val = case val of+ppValue' :: LLVM => (i -> Doc) -> Value' i -> Doc+ppValue' pp val = case val of   ValInteger i       -> integer i   ValBool b          -> ppBool b   ValFloat i         -> float i   ValDouble i        -> double i+  ValFP80 (FP80_LongDouble e s) ->+    -- shown as 0xK<<20-hex-digits>>, per+    -- 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)+    in "0xK" <> text (foldr (fld e) (foldr (fld s) "" $ reverse [0..7::Int]) [1, 0])   ValIdent i         -> ppIdent i   ValSymbol s        -> ppSymbol s   ValNull            -> "null"   ValArray ty es     -> brackets-                      $ commas (map (ppTyped ppValue . Typed ty) es)+                      $ commas (map (ppTyped (ppValue' pp) . Typed ty) es)   ValVector ty es   -> angles $ commas-                     $ map (ppTyped ppValue . Typed ty) es-  ValStruct fs       -> structBraces (commas (map (ppTyped ppValue) fs))+                     $ map (ppTyped (ppValue' pp) . Typed ty) es+  ValStruct fs       -> structBraces (commas (map (ppTyped (ppValue' pp)) fs))   ValPackedStruct fs -> angles-                      $ structBraces (commas (map (ppTyped ppValue) fs))-  ValString s        -> char 'c' <> ppStringLiteral s-  ValConstExpr ce    -> ppConstExpr ce+                      $ structBraces (commas (map (ppTyped (ppValue' pp)) fs))+  ValString s        -> char 'c' <> ppStringLiteral (map (toEnum . fromIntegral) s)+  ValConstExpr ce    -> ppConstExpr' pp ce   ValUndef           -> "undef"-  ValLabel l         -> ppLabel l+  ValLabel l         -> pp l   ValZeroInit        -> "zeroinitializer"   ValAsm s a i c     -> ppAsm s a i c-  ValMd m            -> ppValMd m+  ValMd m            -> ppValMd' pp m -ppValMd :: LLVM => ValMd -> Doc-ppValMd m = case m of+ppValue :: LLVM => Value -> Doc+ppValue = ppValue' ppLabel++ppValMd' :: LLVM => (i -> Doc) -> ValMd' i -> Doc+ppValMd' pp m = case m of   ValMdString str   -> ppMetadata (ppStringLiteral str)-  ValMdValue tv     -> ppTyped ppValue tv+  ValMdValue tv     -> ppTyped (ppValue' pp) tv   ValMdRef i        -> ppMetadata (int i)-  ValMdNode vs      -> ppMetadataNode vs-  ValMdLoc l        -> ppDebugLoc l-  ValMdDebugInfo di -> ppDebugInfo di+  ValMdNode vs      -> ppMetadataNode' pp vs+  ValMdLoc l        -> ppDebugLoc' pp l+  ValMdDebugInfo di -> ppDebugInfo' pp di -ppDebugLoc :: LLVM => DebugLoc -> Doc-ppDebugLoc dl = (if cfgUseDILocation ?config then "!DILocation"-                                             else "!MDLocation")+ppValMd :: LLVM => ValMd -> Doc+ppValMd = ppValMd' ppLabel++ppDebugLoc' :: LLVM => (i -> Doc) -> DebugLoc' i -> Doc+ppDebugLoc' pp dl = (if cfgUseDILocation ?config then "!DILocation"+                                                 else "!MDLocation")              <> parens (commas [ "line:"   <+> integral (dlLine dl)                                , "column:" <+> integral (dlCol dl)-                               , "scope:"  <+> ppValMd (dlScope dl)-                               ] <+> mbIA)+                               , "scope:"  <+> ppValMd' pp (dlScope dl)+                               ] <> mbIA <> mbImplicit)    where   mbIA = case dlIA dl of-           Just md -> comma <+> "inlinedAt:" <+> ppValMd md+           Just md -> comma <+> "inlinedAt:" <+> ppValMd' pp md            Nothing -> empty+  mbImplicit = if dlImplicit dl then comma <+> "implicit" else empty +ppDebugLoc :: LLVM => DebugLoc -> Doc+ppDebugLoc = ppDebugLoc' ppLabel+ ppTypedValMd :: LLVM => ValMd -> Doc ppTypedValMd  = ppTyped ppValMd . Typed (PrimType Metadata)  ppMetadata :: Doc -> Doc ppMetadata body = char '!' <> body +ppMetadataNode' :: LLVM => (i -> Doc) -> [Maybe (ValMd' i)] -> Doc+ppMetadataNode' pp vs = ppMetadata (braces (commas (map arg vs)))+  where arg = maybe ("null") (ppValMd' pp)+ ppMetadataNode :: LLVM => [Maybe ValMd] -> Doc-ppMetadataNode vs = ppMetadata (braces (commas (map arg vs)))-  where-  arg = maybe ("null") ppValMd+ppMetadataNode = ppMetadataNode' ppLabel  ppStringLiteral :: String -> Doc ppStringLiteral  = doubleQuotes . text . concatMap escape@@ -659,48 +813,112 @@              | otherwise = empty  -ppConstExpr :: LLVM => ConstExpr -> Doc-ppConstExpr (ConstGEP inb mp ixs)  = "getelementptr"-  <+> opt inb "inbounds"-  <+> parens (mcommas ((ppType <$> mp) : (map (pure . ppTyped ppValue) ixs)))-ppConstExpr (ConstConv op tv t) = ppConvOp op <+> parens-                                 (ppTyped ppValue tv <+> "to" <+> ppType t)-ppConstExpr (ConstSelect c l r) = "select" <+> parens-                                 (commas [ ppTyped ppValue c, ppTyped ppValue l-                                         , ppTyped ppValue r])-ppConstExpr (ConstBlockAddr t l)= "blockaddress" <+> parens-                                 (ppSymbol t <> comma <+> ppLabel l)--ppConstExpr (ConstFCmp op a b)  = "fcmp" <+> ppFCmpOp op <+> parens-                                 (ppTyped ppValue a <> comma <+> ppTyped ppValue b)+ppConstExpr' :: LLVM => (i -> Doc) -> ConstExpr' i -> Doc+ppConstExpr' pp expr =+  case expr of+    ConstGEP inb _mix mp ixs  ->+      "getelementptr"+        <+> opt inb "inbounds"+        <+> parens (mcommas ((ppType <$> mp) : (map (pure . ppTyp') 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+  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 (ConstICmp op a b)  = "icmp" <+> ppICmpOp op <+> parens-                                 (ppTyped ppValue a <> comma <+> ppTyped ppValue b)-ppConstExpr (ConstArith op a b) = ppArithOp op <+> parens-                                  (ppTyped ppValue a <> comma <+> ppValue b)-ppConstExpr (ConstBit op a b)   = ppBitOp op <+> parens-                                  (ppTyped ppValue a <> comma <+> ppValue b)+ppConstExpr :: LLVM => ConstExpr -> Doc+ppConstExpr = ppConstExpr' ppLabel  -- DWARF Debug Info ------------------------------------------------------------ -ppDebugInfo :: LLVM => DebugInfo -> Doc-ppDebugInfo di = case di of+ppDebugInfo' :: LLVM => (i -> Doc) -> DebugInfo' i -> Doc+ppDebugInfo' pp di = case di of   DebugInfoBasicType bt         -> ppDIBasicType bt-  DebugInfoCompileUnit cu       -> ppDICompileUnit cu-  DebugInfoCompositeType ct     -> ppDICompositeType ct-  DebugInfoDerivedType dt       -> ppDIDerivedType dt+  DebugInfoCompileUnit cu       -> ppDICompileUnit' pp cu+  DebugInfoCompositeType ct     -> ppDICompositeType' pp ct+  DebugInfoDerivedType dt       -> ppDIDerivedType' pp dt   DebugInfoEnumerator nm v      -> ppDIEnumerator nm v   DebugInfoExpression e         -> ppDIExpression e   DebugInfoFile f               -> ppDIFile f-  DebugInfoGlobalVariable gv    -> ppDIGlobalVariable gv-  DebugInfoGlobalVariableExpression gv -> ppDIGlobalVariableExpression gv-  DebugInfoLexicalBlock lb      -> ppDILexicalBlock lb-  DebugInfoLexicalBlockFile lbf -> ppDILexicalBlockFile lbf-  DebugInfoLocalVariable lv     -> ppDILocalVariable lv-  DebugInfoSubprogram sp        -> ppDISubprogram sp+  DebugInfoGlobalVariable gv    -> ppDIGlobalVariable' pp gv+  DebugInfoGlobalVariableExpression gv -> ppDIGlobalVariableExpression' pp gv+  DebugInfoLexicalBlock lb      -> ppDILexicalBlock' pp lb+  DebugInfoLexicalBlockFile lbf -> ppDILexicalBlockFile' pp lbf+  DebugInfoLocalVariable lv     -> ppDILocalVariable' pp lv+  DebugInfoSubprogram sp        -> ppDISubprogram' pp sp   DebugInfoSubrange sr          -> ppDISubrange sr-  DebugInfoSubroutineType st    -> ppDISubroutineType st+  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 +ppDebugInfo :: LLVM => DebugInfo -> Doc+ppDebugInfo = ppDebugInfo' ppLabel++ppDIImportedEntity' :: LLVM => (i -> Doc) -> DIImportedEntity' i -> Doc+ppDIImportedEntity' pp ie = "!DIImportedEntity"+  <> parens (mcommas [ pure ("tag:"    <+> integral (diieTag ie))+                     , (("scope:"  <+>) . ppValMd' pp) <$> diieScope ie+                     , (("entity:" <+>) . ppValMd' pp) <$> diieEntity ie+                     , (("file:"   <+>) . ppValMd' pp) <$> diieFile ie+                     , pure ("line:"   <+> integral (diieLine ie))+                     , (("name:"   <+>) . text)        <$> diieName ie+                     ])++ppDIImportedEntity :: LLVM => DIImportedEntity -> Doc+ppDIImportedEntity = ppDIImportedEntity' ppLabel++ppDILabel' :: LLVM => (i -> Doc) -> DILabel' i -> Doc+ppDILabel' pp ie = "!DILabel"+  <> parens (mcommas [ (("scope:"  <+>) . ppValMd' pp) <$> dilScope ie+                     , pure ("name:" <+> text (dilName ie))+                     , (("file:"   <+>) . ppValMd' pp) <$> dilFile ie+                     , pure ("line:"   <+> integral (dilLine ie))+                     ])++ppDILabel :: LLVM => DILabel -> Doc+ppDILabel = ppDILabel' ppLabel++ppDINameSpace' :: LLVM => (i -> Doc) -> DINameSpace' i -> Doc+ppDINameSpace' pp ns = "!DINameSpace"+  <> parens (mcommas [ ("name:"   <+>) . text <$> (dinsName ns)+                     , pure ("scope:"  <+> ppValMd' pp (dinsScope ns))+                     , pure ("file:"   <+> ppValMd' pp (dinsFile ns))+                     , pure ("line:"   <+> integral (dinsLine ns))+                     ])++ppDINameSpace :: LLVM => DINameSpace -> Doc+ppDINameSpace = ppDINameSpace' ppLabel++ppDITemplateTypeParameter' :: LLVM => (i -> Doc) -> DITemplateTypeParameter' i -> Doc+ppDITemplateTypeParameter' pp tp = "!DITemplateTypeParameter"+  <> parens (mcommas [ ("name:"  <+>) . text        <$> dittpName tp+                     , ("type:"  <+>) . ppValMd' pp <$> dittpType tp+                     ])++ppDITemplateTypeParameter :: LLVM => DITemplateTypeParameter -> Doc+ppDITemplateTypeParameter = ppDITemplateTypeParameter' ppLabel++ppDITemplateValueParameter' :: LLVM => (i -> Doc) -> DITemplateValueParameter' i -> Doc+ppDITemplateValueParameter' pp vp = "!DITemplateValueParameter"+  <> parens (mcommas [ pure ("tag:"   <+> integral (ditvpTag vp))+                     , ("name:"  <+>) . text        <$> ditvpName vp+                     , ("type:"  <+>) . ppValMd' pp <$> ditvpType vp+                     , pure ("value:" <+> ppValMd' pp (ditvpValue vp))+                     ])++ppDITemplateValueParameter :: LLVM => DITemplateValueParameter -> Doc+ppDITemplateValueParameter = ppDITemplateValueParameter' ppLabel+ ppDIBasicType :: DIBasicType -> Doc ppDIBasicType bt = "!DIBasicType"   <> parens (commas [ "tag:"      <+> integral (dibtTag bt)@@ -708,13 +926,17 @@                     , "size:"     <+> integral (dibtSize bt)                     , "align:"    <+> integral (dibtAlign bt)                     , "encoding:" <+> integral (dibtEncoding bt)-                    ])+                    ] <> mbFlags)+  where+  mbFlags = case dibtFlags bt of+              Just flags -> comma <+> "flags:" <+> integral flags+              Nothing -> empty -ppDICompileUnit :: LLVM => DICompileUnit -> Doc-ppDICompileUnit cu = "!DICompileUnit"+ppDICompileUnit' :: LLVM => (i -> Doc) -> DICompileUnit' i -> Doc+ppDICompileUnit' pp cu = "!DICompileUnit"   <> parens (mcommas        [ pure ("language:"           <+> integral (dicuLanguage cu))-       ,     (("file:"               <+>) . ppValMd) <$> (dicuFile cu)+       ,     (("file:"               <+>) . ppValMd' pp) <$> (dicuFile cu)        ,     (("producer:"           <+>) . doubleQuotes . text)              <$> (dicuProducer cu)        , pure ("isOptimized:"        <+> ppBool (dicuIsOptimized cu))@@ -723,53 +945,63 @@        ,     (("splitDebugFilename:" <+>) . doubleQuotes . text)              <$> (dicuSplitDebugFilename cu)        , pure ("emissionKind:"       <+> integral (dicuEmissionKind cu))-       ,     (("enums:"              <+>) . ppValMd) <$> (dicuEnums cu)-       ,     (("retainedTypes:"      <+>) . ppValMd) <$> (dicuRetainedTypes cu)-       ,     (("subprograms:"        <+>) . ppValMd) <$> (dicuSubprograms cu)-       ,     (("globals:"            <+>) . ppValMd) <$> (dicuGlobals cu)-       ,     (("imports:"            <+>) . ppValMd) <$> (dicuImports cu)-       ,     (("macros:"             <+>) . ppValMd) <$> (dicuMacros 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))        ]) +ppDICompileUnit :: LLVM => DICompileUnit -> Doc+ppDICompileUnit = ppDICompileUnit' ppLabel+ ppFlags :: Maybe String -> Doc ppFlags mb = doubleQuotes (maybe empty text mb) -ppDICompositeType :: LLVM => DICompositeType -> Doc-ppDICompositeType ct = "!DICompositeType"+ppDICompositeType' :: LLVM => (i -> Doc) -> DICompositeType' i -> Doc+ppDICompositeType' pp ct = "!DICompositeType"   <> parens (mcommas        [ pure ("tag:"            <+> integral (dictTag ct))        ,     (("name:"           <+>) . doubleQuotes . text) <$> (dictName ct)-       ,     (("file:"           <+>) . ppValMd) <$> (dictFile ct)+       ,     (("file:"           <+>) . ppValMd' pp) <$> (dictFile ct)        , pure ("line:"           <+> integral (dictLine ct))-       ,     (("baseType:"       <+>) . ppValMd) <$> (dictBaseType ct)+       ,     (("baseType:"       <+>) . ppValMd' pp) <$> (dictBaseType ct)        , pure ("size:"           <+> integral (dictSize ct))        , pure ("align:"          <+> integral (dictAlign ct))        , pure ("offset:"         <+> integral (dictOffset ct))        , pure ("flags:"          <+> integral (dictFlags ct))-       ,     (("elements:"       <+>) . ppValMd) <$> (dictElements ct)+       ,     (("elements:"       <+>) . ppValMd' pp) <$> (dictElements ct)        , pure ("runtimeLang:"    <+> integral (dictRuntimeLang ct))-       ,     (("vtableHolder:"   <+>) . ppValMd) <$> (dictVTableHolder ct)-       ,     (("templateParams:" <+>) . ppValMd) <$> (dictTemplateParams ct)+       ,     (("vtableHolder:"   <+>) . ppValMd' pp) <$> (dictVTableHolder ct)+       ,     (("templateParams:" <+>) . ppValMd' pp) <$> (dictTemplateParams ct)        ,     (("identifier:"     <+>) . doubleQuotes . text)              <$> (dictIdentifier ct)+       ,     (("discriminator:"  <+>) . ppValMd' pp) <$> (dictDiscriminator ct)        ]) -ppDIDerivedType :: LLVM => DIDerivedType -> Doc-ppDIDerivedType dt = "!DIDerivedType"+ppDICompositeType :: LLVM => DICompositeType -> Doc+ppDICompositeType = ppDICompositeType' ppLabel++ppDIDerivedType' :: LLVM => (i -> Doc) -> DIDerivedType' i -> Doc+ppDIDerivedType' pp dt = "!DIDerivedType"   <> parens (mcommas        [ pure ("tag:"       <+> integral (didtTag dt))        ,     (("name:"      <+>) . doubleQuotes . text) <$> (didtName dt)-       ,     (("file:"      <+>) . ppValMd) <$> (didtFile dt)+       ,     (("file:"      <+>) . ppValMd' pp) <$> (didtFile dt)        , pure ("line:"      <+> integral (didtLine dt))-       ,      ("baseType:"  <+>) <$> (ppValMd <$> didtBaseType dt <|> Just "null")+       ,      ("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) <$> (didtExtraData dt)+       ,     (("extraData:" <+>) . ppValMd' pp) <$> (didtExtraData dt)        ]) +ppDIDerivedType :: LLVM => DIDerivedType -> Doc+ppDIDerivedType = ppDIDerivedType' ppLabel+ ppDIEnumerator :: String -> Int64 -> Doc ppDIEnumerator n v = "!DIEnumerator"   <> parens (commas [ "name:"  <+> doubleQuotes (text n)@@ -786,94 +1018,118 @@                     , "directory:" <+> doubleQuotes (text (difDirectory f))                     ]) -ppDIGlobalVariable :: LLVM => DIGlobalVariable -> Doc-ppDIGlobalVariable gv = "!DIGlobalVariable"+ppDIGlobalVariable' :: LLVM => (i -> Doc) -> DIGlobalVariable' i -> Doc+ppDIGlobalVariable' pp gv = "!DIGlobalVariable"   <> parens (mcommas-       [      (("scope:"       <+>) . ppValMd) <$> (digvScope gv)+       [      (("scope:"       <+>) . ppValMd' pp) <$> (digvScope gv)        ,      (("name:"        <+>) . doubleQuotes . text) <$> (digvName gv)        ,      (("linkageName:" <+>) . doubleQuotes . text)               <$> (digvLinkageName gv)-       ,      (("file:"        <+>) . ppValMd) <$> (digvFile gv)+       ,      (("file:"        <+>) . ppValMd' pp) <$> (digvFile gv)        , pure ("line:"         <+> integral (digvLine gv))-       ,      (("type:"        <+>) . ppValMd) <$> (digvType gv)+       ,      (("type:"        <+>) . ppValMd' pp) <$> (digvType gv)        , pure ("isLocal:"      <+> ppBool (digvIsLocal gv))        , pure ("isDefinition:" <+> ppBool (digvIsDefinition gv))-       ,      (("variable:"    <+>) . ppValMd) <$> (digvVariable gv)-       ,      (("declaration:" <+>) . ppValMd) <$> (digvDeclaration gv)+       ,      (("variable:"    <+>) . ppValMd' pp) <$> (digvVariable gv)+       ,      (("declaration:" <+>) . ppValMd' pp) <$> (digvDeclaration gv)        ,      (("align:"       <+>) . integral) <$> digvAlignment gv        ]) -ppDIGlobalVariableExpression :: LLVM => DIGlobalVariableExpression -> Doc-ppDIGlobalVariableExpression gve = "!DIGlobalVariableExpression"+ppDIGlobalVariable :: LLVM => DIGlobalVariable -> Doc+ppDIGlobalVariable = ppDIGlobalVariable' ppLabel++ppDIGlobalVariableExpression' :: LLVM => (i -> Doc) -> DIGlobalVariableExpression' i -> Doc+ppDIGlobalVariableExpression' pp gve = "!DIGlobalVariableExpression"   <> parens (mcommas-       [      (("var:"  <+>) . ppValMd) <$> (digveVariable gve)-       ,      (("expr:" <+>) . ppValMd) <$> (digveExpression gve)+       [      (("var:"  <+>) . ppValMd' pp) <$> (digveVariable gve)+       ,      (("expr:" <+>) . ppValMd' pp) <$> (digveExpression gve)        ]) -ppDILexicalBlock :: LLVM => DILexicalBlock -> Doc-ppDILexicalBlock ct = "!DILexicalBlock"+ppDIGlobalVariableExpression :: LLVM => DIGlobalVariableExpression -> Doc+ppDIGlobalVariableExpression = ppDIGlobalVariableExpression' ppLabel++ppDILexicalBlock' :: LLVM => (i -> Doc) -> DILexicalBlock' i -> Doc+ppDILexicalBlock' pp ct = "!DILexicalBlock"   <> parens (mcommas-       [     (("scope:"  <+>) . ppValMd) <$> (dilbScope ct)-       ,     (("file:"   <+>) . ppValMd) <$> (dilbFile ct)+       [     (("scope:"  <+>) . ppValMd' pp) <$> (dilbScope ct)+       ,     (("file:"   <+>) . ppValMd' pp) <$> (dilbFile ct)        , pure ("line:"   <+> integral (dilbLine ct))        , pure ("column:" <+> integral (dilbColumn ct))        ]) -ppDILexicalBlockFile :: LLVM => DILexicalBlockFile -> Doc-ppDILexicalBlockFile lbf = "!DILexicalBlockFile"+ppDILexicalBlock :: LLVM => DILexicalBlock -> Doc+ppDILexicalBlock = ppDILexicalBlock' ppLabel++ppDILexicalBlockFile' :: LLVM => (i -> Doc) -> DILexicalBlockFile' i -> Doc+ppDILexicalBlockFile' pp lbf = "!DILexicalBlockFile"   <> parens (mcommas-       [ pure ("scope:"         <+> ppValMd (dilbfScope lbf))-       ,     (("file:"          <+>) . ppValMd) <$> (dilbfFile lbf)+       [ pure ("scope:"         <+> ppValMd' pp (dilbfScope lbf))+       ,     (("file:"          <+>) . ppValMd' pp) <$> (dilbfFile lbf)        , pure ("discriminator:" <+> integral (dilbfDiscriminator lbf))        ]) -ppDILocalVariable :: LLVM => DILocalVariable -> Doc-ppDILocalVariable lv = "!DILocalVariable"+ppDILexicalBlockFile :: LLVM => DILexicalBlockFile -> Doc+ppDILexicalBlockFile = ppDILexicalBlockFile' ppLabel++ppDILocalVariable' :: LLVM => (i -> Doc) -> DILocalVariable' i -> Doc+ppDILocalVariable' pp lv = "!DILocalVariable"   <> parens (mcommas-       [      (("scope:" <+>) . ppValMd) <$> (dilvScope lv)+       [      (("scope:" <+>) . ppValMd' pp) <$> (dilvScope lv)        ,      (("name:"  <+>) . doubleQuotes . text) <$> (dilvName lv)-       ,      (("file:"  <+>) . ppValMd) <$> (dilvFile lv)+       ,      (("file:"  <+>) . ppValMd' pp) <$> (dilvFile lv)        , pure ("line:"   <+> integral (dilvLine lv))-       ,      (("type:"  <+>) . ppValMd) <$> (dilvType lv)+       ,      (("type:"  <+>) . ppValMd' pp) <$> (dilvType lv)        , pure ("arg:"    <+> integral (dilvArg lv))        , pure ("flags:"  <+> integral (dilvFlags lv))        ]) -ppDISubprogram :: LLVM => DISubprogram -> Doc-ppDISubprogram sp = "!DISubprogram"+ppDILocalVariable :: LLVM => DILocalVariable -> Doc+ppDILocalVariable = ppDILocalVariable' ppLabel++-- | See @writeDISubprogram@ in the LLVM source, in the file @AsmWriter.cpp@+ppDISubprogram' :: LLVM => (i -> Doc) -> DISubprogram' i -> Doc+ppDISubprogram' pp sp = "!DISubprogram"   <> parens (mcommas-       [      (("scope:"          <+>) . ppValMd) <$> (dispScope sp)+       [      (("scope:"          <+>) . ppValMd' pp) <$> (dispScope sp)        ,      (("name:"           <+>) . doubleQuotes . text) <$> (dispName sp)        ,      (("linkageName:"    <+>) . doubleQuotes . text)               <$> (dispLinkageName sp)-       ,      (("file:"           <+>) . ppValMd) <$> (dispFile sp)+       ,      (("file:"           <+>) . ppValMd' pp) <$> (dispFile sp)        , pure ("line:"            <+> integral (dispLine sp))-       ,      (("type:"           <+>) . ppValMd) <$> (dispType sp)+       ,      (("type:"           <+>) . ppValMd' pp) <$> (dispType sp)        , pure ("isLocal:"         <+> ppBool (dispIsLocal sp))        , pure ("isDefinition:"    <+> ppBool (dispIsDefinition sp))        , pure ("scopeLine:"       <+> integral (dispScopeLine sp))-       ,      (("containingType:" <+>) . ppValMd) <$> (dispContainingType sp)+       ,      (("containingType:" <+>) . ppValMd' pp) <$> (dispContainingType sp)        , pure ("virtuality:"      <+> integral (dispVirtuality sp))        , pure ("virtualIndex:"    <+> integral (dispVirtualIndex sp))        , pure ("flags:"           <+> integral (dispFlags sp))        , pure ("isOptimized:"     <+> ppBool (dispIsOptimized sp))-       ,      (("templateParams:" <+>) . ppValMd) <$> (dispTemplateParams sp)-       ,      (("declaration:"    <+>) . ppValMd) <$> (dispDeclaration sp)-       ,      (("variables:"      <+>) . ppValMd) <$> (dispVariables sp)+       ,      (("unit:"           <+>) . ppValMd' pp) <$> (dispUnit sp)+       ,      (("templateParams:" <+>) . ppValMd' pp) <$> (dispTemplateParams sp)+       ,      (("declaration:"    <+>) . ppValMd' pp) <$> (dispDeclaration sp)+       ,      (("variables:"      <+>) . ppValMd' pp) <$> (dispVariables sp)+       ,      (("thrownTypes:"    <+>) . ppValMd' pp) <$> (dispThrownTypes sp)        ]) +ppDISubprogram :: LLVM => DISubprogram -> Doc+ppDISubprogram = ppDISubprogram' ppLabel+ ppDISubrange :: DISubrange -> Doc ppDISubrange sr = "!DISubrange"   <> parens (commas [ "count:" <+> integral (disrCount sr)                     , "lowerBound:" <+> integral (disrLowerBound sr)                     ]) -ppDISubroutineType :: LLVM => DISubroutineType -> Doc-ppDISubroutineType st = "!DISubroutineType"+ppDISubroutineType' :: LLVM => (i -> Doc) -> DISubroutineType' i -> Doc+ppDISubroutineType' pp st = "!DISubroutineType"   <> parens (commas        [ "flags:" <+> integral (distFlags st)-       , "types:" <+> fromMaybe "null" (ppValMd <$> (distTypeArray st))+       , "types:" <+> fromMaybe "null" (ppValMd' pp <$> (distTypeArray st))        ])++ppDISubroutineType :: LLVM => DISubroutineType -> Doc+ppDISubroutineType = ppDISubroutineType' ppLabel  -- Utilities ------------------------------------------------------------------- 

@@ -2,7 +2,8 @@  import Text.LLVM.AST -import Data.Int (Int32)+import Data.Char (chr)+import Data.Word (Word32, Word64) import Text.Parsec import Text.Parsec.String @@ -12,21 +13,37 @@ pNameChar :: Parser Char pNameChar = letter <|> digit <|> oneOf "-$._" +pHexEscape :: Parser Char+pHexEscape =+  do _ <- char '\\'+     a <- hexDigit+     b <- hexDigit+     return (chr (read ("0x" ++ [a, b])))++pStringChar :: Parser Char+pStringChar = noneOf "\"\\" <|> pHexEscape++pName :: Parser String+pName = many1 pNameChar <|> quotes (many1 pStringChar)+ pIdent :: Parser Ident-pIdent = Ident <$> (char '%' >> many1 pNameChar)+pIdent = Ident <$> (char '%' >> pName)  pSymbol :: Parser Symbol-pSymbol = Symbol <$> (char '@' >> many1 pNameChar)+pSymbol = Symbol <$> (char '@' >> pName)   -- Types ----------------------------------------------------------------------- -pInt32 :: Parser Int32-pInt32 = read <$> many1 digit+pWord32 :: Parser Word32+pWord32 = read <$> many1 digit +pWord64 :: Parser Word64+pWord64 = read <$> many1 digit+ pPrimType :: Parser PrimType pPrimType = choice-  [ Integer <$> try (char 'i' >> pInt32)+  [ Integer <$> try (char 'i' >> pWord32)   , FloatType <$> try pFloatType   , try (string "label")    >> return Label   , try (string "void")     >> return Void@@ -61,9 +78,9 @@     pTypeList :: Parser [Type]     pTypeList = sepBy (spaced pType) (char ',') -    pNumType :: (Int32 -> Type -> Type) -> Parser Type+    pNumType :: (Word64 -> Type -> Type) -> Parser Type     pNumType f =-      do n <- pInt32+      do n <- pWord64          spaces >> char 'x' >> spaces          t <- pType          return (f n t)@@ -101,6 +118,9 @@  parens :: Parser a -> Parser a parens body = char '(' *> body <* char ')'++quotes :: Parser a -> Parser a+quotes body = char '"' *> body <* char '"'  spaced :: Parser a -> Parser a spaced body = spaces *> body <* spaces