packages feed

dwarfadt (empty) → 0.1.0.0

raw patch · 9 files changed

+912/−0 lines, 9 filesdep +TraceUtilsdep +basedep +bytestringsetup-changed

Dependencies added: TraceUtils, base, bytestring, bytestring-mmap, containers, dwarf-el, dwarfadt, elf, lens, pretty, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Eyal Lotem++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Eyal Lotem nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dumpadt.hs view
@@ -0,0 +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.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
+ dumpdwarf.hs view
@@ -0,0 +1,15 @@+module Main(main) where++import Data.Dwarf.Elf (loadElfDwarf)+import Data.Tree (Tree(..), drawTree)+import System.Environment (getArgs)+import qualified Data.Dwarf as Dwarf++dieTree :: Dwarf.DIE -> Tree Dwarf.DIE+dieTree die = Node die . map dieTree $ Dwarf.dieChildren die++main :: IO ()+main = do+  [filename] <- getArgs+  (_, (cuDies, _)) <- loadElfDwarf Dwarf.LittleEndian filename+  putStrLn . drawTree . fmap show . head $ map dieTree cuDies
+ dwarfadt.cabal view
@@ -0,0 +1,43 @@+name:                dwarfadt+version:             0.1.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.+                     .+                     This library intends to wrap dwarf and return a simple ADT representing+                     the DWARF information in a high-level way, easy to work with.+license:             BSD3+license-file:        LICENSE+author:              Eyal Lotem+maintainer:          eyal.lotem@gmail.com+-- copyright:+category:            Development+build-type:          Simple+cabal-version:       >=1.8++source-repository head+  type: git+  location: https://github.com/Peaker/dwarfadt.git++library+  hs-source-dirs:      src+  exposed-modules:     Data.Dwarf.Elf+                     , Data.Dwarf.ADT+                     , Data.Dwarf.ADT.Pretty+                     , 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 >=0.9, containers >= 0.3, transformers >= 0.3+                     , pretty >= 1.1+                     , TraceUtils+  ghc-options:         -Wall++executable dumpdwarf+  main-is:             dumpdwarf.hs+  build-depends:       base >= 4 && < 5, dwarfadt, dwarf-el, containers+  ghc-options:         -Wall++executable dumpadt+  main-is:             dumpadt.hs+  build-depends:       base >= 4 && < 5, dwarfadt, dwarf-el+  ghc-options:         -Wall
+ src/Data/Dwarf/ADT.hs view
@@ -0,0 +1,524 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.Dwarf.ADT+  ( parseCU+  , Boxed(..)+  , CompilationUnit(..)+  , Decl(..)+  , Def(..)+  , TypeRef(..)+  , BaseType(..)+  , Typedef(..)+  , PtrType(..)+  , ConstType(..)+  , Member(..), StructureType(..), UnionType(..)+  , SubrangeType(..), ArrayType(..)+  , EnumerationType(..), Enumerator(..)+  , SubroutineType(..), FormalParameter(..)+  , Subprogram(..)+  , Variable(..)+  ) where++-- TODO: Separate ADT for type definitions, sum that with+-- subprogram/variable to get a CompilationUnitDef++import Control.Applicative (Applicative(..), (<$>))+import Control.Monad.Fix (MonadFix, mfix)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (Reader, runReader)+import Control.Monad.Trans.State (StateT, evalStateT)+import Data.Dwarf (DieID, DIEMap, DIE(..), DW_TAG(..), DW_AT(..), DW_ATVAL(..), (!?))+import Data.Int (Int64)+import Data.List (intercalate)+import Data.Map (Map)+import Data.Maybe (fromMaybe, maybeToList)+import Data.Traversable (traverse)+import Data.Word (Word, Word64)+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State as State+import qualified Data.Dwarf as Dwarf+import qualified Data.Dwarf.Lens as Dwarf.Lens+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++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++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++getATVal :: DIE -> DW_AT -> Dwarf.Lens.ATVAL_NamedPrism a -> DW_ATVAL -> a+getATVal die at = Dwarf.Lens.getATVal ("attribute " ++ show at ++ " of " ++ show die)++getAttrVal :: DW_AT -> Dwarf.Lens.ATVAL_NamedPrism a -> DIE -> a+getAttrVal at prism die = getATVal die at prism $ uniqueAttr at die++getMAttrVal :: DW_AT -> Dwarf.Lens.ATVAL_NamedPrism a -> DIE -> Maybe a+getMAttrVal at prism die =+  getATVal die at prism <$> maybeAttr at die++getName :: DIE -> String+getName = getAttrVal DW_AT_name Dwarf.Lens.aTVAL_STRING++getMName :: DIE -> Maybe String+getMName = getMAttrVal DW_AT_name Dwarf.Lens.aTVAL_STRING++---------- 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++askDIEMap :: M DIEMap+askDIEMap = liftDefCache $ lift Reader.ask++liftDefCache :: StateT (Map DieID (Boxed Def)) (Reader DIEMap) a -> M a+liftDefCache = M+---------- Monad++cachedMake :: DieID -> M (Boxed Def) -> M (Boxed Def)+cachedMake i act = do+  found <- liftDefCache . State.gets $ Map.lookup i+  case found of+    Just res -> pure res+    Nothing -> mfix $ \res -> do+      liftDefCache . State.modify $ Map.insert i res+      act++parseAt :: DieID -> M (Boxed Def)+parseAt i = cachedMake i $ do+  dieMap <- askDIEMap+  let die = Dwarf.dieRefsDIE $ dieMap Map.! i+  parseDefI die++data Loc = LocOp Dwarf.DW_OP | LocUINT Word64+  deriving (Eq, Ord, Show)++-------------------++data TypeRef = Void | TypeRef (Boxed Def)+  deriving (Eq, Ord)++instance Show TypeRef where+  show Void = "void"+  show (TypeRef _) = "(..type..)"++toTypeRef :: Maybe (Boxed Def) -> TypeRef+toTypeRef Nothing = Void+toTypeRef (Just x) = TypeRef x++-------------------++data Decl = Decl+  { declFile :: Maybe Word64 -- TODO: Convert to FilePath with LNI+  , declLine :: Maybe Int+  , declColumn :: Maybe Int+  } deriving (Eq, Ord)++instance Show Decl where+  show (Decl f l c) = intercalate ":" $ fmap ("FN"++) (toList f) ++ toList l ++ toList c+    where+      toList x = maybeToList $ fmap show x++getDecl :: DIE -> Decl+getDecl die =+  Decl+  (get DW_AT_decl_file)+  (fromIntegral <$> get DW_AT_decl_line)+  (fromIntegral <$> get DW_AT_decl_column)+  where+    get at = getMAttrVal at Dwarf.Lens.aTVAL_UINT die++getByteSize :: DIE -> Word+getByteSize = fromIntegral . getAttrVal DW_AT_byte_size Dwarf.Lens.aTVAL_UINT++getMByteSize :: DIE -> Maybe Word+getMByteSize = fmap fromIntegral . getMAttrVal DW_AT_byte_size Dwarf.Lens.aTVAL_UINT++data Boxed a = Boxed+  { bDieId :: DieID+  , bData :: a+  } deriving (Eq, Ord, Show)++box :: DIE -> a -> Boxed a+box = Boxed . dieId++-- DW_AT_byte_size=(DW_ATVAL_UINT 4)+-- DW_AT_encoding=(DW_ATVAL_UINT 7)+-- DW_AT_name=(DW_ATVAL_STRING "long unsigned int")+data BaseType = BaseType+  { btByteSize :: Word+  , btEncoding :: Dwarf.DW_ATE+  , btName :: Maybe String+  } deriving (Eq, Ord, Show)++parseBaseType :: DIE -> M BaseType+parseBaseType die =+  pure $+  BaseType+  (getByteSize die)+  (Dwarf.dw_ate (getAttrVal DW_AT_encoding Dwarf.Lens.aTVAL_UINT die))+  (getMName die)++-- DW_AT_name=(DW_ATVAL_STRING "ptrdiff_t")+-- DW_AT_decl_file=(DW_ATVAL_UINT 3)+-- DW_AT_decl_line=(DW_ATVAL_UINT 149)+-- DW_AT_type=(DW_ATVAL_REF (DieID 62))}+data Typedef = Typedef+  { tdName :: String+  , tdDecl :: Decl+  , tdType :: TypeRef+  } deriving (Eq, Ord)++instance Show Typedef where+  show (Typedef name decl _) = "Typedef " ++ show name ++ "@(" ++ show decl ++ ") = .."++parseTypeRef :: DIE -> M TypeRef+parseTypeRef die =+  fmap toTypeRef . traverse parseAt $ getMAttrVal DW_AT_type Dwarf.Lens.aTVAL_REF die++parseTypedef :: DIE -> M Typedef+parseTypedef die =+  Typedef (getName die) (getDecl die) <$>+  parseTypeRef die++data PtrType = PtrType+  { ptType :: TypeRef+  , ptByteSize :: Word+  } deriving (Eq, Ord)++instance Show PtrType where+  show (PtrType t _) = "Ptr to " ++ show t++parsePtrType :: DIE -> M PtrType+parsePtrType die =+  PtrType+  <$> parseTypeRef die+  <*> pure (getByteSize die)++-- 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++-- DW_AT_name=(DW_ATVAL_STRING "__val")+-- DW_AT_decl_file=(DW_ATVAL_UINT 4)+-- DW_AT_decl_line=(DW_ATVAL_UINT 144)+-- DW_AT_type=(DW_ATVAL_REF (DieID 221))+-- DW_AT_data_member_location=(DW_ATVAL_BLOB "#\NUL")+data Member loc = Member+  { membName :: Maybe String+  , membDecl :: Decl+  , membLoc :: loc+  , membType :: TypeRef+  } deriving (Eq, Ord, Show)++parseMember :: (DIE -> 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++-- DW_AT_name=(DW_ATVAL_STRING "__pthread_mutex_s")+-- DW_AT_byte_size=(DW_ATVAL_UINT 24)+-- DW_AT_decl_file=(DW_ATVAL_UINT 6)+-- DW_AT_decl_line=(DW_ATVAL_UINT 79)+data StructureType = StructureType+  { stName :: Maybe String+  , stByteSize :: Maybe Word -- Does not exist for forward-declarations+  , stDecl :: Decl+  , stIsDeclaration :: Bool -- is forward-declaration+  , 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)+  where+    getLoc memb =+      Dwarf.parseDW_OP (dieReader memb) $+      getAttrVal DW_AT_data_member_location Dwarf.Lens.aTVAL_BLOB memb+  -- 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+  , subRangeType :: TypeRef+  } deriving (Eq, Ord, Show)++parseSubrangeType :: DIE -> M (Boxed SubrangeType)+parseSubrangeType die =+  box die <$>+  verifyTag DW_TAG_subrange_type die .+  SubrangeType+  (fromIntegral (getAttrVal DW_AT_upper_bound Dwarf.Lens.aTVAL_UINT die))+  <$> parseTypeRef die++-- DW_AT_type=(DW_ATVAL_REF (DieID 62))+data ArrayType = ArrayType+  { 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++----------------++-- DW_AT_byte_size=(DW_ATVAL_UINT 4)+-- DW_AT_decl_file=(DW_ATVAL_UINT 6)+-- DW_AT_decl_line=(DW_ATVAL_UINT 96)+data UnionType = UnionType+  { unionName :: Maybe String+  , unionByteSize :: Word+  , unionDecl :: Decl+  , unionMembers :: [Boxed (Member (Maybe DW_ATVAL))]+  } deriving (Eq, Ord, Show)++parseUnionType :: DIE -> M UnionType+parseUnionType die =+  UnionType (getMName die) (getByteSize die) (getDecl die)+  <$> mapM (parseMember getLoc) (dieChildren die)+  where+    getLoc = maybeAttr DW_AT_data_member_location++-- DW_AT_name=(DW_ATVAL_STRING "_SC_ARG_MAX")+-- DW_AT_const_value=(DW_ATVAL_INT 0)+data Enumerator = Enumerator+  { enumeratorName :: String+  , enumeratorConstValue :: Int64+  } deriving (Eq, Ord, Show)++parseEnumerator :: DIE -> M (Boxed Enumerator)+parseEnumerator die =+  pure . box die . verifyTag DW_TAG_enumerator die $+  Enumerator+  (getName die)+  (getAttrVal DW_AT_const_value Dwarf.Lens.aTVAL_INT die)++-- DW_AT_byte_size=(DW_ATVAL_UINT 4)+-- DW_AT_decl_file=(DW_ATVAL_UINT 11)+-- DW_AT_decl_line=(DW_ATVAL_UINT 74)+data EnumerationType = EnumerationType+  { enumName :: Maybe String+  , enumDecl :: Decl+  , enumByteSize :: Word+  , enumEnumerators :: [Boxed Enumerator]+  } deriving (Eq, Ord, Show)++parseEnumerationType :: DIE -> M EnumerationType+parseEnumerationType die =+  EnumerationType (getMName die) (getDecl die) (getByteSize die)+  <$> mapM parseEnumerator (dieChildren die)++-- DW_AT_type=(DW_ATVAL_REF (DieID 119))+data FormalParameter = FormalParameter+  { formalParamName :: Maybe String+  , formalParamType :: TypeRef+  } deriving (Eq, Ord, Show)++parseFormalParameter :: DIE -> M (Boxed FormalParameter)+parseFormalParameter die =+  box die <$>+  verifyTag DW_TAG_formal_parameter die .+  FormalParameter (getMName die) <$> parseTypeRef die++-- DW_AT_prototyped=(DW_ATVAL_BOOL True)+-- DW_AT_type=(DW_ATVAL_REF (DieID 62))+data SubroutineType = SubroutineType+  { subrPrototyped :: Bool+  , subrRetType :: TypeRef+  , subrFormalParameters :: [Boxed FormalParameter]+  } deriving (Eq, Ord, Show)++getPrototyped :: DIE -> Bool+getPrototyped = fromMaybe False . getMAttrVal DW_AT_prototyped Dwarf.Lens.aTVAL_BOOL++parseSubroutineType :: DIE -> M SubroutineType+parseSubroutineType die =+  SubroutineType (getPrototyped die)+  <$> parseTypeRef die+  <*> mapM parseFormalParameter (dieChildren die)++getLowPC :: DIE -> Word64+getLowPC = getAttrVal DW_AT_low_pc Dwarf.Lens.aTVAL_UINT++getMLowPC :: DIE -> Maybe Word64+getMLowPC = getMAttrVal DW_AT_low_pc Dwarf.Lens.aTVAL_UINT++getMHighPC :: DIE -> Maybe Word64+getMHighPC = getMAttrVal DW_AT_high_pc Dwarf.Lens.aTVAL_UINT++-- 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)+-- DW_AT_prototyped=(DW_ATVAL_BOOL True)+-- DW_AT_type=(DW_ATVAL_REF (DieID 62))+-- DW_AT_low_pc=(DW_ATVAL_UINT 135801260)+-- DW_AT_high_pc=(DW_ATVAL_UINT 135801563)+-- DW_AT_frame_base=(DW_ATVAL_UINT 0)+data Subprogram = Subprogram+  { subprogName :: String+  , subprogDecl :: Decl+  , subprogPrototyped :: Bool+  , subprogLowPC :: Maybe Word64+  , subprogHighPC :: Maybe Word64+  , subprogFrameBase :: Maybe Loc+  , subprogFormalParameters :: [Boxed FormalParameter]+  , subprogUnspecifiedParameters :: Bool+  , subprogVariables :: [Boxed (Variable (Maybe String))]+  , subprogType :: TypeRef+  } deriving (Eq, Ord, Show)++data SubprogramChild+  = SubprogramChildFormalParameter (Boxed FormalParameter)+  | SubprogramChildVariable (Boxed (Variable (Maybe String)))+  | SubprogramChildIgnored+  | SubprogramChildUnspecifiedParameters+  deriving (Eq)++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+  where+    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 -> SubprogramChildVariable . box child  <$> parseVariable getMName child+      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++data Def+  = DefBaseType BaseType+  | DefTypedef Typedef+  | DefPtrType PtrType+  | DefConstType ConstType+  | DefStructureType StructureType+  | DefArrayType ArrayType+  | DefUnionType UnionType+  | DefEnumerationType EnumerationType+  | DefSubroutineType SubroutineType+  | 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++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++parseDef :: DIE -> M (Boxed Def)+parseDef die = cachedMake (dieId die) $ parseDefI die++-- DW_AT_producer=(DW_ATVAL_STRING "GNU C 4.4.5")+-- DW_AT_language=(DW_ATVAL_UINT 1)+-- DW_AT_name=(DW_ATVAL_STRING "../src/closures.c")+-- DW_AT_comp_dir=(DW_ATVAL_STRING "/home/ian/zz/ghc-7.4.1/libffi/build/i386-unknown-linux-gnu")+-- DW_AT_low_pc=(DW_ATVAL_UINT 135625548)+-- DW_AT_high_pc=(DW_ATVAL_UINT 135646754)+-- DW_AT_stmt_list=(DW_ATVAL_UINT 0)+data CompilationUnit = CompilationUnit+  { cuProducer :: String+  , cuLanguage :: Dwarf.DW_LANG+  , cuName :: String+  , cuCompDir :: String+  , cuLowPc :: Word64+  , cuHighPc :: Maybe Word64+--  , cuLineNumInfo :: ([String], [Dwarf.DW_LNE])+  , cuDefs :: [Boxed Def]+  } deriving (Show)++parseCU :: DIEMap -> DIE -> Boxed CompilationUnit+parseCU dieMap die =+  runM dieMap $+  box die .+  verifyTag 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)+  -- lineNumInfo+  <$> mapM parseDef (dieChildren die)
+ src/Data/Dwarf/ADT/Pretty.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Dwarf.ADT.Pretty (compilationUnit) where++import Data.Dwarf (DW_ATE(..))+import Data.Dwarf.ADT (Boxed(..), Def(..))+import Data.Maybe (mapMaybe)+import Text.PrettyPrint ((<>))+import qualified Data.Dwarf.ADT as ADT+import qualified Data.List as List+import qualified Text.PrettyPrint as PP++showPP :: Show a => a -> PP.Doc+showPP = PP.text . show++-- Dislike drop-prefix-length trickery as it is tightly coupled with+-- the names defined without any type safety about it.+ppATE :: DW_ATE -> PP.Doc+ppATE DW_ATE_address = "address"+ppATE DW_ATE_boolean = "boolean"+ppATE DW_ATE_complex_float = "complex_float"+ppATE DW_ATE_float = "float"+ppATE DW_ATE_signed = "signed"+ppATE DW_ATE_signed_char = "signed_char"+ppATE DW_ATE_unsigned = "unsigned"+ppATE DW_ATE_unsigned_char = "unsigned_char"+ppATE DW_ATE_imaginary_float = "imaginary_float"+ppATE DW_ATE_packed_decimal = "packed_decimal"+ppATE DW_ATE_numeric_string = "numeric_string"+ppATE DW_ATE_edited = "edited"+ppATE DW_ATE_signed_fixed = "signed_fixed"+ppATE DW_ATE_unsigned_fixed = "unsigned_fixed"+ppATE DW_ATE_decimal_float = "decimal_float"++baseTypeName :: ADT.BaseType -> PP.Doc+baseTypeName (ADT.BaseType _ _ (Just name)) = PP.text name+baseTypeName (ADT.BaseType _ encoding Nothing) = ppATE encoding++withName :: PP.Doc -> Maybe String -> PP.Doc+withName prefix Nothing = prefix+withName prefix (Just name) = prefix <> " " <> PP.text name++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)+  , "}"+  ]+  where+    memberPP Boxed { bData = member } =+      ppType (ADT.membName member) (ADT.membType member) <> ";"++structureType :: ADT.StructureType -> PP.Doc+structureType ADT.StructureType+  { ADT.stName = mName+  , ADT.stMembers = members+  } = compositeMembers "struct" mName members++unionType :: ADT.UnionType -> PP.Doc+unionType ADT.UnionType+  { ADT.unionName = mName+  , ADT.unionMembers = members+  } = compositeMembers "union" mName members++enumerationType :: ADT.EnumerationType -> PP.Doc+enumerationType ADT.EnumerationType+  { ADT.enumName = mName+  , ADT.enumEnumerators = enumerators+  } =+  PP.vcat+  [ withName "enum" mName <> " {"+  , "  " <> PP.vcat (map enumeratorPP enumerators)+  , "}"+  ]+  where+    enumeratorPP Boxed { bData = enumerator } = PP.hcat+      [ PP.text $ ADT.enumeratorName enumerator+      , " = "+      , showPP $ ADT.enumeratorConstValue enumerator+      , ","+      ]++data Precedence = Prefix | Postfix++paramList :: [Boxed ADT.FormalParameter] -> PP.Doc+paramList params = "(" <> PP.hcat (List.intersperse ", " (map param params)) <> ")"+  where+    param+      Boxed+      { bData = ADT.FormalParameter+        { ADT.formalParamName = name, ADT.formalParamType = t+        }+      } = ppType name t++ppType :: Maybe String -> ADT.TypeRef -> PP.Doc+ppType mName = result . recurseType+  where+    result (baseType, decl) = baseType <> PP.space <> decl Nothing (nameCont mName)+    nameCont Nothing = id+    nameCont (Just name) = (<> PP.text name)+    addAnnotation onPrecedence f innerDecl outerPrecedence cont =+      innerDecl innerPrecedence $ f . p . cont+      where+        p = case (outerPrecedence, innerPrecedence) of+          (Just Prefix, Just Postfix) -> PP.parens+          _ -> id+        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 <> "]"+    simplePrecedence = const . Just+    recurseType ADT.Void = mkBaseType "void"+    recurseType (ADT.TypeRef Boxed { bData = typ }) =+      case typ of+      DefBaseType x -> mkBaseType $ baseTypeName x+      DefTypedef x -> mkBaseType . PP.text $ ADT.tdName x+      DefStructureType ADT.StructureType { ADT.stName = Just name } ->+        mkBaseType $ "struct " <> PP.text name+      DefStructureType x@ADT.StructureType { ADT.stName = Nothing } ->+        mkBaseType $ structureType x+      DefUnionType ADT.UnionType { ADT.unionName = Just name } ->+        mkBaseType $ "union " <> PP.text name+      DefUnionType x@ADT.UnionType { ADT.unionName = Nothing } ->+        mkBaseType $ unionType x+      DefEnumerationType ADT.EnumerationType { ADT.enumName = Just name } ->+        mkBaseType $ "enum " <> PP.text name+      DefEnumerationType x@ADT.EnumerationType { ADT.enumName = Nothing } ->+        mkBaseType $ enumerationType x++      DefPtrType ADT.PtrType { ADT.ptType = t } ->+        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 } ->+        annotate (simplePrecedence Postfix) (<> 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++defStructureType :: ADT.StructureType -> PP.Doc+defStructureType = structureType++defUnionType :: ADT.UnionType -> PP.Doc+defUnionType = unionType++defEnumerationType :: ADT.EnumerationType -> PP.Doc+defEnumerationType = enumerationType++defSubprogram :: ADT.Subprogram -> PP.Doc+defSubprogram ADT.Subprogram+  { ADT.subprogName = name+  , ADT.subprogType = typ+  , ADT.subprogFormalParameters = params+  , ADT.subprogLowPC = lowPC+  , ADT.subprogHighPC = highPC+  } =+  PP.hcat+  [ ppType (Just name) typ, paramList params+  , " at (", m lowPC, ":", m highPC, ")"+  ]+  where+    m = maybe "" showPP++defVariable :: (name -> Maybe String) -> ADT.Variable name -> PP.Doc+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+  DefBaseType _        -> Nothing+  DefPtrType _         -> Nothing+  DefConstType _       -> 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+  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 }+  = 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)+    , ""+    ]
+ src/Data/Dwarf/Elf.hs view
@@ -0,0 +1,38 @@+module Data.Dwarf.Elf+  ( loadElfDwarf+  , elfSectionByName+  , parseElfDwarfADT+  ) where++import Control.Applicative (Applicative(..), (<$>))+import Data.Dwarf.ADT (Boxed, CompilationUnit)+import Data.Elf (parseElf, Elf(..), ElfSection(..))+import Data.List (find)+import System.IO.Posix.MMap (unsafeMMapFile)+import qualified Data.ByteString as BS+import qualified Data.Dwarf as Dwarf+import qualified Data.Dwarf.ADT as Dwarf.ADT++elfSectionByName :: Elf -> String -> Either String BS.ByteString+elfSectionByName elf name =+  maybe (Left ("Missing section " ++ name)) Right .+  fmap elfSectionData .+  find ((== name) . elfSectionName) $ elfSections elf++loadElfDwarf :: Dwarf.Endianess -> FilePath -> IO (Elf, ([Dwarf.DIE], Dwarf.DIEMap))+loadElfDwarf endianess filename = do+  bs <- unsafeMMapFile filename+  let elf = parseElf bs+      get = elfSectionByName elf+  sections <-+    either fail return $+    Dwarf.Sections+    <$> get ".debug_info"+    <*> get ".debug_abbrev"+    <*> get ".debug_str"+  pure (elf, Dwarf.parseInfo endianess sections)++parseElfDwarfADT :: Dwarf.Endianess -> FilePath -> IO [Boxed CompilationUnit]+parseElfDwarfADT endianess filename = do+  (_elf, (cuDies, dieMap)) <- loadElfDwarf endianess filename+  pure $ map (Dwarf.ADT.parseCU dieMap) cuDies
+ src/Data/Dwarf/Lens.hs view
@@ -0,0 +1,49 @@+{-# 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+  ) where++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)++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_REF :: ATVAL_NamedPrism DieID+aTVAL_REF = ("ATVAL_REF", dW_ATVAL_REF)++aTVAL_STRING :: ATVAL_NamedPrism String+aTVAL_STRING = ("ATVAL_STRING", dW_ATVAL_STRING)++aTVAL_BLOB :: ATVAL_NamedPrism BS.ByteString+aTVAL_BLOB = ("ATVAL_BLOB", dW_ATVAL_BLOB)++aTVAL_BOOL :: ATVAL_NamedPrism Bool+aTVAL_BOOL = ("ATVAL_BOOL", dW_ATVAL_BOOL)++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]