diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dumpadt.hs b/dumpadt.hs new file mode 100644 --- /dev/null +++ b/dumpadt.hs @@ -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 diff --git a/dumpdwarf.hs b/dumpdwarf.hs new file mode 100644 --- /dev/null +++ b/dumpdwarf.hs @@ -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 diff --git a/dwarfadt.cabal b/dwarfadt.cabal new file mode 100644 --- /dev/null +++ b/dwarfadt.cabal @@ -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 diff --git a/src/Data/Dwarf/ADT.hs b/src/Data/Dwarf/ADT.hs new file mode 100644 --- /dev/null +++ b/src/Data/Dwarf/ADT.hs @@ -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) diff --git a/src/Data/Dwarf/ADT/Pretty.hs b/src/Data/Dwarf/ADT/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Dwarf/ADT/Pretty.hs @@ -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) + , "" + ] diff --git a/src/Data/Dwarf/Elf.hs b/src/Data/Dwarf/Elf.hs new file mode 100644 --- /dev/null +++ b/src/Data/Dwarf/Elf.hs @@ -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 diff --git a/src/Data/Dwarf/Lens.hs b/src/Data/Dwarf/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Dwarf/Lens.hs @@ -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]