{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# Language TransformListComp, MonadComprehensions #-}
{- |
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
Maintainer       : emertens@galois.com
-}
module Text.LLVM.DebugUtils
  ( -- * Definition type analyzer
    Info(..), StructFieldInfo(..), BitfieldInfo(..), UnionFieldInfo(..)
  , computeFunctionTypes, valMdToInfo
  , localVariableNameDeclarations

  -- * Metadata lookup
  , mkMdMap

  -- * Type structure dereference
  , derefInfo
  , fieldIndexByPosition
  , fieldIndexByName

  -- * Info hueristics
  , guessAliasInfo
  , guessTypeInfo

  -- * Function arguments
  , debugInfoArgNames

  -- * Line numbers of definitions
  , debugInfoGlobalLines
  , debugInfoDefineLines
  , atFileLines
  , AtFileLines(atDefine, atBlockStart, atStmt, atGlobal)
  , DefineRel(..)
  , BlockRel(..)
  ) where

import           Control.Applicative    ((<|>))
import           Control.Monad          ((<=<))
import           Data.Bits              (Bits(..))
import           Data.Bool              (bool)
import           Data.IntMap            (IntMap)
import qualified Data.IntMap as IntMap
import           Data.List              (elemIndex, tails, stripPrefix)
import           Data.Map               (Map)
import qualified Data.Map    as Map
import           Data.Maybe             (fromMaybe, listToMaybe, maybeToList, mapMaybe)
import           Data.Word              (Word16, Word64)
import           Lens.Micro.Platform    ((^.), at, _Just, to)
import           System.FilePath        ( (</>), equalFilePath, normalise
                                        , hasTrailingPathSeparator )
import           Text.LLVM.AST

dbgKind :: String
dbgKind :: String
dbgKind = String
"dbg"

llvmDbgCuKey :: String
llvmDbgCuKey :: String
llvmDbgCuKey = String
"llvm.dbg.cu"

dwarfPointer, dwarfStruct, dwarfTypedef, dwarfUnion, dwarfBasetype,
  dwarfConst, dwarfArray :: Word16
dwarfPointer :: Word16
dwarfPointer  = Word16
0x0f
dwarfStruct :: Word16
dwarfStruct   = Word16
0x13
dwarfTypedef :: Word16
dwarfTypedef  = Word16
0x16
dwarfArray :: Word16
dwarfArray    = Word16
0x01
dwarfUnion :: Word16
dwarfUnion    = Word16
0x17
dwarfBasetype :: Word16
dwarfBasetype = Word16
0x24
dwarfConst :: Word16
dwarfConst    = Word16
0x26

type MdMap = IntMap ValMd

data Info
  = Pointer Info
  | Structure (Maybe String) [StructFieldInfo]
  | Union     (Maybe String) [UnionFieldInfo]
  | Typedef String Info
  | ArrInfo Info
  | BaseType String DIBasicType
  | Unknown
  deriving Int -> Info -> ShowS
[Info] -> ShowS
Info -> String
(Int -> Info -> ShowS)
-> (Info -> String) -> ([Info] -> ShowS) -> Show Info
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Info -> ShowS
showsPrec :: Int -> Info -> ShowS
$cshow :: Info -> String
show :: Info -> String
$cshowList :: [Info] -> ShowS
showList :: [Info] -> ShowS
Show

-- | Record debug information about a field in a struct type.
data StructFieldInfo = StructFieldInfo
  { StructFieldInfo -> String
sfiName :: String
    -- ^ The field name.
  , StructFieldInfo -> Word64
sfiOffset :: Word64
    -- ^ The field's offset (in bits) from the start of the struct.
  , StructFieldInfo -> Maybe BitfieldInfo
sfiBitfield :: Maybe BitfieldInfo
    -- ^ If this field resides within a bitfield, this is
    -- @'Just' bitfieldInfo@. Otherwise, this is 'Nothing'.
  , StructFieldInfo -> Info
sfiInfo :: Info
    -- ^ The debug 'Info' associated with the field's type.
  } deriving Int -> StructFieldInfo -> ShowS
[StructFieldInfo] -> ShowS
StructFieldInfo -> String
(Int -> StructFieldInfo -> ShowS)
-> (StructFieldInfo -> String)
-> ([StructFieldInfo] -> ShowS)
-> Show StructFieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StructFieldInfo -> ShowS
showsPrec :: Int -> StructFieldInfo -> ShowS
$cshow :: StructFieldInfo -> String
show :: StructFieldInfo -> String
$cshowList :: [StructFieldInfo] -> ShowS
showList :: [StructFieldInfo] -> ShowS
Show

-- | 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
  { BitfieldInfo -> Word64
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.
  , BitfieldInfo -> Word64
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 Int -> BitfieldInfo -> ShowS
[BitfieldInfo] -> ShowS
BitfieldInfo -> String
(Int -> BitfieldInfo -> ShowS)
-> (BitfieldInfo -> String)
-> ([BitfieldInfo] -> ShowS)
-> Show BitfieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BitfieldInfo -> ShowS
showsPrec :: Int -> BitfieldInfo -> ShowS
$cshow :: BitfieldInfo -> String
show :: BitfieldInfo -> String
$cshowList :: [BitfieldInfo] -> ShowS
showList :: [BitfieldInfo] -> ShowS
Show

-- | Record debug information about a field in a union type.
data UnionFieldInfo = UnionFieldInfo
  { UnionFieldInfo -> String
ufiName :: String
    -- ^ The field name.
  , UnionFieldInfo -> Info
ufiInfo :: Info
    -- ^ The debug 'Info' associated with the field's type.
  } deriving Int -> UnionFieldInfo -> ShowS
[UnionFieldInfo] -> ShowS
UnionFieldInfo -> String
(Int -> UnionFieldInfo -> ShowS)
-> (UnionFieldInfo -> String)
-> ([UnionFieldInfo] -> ShowS)
-> Show UnionFieldInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnionFieldInfo -> ShowS
showsPrec :: Int -> UnionFieldInfo -> ShowS
$cshow :: UnionFieldInfo -> String
show :: UnionFieldInfo -> String
$cshowList :: [UnionFieldInfo] -> ShowS
showList :: [UnionFieldInfo] -> ShowS
Show

-- | Compute an 'IntMap' of the unnamed metadata in a module
mkMdMap :: Module -> IntMap ValMd
mkMdMap :: Module -> MdMap
mkMdMap Module
m = [(Int, ValMd)] -> MdMap
forall a. [(Int, a)] -> IntMap a
IntMap.fromList [ (UnnamedMdIdx -> Int
unnamedMdIdx (UnnamedMdIdx -> Int) -> UnnamedMdIdx -> Int
forall a b. (a -> b) -> a -> b
$ UnnamedMd -> UnnamedMdIdx
umIndex UnnamedMd
md, UnnamedMd -> ValMd
umValues UnnamedMd
md)
                            | UnnamedMd
md <- Module -> [UnnamedMd]
modUnnamedMd Module
m ]

------------------------------------------------------------------------

getDebugInfo :: MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo :: MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap (ValMdRef (UnnamedMdIdx Int
i)) =
  MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap (ValMd -> Maybe DebugInfo) -> Maybe ValMd -> Maybe DebugInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> MdMap -> Maybe ValMd
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i MdMap
mdMap
getDebugInfo MdMap
_ (ValMdDebugInfo DebugInfo
di) = DebugInfo -> Maybe DebugInfo
forall a. a -> Maybe a
Just DebugInfo
di
getDebugInfo MdMap
_ ValMd
_                   = Maybe DebugInfo
forall a. Maybe a
Nothing

getMDFile :: MdMap -> ValMd -> Maybe FilePath
getMDFile :: MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap = \case
  ValMdDebugInfo (DebugInfoFile DIFile
i) -> String -> Maybe String
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ DIFile -> String
difDirectory DIFile
i String -> ShowS
</> DIFile -> String
difFilename DIFile
i
  --  ^^ found it! ^^ or else vvv keep looking (recursively) vvv
  ValMdLoc DebugLoc' BlockLabel
l -> MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> ValMd -> Maybe String
forall a b. (a -> b) -> a -> b
$ DebugLoc' BlockLabel -> ValMd
forall lab. DebugLoc' lab -> ValMd' lab
dlScope DebugLoc' BlockLabel
l
  ValMdRef UnnamedMdIdx
i -> MdMap
mdMap MdMap
-> Getting (Maybe String) MdMap (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. Index MdMap -> Lens' MdMap (Maybe (IxValue MdMap))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (UnnamedMdIdx -> Int
unnamedMdIdx UnnamedMdIdx
i) ((Maybe ValMd -> Const (Maybe String) (Maybe ValMd))
 -> MdMap -> Const (Maybe String) MdMap)
-> ((Maybe String -> Const (Maybe String) (Maybe String))
    -> Maybe ValMd -> Const (Maybe String) (Maybe ValMd))
-> Getting (Maybe String) MdMap (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValMd -> Const (Maybe String) ValMd)
-> Maybe ValMd -> Const (Maybe String) (Maybe ValMd)
forall a a' (f :: * -> *).
Applicative f =>
(a -> f a') -> Maybe a -> f (Maybe a')
_Just ((ValMd -> Const (Maybe String) ValMd)
 -> Maybe ValMd -> Const (Maybe String) (Maybe ValMd))
-> ((Maybe String -> Const (Maybe String) (Maybe String))
    -> ValMd -> Const (Maybe String) ValMd)
-> (Maybe String -> Const (Maybe String) (Maybe String))
-> Maybe ValMd
-> Const (Maybe String) (Maybe ValMd)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValMd -> Maybe String) -> SimpleGetter ValMd (Maybe String)
forall s a. (s -> a) -> SimpleGetter s a
to (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap)
  ValMdDebugInfo (DebugInfoGlobalVariable DIGlobalVariable' BlockLabel
gv) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DIGlobalVariable' BlockLabel -> Maybe ValMd
forall lab. DIGlobalVariable' lab -> Maybe (ValMd' lab)
digvFile DIGlobalVariable' BlockLabel
gv) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DIGlobalVariable' BlockLabel -> Maybe ValMd
forall lab. DIGlobalVariable' lab -> Maybe (ValMd' lab)
digvScope DIGlobalVariable' BlockLabel
gv)
  ValMdDebugInfo (DebugInfoLocalVariable DILocalVariable' BlockLabel
lv) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILocalVariable' BlockLabel -> Maybe ValMd
forall lab. DILocalVariable' lab -> Maybe (ValMd' lab)
dilvFile DILocalVariable' BlockLabel
lv) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILocalVariable' BlockLabel -> Maybe ValMd
forall lab. DILocalVariable' lab -> Maybe (ValMd' lab)
dilvScope DILocalVariable' BlockLabel
lv)
  ValMdDebugInfo (DebugInfoSubprogram DISubprogram' BlockLabel
sp) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DISubprogram' BlockLabel -> Maybe ValMd
forall lab. DISubprogram' lab -> Maybe (ValMd' lab)
dispFile DISubprogram' BlockLabel
sp) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DISubprogram' BlockLabel -> Maybe ValMd
forall lab. DISubprogram' lab -> Maybe (ValMd' lab)
dispScope DISubprogram' BlockLabel
sp)
  ValMdDebugInfo (DebugInfoLexicalBlock DILexicalBlock' BlockLabel
lb) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILexicalBlock' BlockLabel -> Maybe ValMd
forall lab. DILexicalBlock' lab -> Maybe (ValMd' lab)
dilbFile DILexicalBlock' BlockLabel
lb) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILexicalBlock' BlockLabel -> Maybe ValMd
forall lab. DILexicalBlock' lab -> Maybe (ValMd' lab)
dilbScope DILexicalBlock' BlockLabel
lb)
  ValMdDebugInfo (DebugInfoLexicalBlockFile DILexicalBlockFile' BlockLabel
lf) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILexicalBlockFile' BlockLabel -> Maybe ValMd
forall lab. DILexicalBlockFile' lab -> Maybe (ValMd' lab)
dilbfFile DILexicalBlockFile' BlockLabel
lf) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> ValMd -> Maybe String
forall a b. (a -> b) -> a -> b
$ DILexicalBlockFile' BlockLabel -> ValMd
forall lab. DILexicalBlockFile' lab -> ValMd' lab
dilbfScope DILexicalBlockFile' BlockLabel
lf)
  ValMdDebugInfo (DebugInfoDerivedType DIDerivedType' BlockLabel
dt) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtFile DIDerivedType' BlockLabel
dt) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtScope DIDerivedType' BlockLabel
dt)
  ValMdDebugInfo (DebugInfoCompositeType DICompositeType' BlockLabel
ct) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DICompositeType' BlockLabel -> Maybe ValMd
forall lab. DICompositeType' lab -> Maybe (ValMd' lab)
dictFile DICompositeType' BlockLabel
ct) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DICompositeType' BlockLabel -> Maybe ValMd
forall lab. DICompositeType' lab -> Maybe (ValMd' lab)
dictScope DICompositeType' BlockLabel
ct)
  ValMdDebugInfo (DebugInfoCompileUnit DICompileUnit' BlockLabel
cu) -> MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DICompileUnit' BlockLabel -> Maybe ValMd
forall lab. DICompileUnit' lab -> Maybe (ValMd' lab)
dicuFile DICompileUnit' BlockLabel
cu
  ValMdDebugInfo (DebugInfoNameSpace DINameSpace' BlockLabel
ns) -> MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> ValMd -> Maybe String
forall a b. (a -> b) -> a -> b
$ DINameSpace' BlockLabel -> ValMd
forall lab. DINameSpace' lab -> ValMd' lab
dinsFile DINameSpace' BlockLabel
ns
  ValMdDebugInfo (DebugInfoLabel DILabel' BlockLabel
bl) ->
    (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILabel' BlockLabel -> Maybe ValMd
forall lab. DILabel' lab -> Maybe (ValMd' lab)
dilFile DILabel' BlockLabel
bl) Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap (ValMd -> Maybe String) -> Maybe ValMd -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DILabel' BlockLabel -> Maybe ValMd
forall lab. DILabel' lab -> Maybe (ValMd' lab)
dilScope DILabel' BlockLabel
bl)
  ValMd
