dwarfadt 0.3.0.1 → 0.4

raw patch · 3 files changed

+221/−98 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• dwarfadt.cabal +1/−1
• src/Data/Dwarf/ADT.hs +189/−88
• src/Data/Dwarf/ADT/Pretty.hs +31/−9

@@ -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.

@@ -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)

@@ -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