diff --git a/dwarfadt.cabal b/dwarfadt.cabal --- a/dwarfadt.cabal +++ b/dwarfadt.cabal @@ -1,5 +1,5 @@ name: dwarfadt -version: 0.3.0.1 +version: 0.4 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. 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 @@ -12,18 +12,23 @@ , PtrType(..) , ConstType(..) , VolatileType(..) - , Member(..), StructureType(..), UnionType(..) + , FormalParameters(..) + , MemberLocation(..), Member(..), StructureType(..), UnionType(..) , SubrangeType(..), ArrayType(..) , EnumerationType(..), Enumerator(..) , SubroutineType(..), FormalParameter(..) , InlineType(..) - , Subprogram(..) + , InlinedSubroutine(..) + , LexicalBlock(..) + , SubprogramChild(..) + , Subprogram(..), subprogramDefs , Variable(..) ) where import Control.Applicative (Applicative(..), (<$>)) -import Control.Lens (_1) +import Control.Lens (Lens') import Control.Lens.Operators +import Control.Lens.Tuple import Control.Monad (when) import Control.Monad.Fix (MonadFix, mfix) import Control.Monad.Trans.Class (lift) @@ -32,7 +37,7 @@ 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.Dwarf.Lens (_ATVAL_INT, _ATVAL_UINT, _ATVAL_REF, _ATVAL_STRING, _ATVAL_BOOL) import Data.Int (Int64) import Data.List (intercalate) import Data.Map (Map) @@ -231,6 +236,11 @@ parseVolatileType :: AttrGetterT M VolatileType parseVolatileType = VolatileType <$> parseTypeRef +data MemberLocation + = MemberLocationConstant Word64 + | MemberLocationExpression Dwarf.DW_OP + deriving (Eq, Ord, Show) + -- DW_AT_name=(DW_ATVAL_STRING "__val") -- DW_AT_decl_file=(DW_ATVAL_UINT 4) -- DW_AT_decl_line=(DW_ATVAL_UINT 144) @@ -244,15 +254,15 @@ , membByteSize :: Maybe Word64 , membBitSize :: Maybe Word64 , membBitOffset :: Maybe Word64 - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Functor) parseMember :: (Dwarf.Reader -> AttrGetterT M loc) -> DIE -> M (Boxed (Member loc)) -parseMember getLoc die = +parseMember getMemberLocation die = box DW_TAG_member die $ Member <$> getMName <*> getDecl - <*> getLoc (dieReader die) + <*> getMemberLocation (dieReader die) <*> parseTypeRef <*> AttrGetter.findAttr DW_AT_byte_size _ATVAL_UINT <*> AttrGetter.findAttr DW_AT_bit_size _ATVAL_UINT @@ -267,12 +277,21 @@ , stByteSize :: Maybe Word -- Does not exist for forward-declarations , stDecl :: Decl , stIsDeclaration :: Bool -- is forward-declaration - , stMembers :: [Boxed (Member Dwarf.DW_OP)] + , stMembers :: [Boxed (Member MemberLocation)] } deriving (Eq, Ord, Show) flag :: DW_AT -> AttrGetterT M Bool flag atId = ((Just True ==) <$> AttrGetter.findAttr atId _ATVAL_BOOL) +parseMemberLocation :: Dwarf.Reader -> DW_ATVAL -> MemberLocation +parseMemberLocation reader attrVal = + case attrVal of + Dwarf.DW_ATVAL_BLOB opStr -> MemberLocationExpression $ Dwarf.parseDW_OP reader opStr + Dwarf.DW_ATVAL_UINT uint -> MemberLocationConstant uint + _ -> + -- TODO: Use function from AttrGetter to get better error + error $ "member location of unknown type: " ++ show attrVal + parseStructureType :: [DIE] -> AttrGetterT M StructureType parseStructureType children = StructureType @@ -280,12 +299,15 @@ <*> getMByteSize <*> getDecl <*> flag DW_AT_declaration - <*> mapM (lift . parseMember getLoc) children + <*> mapM (lift . parseMember getStructMemberLocation) children where - 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.. + getStructMemberLocation reader = do + mAttrVal <- AttrGetter.findAttrVal DW_AT_data_member_location + return $ case mAttrVal of + Nothing -> + -- TODO: Use function from AttrGetter to get better error + error "StructureType must have a member location" + Just attrVal -> parseMemberLocation reader attrVal -- DW_AT_type=(DW_ATVAL_REF (DieID 101)) -- DW_AT_upper_bound=(DW_ATVAL_UINT 1) @@ -320,7 +342,7 @@ { unionName :: Maybe String , unionByteSize :: Word , unionDecl :: Decl - , unionMembers :: [Boxed (Member (Maybe Dwarf.DW_OP))] + , unionMembers :: [Boxed (Member (Maybe MemberLocation))] } deriving (Eq, Ord, Show) parseUnionType :: [DIE] -> AttrGetterT M UnionType @@ -329,11 +351,11 @@ <$> getMName <*> getByteSize <*> getDecl - <*> mapM (lift . parseMember getLoc) children + <*> mapM (lift . parseMember getUnionMemberLocation) children where - getLoc reader = - fmap (Dwarf.parseDW_OP reader) <$> - AttrGetter.findAttr DW_AT_data_member_location _ATVAL_BLOB + getUnionMemberLocation reader = do + mAttr <- AttrGetter.findAttrVal DW_AT_data_member_location + return $ fmap (parseMemberLocation reader) mAttr -- DW_AT_name=(DW_ATVAL_STRING "_SC_ARG_MAX") -- DW_AT_const_value=(DW_ATVAL_INT 0) @@ -373,6 +395,7 @@ , formalParamDecl :: Decl , formalParamLocation :: Maybe Loc , formalParamType :: TypeRef + , formalParamConstVal :: Maybe Word64 } deriving (Eq, Ord, Show) parseLoc :: Dwarf.Reader -> DW_ATVAL -> Loc @@ -393,41 +416,65 @@ <*> getDecl <*> (fmap (parseLoc (dieReader die)) <$> AttrGetter.findAttrVal DW_AT_location) <*> parseTypeRef + <*> AttrGetter.findAttr DW_AT_const_value _ATVAL_UINT --- DW_AT_prototyped=(DW_ATVAL_BOOL True) --- DW_AT_type=(DW_ATVAL_REF (DieID 62)) +data FormalParameters = FormalParameters + { formalParameters :: [Boxed FormalParameter] + , formalParametersHasUnspecified :: Bool + } deriving (Eq, Ord, Show) + +formalParametersLens :: Lens' FormalParameters [Boxed FormalParameter] +formalParametersLens f (FormalParameters pars unspec) = (`FormalParameters` unspec) <$> f pars + +parseFormalParameters :: [DIE] -> M (FormalParameters, [DIE]) +parseFormalParameters = go + where + go dies = + case dies of + [] -> pure (FormalParameters [] False, []) + (die:rest) + | dieTag die == DW_TAG_unspecified_parameters -> pure (FormalParameters [] True, rest) + | dieTag die == DW_TAG_formal_parameter -> do + param <- parseFormalParameter die + go rest <&> _1 . formalParametersLens %~ (param :) + | otherwise -> go rest <&> _2 %~ (die:) + data SubroutineType = SubroutineType { subrPrototyped :: Bool , subrRetType :: TypeRef - -- TODO: Reduce duplication with subprogram formal params - , subrFormalParameters :: [Boxed FormalParameter] - , subrHaveUnspecified :: Bool + , subrFormalParameters :: FormalParameters } deriving (Eq, Ord, Show) +-- DW_AT_prototyped=(DW_ATVAL_BOOL True) +-- DW_AT_type=(DW_ATVAL_REF (DieID 62)) parseSubroutineType :: [DIE] -> AttrGetterT M SubroutineType parseSubroutineType children = do - (params, haveUnspecified) <- lift (parseParameters children) - SubroutineType - <$> flag DW_AT_prototyped - <*> parseTypeRef - <*> pure params - <*> pure haveUnspecified - where - parseParameters [] = pure ([], False) - parseParameters [die] | dieTag die == DW_TAG_unspecified_parameters = pure ([], True) - parseParameters (die:dies) = do - param <- parseFormalParameter die - parseParameters dies <&> _1 %~ (param :) + (params, extraChildren) <- lift $ parseFormalParameters children + case extraChildren of + [] -> + SubroutineType + <$> flag DW_AT_prototyped + <*> parseTypeRef + <*> pure params + _ -> fail $ "Unexpected children of SubroutineType: " ++ show extraChildren getLowPC :: AttrGetterT M Word64 getLowPC = AttrGetter.getAttr DW_AT_low_pc _ATVAL_UINT +getMRanges :: AttrGetterT M (Maybe Word64) +getMRanges = AttrGetter.findAttr DW_AT_ranges _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 +getMFrameBase :: Dwarf.Reader -> AttrGetterT M (Maybe Loc) +getMFrameBase reader = + fmap (parseLoc reader) <$> + AttrGetter.findAttrVal DW_AT_frame_base + data InlineType = InlineType { inlineRequested :: Bool , inlineHappened :: Bool @@ -460,88 +507,146 @@ , varConstVal :: Maybe Word64 } deriving (Eq, Ord, Show) -parseVariable :: Dwarf.Reader -> AttrGetterT M name -> AttrGetterT M (Variable name) -parseVariable reader getVarName = do - -- for now, ignore abstract origins - _ <- AttrGetter.findAttrVal DW_AT_abstract_origin - Variable - <$> getVarName - <*> getDecl - <*> (fmap (parseLoc reader) <$> AttrGetter.findAttrVal DW_AT_location) - <*> flag DW_AT_external - <*> flag DW_AT_declaration - <*> flag DW_AT_artificial - <*> parseTypeRef - <*> AttrGetter.findAttr DW_AT_const_value _ATVAL_UINT +noChildren :: DIE -> a -> a +noChildren DIE{dieChildren=[]} = id +noChildren die@DIE{dieChildren=cs} = error $ "Unexpected children: " ++ show cs ++ " in " ++ show die +-- TODO: Use Alternative/MonadPlus instance so that we can combine +-- parsers with <|> rather than test outside if it is DW_TAG_variable +-- and then rely on it here unsafely +parseVariable :: DIE -> AttrGetterT M name -> M (Boxed (Variable name)) +parseVariable die getVarName = + noChildren die $ mkBox die $ do + -- for now, ignore abstract origins + _ <- AttrGetter.findAttrVal DW_AT_abstract_origin + Variable + <$> getVarName + <*> getDecl + <*> (fmap (parseLoc (dieReader die)) <$> AttrGetter.findAttrVal DW_AT_location) + <*> flag DW_AT_external + <*> flag DW_AT_declaration + <*> flag DW_AT_artificial + <*> parseTypeRef + <*> AttrGetter.findAttr DW_AT_const_value _ATVAL_UINT + +data InlinedSubroutine = InlinedSubroutine + { inlinedSubroutineCallFile :: Maybe Word64 + , inlinedSubroutineCallLine :: Maybe Word64 + , inlinedSubroutineRanges :: Maybe Word64 + , inlinedSubroutineEntryPC :: Word64 + , inlinedSubroutineSubprogram :: Subprogram + } deriving (Eq, Ord, Show) + +parseInlinedSubroutine :: DIE -> M (Boxed InlinedSubroutine) +parseInlinedSubroutine die = + mkBox die $ InlinedSubroutine + <$> AttrGetter.findAttr DW_AT_call_file _ATVAL_UINT + <*> AttrGetter.findAttr DW_AT_call_line _ATVAL_UINT + <*> getMRanges + <*> AttrGetter.getAttr DW_AT_entry_pc _ATVAL_UINT + <*> parseSubprogram (dieReader die) (dieChildren die) + +data LexicalBlock = LexicalBlock + { lexicalBlockRanges :: Maybe Word64 + , lexicalBlockLowPC :: Maybe Word64 + , lexicalBlockHighPC :: Maybe Word64 + , lexicalBlockSubprogram :: Subprogram + } deriving (Eq, Ord, Show) + +parseLexicalBlock :: DIE -> M (Boxed LexicalBlock) +parseLexicalBlock die = + mkBox die $ LexicalBlock + <$> getMRanges + <*> getMLowPC + <*> getMHighPC + <*> parseSubprogram (dieReader die) (dieChildren die) + +data SubprogramChild + = SubprogramChildDef Def + | SubprogramChildLexicalBlock LexicalBlock -- TODO: Lexical blocks don't quite have everything a subprogram does + | SubprogramChildInlinedSubroutine InlinedSubroutine + | SubprogramChildLocalVariable (Variable (Maybe String)) + | SubprogramChildLabel -- TODO: Label content + | SubprogramChildOther DW_TAG + deriving (Eq, Ord, Show) + +subprogramChildDefs :: Boxed SubprogramChild -> [Boxed Def] +subprogramChildDefs (Boxed dId item) = + case item of + SubprogramChildDef def -> [Boxed dId def] + SubprogramChildLexicalBlock x -> subprogramDefs (lexicalBlockSubprogram x) + SubprogramChildInlinedSubroutine x -> subprogramDefs (inlinedSubroutineSubprogram x) + SubprogramChildLocalVariable _ -> [] + SubprogramChildLabel -> [] + SubprogramChildOther _ -> [] + data Subprogram = Subprogram { subprogName :: Maybe String -- abstract-origin subprograms are anonymous + , subprogType :: TypeRef + , subprogFormalParameters :: FormalParameters , 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 , subprogInline :: Maybe InlineType , subprogDeclaration :: Bool , subprogArtificial :: Bool , subprogLinkageName :: Maybe String + , subprogChildren :: [Boxed SubprogramChild] } 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 +subprogramDefs :: Subprogram -> [Boxed Def] +subprogramDefs = concatMap subprogramChildDefs . subprogChildren parseSubprogram :: Dwarf.Reader -> [DIE] -> AttrGetterT M Subprogram parseSubprogram reader children = do - parsedChildren <- mapM (lift . parseChild) children + (params, extraChildren) <- lift $ parseFormalParameters children -- for now, ignore abstract origins & GNU extended attr for now _ <- AttrGetter.findAttrVal $ DW_AT_user 0x2117 _ <- AttrGetter.findAttrVal $ DW_AT_user 0x2116 _ <- AttrGetter.findAttrVal DW_AT_abstract_origin Subprogram <$> getMName + <*> parseTypeRef + <*> pure params <*> getDecl <*> flag DW_AT_prototyped <*> flag DW_AT_external <*> 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 + <*> getMFrameBase reader <*> getInlineType <*> flag DW_AT_declaration <*> flag DW_AT_artificial <*> AttrGetter.findAttr DW_AT_linkage_name _ATVAL_STRING + <*> mapM (lift . parseChild) extraChildren where + fakeBox child = pure . Boxed (dieId child) parseChild child = case dieTag child of - DW_TAG_formal_parameter -> - SubprogramChildFormalParameter <$> parseFormalParameter child - DW_TAG_lexical_block -> pure SubprogramChildIgnored -- TODO: Parse content? - 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 -- GNU extensions, safe to ignore here - 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 + DW_TAG_formal_parameter -> error $ "BUG: formal_parameter not captured by parseFormalParameters: " ++ show child + DW_TAG_unspecified_parameters -> error $ "BUG: unspecified_parameters not captured by parseFormalParameters: " ++ show child + DW_TAG_lexical_block -> fmap SubprogramChildLexicalBlock <$> parseLexicalBlock child + DW_TAG_variable -> fmap SubprogramChildLocalVariable <$> parseVariable child getMName + DW_TAG_label -> fakeBox child $ SubprogramChildLabel + DW_TAG_inlined_subroutine -> fmap SubprogramChildInlinedSubroutine <$> parseInlinedSubroutine child + tag | tag `elem` + [ DW_TAG_base_type + , DW_TAG_typedef + , DW_TAG_pointer_type + , DW_TAG_const_type + , DW_TAG_volatile_type + , DW_TAG_structure_type + , DW_TAG_array_type + , DW_TAG_union_type + , DW_TAG_enumeration_type + , DW_TAG_subroutine_type + , DW_TAG_variable + , DW_TAG_subprogram + ] -> fmap SubprogramChildDef <$> parseDef child + _ -> fakeBox child $ SubprogramChildOther $ dieTag child -- GNU extensions, safe to ignore here data DefType = DefBaseType BaseType @@ -581,12 +686,8 @@ parseDef :: DIE -> M (Boxed Def) parseDef 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) + DW_TAG_variable -> fmap DefVariable <$> parseVariable die getName + DW_TAG_subprogram -> mkBox die $ DefSubprogram <$> parseSubprogram (dieReader die) (dieChildren die) _ -> (fmap . fmap) DefType . cachedMake (dieId die) $ @@ -623,7 +724,7 @@ <*> AttrGetter.getAttr DW_AT_comp_dir _ATVAL_STRING <*> getLowPC <*> getMHighPC - <*> AttrGetter.findAttr DW_AT_ranges _ATVAL_UINT + <*> getMRanges <*> AttrGetter.getAttr DW_AT_stmt_list _ATVAL_UINT -- lineNumInfo <*> mapM (lift . parseDef) (dieChildren die) 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,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Data.Dwarf.ADT.Pretty (compilationUnit, dwarf) where +import Control.Applicative ((<$>)) import Data.Dwarf (DW_ATE(..)) import Data.Dwarf.ADT (Boxed(..), Def(..), DefType(..)) import Data.Maybe (mapMaybe) @@ -85,8 +86,8 @@ data Precedence = Prefix | Postfix -paramList :: [Boxed ADT.FormalParameter] -> Bool -> PP.Doc -paramList params haveUnspecifiedParams = +paramList :: ADT.FormalParameters -> PP.Doc +paramList (ADT.FormalParameters params haveUnspecifiedParams) = "(" <> PP.hcat (List.intersperse ", " (map param params ++ ["..." | haveUnspecifiedParams])) <> ")" where param @@ -143,8 +144,8 @@ 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, ADT.subrHaveUnspecified = unspec } -> - annotate (simplePrecedence Postfix) (<> paramList params unspec) $ recurseType t + { ADT.subrRetType = t, ADT.subrFormalParameters = params } -> + annotate (simplePrecedence Postfix) (<> paramList params) $ recurseType t defTypedef :: ADT.Typedef -> PP.Doc defTypedef (ADT.Typedef name _ typeRef) = "typedef " <> ppType (Just name) typeRef @@ -158,6 +159,25 @@ defEnumerationType :: ADT.EnumerationType -> PP.Doc defEnumerationType = enumerationType +lexicalBlock :: ADT.LexicalBlock -> PP.Doc +lexicalBlock (ADT.LexicalBlock _ _ _ s) = + PP.text "lexical block " <> defSubprogram s + +inlinedSubroutine :: ADT.InlinedSubroutine -> PP.Doc +inlinedSubroutine (ADT.InlinedSubroutine _ _ _ _ s) = + PP.text "inlined " <> defSubprogram s + +subprogChild :: Boxed ADT.SubprogramChild -> Maybe PP.Doc +subprogChild (Boxed dId dat) = + (showPP dId <> " " <>) . (<> ";") <$> + case dat of + ADT.SubprogramChildDef x -> def (Boxed dId x) + ADT.SubprogramChildLexicalBlock x -> Just $ lexicalBlock x + ADT.SubprogramChildInlinedSubroutine x -> Just $ inlinedSubroutine x + ADT.SubprogramChildLabel -> Nothing + ADT.SubprogramChildLocalVariable _ -> Nothing + ADT.SubprogramChildOther _ -> Nothing + defSubprogram :: ADT.Subprogram -> PP.Doc defSubprogram ADT.Subprogram { ADT.subprogName = name @@ -165,12 +185,14 @@ , ADT.subprogFormalParameters = params , ADT.subprogLowPC = lowPC , ADT.subprogHighPC = highPC - , ADT.subprogUnspecifiedParameters = unspec + , ADT.subprogChildren = children } = - PP.hcat - [ ppType name typ, paramList params unspec - , " at (", m lowPC, ":", m highPC, ")" - ] + PP.vcat $ + [ PP.hcat + [ ppType name typ, paramList params + , " at (", m lowPC, ":", m highPC, ")" + ] + ] ++ mapMaybe subprogChild children where m = maybe "" showPP