dwarfadt 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+425/−268 lines, 7 filesdep −TraceUtilsdep ~basedep ~dwarf-eldep ~lens
Dependencies removed: TraceUtils
Dependency ranges changed: base, dwarf-el, lens
Files
- dumpadt.hs +4/−4
- dwarfadt.cabal +3/−3
- src/Data/Dwarf/ADT.hs +280/−210
- src/Data/Dwarf/ADT/Pretty.hs +38/−20
- src/Data/Dwarf/AttrGetter.hs +76/−0
- src/Data/Dwarf/Elf.hs +3/−3
- src/Data/Dwarf/Lens.hs +21/−28
dumpadt.hs view
@@ -1,11 +1,11 @@ import System.Environment (getArgs) import qualified Data.Dwarf as Dwarf-import qualified Data.Dwarf.ADT.Pretty as Dwarf.ADT.Pretty+import qualified Data.Dwarf.ADT.Pretty as DwarfPretty import qualified Data.Dwarf.Elf as Dwarf.Elf main :: IO () main = do [filename] <- getArgs- let endianess = Dwarf.LittleEndian- cus <- Dwarf.Elf.parseElfDwarfADT endianess filename- print $ map Dwarf.ADT.Pretty.compilationUnit cus+ (dwarf, warnings) <- Dwarf.Elf.parseElfDwarfADT Dwarf.LittleEndian filename+ mapM_ print warnings+ print $ DwarfPretty.dwarf dwarf
dwarfadt.cabal view
@@ -1,5 +1,5 @@ name: dwarfadt-version: 0.1.0.0+version: 0.2.0.0 synopsis: High-level wrapper around the dwarf library description: dwarf is an excellent library to read dwarf files, but the output of parsing dwarf is very low-level and difficult to work with.@@ -24,12 +24,12 @@ exposed-modules: Data.Dwarf.Elf , Data.Dwarf.ADT , Data.Dwarf.ADT.Pretty+ other-modules: Data.Dwarf.AttrGetter , Data.Dwarf.Lens build-depends: base >=4 && <5, elf >=0.27- , bytestring-mmap >=0.2, dwarf-el >=0.1 && <0.2, lens >=3.7+ , bytestring-mmap >=0.2, dwarf-el >=0.1 && <0.3, lens >=3.9 && <5 , bytestring >=0.9, containers >= 0.3, transformers >= 0.3 , pretty >= 1.1- , TraceUtils ghc-options: -Wall executable dumpdwarf
src/Data/Dwarf/ADT.hs view
@@ -1,15 +1,16 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveFunctor #-} module Data.Dwarf.ADT- ( parseCU- , Boxed(..)- , CompilationUnit(..)+ ( Warning(..)+ , Dwarf(..), fromDies+ , Boxed(..), CompilationUnit(..), fromDie , Decl(..)- , Def(..)+ , Def(..), DefType(..) , TypeRef(..) , BaseType(..) , Typedef(..) , PtrType(..) , ConstType(..)+ , VolatileType(..) , Member(..), StructureType(..), UnionType(..) , SubrangeType(..), ArrayType(..) , EnumerationType(..), Enumerator(..)@@ -18,15 +19,16 @@ , Variable(..) ) where --- TODO: Separate ADT for type definitions, sum that with--- subprogram/variable to get a CompilationUnitDef- 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 (Reader, runReader)+import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.State (StateT, evalStateT)-import Data.Dwarf (DieID, DIEMap, DIE(..), DW_TAG(..), DW_AT(..), DW_ATVAL(..), (!?))+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)@@ -35,61 +37,56 @@ 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.Lens as Dwarf.Lens+import qualified Data.Dwarf.AttrGetter as AttrGetter import qualified Data.Map as Map -verifyTag :: DW_TAG -> DIE -> a -> a-verifyTag expected die x- | tag == expected = x- | otherwise = error $ "Invalid tag: " ++ show tag- where- tag = dieTag die+getName :: Monad m => AttrGetterT m String+getName = AttrGetter.getAttr DW_AT_name _ATVAL_STRING -uniqueAttr :: DW_AT -> DIE -> DW_ATVAL-uniqueAttr at die =- case die !? at of- [val] -> val- [] -> error $ "Missing value for attribute: " ++ show at ++ " in " ++ show die- xs -> error $ "Multiple values for attribute: " ++ show at ++ ": " ++ show xs ++ " in " ++ show die+getMName :: Monad m => AttrGetterT m (Maybe String)+getMName = AttrGetter.findAttr DW_AT_name _ATVAL_STRING -maybeAttr :: DW_AT -> DIE -> Maybe DW_ATVAL-maybeAttr at die =- case die !? at of- [val] -> Just val- [] -> Nothing- xs -> error $ "Multiple values for attribute: " ++ show at ++ ": " ++ show xs ++ " in " ++ show die+data Warning = Warning+ { warningDieId :: DIE+ , warningUnusedAttrs :: [(DW_AT, DW_ATVAL)]+ } -getATVal :: DIE -> DW_AT -> Dwarf.Lens.ATVAL_NamedPrism a -> DW_ATVAL -> a-getATVal die at = Dwarf.Lens.getATVal ("attribute " ++ show at ++ " of " ++ show die)+instance Show Warning where+ show (Warning i unusedAttrs) =+ unlines+ $ ("WARNING: ignored attributes in: " ++ show i)+ : map (\(key, val) -> show key ++ "=" ++ show val) unusedAttrs -getAttrVal :: DW_AT -> Dwarf.Lens.ATVAL_NamedPrism a -> DIE -> a-getAttrVal at prism die = getATVal die at prism $ uniqueAttr at die+---------- { Monad+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 -getMAttrVal :: DW_AT -> Dwarf.Lens.ATVAL_NamedPrism a -> DIE -> Maybe a-getMAttrVal at prism die =- getATVal die at prism <$> maybeAttr at die+liftDefCache :: StateT (Map DieID (Boxed DefType)) (ReaderT DIEMap (Writer [Warning])) a -> M a+liftDefCache = M -getName :: DIE -> String-getName = getAttrVal DW_AT_name Dwarf.Lens.aTVAL_STRING+askDIEMap :: M DIEMap+askDIEMap = M $ lift Reader.ask -getMName :: DIE -> Maybe String-getMName = getMAttrVal DW_AT_name Dwarf.Lens.aTVAL_STRING+tellWarning :: Warning -> M ()+tellWarning warn = M . lift . lift $ Writer.tell [warn] ----------- Monad-newtype M a = M (StateT (Map DieID (Boxed Def)) (Reader DIEMap) a)- deriving (Functor, Applicative, Monad, MonadFix)-runM :: DIEMap -> M a -> a-runM dieMap (M act) = runReader (evalStateT act Map.empty) dieMap+runAttrGetterT :: DIE -> AttrGetterT M a -> M a+runAttrGetterT die act = do+ (res, allUnusedAttrs) <- AttrGetter.run die act -askDIEMap :: M DIEMap-askDIEMap = liftDefCache $ lift Reader.ask+ -- We don't care about the sibling attribute+ let unusedAttrs = filter ((/= DW_AT_sibling) . fst) allUnusedAttrs -liftDefCache :: StateT (Map DieID (Boxed Def)) (Reader DIEMap) a -> M a-liftDefCache = M----------- Monad+ when (not (null unusedAttrs)) .+ tellWarning $ Warning die unusedAttrs+ return res+---------- } Monad -cachedMake :: DieID -> M (Boxed Def) -> M (Boxed Def)+cachedMake :: DieID -> M (Boxed DefType) -> M (Boxed DefType) cachedMake i act = do found <- liftDefCache . State.gets $ Map.lookup i case found of@@ -98,25 +95,25 @@ liftDefCache . State.modify $ Map.insert i res act -parseAt :: DieID -> M (Boxed Def)+parseAt :: DieID -> M (Boxed DefType) parseAt i = cachedMake i $ do dieMap <- askDIEMap let die = Dwarf.dieRefsDIE $ dieMap Map.! i- parseDefI die+ parseDefTypeI die data Loc = LocOp Dwarf.DW_OP | LocUINT Word64 deriving (Eq, Ord, Show) ------------------- -data TypeRef = Void | TypeRef (Boxed Def)+data TypeRef = Void | TypeRef (Boxed DefType) deriving (Eq, Ord) instance Show TypeRef where show Void = "void" show (TypeRef _) = "(..type..)" -toTypeRef :: Maybe (Boxed Def) -> TypeRef+toTypeRef :: Maybe (Boxed DefType) -> TypeRef toTypeRef Nothing = Void toTypeRef (Just x) = TypeRef x @@ -133,29 +130,35 @@ where toList x = maybeToList $ fmap show x -getDecl :: DIE -> Decl-getDecl die =+getDecl :: (Monad m, Applicative m) => AttrGetterT m Decl+getDecl = Decl- (get DW_AT_decl_file)- (fromIntegral <$> get DW_AT_decl_line)- (fromIntegral <$> get DW_AT_decl_column)+ <$> getUINT DW_AT_decl_file+ <*> (fmap fromIntegral <$> getUINT DW_AT_decl_line)+ <*> (fmap fromIntegral <$> getUINT DW_AT_decl_column) where- get at = getMAttrVal at Dwarf.Lens.aTVAL_UINT die+ getUINT = (`AttrGetter.findAttr` _ATVAL_UINT) -getByteSize :: DIE -> Word-getByteSize = fromIntegral . getAttrVal DW_AT_byte_size Dwarf.Lens.aTVAL_UINT+getByteSize :: (Monad m, Applicative m) => AttrGetterT m Word+getByteSize = fromIntegral <$> AttrGetter.getAttr DW_AT_byte_size _ATVAL_UINT -getMByteSize :: DIE -> Maybe Word-getMByteSize = fmap fromIntegral . getMAttrVal DW_AT_byte_size Dwarf.Lens.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)+ } deriving (Eq, Ord, Show, Functor) -box :: DIE -> a -> Boxed a-box = Boxed . dieId+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+ -- DW_AT_byte_size=(DW_ATVAL_UINT 4) -- DW_AT_encoding=(DW_ATVAL_UINT 7) -- DW_AT_name=(DW_ATVAL_STRING "long unsigned int")@@ -165,13 +168,12 @@ , btName :: Maybe String } deriving (Eq, Ord, Show) -parseBaseType :: DIE -> M BaseType-parseBaseType die =- pure $+parseBaseType :: (Monad m, Applicative m) => AttrGetterT m BaseType+parseBaseType = BaseType- (getByteSize die)- (Dwarf.dw_ate (getAttrVal DW_AT_encoding Dwarf.Lens.aTVAL_UINT die))- (getMName die)+ <$> getByteSize+ <*> (Dwarf.dw_ate <$> AttrGetter.getAttr DW_AT_encoding _ATVAL_UINT)+ <*> getMName -- DW_AT_name=(DW_ATVAL_STRING "ptrdiff_t") -- DW_AT_decl_file=(DW_ATVAL_UINT 3)@@ -186,14 +188,14 @@ instance Show Typedef where show (Typedef name decl _) = "Typedef " ++ show name ++ "@(" ++ show decl ++ ") = .." -parseTypeRef :: DIE -> M TypeRef-parseTypeRef die =- fmap toTypeRef . traverse parseAt $ getMAttrVal DW_AT_type Dwarf.Lens.aTVAL_REF die+parseTypeRef :: AttrGetterT M TypeRef+parseTypeRef =+ lift . fmap toTypeRef . traverse parseAt =<<+ AttrGetter.findAttr DW_AT_type _ATVAL_REF -parseTypedef :: DIE -> M Typedef-parseTypedef die =- Typedef (getName die) (getDecl die) <$>- parseTypeRef die+parseTypedef :: AttrGetterT M Typedef+parseTypedef =+ Typedef <$> getName <*> getDecl <*> parseTypeRef data PtrType = PtrType { ptType :: TypeRef@@ -203,21 +205,28 @@ instance Show PtrType where show (PtrType t _) = "Ptr to " ++ show t -parsePtrType :: DIE -> M PtrType-parsePtrType die =+parsePtrType :: AttrGetterT M PtrType+parsePtrType = PtrType- <$> parseTypeRef die- <*> pure (getByteSize die)+ <$> parseTypeRef+ <*> getByteSize -- DW_AT_type=(DW_ATVAL_REF (DieID 104)) data ConstType = ConstType { ctType :: TypeRef } deriving (Eq, Ord, Show) -parseConstType :: DIE -> M ConstType-parseConstType die =- ConstType <$> parseTypeRef die+parseConstType :: AttrGetterT M ConstType+parseConstType = ConstType <$> parseTypeRef +-- See ConstType+data VolatileType = VolatileType+ { vtType :: TypeRef+ } deriving (Eq, Ord, Show)++parseVolatileType :: AttrGetterT M VolatileType+parseVolatileType = VolatileType <$> parseTypeRef+ -- DW_AT_name=(DW_ATVAL_STRING "__val") -- DW_AT_decl_file=(DW_ATVAL_UINT 4) -- DW_AT_decl_line=(DW_ATVAL_UINT 144)@@ -230,12 +239,10 @@ , membType :: TypeRef } deriving (Eq, Ord, Show) -parseMember :: (DIE -> loc) -> DIE -> M (Boxed (Member loc))+parseMember :: (Dwarf.Reader -> AttrGetterT M loc) -> DIE -> M (Boxed (Member loc)) parseMember getLoc die =- box die <$>- verifyTag DW_TAG_member die .- Member (getMName die) (getDecl die) (getLoc die) <$>- parseTypeRef die+ box DW_TAG_member die $+ Member <$> getMName <*> getDecl <*> getLoc (dieReader die) <*> parseTypeRef -- DW_AT_name=(DW_ATVAL_STRING "__pthread_mutex_s") -- DW_AT_byte_size=(DW_ATVAL_UINT 24)@@ -249,45 +256,46 @@ , stMembers :: [Boxed (Member Dwarf.DW_OP)] } deriving (Eq, Ord, Show) -parseStructureType :: DIE -> M StructureType-parseStructureType die =- StructureType (getMName die) (getMByteSize die) (getDecl die)- (fromMaybe False (getMAttrVal DW_AT_declaration Dwarf.Lens.aTVAL_BOOL die))- <$> mapM (parseMember getLoc) (dieChildren die)+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 memb =- Dwarf.parseDW_OP (dieReader memb) $- getAttrVal DW_AT_data_member_location Dwarf.Lens.aTVAL_BLOB memb+ getLoc reader =+ Dwarf.parseDW_OP reader <$>+ AttrGetter.getAttr DW_AT_data_member_location _ATVAL_BLOB -- TODO: Parse the member_location, It's a blob with a DWARF program.. -- DW_AT_type=(DW_ATVAL_REF (DieID 101)) -- DW_AT_upper_bound=(DW_ATVAL_UINT 1) data SubrangeType = SubrangeType- { subRangeUpperBound :: Word+ { subRangeUpperBound :: Maybe Word , subRangeType :: TypeRef } deriving (Eq, Ord, Show) parseSubrangeType :: DIE -> M (Boxed SubrangeType) parseSubrangeType die =- box die <$>- verifyTag DW_TAG_subrange_type die .+ box DW_TAG_subrange_type die $ SubrangeType- (fromIntegral (getAttrVal DW_AT_upper_bound Dwarf.Lens.aTVAL_UINT die))- <$> parseTypeRef die+ <$> (fmap fromIntegral <$> AttrGetter.findAttr DW_AT_upper_bound _ATVAL_UINT)+ <*> parseTypeRef -- DW_AT_type=(DW_ATVAL_REF (DieID 62)) data ArrayType = ArrayType- { atSubrangeType :: Boxed SubrangeType+ { atSubrangeType :: [Boxed SubrangeType] , atType :: TypeRef } deriving (Eq, Ord, Show) -parseArrayType :: DIE -> M ArrayType-parseArrayType die =- ArrayType <$> parseSubrangeType child <*> parseTypeRef die- where- child = case dieChildren die of- [x] -> x- cs -> error $ "Array must have exactly one child, not: " ++ show cs+parseArrayType :: [DIE] -> AttrGetterT M ArrayType+parseArrayType cs =+ ArrayType <$> lift (mapM parseSubrangeType cs) <*> parseTypeRef ---------------- @@ -298,15 +306,20 @@ { unionName :: Maybe String , unionByteSize :: Word , unionDecl :: Decl- , unionMembers :: [Boxed (Member (Maybe DW_ATVAL))]+ , unionMembers :: [Boxed (Member (Maybe Dwarf.DW_OP))] } deriving (Eq, Ord, Show) -parseUnionType :: DIE -> M UnionType-parseUnionType die =- UnionType (getMName die) (getByteSize die) (getDecl die)- <$> mapM (parseMember getLoc) (dieChildren die)+parseUnionType :: [DIE] -> AttrGetterT M UnionType+parseUnionType children =+ UnionType+ <$> getMName+ <*> getByteSize+ <*> getDecl+ <*> mapM (lift . parseMember getLoc) children where- getLoc = maybeAttr DW_AT_data_member_location+ getLoc reader =+ fmap (Dwarf.parseDW_OP reader) <$>+ AttrGetter.findAttr DW_AT_data_member_location _ATVAL_BLOB -- DW_AT_name=(DW_ATVAL_STRING "_SC_ARG_MAX") -- DW_AT_const_value=(DW_ATVAL_INT 0)@@ -317,10 +330,10 @@ parseEnumerator :: DIE -> M (Boxed Enumerator) parseEnumerator die =- pure . box die . verifyTag DW_TAG_enumerator die $+ box DW_TAG_enumerator die $ Enumerator- (getName die)- (getAttrVal DW_AT_const_value Dwarf.Lens.aTVAL_INT die)+ <$> getName+ <*> AttrGetter.getAttr DW_AT_const_value _ATVAL_INT -- DW_AT_byte_size=(DW_ATVAL_UINT 4) -- DW_AT_decl_file=(DW_ATVAL_UINT 11)@@ -332,22 +345,38 @@ , enumEnumerators :: [Boxed Enumerator] } deriving (Eq, Ord, Show) -parseEnumerationType :: DIE -> M EnumerationType-parseEnumerationType die =- EnumerationType (getMName die) (getDecl die) (getByteSize die)- <$> mapM parseEnumerator (dieChildren die)+parseEnumerationType :: [DIE] -> AttrGetterT M EnumerationType+parseEnumerationType children =+ EnumerationType+ <$> getMName+ <*> getDecl+ <*> getByteSize+ <*> mapM (lift . parseEnumerator) children -- DW_AT_type=(DW_ATVAL_REF (DieID 119)) 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 die <$>- verifyTag DW_TAG_formal_parameter die .- FormalParameter (getMName die) <$> parseTypeRef die+ box DW_TAG_formal_parameter die $+ FormalParameter+ <$> getMName+ <*> getDecl+ <*> (fmap (parseLoc (dieReader die)) <$> AttrGetter.findAttrVal DW_AT_location)+ <*> parseTypeRef -- DW_AT_prototyped=(DW_ATVAL_BOOL True) -- DW_AT_type=(DW_ATVAL_REF (DieID 62))@@ -357,24 +386,49 @@ , subrFormalParameters :: [Boxed FormalParameter] } deriving (Eq, Ord, Show) -getPrototyped :: DIE -> Bool-getPrototyped = fromMaybe False . getMAttrVal DW_AT_prototyped Dwarf.Lens.aTVAL_BOOL+getPrototyped :: AttrGetterT M Bool+getPrototyped = fromMaybe False <$> AttrGetter.findAttr DW_AT_prototyped _ATVAL_BOOL -parseSubroutineType :: DIE -> M SubroutineType-parseSubroutineType die =- SubroutineType (getPrototyped die)- <$> parseTypeRef die- <*> mapM parseFormalParameter (dieChildren die)+parseSubroutineType :: [DIE] -> AttrGetterT M SubroutineType+parseSubroutineType children =+ SubroutineType+ <$> getPrototyped+ <*> parseTypeRef+ <*> mapM (lift . parseFormalParameter) children -getLowPC :: DIE -> Word64-getLowPC = getAttrVal DW_AT_low_pc Dwarf.Lens.aTVAL_UINT+getLowPC :: AttrGetterT M Word64+getLowPC = AttrGetter.getAttr DW_AT_low_pc _ATVAL_UINT -getMLowPC :: DIE -> Maybe Word64-getMLowPC = getMAttrVal DW_AT_low_pc Dwarf.Lens.aTVAL_UINT+getMLowPC :: AttrGetterT M (Maybe Word64)+getMLowPC = AttrGetter.findAttr DW_AT_low_pc _ATVAL_UINT -getMHighPC :: DIE -> Maybe Word64-getMHighPC = getMAttrVal DW_AT_high_pc Dwarf.Lens.aTVAL_UINT+getMHighPC :: AttrGetterT M (Maybe Word64)+getMHighPC = AttrGetter.findAttr DW_AT_high_pc _ATVAL_UINT +-- DW_AT_name=(DW_ATVAL_STRING "sfs")+-- DW_AT_decl_file=(DW_ATVAL_UINT 1)+-- DW_AT_decl_line=(DW_ATVAL_UINT 135)+-- DW_AT_type=(DW_ATVAL_REF (DieID 2639))+-- DW_AT_location=(DW_ATVAL_BLOB "\145\168\DEL")+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+ -- DW_AT_name=(DW_ATVAL_STRING "selinux_enabled_check") -- DW_AT_decl_file=(DW_ATVAL_UINT 1) -- DW_AT_decl_line=(DW_ATVAL_UINT 133)@@ -387,6 +441,7 @@ { subprogName :: String , subprogDecl :: Decl , subprogPrototyped :: Bool+ , subprogExternal :: Bool , subprogLowPC :: Maybe Word64 , subprogHighPC :: Maybe Word64 , subprogFrameBase :: Maybe Loc@@ -403,16 +458,28 @@ | SubprogramChildUnspecifiedParameters deriving (Eq) -parseSubprogram :: DIE -> M Subprogram-parseSubprogram die = do- children <- mapM parseChild (dieChildren die)- Subprogram (getName die) (getDecl die) (getPrototyped die)- (getMLowPC die) (getMHighPC die)- (parseLoc die <$> maybeAttr DW_AT_frame_base die)- [x | SubprogramChildFormalParameter x <- children]- (SubprogramChildUnspecifiedParameters `elem` children)- [x | SubprogramChildVariable x <- children]- <$> parseTypeRef die+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@@ -420,76 +487,67 @@ SubprogramChildFormalParameter <$> parseFormalParameter child DW_TAG_lexical_block -> pure SubprogramChildIgnored -- TODO: Parse content? DW_TAG_label -> pure SubprogramChildIgnored- DW_TAG_variable -> SubprogramChildVariable . box child <$> parseVariable getMName child+ DW_TAG_variable ->+ noChildren child $+ SubprogramChildVariable <$> mkBox child (parseVariable reader getMName) DW_TAG_inlined_subroutine -> pure SubprogramChildIgnored DW_TAG_user 137 -> pure SubprogramChildIgnored -- GNU extensions, safe to ignore here DW_TAG_unspecified_parameters -> pure SubprogramChildUnspecifiedParameters- tag -> error $ "unsupported child tag for subprogram: " ++ show tag ++ " in: " ++ show die---- DW_AT_name=(DW_ATVAL_STRING "sfs")--- DW_AT_decl_file=(DW_ATVAL_UINT 1)--- DW_AT_decl_line=(DW_ATVAL_UINT 135)--- DW_AT_type=(DW_ATVAL_REF (DieID 2639))--- DW_AT_location=(DW_ATVAL_BLOB "\145\168\DEL")-data Variable name = Variable- { varName :: name- , varDecl :: Decl- , varLoc :: Maybe Loc- , varType :: TypeRef- } deriving (Eq, Ord, Show)--parseVariable :: (DIE -> a) -> DIE -> M (Variable a)-parseVariable getVarName die =- Variable (getVarName die) (getDecl die)- (parseLoc die <$> maybeAttr DW_AT_location die) <$>- parseTypeRef die- where--parseLoc :: DIE -> DW_ATVAL -> Loc-parseLoc die (DW_ATVAL_BLOB blob) = LocOp $ Dwarf.parseDW_OP (dieReader die) blob-parseLoc _ (DW_ATVAL_UINT uint) = LocUINT uint-parseLoc _ other =- error $- "Expected DW_ATVAL_BLOB or DW_ATVAL_UINT for DW_AT_location field of variable, got: " ++- show other+ DW_TAG_structure_type -> pure SubprogramChildIgnored+ DW_TAG_union_type -> pure SubprogramChildIgnored+ _ -> error $ "unsupported child tag in child: " ++ show child -data Def+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) -noChildren :: DIE -> DIE-noChildren die@DIE{dieChildren=[]} = die-noChildren die@DIE{dieChildren=cs} = error $ "Unexpected children: " ++ show cs ++ " in " ++ show die+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 =- box die <$> case dieTag die of- DW_TAG_base_type -> fmap DefBaseType . parseBaseType $ noChildren die- DW_TAG_typedef -> fmap DefTypedef . parseTypedef $ noChildren die- DW_TAG_pointer_type -> fmap DefPtrType . parsePtrType $ noChildren die- DW_TAG_const_type -> fmap DefConstType . parseConstType $ noChildren die- DW_TAG_structure_type -> fmap DefStructureType $ parseStructureType die- DW_TAG_array_type -> fmap DefArrayType $ parseArrayType die- DW_TAG_union_type -> fmap DefUnionType $ parseUnionType die- DW_TAG_enumeration_type -> fmap DefEnumerationType $ parseEnumerationType die- DW_TAG_subroutine_type -> fmap DefSubroutineType $ parseSubroutineType die- DW_TAG_subprogram -> fmap DefSubprogram $ parseSubprogram die- DW_TAG_variable -> fmap DefVariable $ parseVariable getName die- _ -> error $ "unsupported: " ++ show die+ 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 = cachedMake (dieId die) $ parseDefI die+parseDef die = parseDefI die -- DW_AT_producer=(DW_ATVAL_STRING "GNU C 4.4.5") -- DW_AT_language=(DW_ATVAL_UINT 1)@@ -505,20 +563,32 @@ , cuCompDir :: String , cuLowPc :: Word64 , cuHighPc :: Maybe Word64+ , cuStmtList :: Word64 -- TODO: Parse this further -- , cuLineNumInfo :: ([String], [Dwarf.DW_LNE]) , cuDefs :: [Boxed Def] } deriving (Show) -parseCU :: DIEMap -> DIE -> Boxed CompilationUnit+parseCU :: DIEMap -> DIE -> Writer [Warning] (Boxed CompilationUnit) parseCU dieMap die =- runM dieMap $- box die .- verifyTag DW_TAG_compile_unit die .+ runM dieMap .+ box DW_TAG_compile_unit die $ CompilationUnit- (getAttrVal DW_AT_producer Dwarf.Lens.aTVAL_STRING die)- (Dwarf.dw_lang (getAttrVal DW_AT_language Dwarf.Lens.aTVAL_UINT die))- (getName die)- (getAttrVal DW_AT_comp_dir Dwarf.Lens.aTVAL_STRING die)- (getLowPC die) (getMHighPC die)+ <$> 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 -- lineNumInfo- <$> mapM parseDef (dieChildren die)+ <*> 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
src/Data/Dwarf/ADT/Pretty.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}-module Data.Dwarf.ADT.Pretty (compilationUnit) where+module Data.Dwarf.ADT.Pretty (compilationUnit, dwarf) where import Data.Dwarf (DW_ATE(..))-import Data.Dwarf.ADT (Boxed(..), Def(..))+import Data.Dwarf.ADT (Boxed(..), Def(..), DefType(..)) import Data.Maybe (mapMaybe) import Text.PrettyPrint ((<>)) import qualified Data.Dwarf.ADT as ADT@@ -39,11 +39,14 @@ withName prefix Nothing = prefix withName prefix (Just name) = prefix <> " " <> PP.text name +indent :: PP.Doc -> PP.Doc+indent x = " " <> x+ compositeMembers :: PP.Doc -> Maybe String -> [Boxed (ADT.Member a)] -> PP.Doc compositeMembers prefix mName members = PP.vcat [ withName prefix mName <> " {"- , " " <> PP.vcat (map memberPP members)+ , indent $ PP.vcat (map memberPP members) , "}" ] where@@ -69,7 +72,7 @@ } = PP.vcat [ withName "enum" mName <> " {"- , " " <> PP.vcat (map enumeratorPP enumerators)+ , indent $ PP.vcat (map enumeratorPP enumerators) , "}" ] where@@ -107,7 +110,7 @@ innerPrecedence = onPrecedence outerPrecedence annotate onPrecedence f (btn, decl) = (btn, addAnnotation onPrecedence f decl) mkBaseType name = (name, const ($ ""))- subRange ADT.SubrangeType { ADT.subRangeUpperBound = u } = "[" <> showPP u <> "]"+ subRange ADT.SubrangeType { ADT.subRangeUpperBound = u } = "[" <> maybe "" showPP u <> "]" simplePrecedence = const . Just recurseType ADT.Void = mkBaseType "void" recurseType (ADT.TypeRef Boxed { bData = typ }) =@@ -131,12 +134,16 @@ annotate (simplePrecedence Prefix) ("*" <>) $ recurseType t DefConstType ADT.ConstType { ADT.ctType = t } -> annotate id ("const " <>) $ recurseType t- DefArrayType ADT.ArrayType { ADT.atType = t, ADT.atSubrangeType = r } ->+ DefVolatileType ADT.VolatileType { ADT.vtType = t } ->+ annotate id ("volatile " <>) $ recurseType t+ DefArrayType ADT.ArrayType { ADT.atType = t, ADT.atSubrangeType = [r] } -> annotate (simplePrecedence Postfix) (<> subRange (bData r)) $ recurseType t+ DefArrayType ADT.ArrayType { ADT.atType = t, ADT.atSubrangeType = r } ->+ annotate (simplePrecedence Postfix) (<> PP.parens+ (PP.hcat $ PP.punctuate PP.comma (map (subRange . bData) r))) $ recurseType t DefSubroutineType ADT.SubroutineType { ADT.subrRetType = t, ADT.subrFormalParameters = params } -> annotate (simplePrecedence Postfix) (<> paramList params) $ recurseType t- _ -> error "Type contains non-types" defTypedef :: ADT.Typedef -> PP.Doc defTypedef (ADT.Typedef name _ typeRef) = "typedef " <> ppType (Just name) typeRef@@ -169,32 +176,43 @@ defVariable f ADT.Variable { ADT.varName = name, ADT.varType = typeRef } = ppType (f name) typeRef -def :: Boxed Def -> Maybe PP.Doc-def Boxed { bDieId = i, bData = d } = fmap ((showPP i <> " " <>) . (<> ";")) $- case d of+defType :: DefType -> Maybe PP.Doc+defType t = case t of DefBaseType _ -> Nothing DefPtrType _ -> Nothing DefConstType _ -> Nothing+ DefVolatileType _ -> Nothing DefArrayType _ -> Nothing DefSubroutineType _ -> Nothing DefTypedef x -> Just $ "Typedef: " <> defTypedef x DefStructureType x -> Just $ "StructureType: " <> defStructureType x DefUnionType x -> Just $ "UnionType: " <> defUnionType x DefEnumerationType x -> Just $ "EnumerationType: " <> defEnumerationType x++def :: Boxed Def -> Maybe PP.Doc+def Boxed { bDieId = i, bData = d } = fmap ((showPP i <> " " <>) . (<> ";")) $+ case d of+ DefType t -> defType t DefSubprogram x -> Just $ "Subprogram: " <> defSubprogram x DefVariable x -> Just $ "Variable: " <> defVariable Just x compilationUnit :: Boxed ADT.CompilationUnit -> PP.Doc compilationUnit- Boxed { bData = ADT.CompilationUnit producer language name compDir lowPc highPc defs }+ (Boxed i (ADT.CompilationUnit producer language name compDir lowPc highPc _stmtList defs)) = PP.vcat- [ "producer = " <> showPP producer- , "language = " <> showPP language- , "name = " <> showPP name- , "compDir = " <> showPP compDir- , "lowPc = " <> showPP lowPc- , "highPc = " <> showPP highPc- , "defs = "- , " " <> PP.vcat (mapMaybe def defs)- , ""+ [ "Compilation unit at " <> showPP i+ , indent $ PP.vcat+ [ "producer = " <> showPP producer+ , "language = " <> showPP language+ , "name = " <> showPP name+ , "compDir = " <> showPP compDir+ , "lowPc = " <> showPP lowPc+ , "highPc = " <> showPP highPc+ , "defs = "+ , " " <> PP.vcat (mapMaybe def defs)+ ] ]++dwarf :: ADT.Dwarf -> PP.Doc+dwarf (ADT.Dwarf compilationUnits) =+ PP.vcat $ map compilationUnit compilationUnits
+ src/Data/Dwarf/AttrGetter.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Dwarf.AttrGetter+ ( AttrGetterT, run+ , findAttrVals, findAttrVal+ , findAttrs, findAttr+ , getAttr+ ) where++import Control.Applicative (Applicative(..), (<$>))+import Control.Lens ((^?))+import Control.Monad (liftM)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.State (StateT(..))+import Data.Dwarf (DIE(..), DW_AT, DW_ATVAL)+import Data.List (partition)+import Data.Maybe (fromMaybe)+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State as State+import qualified Data.Dwarf.Lens as DwarfLens++newtype AttrGetterT m a = AttrGetterT (ReaderT String (StateT [(DW_AT, DW_ATVAL)] m) a)+ deriving (Functor, Applicative, Monad)++instance MonadTrans AttrGetterT where+ lift = AttrGetterT . lift . lift++run :: DIE -> AttrGetterT m a -> m (a, [(DW_AT, DW_ATVAL)])+run die (AttrGetterT act) =+ (`runStateT` dieAttributes die) .+ (`runReaderT` (" in " ++ show die)) $+ act++getSuffix :: Monad m => AttrGetterT m String+getSuffix = AttrGetterT Reader.ask++findAttrVals :: Monad m => DW_AT -> AttrGetterT m [DW_ATVAL]+findAttrVals at = AttrGetterT . lift $ do+ (matches, mismatches) <- State.gets $ partition ((== at) . fst)+ State.put mismatches+ return $ snd <$> matches++findAttrVal :: Monad m => DW_AT -> AttrGetterT m (Maybe DW_ATVAL)+findAttrVal at = AttrGetterT . lift $ do+ (unmatched, rest) <- State.gets $ break ((at ==) . fst)+ case rest of+ (_, val) : afterMatch -> do+ State.put (unmatched ++ afterMatch)+ return $ Just val+ _ -> return Nothing++getATVal :: String -> String -> DwarfLens.ATVAL_NamedPrism a -> DW_ATVAL -> a+getATVal prefix suffix (typName, typ) atval =+ fromMaybe (error msg) $ atval ^? typ+ where+ msg = concat [prefix, " is: ", show atval, " but expected: ", typName, suffix]++toVal ::+ (Monad m, Functor f, Show a) =>+ (a -> AttrGetterT m (f DW_ATVAL)) ->+ a -> DwarfLens.ATVAL_NamedPrism b -> AttrGetterT m (f b)+toVal finder at prism = do+ suffix <- getSuffix+ (liftM . fmap) (getATVal (show at) suffix prism) $ finder at++findAttrs :: Monad m => DW_AT -> DwarfLens.ATVAL_NamedPrism a -> AttrGetterT m [a]+findAttrs = toVal findAttrVals++findAttr :: Monad m => DW_AT -> DwarfLens.ATVAL_NamedPrism a -> AttrGetterT m (Maybe a)+findAttr = toVal findAttrVal++getAttr :: Monad m => DW_AT -> DwarfLens.ATVAL_NamedPrism a -> AttrGetterT m a+getAttr at prism = do+ suffix <- getSuffix+ (liftM . fromMaybe . error) ("Could not find " ++ show at ++ suffix) $+ findAttr at prism
src/Data/Dwarf/Elf.hs view
@@ -5,7 +5,7 @@ ) where import Control.Applicative (Applicative(..), (<$>))-import Data.Dwarf.ADT (Boxed, CompilationUnit)+import Data.Dwarf.ADT (Dwarf) import Data.Elf (parseElf, Elf(..), ElfSection(..)) import Data.List (find) import System.IO.Posix.MMap (unsafeMMapFile)@@ -32,7 +32,7 @@ <*> get ".debug_str" pure (elf, Dwarf.parseInfo endianess sections) -parseElfDwarfADT :: Dwarf.Endianess -> FilePath -> IO [Boxed CompilationUnit]+parseElfDwarfADT :: Dwarf.Endianess -> FilePath -> IO (Dwarf, [Dwarf.ADT.Warning]) parseElfDwarfADT endianess filename = do (_elf, (cuDies, dieMap)) <- loadElfDwarf endianess filename- pure $ map (Dwarf.ADT.parseCU dieMap) cuDies+ pure $ Dwarf.ADT.fromDies dieMap cuDies
src/Data/Dwarf/Lens.hs view
@@ -1,49 +1,42 @@ {-# LANGUAGE TemplateHaskell #-} module Data.Dwarf.Lens- ( dW_ATVAL_INT, aTVAL_INT- , dW_ATVAL_UINT, aTVAL_UINT- , dW_ATVAL_REF, aTVAL_REF- , dW_ATVAL_STRING, aTVAL_STRING- , dW_ATVAL_BLOB, aTVAL_BLOB- , dW_ATVAL_BOOL, aTVAL_BOOL- , getATVal, ATVAL_NamedPrism+ ( _DW_ATVAL_INT, _ATVAL_INT+ , _DW_ATVAL_UINT, _ATVAL_UINT+ , _DW_ATVAL_REF, _ATVAL_REF+ , _DW_ATVAL_STRING, _ATVAL_STRING+ , _DW_ATVAL_BLOB, _ATVAL_BLOB+ , _DW_ATVAL_BOOL, _ATVAL_BOOL+ , ATVAL_NamedPrism ) where -import Control.Lens (Getting, (^?))+import Control.Lens (Getting) import Control.Lens.TH (makePrisms) import Data.Dwarf (DieID, DW_ATVAL) import Data.Int (Int64)-import Data.Maybe (fromMaybe) import Data.Word (Word64) import qualified Data.ByteString as BS import qualified Data.Monoid as Monoid {-# ANN module "HLint: ignore Use camelCase" #-} -type ATVAL_NamedPrism a = (String, Getting (Monoid.First a) DW_ATVAL DW_ATVAL a a)+type ATVAL_NamedPrism a = (String, Getting (Monoid.First a) DW_ATVAL a) makePrisms ''DW_ATVAL -aTVAL_INT :: ATVAL_NamedPrism Int64-aTVAL_INT = ("ATVAL_INT", dW_ATVAL_INT)--aTVAL_UINT :: ATVAL_NamedPrism Word64-aTVAL_UINT = ("ATVAL_UINT", dW_ATVAL_UINT)+_ATVAL_INT :: ATVAL_NamedPrism Int64+_ATVAL_INT = ("ATVAL_INT", _DW_ATVAL_INT) -aTVAL_REF :: ATVAL_NamedPrism DieID-aTVAL_REF = ("ATVAL_REF", dW_ATVAL_REF)+_ATVAL_UINT :: ATVAL_NamedPrism Word64+_ATVAL_UINT = ("ATVAL_UINT", _DW_ATVAL_UINT) -aTVAL_STRING :: ATVAL_NamedPrism String-aTVAL_STRING = ("ATVAL_STRING", dW_ATVAL_STRING)+_ATVAL_REF :: ATVAL_NamedPrism DieID+_ATVAL_REF = ("ATVAL_REF", _DW_ATVAL_REF) -aTVAL_BLOB :: ATVAL_NamedPrism BS.ByteString-aTVAL_BLOB = ("ATVAL_BLOB", dW_ATVAL_BLOB)+_ATVAL_STRING :: ATVAL_NamedPrism String+_ATVAL_STRING = ("ATVAL_STRING", _DW_ATVAL_STRING) -aTVAL_BOOL :: ATVAL_NamedPrism Bool-aTVAL_BOOL = ("ATVAL_BOOL", dW_ATVAL_BOOL)+_ATVAL_BLOB :: ATVAL_NamedPrism BS.ByteString+_ATVAL_BLOB = ("ATVAL_BLOB", _DW_ATVAL_BLOB) -getATVal :: String -> ATVAL_NamedPrism a -> DW_ATVAL -> a-getATVal prefix (typName, typ) atval =- fromMaybe (error msg) $ atval ^? typ- where- msg = concat [prefix, " is: ", show atval, " but expected: ", typName]+_ATVAL_BOOL :: ATVAL_NamedPrism Bool+_ATVAL_BOOL = ("ATVAL_BOOL", _DW_ATVAL_BOOL)