_ -> Maybe String
forall a. Maybe a
Nothing

getInteger :: MdMap -> ValMd -> Maybe Integer
getInteger :: MdMap -> ValMd -> Maybe Integer
getInteger MdMap
mdMap (ValMdRef (UnnamedMdIdx Int
i))           = MdMap -> ValMd -> Maybe Integer
getInteger MdMap
mdMap (ValMd -> Maybe Integer) -> Maybe ValMd -> Maybe Integer
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> MdMap -> Maybe ValMd
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i MdMap
mdMap
getInteger MdMap
_     (ValMdValue (Typed Type
_ (ValInteger Integer
i))) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
getInteger MdMap
_     ValMd
_                                     = Maybe Integer
forall a. Maybe a
Nothing

getList :: MdMap -> ValMd -> Maybe [Maybe ValMd]
getList :: MdMap -> ValMd -> Maybe [Maybe ValMd]
getList MdMap
mdMap (ValMdRef (UnnamedMdIdx Int
i)) = MdMap -> ValMd -> Maybe [Maybe ValMd]
getList MdMap
mdMap (ValMd -> Maybe [Maybe ValMd])
-> Maybe ValMd -> Maybe [Maybe ValMd]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> MdMap -> Maybe ValMd
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
i MdMap
mdMap
getList MdMap
_ (ValMdNode [Maybe ValMd]
di)   = [Maybe ValMd] -> Maybe [Maybe ValMd]
forall a. a -> Maybe a
Just [Maybe ValMd]
di
getList MdMap
_ ValMd
_                = Maybe [Maybe ValMd]
forall a. Maybe a
Nothing

------------------------------------------------------------------------

valMdToInfo :: MdMap -> ValMd -> Info
valMdToInfo :: MdMap -> ValMd -> Info
valMdToInfo MdMap
mdMap ValMd
val =
  Info -> (DebugInfo -> Info) -> Maybe DebugInfo -> Info
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Info
Unknown (MdMap -> DebugInfo -> Info
debugInfoToInfo MdMap
mdMap) (MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap ValMd
val)


