diff --git a/dumpadt.hs b/dumpadt.hs --- a/dumpadt.hs +++ b/dumpadt.hs @@ -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 diff --git a/dwarfadt.cabal b/dwarfadt.cabal --- a/dwarfadt.cabal +++ b/dwarfadt.cabal @@ -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 diff --git a/src/Data/Dwarf/ADT.hs b/src/Data/Dwarf/ADT.hs --- a/src/Data/Dwarf/ADT.hs +++ b/src/Data/Dwarf/ADT.hs @@ -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 diff --git a/src/Data/Dwarf/ADT/Pretty.hs b/src/Data/Dwarf/ADT/Pretty.hs --- a/src/Data/Dwarf/ADT/Pretty.hs +++ b/src/Data/Dwarf/ADT/Pretty.hs @@ -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 diff --git a/src/Data/Dwarf/AttrGetter.hs b/src/Data/Dwarf/AttrGetter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Dwarf/AttrGetter.hs @@ -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 diff --git a/src/Data/Dwarf/Elf.hs b/src/Data/Dwarf/Elf.hs --- a/src/Data/Dwarf/Elf.hs +++ b/src/Data/Dwarf/Elf.hs @@ -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 diff --git a/src/Data/Dwarf/Lens.hs b/src/Data/Dwarf/Lens.hs --- a/src/Data/Dwarf/Lens.hs +++ b/src/Data/Dwarf/Lens.hs @@ -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)