module Data.Dwarf.ADT
( Warning(..)
, Dwarf(..), fromDies
, Boxed(..), CompilationUnit(..), fromDie
, Decl(..)
, Def(..), DefType(..)
, TypeRef(..)
, BaseType(..)
, Typedef(..)
, PtrType(..)
, ConstType(..)
, VolatileType(..)
, Member(..), StructureType(..), UnionType(..)
, SubrangeType(..), ArrayType(..)
, EnumerationType(..), Enumerator(..)
, SubroutineType(..), FormalParameter(..)
, Subprogram(..)
, Variable(..)
) where
import Control.Applicative (Applicative(..), (<$>))
import Control.Monad (when)
import Control.Monad.Fix (MonadFix, mfix)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State (StateT, evalStateT)
import Control.Monad.Trans.Writer (Writer, runWriter)
import Data.Dwarf (DieID, DIEMap, DIE(..), DW_TAG(..), DW_AT(..), DW_ATVAL(..))
import Data.Dwarf.AttrGetter (AttrGetterT)
import Data.Dwarf.Lens (_ATVAL_INT, _ATVAL_UINT, _ATVAL_REF, _ATVAL_STRING, _ATVAL_BLOB, _ATVAL_BOOL)
import Data.Int (Int64)
import Data.List (intercalate)
import Data.Map (Map)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Traversable (traverse)
import Data.Word (Word, Word64)
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Writer as Writer
import qualified Data.Dwarf as Dwarf
import qualified Data.Dwarf.AttrGetter as AttrGetter
import qualified Data.Map as Map
getName :: Monad m => AttrGetterT m String
getName = AttrGetter.getAttr DW_AT_name _ATVAL_STRING
getMName :: Monad m => AttrGetterT m (Maybe String)
getMName = AttrGetter.findAttr DW_AT_name _ATVAL_STRING
data Warning = Warning
{ warningDieId :: DIE
, warningUnusedAttrs :: [(DW_AT, DW_ATVAL)]
}
instance Show Warning where
show (Warning i unusedAttrs) =
unlines
$ ("WARNING: ignored attributes in: " ++ show i)
: map (\(key, val) -> show key ++ "=" ++ show val) unusedAttrs
newtype M a = M (StateT (Map DieID (Boxed DefType)) (ReaderT DIEMap (Writer [Warning])) a)
deriving (Functor, Applicative, Monad, MonadFix)
runM :: DIEMap -> M a -> Writer [Warning] a
runM dieMap (M act) = runReaderT (evalStateT act Map.empty) dieMap
liftDefCache :: StateT (Map DieID (Boxed DefType)) (ReaderT DIEMap (Writer [Warning])) a -> M a
liftDefCache = M
askDIEMap :: M DIEMap
askDIEMap = M $ lift Reader.ask
tellWarning :: Warning -> M ()
tellWarning warn = M . lift . lift $ Writer.tell [warn]
runAttrGetterT :: DIE -> AttrGetterT M a -> M a
runAttrGetterT die act = do
(res, allUnusedAttrs) <- AttrGetter.run die act
let unusedAttrs = filter ((/= DW_AT_sibling) . fst) allUnusedAttrs
when (not (null unusedAttrs)) .
tellWarning $ Warning die unusedAttrs
return res
cachedMake :: DieID -> M (Boxed DefType) -> M (Boxed DefType)
cachedMake i act = do
found <- liftDefCache . State.gets $ Map.lookup i
case found of
Just res -> pure res
Nothing -> mfix $ \res -> do
liftDefCache . State.modify $ Map.insert i res
act
parseAt :: DieID -> M (Boxed DefType)
parseAt i = cachedMake i $ do
dieMap <- askDIEMap
let die = Dwarf.dieRefsDIE $ dieMap Map.! i
parseDefTypeI die
data Loc = LocOp Dwarf.DW_OP | LocUINT Word64
deriving (Eq, Ord, Show)
data TypeRef = Void | TypeRef (Boxed DefType)
deriving (Eq, Ord)
instance Show TypeRef where
show Void = "void"
show (TypeRef _) = "(..type..)"
toTypeRef :: Maybe (Boxed DefType) -> TypeRef
toTypeRef Nothing = Void
toTypeRef (Just x) = TypeRef x
data Decl = Decl
{ declFile :: Maybe Word64
, declLine :: Maybe Int
, declColumn :: Maybe Int
} deriving (Eq, Ord)
instance Show Decl where
show (Decl f l c) = intercalate ":" $ fmap ("FN"++) (toList f) ++ toList l ++ toList c
where
toList x = maybeToList $ fmap show x
getDecl :: (Monad m, Applicative m) => AttrGetterT m Decl
getDecl =
Decl
<$> getUINT DW_AT_decl_file
<*> (fmap fromIntegral <$> getUINT DW_AT_decl_line)
<*> (fmap fromIntegral <$> getUINT DW_AT_decl_column)
where
getUINT = (`AttrGetter.findAttr` _ATVAL_UINT)
getByteSize :: (Monad m, Applicative m) => AttrGetterT m Word
getByteSize = fromIntegral <$> AttrGetter.getAttr DW_AT_byte_size _ATVAL_UINT
getMByteSize :: (Monad m, Applicative m) => AttrGetterT m (Maybe Word)
getMByteSize = fmap fromIntegral <$> AttrGetter.findAttr DW_AT_byte_size _ATVAL_UINT
data Boxed a = Boxed
{ bDieId :: DieID
, bData :: a
} deriving (Eq, Ord, Show, Functor)
mkBox :: DIE -> AttrGetterT M a -> M (Boxed a)
mkBox die act = Boxed (dieId die) <$> runAttrGetterT die act
box :: DW_TAG -> DIE -> AttrGetterT M a -> M (Boxed a)
box tag die act
| tag == dieTag die = mkBox die act
| otherwise =
fail $ "Expected DIE with tag: " ++ show tag ++ " but found: " ++ show die
data BaseType = BaseType
{ btByteSize :: Word
, btEncoding :: Dwarf.DW_ATE
, btName :: Maybe String
} deriving (Eq, Ord, Show)
parseBaseType :: (Monad m, Applicative m) => AttrGetterT m BaseType
parseBaseType =
BaseType
<$> getByteSize
<*> (Dwarf.dw_ate <$> AttrGetter.getAttr DW_AT_encoding _ATVAL_UINT)
<*> getMName
data Typedef = Typedef
{ tdName :: String
, tdDecl :: Decl
, tdType :: TypeRef
} deriving (Eq, Ord)
instance Show Typedef where
show (Typedef name decl _) = "Typedef " ++ show name ++ "@(" ++ show decl ++ ") = .."
parseTypeRef :: AttrGetterT M TypeRef
parseTypeRef =
lift . fmap toTypeRef . traverse parseAt =<<
AttrGetter.findAttr DW_AT_type _ATVAL_REF
parseTypedef :: AttrGetterT M Typedef
parseTypedef =
Typedef <$> getName <*> getDecl <*> parseTypeRef
data PtrType = PtrType
{ ptType :: TypeRef
, ptByteSize :: Word
} deriving (Eq, Ord)
instance Show PtrType where
show (PtrType t _) = "Ptr to " ++ show t
parsePtrType :: AttrGetterT M PtrType
parsePtrType =
PtrType
<$> parseTypeRef
<*> getByteSize
data ConstType = ConstType
{ ctType :: TypeRef
} deriving (Eq, Ord, Show)
parseConstType :: AttrGetterT M ConstType
parseConstType = ConstType <$> parseTypeRef
data VolatileType = VolatileType
{ vtType :: TypeRef
} deriving (Eq, Ord, Show)
parseVolatileType :: AttrGetterT M VolatileType
parseVolatileType = VolatileType <$> parseTypeRef
data Member loc = Member
{ membName :: Maybe String
, membDecl :: Decl
, membLoc :: loc
, membType :: TypeRef
} deriving (Eq, Ord, Show)
parseMember :: (Dwarf.Reader -> AttrGetterT M loc) -> DIE -> M (Boxed (Member loc))
parseMember getLoc die =
box DW_TAG_member die $
Member <$> getMName <*> getDecl <*> getLoc (dieReader die) <*> parseTypeRef
data StructureType = StructureType
{ stName :: Maybe String
, stByteSize :: Maybe Word
, stDecl :: Decl
, stIsDeclaration :: Bool
, stMembers :: [Boxed (Member Dwarf.DW_OP)]
} deriving (Eq, Ord, Show)
getDeclaration :: AttrGetterT M Bool
getDeclaration = fromMaybe False <$> AttrGetter.findAttr DW_AT_declaration _ATVAL_BOOL
parseStructureType :: [DIE] -> AttrGetterT M StructureType
parseStructureType children =
StructureType
<$> getMName
<*> getMByteSize
<*> getDecl
<*> getDeclaration
<*> mapM (lift . parseMember getLoc) children
where
getLoc reader =
Dwarf.parseDW_OP reader <$>
AttrGetter.getAttr DW_AT_data_member_location _ATVAL_BLOB
data SubrangeType = SubrangeType
{ subRangeUpperBound :: Maybe Word
, subRangeType :: TypeRef
} deriving (Eq, Ord, Show)
parseSubrangeType :: DIE -> M (Boxed SubrangeType)
parseSubrangeType die =
box DW_TAG_subrange_type die $
SubrangeType
<$> (fmap fromIntegral <$> AttrGetter.findAttr DW_AT_upper_bound _ATVAL_UINT)
<*> parseTypeRef
data ArrayType = ArrayType
{ atSubrangeType :: [Boxed SubrangeType]
, atType :: TypeRef
} deriving (Eq, Ord, Show)
parseArrayType :: [DIE] -> AttrGetterT M ArrayType
parseArrayType cs =
ArrayType <$> lift (mapM parseSubrangeType cs) <*> parseTypeRef
data UnionType = UnionType
{ unionName :: Maybe String
, unionByteSize :: Word
, unionDecl :: Decl
, unionMembers :: [Boxed (Member (Maybe Dwarf.DW_OP))]
} deriving (Eq, Ord, Show)
parseUnionType :: [DIE] -> AttrGetterT M UnionType
parseUnionType children =
UnionType
<$> getMName
<*> getByteSize
<*> getDecl
<*> mapM (lift . parseMember getLoc) children
where
getLoc reader =
fmap (Dwarf.parseDW_OP reader) <$>
AttrGetter.findAttr DW_AT_data_member_location _ATVAL_BLOB
data Enumerator = Enumerator
{ enumeratorName :: String
, enumeratorConstValue :: Int64
} deriving (Eq, Ord, Show)
parseEnumerator :: DIE -> M (Boxed Enumerator)
parseEnumerator die =
box DW_TAG_enumerator die $
Enumerator
<$> getName
<*> AttrGetter.getAttr DW_AT_const_value _ATVAL_INT
data EnumerationType = EnumerationType
{ enumName :: Maybe String
, enumDecl :: Decl
, enumByteSize :: Word
, enumEnumerators :: [Boxed Enumerator]
} deriving (Eq, Ord, Show)
parseEnumerationType :: [DIE] -> AttrGetterT M EnumerationType
parseEnumerationType children =
EnumerationType
<$> getMName
<*> getDecl
<*> getByteSize
<*> mapM (lift . parseEnumerator) children
data FormalParameter = FormalParameter
{ formalParamName :: Maybe String
, formalParamDecl :: Decl
, formalParamLocation :: Maybe Loc
, formalParamType :: TypeRef
} deriving (Eq, Ord, Show)
parseLoc :: Dwarf.Reader -> DW_ATVAL -> Loc
parseLoc reader (DW_ATVAL_BLOB blob) = LocOp $ Dwarf.parseDW_OP reader blob
parseLoc _ (DW_ATVAL_UINT uint) = LocUINT uint
parseLoc _ x =
error $
"Expected DW_ATVAL_BLOB or DW_ATVAL_UINT for DW_AT_location field of variable, got: " ++
show x
parseFormalParameter :: DIE -> M (Boxed FormalParameter)
parseFormalParameter die =
box DW_TAG_formal_parameter die $
FormalParameter
<$> getMName
<*> getDecl
<*> (fmap (parseLoc (dieReader die)) <$> AttrGetter.findAttrVal DW_AT_location)
<*> parseTypeRef
data SubroutineType = SubroutineType
{ subrPrototyped :: Bool
, subrRetType :: TypeRef
, subrFormalParameters :: [Boxed FormalParameter]
} deriving (Eq, Ord, Show)
getPrototyped :: AttrGetterT M Bool
getPrototyped = fromMaybe False <$> AttrGetter.findAttr DW_AT_prototyped _ATVAL_BOOL
parseSubroutineType :: [DIE] -> AttrGetterT M SubroutineType
parseSubroutineType children =
SubroutineType
<$> getPrototyped
<*> parseTypeRef
<*> mapM (lift . parseFormalParameter) children
getLowPC :: AttrGetterT M Word64
getLowPC = AttrGetter.getAttr DW_AT_low_pc _ATVAL_UINT
getMLowPC :: AttrGetterT M (Maybe Word64)
getMLowPC = AttrGetter.findAttr DW_AT_low_pc _ATVAL_UINT
getMHighPC :: AttrGetterT M (Maybe Word64)
getMHighPC = AttrGetter.findAttr DW_AT_high_pc _ATVAL_UINT
data Variable name = Variable
{ varName :: name
, varDecl :: Decl
, varLoc :: Maybe Loc
, varExternal :: Bool
, varDeclaration :: Bool
, varType :: TypeRef
} deriving (Eq, Ord, Show)
parseVariable :: Dwarf.Reader -> AttrGetterT M name -> AttrGetterT M (Variable name)
parseVariable reader getVarName =
Variable
<$> getVarName
<*> getDecl
<*> (fmap (parseLoc reader) <$> AttrGetter.findAttrVal DW_AT_location)
<*> getExternal
<*> getDeclaration
<*> parseTypeRef
data Subprogram = Subprogram
{ subprogName :: String
, subprogDecl :: Decl
, subprogPrototyped :: Bool
, subprogExternal :: Bool
, subprogLowPC :: Maybe Word64
, subprogHighPC :: Maybe Word64
, subprogFrameBase :: Maybe Loc
, subprogFormalParameters :: [Boxed FormalParameter]
, subprogUnspecifiedParameters :: Bool
, subprogVariables :: [Boxed (Variable (Maybe String))]
, subprogType :: TypeRef
} deriving (Eq, Ord, Show)
data SubprogramChild
= SubprogramChildFormalParameter (Boxed FormalParameter)
| SubprogramChildVariable (Boxed (Variable (Maybe String)))
| SubprogramChildIgnored
| SubprogramChildUnspecifiedParameters
deriving (Eq)
noChildren :: DIE -> a -> a
noChildren DIE{dieChildren=[]} = id
noChildren die@DIE{dieChildren=cs} = error $ "Unexpected children: " ++ show cs ++ " in " ++ show die
getExternal :: AttrGetterT M Bool
getExternal = fromMaybe False <$> AttrGetter.findAttr DW_AT_external _ATVAL_BOOL
parseSubprogram :: Dwarf.Reader -> [DIE] -> AttrGetterT M Subprogram
parseSubprogram reader children = do
parsedChildren <- mapM (lift . parseChild) children
Subprogram
<$> getName
<*> getDecl
<*> getPrototyped
<*> getExternal
<*> getMLowPC
<*> getMHighPC
<*> (fmap (parseLoc reader) <$> AttrGetter.findAttrVal DW_AT_frame_base)
<*> pure [x | SubprogramChildFormalParameter x <- parsedChildren]
<*> pure (SubprogramChildUnspecifiedParameters `elem` parsedChildren)
<*> pure [x | SubprogramChildVariable x <- parsedChildren]
<*> parseTypeRef
where
parseChild child =
case dieTag child of
DW_TAG_formal_parameter ->
SubprogramChildFormalParameter <$> parseFormalParameter child
DW_TAG_lexical_block -> pure SubprogramChildIgnored
DW_TAG_label -> pure SubprogramChildIgnored
DW_TAG_variable ->
noChildren child $
SubprogramChildVariable <$> mkBox child (parseVariable reader getMName)
DW_TAG_inlined_subroutine -> pure SubprogramChildIgnored
DW_TAG_user 137 -> pure SubprogramChildIgnored
DW_TAG_unspecified_parameters -> pure SubprogramChildUnspecifiedParameters
DW_TAG_structure_type -> pure SubprogramChildIgnored
DW_TAG_union_type -> pure SubprogramChildIgnored
_ -> error $ "unsupported child tag in child: " ++ show child
data DefType
= DefBaseType BaseType
| DefTypedef Typedef
| DefPtrType PtrType
| DefConstType ConstType
| DefVolatileType VolatileType
| DefStructureType StructureType
| DefArrayType ArrayType
| DefUnionType UnionType
| DefEnumerationType EnumerationType
| DefSubroutineType SubroutineType
deriving (Eq, Ord, Show)
data Def
= DefType DefType
| DefSubprogram Subprogram
| DefVariable (Variable String)
deriving (Eq, Ord, Show)
parseDefTypeI :: DIE -> M (Boxed DefType)
parseDefTypeI die =
mkBox die $
case dieTag die of
DW_TAG_base_type -> noChildren die $ DefBaseType <$> parseBaseType
DW_TAG_typedef -> noChildren die $ DefTypedef <$> parseTypedef
DW_TAG_pointer_type -> noChildren die $ DefPtrType <$> parsePtrType
DW_TAG_const_type -> noChildren die $ DefConstType <$> parseConstType
DW_TAG_volatile_type -> noChildren die $ DefVolatileType <$> parseVolatileType
DW_TAG_structure_type -> DefStructureType <$> parseStructureType (dieChildren die)
DW_TAG_array_type -> DefArrayType <$> parseArrayType (dieChildren die)
DW_TAG_union_type -> DefUnionType <$> parseUnionType (dieChildren die)
DW_TAG_enumeration_type -> DefEnumerationType <$> parseEnumerationType (dieChildren die)
DW_TAG_subroutine_type -> DefSubroutineType <$> parseSubroutineType (dieChildren die)
_ -> error $ "unsupported def type: " ++ show die
parseDefI :: DIE -> M (Boxed Def)
parseDefI die =
case dieTag die of
DW_TAG_variable ->
mkBox die . noChildren die $
DefVariable <$> parseVariable (dieReader die) getName
DW_TAG_subprogram ->
mkBox die $
DefSubprogram <$> parseSubprogram (dieReader die) (dieChildren die)
_ ->
(fmap . fmap) DefType .
cachedMake (dieId die) $
parseDefTypeI die
parseDef :: DIE -> M (Boxed Def)
parseDef die = parseDefI die
data CompilationUnit = CompilationUnit
{ cuProducer :: String
, cuLanguage :: Dwarf.DW_LANG
, cuName :: String
, cuCompDir :: String
, cuLowPc :: Word64
, cuHighPc :: Maybe Word64
, cuStmtList :: Word64
, cuDefs :: [Boxed Def]
} deriving (Show)
parseCU :: DIEMap -> DIE -> Writer [Warning] (Boxed CompilationUnit)
parseCU dieMap die =
runM dieMap .
box DW_TAG_compile_unit die $
CompilationUnit
<$> AttrGetter.getAttr DW_AT_producer _ATVAL_STRING
<*> (Dwarf.dw_lang <$> AttrGetter.getAttr DW_AT_language _ATVAL_UINT)
<*> getName
<*> AttrGetter.getAttr DW_AT_comp_dir _ATVAL_STRING
<*> getLowPC
<*> getMHighPC
<*> AttrGetter.getAttr DW_AT_stmt_list _ATVAL_UINT
<*> mapM (lift . parseDef) (dieChildren die)
fromDie :: DIEMap -> DIE -> (Boxed CompilationUnit, [Warning])
fromDie dieMap die = runWriter $ parseCU dieMap die
newtype Dwarf = Dwarf
{ dwarfCompilationUnits :: [Boxed CompilationUnit]
}
fromDies :: DIEMap -> [DIE] -> (Dwarf, [Warning])
fromDies dieMap dies = runWriter $ Dwarf <$> mapM (parseCU dieMap) dies