valMdToInfo' :: MdMap -> Maybe ValMd -> Info
valMdToInfo' :: MdMap -> Maybe ValMd -> Info
valMdToInfo' = Info -> (ValMd -> Info) -> Maybe ValMd -> Info
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Info
Unknown ((ValMd -> Info) -> Maybe ValMd -> Info)
-> (MdMap -> ValMd -> Info) -> MdMap -> Maybe ValMd -> Info
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MdMap -> ValMd -> Info
valMdToInfo


debugInfoToInfo :: MdMap -> DebugInfo -> Info
debugInfoToInfo :: MdMap -> DebugInfo -> Info
debugInfoToInfo MdMap
mdMap (DebugInfoDerivedType DIDerivedType' BlockLabel
dt)
  | DIDerivedType' BlockLabel -> Word16
forall lab. DIDerivedType' lab -> Word16
didtTag DIDerivedType' BlockLabel
dt Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfPointer  = Info -> Info
Pointer (MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtBaseType DIDerivedType' BlockLabel
dt))
  | DIDerivedType' BlockLabel -> Word16
forall lab. DIDerivedType' lab -> Word16
didtTag DIDerivedType' BlockLabel
dt Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfTypedef  = case DIDerivedType' BlockLabel -> Maybe String
forall lab. DIDerivedType' lab -> Maybe String
didtName DIDerivedType' BlockLabel
dt of
                                    Maybe String
Nothing -> MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtBaseType DIDerivedType' BlockLabel
dt)
                                    Just String
nm -> String -> Info -> Info
Typedef String
nm (MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtBaseType DIDerivedType' BlockLabel
dt))
  | DIDerivedType' BlockLabel -> Word16
forall lab. DIDerivedType' lab -> Word16
didtTag DIDerivedType' BlockLabel
dt Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfConst    = MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtBaseType DIDerivedType' BlockLabel
dt)
debugInfoToInfo MdMap
_     (DebugInfoBasicType DIBasicType
bt)
  | DIBasicType -> Word16
forall lab. DIBasicType' lab -> Word16
dibtTag DIBasicType
bt Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfBasetype = String -> DIBasicType -> Info
BaseType (DIBasicType -> String
forall lab. DIBasicType' lab -> String
dibtName DIBasicType
bt) DIBasicType
bt
debugInfoToInfo MdMap
mdMap (DebugInfoCompositeType DICompositeType' BlockLabel
ct)
  | DICompositeType' BlockLabel -> Word16
forall lab. DICompositeType' lab -> Word16
dictTag DICompositeType' BlockLabel
ct Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfStruct   = Info
-> ([StructFieldInfo] -> Info) -> Maybe [StructFieldInfo] -> Info
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Info
Unknown (Maybe String -> [StructFieldInfo] -> Info
Structure (DICompositeType' BlockLabel -> Maybe String
forall lab. DICompositeType' lab -> Maybe String
dictName DICompositeType' BlockLabel
ct)) (MdMap -> DICompositeType' BlockLabel -> Maybe [StructFieldInfo]
getStructFields MdMap
mdMap DICompositeType' BlockLabel
ct)
  | DICompositeType' BlockLabel -> Word16
forall lab. DICompositeType' lab -> Word16
dictTag DICompositeType' BlockLabel
ct Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfUnion    = Info
-> ([UnionFieldInfo] -> Info) -> Maybe [UnionFieldInfo] -> Info
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Info
Unknown (Maybe String -> [UnionFieldInfo] -> Info
Union     (DICompositeType' BlockLabel -> Maybe String
forall lab. DICompositeType' lab -> Maybe String
dictName DICompositeType' BlockLabel
ct)) (MdMap -> DICompositeType' BlockLabel -> Maybe [UnionFieldInfo]
getUnionFields MdMap
mdMap DICompositeType' BlockLabel
ct)
  | DICompositeType' BlockLabel -> Word16
forall lab. DICompositeType' lab -> Word16
dictTag DICompositeType' BlockLabel
ct Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
dwarfArray    = Info -> Info
ArrInfo (MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DICompositeType' BlockLabel -> Maybe ValMd
forall lab. DICompositeType' lab -> Maybe (ValMd' lab)
dictBaseType DICompositeType' BlockLabel
ct))
debugInfoToInfo MdMap
_ DebugInfo
_             = Info
Unknown


getFieldDIs :: MdMap -> DICompositeType -> Maybe [DebugInfo]
getFieldDIs :: MdMap -> DICompositeType' BlockLabel -> Maybe [DebugInfo]
getFieldDIs MdMap
mdMap =
  (ValMd -> Maybe DebugInfo) -> [ValMd] -> Maybe [DebugInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap) ([ValMd] -> Maybe [DebugInfo])
-> (DICompositeType' BlockLabel -> Maybe [ValMd])
-> DICompositeType' BlockLabel
-> Maybe [DebugInfo]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Maybe ValMd] -> Maybe [ValMd]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Maybe ValMd] -> Maybe [ValMd])
-> (DICompositeType' BlockLabel -> Maybe [Maybe ValMd])
-> DICompositeType' BlockLabel
-> Maybe [ValMd]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MdMap -> ValMd -> Maybe [Maybe ValMd]
getList MdMap
mdMap (ValMd -> Maybe [Maybe ValMd])
-> (DICompositeType' BlockLabel -> Maybe ValMd)
-> DICompositeType' BlockLabel
-> Maybe [Maybe ValMd]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< DICompositeType' BlockLabel -> Maybe ValMd
forall lab. DICompositeType' lab -> Maybe (ValMd' lab)
dictElements

getStructFields :: MdMap -> DICompositeType -> Maybe [StructFieldInfo]
getStructFields :: MdMap -> DICompositeType' BlockLabel -> Maybe [StructFieldInfo]
getStructFields MdMap
mdMap = (DebugInfo -> Maybe StructFieldInfo)
-> [DebugInfo] -> Maybe [StructFieldInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (MdMap -> DebugInfo -> Maybe StructFieldInfo
debugInfoToStructField MdMap
mdMap) ([DebugInfo] -> Maybe [StructFieldInfo])
-> (DICompositeType' BlockLabel -> Maybe [DebugInfo])
-> DICompositeType' BlockLabel
-> Maybe [StructFieldInfo]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MdMap -> DICompositeType' BlockLabel -> Maybe [DebugInfo]
getFieldDIs MdMap
mdMap

debugInfoToStructField :: MdMap -> DebugInfo -> Maybe StructFieldInfo
debugInfoToStructField :: MdMap -> DebugInfo -> Maybe StructFieldInfo
debugInfoToStructField MdMap
mdMap DebugInfo
di =
  do DebugInfoDerivedType DIDerivedType' BlockLabel
dt <- DebugInfo -> Maybe DebugInfo
forall a. a -> Maybe a
Just DebugInfo
di
     String
fieldName               <- DIDerivedType' BlockLabel -> Maybe String
forall lab. DIDerivedType' lab -> Maybe String
didtName DIDerivedType' BlockLabel
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 :: Maybe BitfieldInfo
bitfield | Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (DIDerivedType' BlockLabel -> Word32
forall lab. DIDerivedType' lab -> Word32
didtFlags DIDerivedType' BlockLabel
dt) Int
19
                  , Just ValMd
extraData      <- DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtExtraData DIDerivedType' BlockLabel
dt
                  , Just Integer
bitfieldOffset <- MdMap -> ValMd -> Maybe Integer
getInteger MdMap
mdMap ValMd
extraData
                  = do Word64
size <- Maybe ValMd -> Maybe Word64
getSizeOrOffset (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtSize DIDerivedType' BlockLabel
dt)
                       BitfieldInfo -> Maybe BitfieldInfo
forall a. a -> Maybe a
Just (BitfieldInfo -> Maybe BitfieldInfo)
-> BitfieldInfo -> Maybe BitfieldInfo
forall a b. (a -> b) -> a -> b
$ BitfieldInfo { biFieldSize :: Word64
biFieldSize      = Word64
size
                                           , biBitfieldOffset :: Word64
biBitfieldOffset = Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
bitfieldOffset
                                           }
                  | Bool
otherwise
                  = Maybe BitfieldInfo
forall a. Maybe a
Nothing
     Word64
offset <- Maybe ValMd -> Maybe Word64
getSizeOrOffset (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtOffset DIDerivedType' BlockLabel
dt)
     StructFieldInfo -> Maybe StructFieldInfo
forall a. a -> Maybe a
Just (StructFieldInfo { sfiName :: String
sfiName     = String
fieldName
                           , sfiOffset :: Word64
sfiOffset   = Word64
offset
                           , sfiBitfield :: Maybe BitfieldInfo
sfiBitfield = Maybe BitfieldInfo
bitfield
                           , sfiInfo :: Info
sfiInfo     = MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtBaseType DIDerivedType' BlockLabel
dt)
                           })
  where
    -- TODO: Currently, this only recognizes bare integer (i.e., 'ValInteger')
    -- sizes and offsets. This is likely good enough for Clang-derived LLVM, but
    -- Ada-derived LLVM may contain more complex metadata values that this
    -- currently doesn't handle.
    getSizeOrOffset :: Maybe ValMd -> Maybe Word64
    getSizeOrOffset :: Maybe ValMd -> Maybe Word64
getSizeOrOffset (Just (ValMdValue Typed (Value' BlockLabel)
tv))
      | ValInteger Integer
i <- Typed (Value' BlockLabel) -> Value' BlockLabel
forall a. Typed a -> a
typedValue Typed (Value' BlockLabel)
tv
      = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Integer -> Word64
forall a. Num a => Integer -> a
fromInteger Integer
i)
    getSizeOrOffset Maybe ValMd
_ = Maybe Word64
forall a. Maybe a
Nothing


getUnionFields :: MdMap -> DICompositeType -> Maybe [UnionFieldInfo]
getUnionFields :: MdMap -> DICompositeType' BlockLabel -> Maybe [UnionFieldInfo]
getUnionFields MdMap
mdMap = (DebugInfo -> Maybe UnionFieldInfo)
-> [DebugInfo] -> Maybe [UnionFieldInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (MdMap -> DebugInfo -> Maybe UnionFieldInfo
debugInfoToUnionField MdMap
mdMap) ([DebugInfo] -> Maybe [UnionFieldInfo])
-> (DICompositeType' BlockLabel -> Maybe [DebugInfo])
-> DICompositeType' BlockLabel
-> Maybe [UnionFieldInfo]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MdMap -> DICompositeType' BlockLabel -> Maybe [DebugInfo]
getFieldDIs MdMap
mdMap


debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe UnionFieldInfo
debugInfoToUnionField :: MdMap -> DebugInfo -> Maybe UnionFieldInfo
debugInfoToUnionField MdMap
mdMap DebugInfo
di =
  do DebugInfoDerivedType DIDerivedType' BlockLabel
dt <- DebugInfo -> Maybe DebugInfo
forall a. a -> Maybe a
Just DebugInfo
di
     String
fieldName               <- DIDerivedType' BlockLabel -> Maybe String
forall lab. DIDerivedType' lab -> Maybe String
didtName DIDerivedType' BlockLabel
dt
     UnionFieldInfo -> Maybe UnionFieldInfo
forall a. a -> Maybe a
Just (UnionFieldInfo { ufiName :: String
ufiName = String
fieldName
                          , ufiInfo :: Info
ufiInfo = MdMap -> Maybe ValMd -> Info
valMdToInfo' MdMap
mdMap (DIDerivedType' BlockLabel -> Maybe ValMd
forall lab. DIDerivedType' lab -> Maybe (ValMd' lab)
didtBaseType DIDerivedType' BlockLabel
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
-- paths. This function attempts to support the variations.
computeFunctionTypes ::
  Module       {- ^ module to search                     -} ->
  Symbol       {- ^ function symbol                      -} ->
  Maybe [Maybe Info] {- ^ return and argument type information -}
computeFunctionTypes :: Module -> Symbol -> Maybe [Maybe Info]
computeFunctionTypes Module
m Symbol
sym =
  [ (ValMd -> Info) -> Maybe ValMd -> Maybe Info
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MdMap -> ValMd -> Info
valMdToInfo MdMap
mdMap) (Maybe ValMd -> Maybe Info) -> [Maybe ValMd] -> [Maybe Info]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe ValMd]
types
     | let mdMap :: MdMap
mdMap = Module -> MdMap
mkMdMap Module
m
     , DISubprogram' BlockLabel
sp <- MdMap -> Module -> Symbol -> Maybe (DISubprogram' BlockLabel)
findSubprogramViaDefine MdMap
mdMap Module
m Symbol
sym
         Maybe (DISubprogram' BlockLabel)
-> Maybe (DISubprogram' BlockLabel)
-> Maybe (DISubprogram' BlockLabel)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MdMap -> Module -> Symbol -> Maybe (DISubprogram' BlockLabel)
findSubprogramViaCu     MdMap
mdMap Module
m Symbol
sym
     , DebugInfoSubroutineType DISubroutineType' BlockLabel
st <- MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap (ValMd -> Maybe DebugInfo) -> Maybe ValMd -> Maybe DebugInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DISubprogram' BlockLabel -> Maybe ValMd
forall lab. DISubprogram' lab -> Maybe (ValMd' lab)
dispType DISubprogram' BlockLabel
sp
     , [Maybe ValMd]
types                      <- MdMap -> ValMd -> Maybe [Maybe ValMd]
getList MdMap
mdMap      (ValMd -> Maybe [Maybe ValMd])
-> Maybe ValMd -> Maybe [Maybe ValMd]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DISubroutineType' BlockLabel -> Maybe ValMd
forall lab. DISubroutineType' lab -> Maybe (ValMd' lab)
distTypeArray DISubroutineType' BlockLabel
st
     ]


-- | This method of computing argument type information works on at least LLVM 3.8
findSubprogramViaDefine ::
  IntMap ValMd       {- ^ unnamed metadata                             -} ->
  Module             {- ^ module to search                             -} ->
  Symbol             {- ^ function symbol to find                      -} ->
  Maybe DISubprogram {- ^ debug information related to function symbol -}
findSubprogramViaDefine :: MdMap -> Module -> Symbol -> Maybe (DISubprogram' BlockLabel)
findSubprogramViaDefine MdMap
mdMap Module
m Symbol
sym =
  [ DISubprogram' BlockLabel
sp
     | Define
def                    <- Module -> [Define]
modDefines Module
m
     , Define -> Symbol
defName Define
def Symbol -> Symbol -> Bool
forall a. Eq a => a -> a -> Bool
== Symbol
sym
     , then [a] -> Maybe a
[Define] -> Maybe Define
forall a. [a] -> Maybe a
listToMaybe ----- commits to a choice -----
     , ValMd
dbgMd                  <- String -> Map String ValMd -> Maybe ValMd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
dbgKind (Define -> Map String ValMd
defMetadata Define
def)
     , DebugInfoSubprogram DISubprogram' BlockLabel
sp <- MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap ValMd
dbgMd
     ]


-- | This method of computing function debugging information works on LLVM 3.7
findSubprogramViaCu ::
  MdMap              {- ^ map of unnamed metadata                -} ->
  Module             {- ^ module to search                       -} ->
  Symbol             {- ^ function symbol to search for          -} ->
  Maybe DISubprogram {- ^ debugging information for given symbol -}
findSubprogramViaCu :: MdMap -> Module -> Symbol -> Maybe (DISubprogram' BlockLabel)
findSubprogramViaCu MdMap
mdMap Module
m (Symbol String
sym) = [DISubprogram' BlockLabel] -> Maybe (DISubprogram' BlockLabel)
forall a. [a] -> Maybe a
listToMaybe
  [ DISubprogram' BlockLabel
sp
    | NamedMd
md                      <- Module -> [NamedMd]
modNamedMd Module
m
    , NamedMd -> String
nmName NamedMd
md String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
llvmDbgCuKey
    , UnnamedMdIdx
ref                     <- NamedMd -> [UnnamedMdIdx]
nmValues NamedMd
md
    , DebugInfoCompileUnit DICompileUnit' BlockLabel
cu <- Maybe DebugInfo -> [DebugInfo]
forall a. Maybe a -> [a]
maybeToList  (Maybe DebugInfo -> [DebugInfo]) -> Maybe DebugInfo -> [DebugInfo]
forall a b. (a -> b) -> a -> b
$ MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap (ValMd -> Maybe DebugInfo) -> ValMd -> Maybe DebugInfo
forall a b. (a -> b) -> a -> b
$ UnnamedMdIdx -> ValMd
forall lab. UnnamedMdIdx -> ValMd' lab
ValMdRef UnnamedMdIdx
ref
    , Just ValMd
entry              <- [Maybe ValMd] -> Maybe [Maybe ValMd] -> [Maybe ValMd]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Maybe ValMd] -> [Maybe ValMd])
-> Maybe [Maybe ValMd] -> [Maybe ValMd]
forall a b. (a -> b) -> a -> b
$ MdMap -> ValMd -> Maybe [Maybe ValMd]
getList MdMap
mdMap (ValMd -> Maybe [Maybe ValMd])
-> Maybe ValMd -> Maybe [Maybe ValMd]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DICompileUnit' BlockLabel -> Maybe ValMd
forall lab. DICompileUnit' lab -> Maybe (ValMd' lab)
dicuSubprograms DICompileUnit' BlockLabel
cu
    , DebugInfoSubprogram DISubprogram' BlockLabel
sp  <- Maybe DebugInfo -> [DebugInfo]
forall a. Maybe a -> [a]
maybeToList  (Maybe DebugInfo -> [DebugInfo]) -> Maybe DebugInfo -> [DebugInfo]
forall a b. (a -> b) -> a -> b
$ MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap ValMd
entry
    , DISubprogram' BlockLabel -> Maybe String
forall lab. DISubprogram' lab -> Maybe String
dispName DISubprogram' BlockLabel
sp Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
sym
    ]


------------------------------------------------------------------------

-- | If the argument describes a pointer, return the information for the
-- 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 :: Info -> Info
derefInfo (Pointer Info
x) = Info
x
derefInfo (ArrInfo Info
x) = Info
x
derefInfo Info
_           = Info
Unknown

-- | If the argument describes a composite type, returns the type of the
-- field by zero-based index into the list of fields.
fieldIndexByPosition ::
  Int  {- ^ zero-based field index               -} ->
  Info {- ^ composite type information           -} ->
  Info {- ^ type information for specified field -}
fieldIndexByPosition :: Int -> Info -> Info
fieldIndexByPosition Int
i Info
info =
  case Info
info of
    Typedef String
_ Info
info' -> Int -> Info -> Info
fieldIndexByPosition Int
i Info
info'
    Structure Maybe String
_ [StructFieldInfo]
xs  -> [Info] -> Info
go [ Info
x | StructFieldInfo{sfiInfo :: StructFieldInfo -> Info
sfiInfo = Info
x} <- [StructFieldInfo]
xs ]
    Union     Maybe String
_ [UnionFieldInfo]
xs  -> [Info] -> Info
go [ Info
x | UnionFieldInfo{ufiInfo :: UnionFieldInfo -> Info
ufiInfo = Info
x}  <- [UnionFieldInfo]
xs ]
    Info
_               -> Info
Unknown
  where
    go :: [Info] -> Info
go [Info]
xs = case Int -> [Info] -> [Info]
forall a. Int -> [a] -> [a]
drop Int
i [Info]
xs of
              []  -> Info
Unknown
              Info
x:[Info]
_ -> Info
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.
fieldIndexByName ::
  String    {- ^ field name                                  -} ->
  Info      {- ^ composite type info                         -} ->
  Maybe Int {- ^ zero-based index of field matching the name -}
fieldIndexByName :: String -> Info -> Maybe Int
fieldIndexByName String
n Info
info =
  case Info
info of
    Typedef String
_ Info
info' -> String -> Info -> Maybe Int
fieldIndexByName String
n Info
info'
    Structure Maybe String
_ [StructFieldInfo]
xs  -> [String] -> Maybe Int
go [ String
x | StructFieldInfo{sfiName :: StructFieldInfo -> String
sfiName = String
x} <- [StructFieldInfo]
xs ]
    Union     Maybe String
_ [UnionFieldInfo]
xs  -> [String] -> Maybe Int
go [ String
x | UnionFieldInfo{ufiName :: UnionFieldInfo -> String
ufiName = String
x}  <- [UnionFieldInfo]
xs ]
    Info
_               -> Maybe Int
forall a. Maybe a
Nothing
  where
    go :: [String] -> Maybe Int
go = String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
n

------------------------------------------------------------------------

localVariableNameDeclarations ::
  IntMap ValMd    {- ^ unnamed metadata      -} ->
  Define          {- ^ function definition   -} ->
  Map Ident Ident {- ^ raw name, actual name -}
localVariableNameDeclarations :: MdMap -> Define -> Map Ident Ident
localVariableNameDeclarations MdMap
mdMap Define
def =
  case Define -> [BasicBlock]
defBody Define
def of
    BasicBlock
blk1 : [BasicBlock]
_ -> ([Stmt] -> Map Ident Ident -> Map Ident Ident)
-> Map Ident Ident -> [[Stmt]] -> Map Ident Ident
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Stmt] -> Map Ident Ident -> Map Ident Ident
aux Map Ident Ident
forall k a. Map k a
Map.empty ([Stmt] -> [[Stmt]]
forall a. [a] -> [[a]]
tails (BasicBlock -> [Stmt]
forall lab. BasicBlock' lab -> [Stmt' lab]
bbStmts BasicBlock
blk1))
    [BasicBlock]
_        -> Map Ident Ident
forall k a. Map k a
Map.empty
  where

    aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident
    aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident
aux ( Effect (Store Typed (Value' BlockLabel)
src Typed (Value' BlockLabel)
dst Maybe AtomicOrdering
_ Maybe Int
_) [DebugRecord' BlockLabel]
_ [(String, ValMd)]
_
        : Effect (Call Bool
_ Type
_ (ValSymbol (Symbol String
what)) [Typed (Value' BlockLabel)
var,Typed (Value' BlockLabel)
md,Typed (Value' BlockLabel)
_]) [DebugRecord' BlockLabel]
_ [(String, ValMd)]
_
        : [Stmt]
_) Map Ident Ident
sofar
      | String
what String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"llvm.dbg.declare"  -- pre-LLVM19: intrinsic declaration match
      , Just Ident
dstIdent <- Typed (Value' BlockLabel) -> Maybe Ident
extractIdent Typed (Value' BlockLabel)
dst
      , Just Ident
srcIdent <- Typed (Value' BlockLabel) -> Maybe Ident
extractIdent Typed (Value' BlockLabel)
src
      , Just Ident
varIdent <- Typed (Value' BlockLabel) -> Maybe Ident
extractIdent Typed (Value' BlockLabel)
var
      , Ident
dstIdent Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
varIdent
      , Just Ident
name <- Typed (Value' BlockLabel) -> Maybe Ident
extractLvName Typed (Value' BlockLabel)
md
      = Ident -> Ident -> Map Ident Ident -> Map Ident Ident
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
name Ident
srcIdent Map Ident Ident
sofar

    aux ( Effect (Call Bool
_ Type
_ (ValSymbol (Symbol String
what)) [Typed (Value' BlockLabel)
var,Typed (Value' BlockLabel)
_,Typed (Value' BlockLabel)
md,Typed (Value' BlockLabel)
_]) [DebugRecord' BlockLabel]
_ [(String, ValMd)]
_
        : [Stmt]
_) Map Ident Ident
sofar
      | String
what String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"llvm.dbg.value"  -- pre-LLVM19: intrinsic declaration match
      , Just Ident
key  <- Typed (Value' BlockLabel) -> Maybe Ident
extractIdent Typed (Value' BlockLabel)
var
      , Just Ident
name <- Typed (Value' BlockLabel) -> Maybe Ident
extractLvName Typed (Value' BlockLabel)
md
      = Ident -> Ident -> Map Ident Ident -> Map Ident Ident
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Ident
name Ident
key Map Ident Ident
sofar

    aux [Stmt]
_ Map Ident Ident
sofar = Map Ident Ident
sofar

    extractIdent :: Typed Value -> Maybe Ident
    extractIdent :: Typed (Value' BlockLabel) -> Maybe Ident
extractIdent (Typed Type
_ (ValIdent Ident
i)) = Ident -> Maybe Ident
forall a. a -> Maybe a
Just Ident
i
    extractIdent Typed (Value' BlockLabel)
_                      = Maybe Ident
forall a. Maybe a
Nothing

    extractLvName :: Typed Value -> Maybe Ident
    extractLvName :: Typed (Value' BlockLabel) -> Maybe Ident
extractLvName Typed (Value' BlockLabel)
mdArg =
      do ValMd ValMd
md                    <- Value' BlockLabel -> Maybe (Value' BlockLabel)
forall a. a -> Maybe a
Just (Typed (Value' BlockLabel) -> Value' BlockLabel
forall a. Typed a -> a
typedValue Typed (Value' BlockLabel)
mdArg)
         DebugInfoLocalVariable DILocalVariable' BlockLabel
dilv <- MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap ValMd
md
         String -> Ident
Ident (String -> Ident) -> Maybe String -> Maybe Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DILocalVariable' BlockLabel -> Maybe String
forall lab. DILocalVariable' lab -> Maybe String
dilvName DILocalVariable' BlockLabel
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.
--
-- 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 -> Info
guessAliasInfo MdMap
mdMap (Ident String
name)
  | Just String
pfx <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"struct." String
name = MdMap -> String -> Info
guessTypeInfo MdMap
mdMap String
pfx
  | Just String
pfx <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"union."  String
name = MdMap -> String -> Info
guessTypeInfo MdMap
mdMap String
pfx
  | Bool
otherwise = MdMap -> String -> Info
guessTypeInfo MdMap
mdMap String
name

-- | 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
guessTypeInfo :: MdMap -> String -> Info
guessTypeInfo MdMap
mdMap String
name =
  case (ValMd -> Maybe Info) -> [ValMd] -> [Info]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DebugInfo -> Maybe Info
go (DebugInfo -> Maybe Info)
-> (ValMd -> Maybe DebugInfo) -> ValMd -> Maybe Info
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< MdMap -> ValMd -> Maybe DebugInfo
getDebugInfo MdMap
mdMap) (MdMap -> [ValMd]
forall a. IntMap a -> [a]
IntMap.elems MdMap
mdMap) of
    []  -> Info
Unknown
    Info
x:[Info]
_ -> Info
x

  where
    go :: DebugInfo -> Maybe Info
go DebugInfo
di | DebugInfoDerivedType DIDerivedType' BlockLabel
didt <- DebugInfo
di
          , String -> Maybe String
forall a. a -> Maybe a
Just String
name Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== DIDerivedType' BlockLabel -> Maybe String
forall lab. DIDerivedType' lab -> Maybe String
didtName DIDerivedType' BlockLabel
didt
          = Info -> Maybe Info
forall a. a -> Maybe a
Just (MdMap -> DebugInfo -> Info
debugInfoToInfo MdMap
mdMap DebugInfo
di)

    go DebugInfo
di | DebugInfoCompositeType DICompositeType' BlockLabel
dict <- DebugInfo
di
          , String -> Maybe String
forall a. a -> Maybe a
Just String
name Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== DICompositeType' BlockLabel -> Maybe String
forall lab. DICompositeType' lab -> Maybe String
dictName DICompositeType' BlockLabel
dict
          = Info -> Maybe Info
forall a. a -> Maybe a
Just (MdMap -> DebugInfo -> Info
debugInfoToInfo MdMap
mdMap DebugInfo
di)

    go DebugInfo
_ = Maybe Info
forall a. Maybe a
Nothing

------------------------------------------------------------------------

-- | Find source-level names of function arguments
debugInfoArgNames :: Module -> Define -> IntMap String
debugInfoArgNames :: Module -> Define -> IntMap String
debugInfoArgNames Module
m Define
d =
  case String -> Map String ValMd -> Maybe ValMd
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
dbgKind (Map String ValMd -> Maybe ValMd)
-> Map String ValMd -> Maybe ValMd
forall a b. (a -> b) -> a -> b
$ Define -> Map String ValMd
defMetadata Define
d of
    Just (ValMdRef UnnamedMdIdx
s) -> UnnamedMdIdx -> IntMap String
scopeArgs UnnamedMdIdx
s
    Maybe ValMd
_ -> IntMap String
forall a. IntMap a
IntMap.empty
  where
    scopeArgs :: UnnamedMdIdx -> IntMap String
    scopeArgs :: UnnamedMdIdx -> IntMap String
scopeArgs UnnamedMdIdx
s = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, String)] -> IntMap String)
-> ([UnnamedMd] -> [(Int, String)]) -> [UnnamedMd] -> IntMap String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnnamedMd -> Maybe (Int, String))
-> [UnnamedMd] -> [(Int, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UnnamedMd -> Maybe (Int, String)
go ([UnnamedMd] -> IntMap String) -> [UnnamedMd] -> IntMap String
forall a b. (a -> b) -> a -> b
$ Module -> [UnnamedMd]
modUnnamedMd Module
m
      where
        go :: UnnamedMd -> Maybe (Int, String)
        go :: UnnamedMd -> Maybe (Int, String)
go
          ( UnnamedMd
              { umValues :: UnnamedMd -> ValMd
umValues =
                  ValMdDebugInfo
                    ( DebugInfoLocalVariable
                        DILocalVariable
                          { dilvScope :: forall lab. DILocalVariable' lab -> Maybe (ValMd' lab)
dilvScope = Just (ValMdRef UnnamedMdIdx
s'),
                            dilvArg :: forall lab. DILocalVariable' lab -> Word16
dilvArg = Word16
a,
                            dilvName :: forall lab. DILocalVariable' lab -> Maybe String
dilvName = Just String
n
                          }
                      )
              }) =
            if UnnamedMdIdx
s UnnamedMdIdx -> UnnamedMdIdx -> Bool
forall a. Eq a => a -> a -> Bool
== UnnamedMdIdx
s'
            then (Int, String) -> Maybe (Int, String)
forall a. a -> Maybe a
Just (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
a Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, String
n)
            else Maybe (Int, String)
forall a. Maybe a
Nothing
        go UnnamedMd
_ = Maybe (Int, String)
forall a. Maybe a
Nothing

------------------------------------------------------------------------

-- | Map global variable names to the line on which the global is defined
debugInfoGlobalLines :: Module -> Map String Int
debugInfoGlobalLines :: Module -> Map String Int
debugInfoGlobalLines = [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Int)] -> Map String Int)
-> (Module -> [(String, Int)]) -> Module -> Map String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnnamedMd -> Maybe (String, Int))
-> [UnnamedMd] -> [(String, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UnnamedMd -> Maybe (String, Int)
go ([UnnamedMd] -> [(String, Int)])
-> (Module -> [UnnamedMd]) -> Module -> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> [UnnamedMd]
modUnnamedMd
  where
    go :: UnnamedMd -> Maybe (String, Int)
    go :: UnnamedMd -> Maybe (String, Int)
go (UnnamedMd
         { umValues :: UnnamedMd -> ValMd
umValues = ValMdDebugInfo
           (DebugInfoGlobalVariable DIGlobalVariable
             { digvName :: forall lab. DIGlobalVariable' lab -> Maybe String
digvName = Just String
n
             , digvLine :: forall lab. DIGlobalVariable' lab -> Word32
digvLine = Word32
l
             }
           )
         }) = (String, Int) -> Maybe (String, Int)
forall a. a -> Maybe a
Just (String
n, (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
l))
    go UnnamedMd
_ = Maybe (String, Int)
forall a. Maybe a
Nothing

-- | Map function names to the line on which the function is defined
debugInfoDefineLines :: Module -> Map String Int
debugInfoDefineLines :: Module -> Map String Int
debugInfoDefineLines = [(String, Int)] -> Map String Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(String, Int)] -> Map String Int)
-> (Module -> [(String, Int)]) -> Module -> Map String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnnamedMd -> Maybe (String, Int))
-> [UnnamedMd] -> [(String, Int)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UnnamedMd -> Maybe (String, Int)
go ([UnnamedMd] -> [(String, Int)])
-> (Module -> [UnnamedMd]) -> Module -> [(String, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> [UnnamedMd]
modUnnamedMd
  where
    go :: UnnamedMd -> Maybe (String, Int)
    go :: UnnamedMd -> Maybe (String, Int)
go (UnnamedMd
         { umValues :: UnnamedMd -> ValMd
umValues = ValMdDebugInfo
           (DebugInfoSubprogram DISubprogram
             { dispName :: forall lab. DISubprogram' lab -> Maybe String
dispName = Just String
n
             , dispIsDefinition :: forall lab. DISubprogram' lab -> Bool
dispIsDefinition = Bool
True
             , dispLine :: forall lab. DISubprogram' lab -> Word32
dispLine = Word32
l
             }
           )
         }) = (String, Int) -> Maybe (String, Int)
forall a. a -> Maybe a
Just (String
n, (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
l))
    go UnnamedMd
_ = Maybe (String, Int)
forall a. Maybe a
Nothing


-- | Given a file and line number and a handler, call the appropriate handler
-- method on every Define, Block, and Stmt that is associated with the line
-- number.
atFileLines :: AtFileLines a b
            => b -> a -> FilePath -> Integer -> Module -> a
atFileLines :: forall a b.
AtFileLines a b =>
b -> a -> String -> Integer -> Module -> a
atFileLines b
handle a
seed String
file Integer
line Module
mdule =
  let mdMap :: MdMap
mdMap = Module -> MdMap
mkMdMap Module
mdule
      matchesFile :: String -> Bool
matchesFile String
x =
        let fn :: String
fn = ShowS
normalise String
file
            fl :: Int
fl = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fn
            xl :: Int
xl = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x
            (String
p,String
r) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
xl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fl) String
x
        in [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int
fl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
xl
               , String
fn String -> String -> Bool
`equalFilePath` String
r
               , String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
p Bool -> Bool -> Bool
|| String -> Bool
hasTrailingPathSeparator String
p
               ]
      locMatch :: ValMd -> Bool
locMatch ValMd
di =
        let getMDLine :: ValMd -> Word32
getMDLine = \case
              ValMdLoc x :: DebugLoc' BlockLabel
x@(DebugLoc {}) -> DebugLoc' BlockLabel -> Word32
forall lab. DebugLoc' lab -> Word32
dlLine DebugLoc' BlockLabel
x
              ValMdDebugInfo (DebugInfoSubprogram DISubprogram' BlockLabel
x) -> DISubprogram' BlockLabel -> Word32
forall lab. DISubprogram' lab -> Word32
dispLine DISubprogram' BlockLabel
x
              ValMdDebugInfo (DebugInfoLocalVariable DILocalVariable' BlockLabel
x) -> DILocalVariable' BlockLabel -> Word32
forall lab. DILocalVariable' lab -> Word32
dilvLine DILocalVariable' BlockLabel
x
              ValMdDebugInfo (DebugInfoLexicalBlock DILexicalBlock' BlockLabel
x) -> DILexicalBlock' BlockLabel -> Word32
forall lab. DILexicalBlock' lab -> Word32
dilbLine DILexicalBlock' BlockLabel
x
              ValMdDebugInfo (DebugInfoGlobalVariable DIGlobalVariable' BlockLabel
x) -> DIGlobalVariable' BlockLabel -> Word32
forall lab. DIGlobalVariable' lab -> Word32
digvLine DIGlobalVariable' BlockLabel
x
              ValMdDebugInfo (DebugInfoDerivedType DIDerivedType' BlockLabel
x) -> DIDerivedType' BlockLabel -> Word32
forall lab. DIDerivedType' lab -> Word32
didtLine DIDerivedType' BlockLabel
x
              ValMdDebugInfo (DebugInfoCompositeType DICompositeType' BlockLabel
x) -> DICompositeType' BlockLabel -> Word32
forall lab. DICompositeType' lab -> Word32
dictLine DICompositeType' BlockLabel
x
              ValMdDebugInfo (DebugInfoNameSpace DINameSpace' BlockLabel
x) -> DINameSpace' BlockLabel -> Word32
forall lab. DINameSpace' lab -> Word32
dinsLine DINameSpace' BlockLabel
x
              ValMdDebugInfo (DebugInfoLabel DILabel' BlockLabel
x) -> DILabel' BlockLabel -> Word32
forall lab. DILabel' lab -> Word32
dilLine DILabel' BlockLabel
x
              ValMdRef (UnnamedMdIdx Int
i) -> Word32 -> (ValMd -> Word32) -> Maybe ValMd -> Word32
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Word32
0 ValMd -> Word32
getMDLine (Maybe ValMd -> Word32) -> Maybe ValMd -> Word32
forall a b. (a -> b) -> a -> b
$ MdMap
mdMap MdMap -> Getting (Maybe ValMd) MdMap (Maybe ValMd) -> Maybe ValMd
forall s a. s -> Getting a s a -> a
^. Index MdMap -> Lens' MdMap (Maybe (IxValue MdMap))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
Index MdMap
i
              ValMd
_ -> Word32
0
        in [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False String -> Bool
matchesFile (MdMap -> ValMd -> Maybe String
getMDFile MdMap
mdMap ValMd
di)
               , Integer
line Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== (Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word32 -> Integer) -> Word32 -> Integer
forall a b. (a -> b) -> a -> b
$ ValMd -> Word32
getMDLine ValMd
di)
               ]
      onGlobal :: a -> Global -> a
onGlobal a
a Global
g =
        a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool a
a (b -> Global -> a -> a
forall a b. AtFileLines a b => b -> Global -> a -> a
atGlobal b
handle Global
g a
a) (Bool -> a) -> Bool -> a
forall a b. (a -> b) -> a -> b
$ (ValMd -> Bool) -> [ValMd] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ValMd -> Bool
locMatch ([ValMd] -> Bool) -> [ValMd] -> Bool
forall a b. (a -> b) -> a -> b
$ Map String ValMd -> [ValMd]
forall k a. Map k a -> [a]
Map.elems (Map String ValMd -> [ValMd]) -> Map String ValMd -> [ValMd]
forall a b. (a -> b) -> a -> b
$ Global -> Map String ValMd
globalMetadata Global
g
      onDefs :: b -> Define -> b
onDefs b
a Define
d =
        let isMatch :: Bool
isMatch = (ValMd -> Bool) -> [ValMd] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ValMd -> Bool
locMatch ([ValMd] -> Bool) -> [ValMd] -> Bool
forall a b. (a -> b) -> a -> b
$ Map String ValMd -> [ValMd]
forall k a. Map k a -> [a]
Map.elems (Map String ValMd -> [ValMd]) -> Map String ValMd -> [ValMd]
forall a b. (a -> b) -> a -> b
$ Define -> Map String ValMd
defMetadata Define
d
            onDecl :: b -> b
onDecl = (b -> b) -> (b -> b) -> Bool -> b -> b
forall a. a -> a -> Bool -> a
bool b -> b
forall a. a -> a
id (b -> Define -> b -> b
forall a b. AtFileLines a b => b -> Define -> a -> a
atDefine b
handle Define
d) Bool
isMatch
        in (DefineRel, b) -> b
forall a b. (a, b) -> b
snd ((DefineRel, b) -> b) -> (DefineRel, b) -> b
forall a b. (a -> b) -> a -> b
$ ((DefineRel, b) -> BasicBlock -> (DefineRel, b))
-> (DefineRel, b) -> [BasicBlock] -> (DefineRel, b)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (DefineRel, b) -> BasicBlock -> (DefineRel, b)
forall {b}.
AtFileLines b b =>
(DefineRel, b) -> BasicBlock -> (DefineRel, b)
onBlock (Bool -> DefineRel
FirstBlock Bool
isMatch, b -> b
onDecl b
a) ([BasicBlock] -> (DefineRel, b)) -> [BasicBlock] -> (DefineRel, b)
forall a b. (a -> b) -> a -> b
$ Define -> [BasicBlock]
defBody Define
d
      onBlock :: (DefineRel, b) -> BasicBlock -> (DefineRel, b)
onBlock (DefineRel
dr, b
a) BasicBlock
bb =
        let onBlockLabel :: b -> b
onBlockLabel = case BasicBlock -> [Stmt]
forall lab. BasicBlock' lab -> [Stmt' lab]
bbStmts BasicBlock
bb of
                             [] -> b -> b
forall a. a -> a
id
                             (Stmt
s:[Stmt]
_) -> (b -> b) -> (b -> b) -> Bool -> b -> b
forall a. a -> a -> Bool -> a
bool b -> b
forall a. a -> a
id (b -> DefineRel -> BasicBlock -> b -> b
forall a b.
AtFileLines a b =>
b -> DefineRel -> BasicBlock -> a -> a
atBlockStart b
handle DefineRel
dr BasicBlock
bb)
                                      (Bool -> b -> b) -> Bool -> b -> b
forall a b. (a -> b) -> a -> b
$ ((String, ValMd) -> Bool) -> [(String, ValMd)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ValMd -> Bool
locMatch (ValMd -> Bool)
-> ((String, ValMd) -> ValMd) -> (String, ValMd) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ValMd) -> ValMd
forall a b. (a, b) -> b
snd) ([(String, ValMd)] -> Bool) -> [(String, ValMd)] -> Bool
forall a b. (a -> b) -> a -> b
$ Stmt -> [(String, ValMd)]
forall lab. Stmt' lab -> [(String, ValMd' lab)]
stmtMetadata Stmt
s
            sseed :: (DefineRel, BlockRel, b)
sseed = (DefineRel
dr, BlockRel
FirstBlockStmt, b -> b
onBlockLabel b
a)
            (DefineRel
_, BlockRel
_, b
blkstmts) = ((DefineRel, BlockRel, b) -> Stmt -> (DefineRel, BlockRel, b))
-> (DefineRel, BlockRel, b) -> [Stmt] -> (DefineRel, BlockRel, b)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (DefineRel, BlockRel, b) -> Stmt -> (DefineRel, BlockRel, b)
forall {c}.
AtFileLines c b =>
(DefineRel, BlockRel, c) -> Stmt -> (DefineRel, BlockRel, c)
onStmt (DefineRel, BlockRel, b)
sseed ([Stmt] -> (DefineRel, BlockRel, b))
-> [Stmt] -> (DefineRel, BlockRel, b)
forall a b. (a -> b) -> a -> b
$ BasicBlock -> [Stmt]
forall lab. BasicBlock' lab -> [Stmt' lab]
bbStmts BasicBlock
bb
        in (DefineRel
OtherBlock, b
blkstmts)
      onStmt :: (DefineRel, BlockRel, c) -> Stmt -> (DefineRel, BlockRel, c)
onStmt (DefineRel
dr, BlockRel
br, c
a) Stmt
s =
        (DefineRel, BlockRel, c)
-> (DefineRel, BlockRel, c) -> Bool -> (DefineRel, BlockRel, c)
forall a. a -> a -> Bool -> a
bool
        (DefineRel
dr, BlockRel
FirstLineStmt, c
a)
        (DefineRel
dr, BlockRel
ContiguousStmt, b -> DefineRel -> BlockRel -> Stmt -> c -> c
forall a b.
AtFileLines a b =>
b -> DefineRel -> BlockRel -> Stmt -> a -> a
atStmt b
handle DefineRel
dr BlockRel
br Stmt
s c
a)
        (Bool -> (DefineRel, BlockRel, c))
-> Bool -> (DefineRel, BlockRel, c)
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ ((String, ValMd) -> Bool) -> [(String, ValMd)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ValMd -> Bool
locMatch (ValMd -> Bool)
-> ((String, ValMd) -> ValMd) -> (String, ValMd) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ValMd) -> ValMd
forall a b. (a, b) -> b
snd) ([(String, ValMd)] -> Bool) -> [(String, ValMd)] -> Bool
forall a b. (a -> b) -> a -> b
$ Stmt -> [(String, ValMd)]
forall lab. Stmt' lab -> [(String, ValMd' lab)]
stmtMetadata Stmt
s
             -- n.b. the DebugRecords describe associated data, but do not
             -- (at this time, circa LLVM 22) contain instruction location
             -- references, so they are not considered here.
             , DefineRel
dr DefineRel -> DefineRel -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> DefineRel
FirstBlock Bool
True Bool -> Bool -> Bool
&& [(String, ValMd)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Stmt -> [(String, ValMd)]
forall lab. Stmt' lab -> [(String, ValMd' lab)]
stmtMetadata Stmt
s)
             ]
  in (a -> Global -> a) -> a -> [Global] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a -> Global -> a
forall {a}. AtFileLines a b => a -> Global -> a
onGlobal ((a -> Define -> a) -> a -> [Define] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a -> Define -> a
forall {b}. AtFileLines b b => b -> Define -> b
onDefs a
seed ([Define] -> a) -> [Define] -> a
forall a b. (a -> b) -> a -> b
$ Module -> [Define]
modDefines Module
mdule) ([Global] -> a) -> [Global] -> a
forall a b. (a -> b) -> a -> b
$ Module -> [Global]
modGlobals Module
mdule

-- | The handler passed to 'atFileLines' must be an instance of this class.
--
-- Here, @b@ is an object for which the following methods can be called with an
-- accumulator @a@ and the corresponding LLVM AST element that has the @lab@
-- label type.  The method will return an updated accumulator.
class AtFileLines a b where
  -- | The 'atDefine' method is called (before any enclosed 'BasicBlock' or
  --   'Stmt' elements) if the file and line number are associated with the
  --   'Define' signature line.
  atDefine :: b -> Define -> a -> a
  -- | The 'atBlockStart' method is called if the first 'Stmt' in the
  --   'BasicBlock' is associated with the file and line number, and before any
  --   'Stmt's in the block are passed to 'atStmt'.
  --   the first block in the 'Define'.
  atBlockStart :: b -> DefineRel -> BasicBlock -> a -> a
  -- | The 'atStmt' method is called for every 'Stmt' in the basic block that is
  --   associated with the file and line number.  The boolean value passed is
  --   true if the 'Stmt' immediately follows a previous 'Stmt' that was
  --   associated with the same line, or if this was the first 'Stmt' in the
  --   block.
  atStmt :: b -> DefineRel -> BlockRel -> Stmt -> a -> a
  -- | The 'atGlobal' method is called for evey 'Global' that is associated with
  -- the file and line number.
  atGlobal :: b -> Global -> a -> a

data DefineRel = FirstBlock Bool -- ^ first block of a 'Define', matched file & line?
               | OtherBlock      -- ^ other blocks of a 'Define'
  deriving DefineRel -> DefineRel -> Bool
(DefineRel -> DefineRel -> Bool)
-> (DefineRel -> DefineRel -> Bool) -> Eq DefineRel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DefineRel -> DefineRel -> Bool
== :: DefineRel -> DefineRel -> Bool
$c/= :: DefineRel -> DefineRel -> Bool
/= :: DefineRel -> DefineRel -> Bool
Eq

data BlockRel = FirstBlockStmt -- ^ first statement in a 'BasicBlock'
              | ContiguousStmt -- ^ previous statement also matched the file & line
              | FirstLineStmt  -- ^ previous statement did not match the file & line
  deriving BlockRel -> BlockRel -> Bool
(BlockRel -> BlockRel -> Bool)
-> (BlockRel -> BlockRel -> Bool) -> Eq BlockRel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockRel -> BlockRel -> Bool
== :: BlockRel -> BlockRel -> Bool
$c/= :: BlockRel -> BlockRel -> Bool
/= :: BlockRel -> BlockRel -> Bool
Eq