llvm-pretty 0.7.0.0 → 0.7.1.0

raw patch · 3 files changed

+374/−2 lines, 3 filesdep +parsecPVP ok

version bump matches the API change (PVP)

Dependencies added: parsec

API changes (from Hackage documentation)

Files

• llvm-pretty.cabal +5/−2
• src/Text/LLVM/DebugUtils.hs +263/−0
• src/Text/LLVM/Parser.hs +106/−0

@@ -1,5 +1,5 @@ Name:                llvm-pretty-Version:             0.7.0.0+Version:             0.7.1.0 License:             BSD3 License-file:        LICENSE Author:              Trevor Elliott@@ -12,7 +12,7 @@   A pretty printing library that was inspired by the LLVM binding by Lennart   Augustsson.  The library provides a monadic interface to a pretty printer,   that allows functions to be defined and called, generating the corresponding-  LLVM assemblly when run.+  LLVM assembly when run.  source-repository head   type:                 git@@ -25,11 +25,14 @@   Exposed-modules:     Text.LLVM                        Text.LLVM.AST                        Text.LLVM.Labels+                       Text.LLVM.Parser                        Text.LLVM.PP+                       Text.LLVM.DebugUtils   Other-modules:       Text.LLVM.Util    Build-depends:       base       >= 4 && < 5,                        containers >= 0.4,+                       parsec     >= 3,                        pretty     >= 1.0.1,                        monadLib   >= 3.6.1 

@@ -0,0 +1,263 @@+{-# Language TransformListComp, MonadComprehensions #-}+{- |+Module           : $Header$+Description      : This module interprets the DWARF information associated+                   with a function's argument and return types in order to+                   interpret field name references.+License          : BSD3+Stability        : provisional+Point-of-contact : emertens+-}+module Text.LLVM.DebugUtils+  ( -- * Definition type analyzer+    Info(..), computeFunctionTypes, valMdToInfo+  , localVariableNameDeclarations++  -- * Metadata lookup+  , mkMdMap++  -- * Type structure dereference+  , derefInfo+  , fieldIndexByPosition+  , fieldIndexByName+  ) where++import           Control.Applicative    ((<|>))+import           Control.Monad          ((<=<))+import           Data.IntMap            (IntMap)+import qualified Data.IntMap as IntMap+import           Data.List              (elemIndex, tails)+import           Data.Map               (Map)+import qualified Data.Map    as Map+import           Data.Maybe             (fromMaybe, listToMaybe, maybeToList)+import           Data.Word              (Word16)+import           Text.LLVM.AST++dbgKind :: String+dbgKind = "dbg"++llvmDbgCuKey :: String+llvmDbgCuKey = "llvm.dbg.cu"++dwarfPointer, dwarfStruct, dwarfTypedef, dwarfUnion, dwarfBasetype,+  dwarfConst :: Word16+dwarfPointer  = 0x0f+dwarfStruct   = 0x13+dwarfTypedef  = 0x16+dwarfUnion    = 0x17+dwarfBasetype = 0x24+dwarfConst    = 0x26++type MdMap = IntMap ValMd++data Info+  = Pointer Info+  | Structure [(String,Info)]+  | Union     [(String,Info)]+  | BaseType String+  | Unknown+  deriving Show++{-+import Text.Show.Pretty+import Data.Foldable++test =+  do test' "/Users/emertens/Source/saw/saw-script\+           \/examples/llvm/dotprod_struct.bc"+     test' "/Users/emertens/Desktop/temp.bc"++test' fn =+  do Right bc <- parseBitCodeFromFile fn+     let mdMap = mkMdMap bc+     traverse_ (putStrLn . ppShow . analyzeDefine mdMap) (modDefines bc)+-}++-- | Compute an 'IntMap' of the unnamed metadata in a module+mkMdMap :: Module -> IntMap ValMd+mkMdMap m = IntMap.fromList [ (umIndex md, umValues md) | md <- modUnnamedMd m ]++------------------------------------------------------------------------++getDebugInfo :: MdMap -> ValMd -> Maybe DebugInfo+getDebugInfo mdMap (ValMdRef i)    = getDebugInfo mdMap =<< IntMap.lookup i mdMap+getDebugInfo _ (ValMdDebugInfo di) = Just di+getDebugInfo _ _                   = Nothing+++getList :: MdMap -> ValMd -> Maybe [Maybe ValMd]+getList mdMap (ValMdRef i) = getList mdMap =<< IntMap.lookup i mdMap+getList _ (ValMdNode di)   = Just di+getList _ _                = Nothing++------------------------------------------------------------------------++valMdToInfo :: MdMap -> ValMd -> Info+valMdToInfo mdMap val =+  maybe Unknown (debugInfoToInfo mdMap) (getDebugInfo mdMap val)+++valMdToInfo' :: MdMap -> Maybe ValMd -> Info+valMdToInfo' = maybe Unknown . valMdToInfo+++debugInfoToInfo :: MdMap -> DebugInfo -> Info+debugInfoToInfo mdMap (DebugInfoDerivedType dt)+  | didtTag dt == dwarfPointer  = Pointer (valMdToInfo' mdMap (didtBaseType dt))+  | didtTag dt == dwarfTypedef  =          valMdToInfo' mdMap (didtBaseType dt)+  | didtTag dt == dwarfConst    =          valMdToInfo' mdMap (didtBaseType dt)+debugInfoToInfo _     (DebugInfoBasicType bt)+  | dibtTag bt == dwarfBasetype = BaseType (dibtName bt)+debugInfoToInfo mdMap (DebugInfoCompositeType ct)+  | dictTag ct == dwarfStruct   = maybe Unknown Structure (getFields mdMap ct)+  | dictTag ct == dwarfUnion    = maybe Unknown Union     (getFields mdMap ct)+debugInfoToInfo _ _             = Unknown+++getFields :: MdMap -> DICompositeType -> Maybe [(String, Info)]+getFields mdMap ct =+  traverse (debugInfoToField mdMap <=< getDebugInfo mdMap)+       =<< sequence =<< getList mdMap =<< dictElements ct+++debugInfoToField :: MdMap -> DebugInfo -> Maybe (String, Info)+debugInfoToField mdMap di =+  do DebugInfoDerivedType dt <- Just di+     fieldName               <- didtName dt+     Just (fieldName, valMdToInfo' mdMap (didtBaseType dt))+++-- | Compute the structures of a function's return and argument types+-- using DWARF information metadata of the LLVM module. Different+-- versions of LLVM make this information available via different+-- paths. This function attempts to support the variations.+computeFunctionTypes ::+  Module       {- ^ module to search                     -} ->+  Symbol       {- ^ function symbol                      -} ->+  Maybe [Info] {- ^ return and argument type information -}+computeFunctionTypes m sym =+  [ maybe (BaseType "void") (valMdToInfo mdMap) <$> types+     | let mdMap = mkMdMap m+     , sp <- findSubprogramViaDefine mdMap m sym+         <|> findSubprogramViaCu     mdMap m sym+     , DebugInfoSubroutineType st <- getDebugInfo mdMap =<< dispType sp+     , types                      <- getList mdMap      =<< distTypeArray st+     ]+++-- | This method of computing argument type information works on at least LLVM 3.8+findSubprogramViaDefine ::+  IntMap ValMd       {- ^ unnamed metadata                             -} ->+  Module             {- ^ module to search                             -} ->+  Symbol             {- ^ function symbol to find                      -} ->+  Maybe DISubprogram {- ^ debug information related to function symbol -}+findSubprogramViaDefine mdMap m sym =+  [ sp+     | def                    <- modDefines m+     , defName def == sym+     , then listToMaybe ----- commits to a choice -----+     , dbgMd                  <- Map.lookup dbgKind (defMetadata def)+     , DebugInfoSubprogram sp <- getDebugInfo mdMap dbgMd+     ]+++-- | This method of computing function debugging information works on LLVM 3.7+findSubprogramViaCu ::+  MdMap              {- ^ map of unnamed metadata                -} ->+  Module             {- ^ module to search                       -} ->+  Symbol             {- ^ function symbol to search for          -} ->+  Maybe DISubprogram {- ^ debugging information for given symbol -}+findSubprogramViaCu mdMap m (Symbol sym) = listToMaybe+  [ sp+    | md                      <- modNamedMd m+    , nmName md == llvmDbgCuKey+    , ref                     <- nmValues md+    , DebugInfoCompileUnit cu <- maybeToList  $ getDebugInfo mdMap $ ValMdRef ref+    , Just entry              <- fromMaybe [] $ getList mdMap =<< dicuSubprograms cu+    , DebugInfoSubprogram sp  <- maybeToList  $ getDebugInfo mdMap entry+    , dispName sp == Just sym+    ]+++------------------------------------------------------------------------++-- | If the argument describes a pointer, return the information for the+-- type that it points do.+derefInfo ::+  Info {- ^ pointer type information                -} ->+  Info {- ^ type information of pointer's base type -}+derefInfo (Pointer x) = x+derefInfo _           = Unknown++-- | If the argument describes a composite type, returns the type of the+-- field by zero-based index into the list of fields.+fieldIndexByPosition ::+  Int  {- ^ zero-based field index               -} ->+  Info {- ^ composite type information           -} ->+  Info {- ^ type information for specified field -}+fieldIndexByPosition i info =+  case info of+    Structure xs -> go xs+    Union     xs -> go xs+    _            -> Unknown+  where+    go xs = case drop i xs of+              []  -> Unknown+              x:_ -> snd x++-- | If the argument describes a composite type, return the first, zero-based+-- index of the field in that type that matches the given name.+fieldIndexByName ::+  String    {- ^ field name                                  -} ->+  Info      {- ^ composite type info                         -} ->+  Maybe Int {- ^ zero-based index of field matching the name -}+fieldIndexByName n info =+  case info of+    Structure xs -> go xs+    Union     xs -> go xs+    _            -> Nothing+  where+    go = elemIndex n . map fst++------------------------------------------------------------------------++localVariableNameDeclarations ::+  IntMap ValMd    {- ^ unnamed metadata      -} ->+  Define          {- ^ function definition   -} ->+  Map Ident Ident {- ^ raw name, actual name -}+localVariableNameDeclarations mdMap def =+  case defBody def of+    blk1 : _ -> foldr aux Map.empty (tails (bbStmts blk1))+    _        -> Map.empty+  where++    aux :: [Stmt] -> Map Ident Ident -> Map Ident Ident+    aux ( Effect (Store src dst _) _+        : Effect (Call _ _ (ValSymbol (Symbol what)) [var,md,_]) _+        : _) sofar+      | what == "llvm.dbg.declare"+      , Just dstIdent <- extractIdent dst+      , Just srcIdent <- extractIdent src+      , Just varIdent <- extractIdent var+      , dstIdent == varIdent+      , Just name <- extractLvName md+      = Map.insert name srcIdent sofar++    aux ( Effect (Call _ _ (ValSymbol (Symbol what)) [var,_,md,_]) _+        : _) sofar+      | what == "llvm.dbg.value"+      , Just key  <- extractIdent var+      , Just name <- extractLvName md+      = Map.insert name key sofar++    aux _ sofar = sofar++    extractIdent :: Typed Value -> Maybe Ident+    extractIdent (Typed _ (ValIdent i)) = Just i+    extractIdent _                      = Nothing++    extractLvName :: Typed Value -> Maybe Ident+    extractLvName mdArg =+      do ValMd md                    <- Just (typedValue mdArg)+         DebugInfoLocalVariable dilv <- getDebugInfo mdMap md+         Ident <$> dilvName dilv

@@ -0,0 +1,106 @@+module Text.LLVM.Parser where++import Text.LLVM.AST++import Data.Int (Int32)+import Text.Parsec+import Text.Parsec.String+++-- Identifiers and Symbols -----------------------------------------------------++pNameChar :: Parser Char+pNameChar = letter <|> digit <|> oneOf "-$._"++pIdent :: Parser Ident+pIdent = Ident <$> (char '%' >> many1 pNameChar)++pSymbol :: Parser Symbol+pSymbol = Symbol <$> (char '@' >> many1 pNameChar)+++-- Types -----------------------------------------------------------------------++pInt32 :: Parser Int32+pInt32 = read <$> many1 digit++pPrimType :: Parser PrimType+pPrimType = choice+  [ Integer <$> try (char 'i' >> pInt32)+  , FloatType <$> try pFloatType+  , try (string "label")    >> return Label+  , try (string "void")     >> return Void+  , try (string "x86mmx")   >> return X86mmx+  , try (string "metadata") >> return Metadata+  ]++pFloatType :: Parser FloatType+pFloatType = choice+  [ try (string "half")      >> return Half+  , try (string "float")     >> return Float+  , try (string "double")    >> return Double+  , try (string "fp128")     >> return Fp128+  , try (string "x86_fp80")  >> return X86_fp80+  , try (string "ppc_fp128") >> return PPC_fp128+  ]++pType :: Parser Type+pType = pType0 >>= pFunPtr+  where+    pType0 :: Parser Type+    pType0 =+      choice+      [ Alias <$> pIdent+      , brackets (pNumType Array)+      , braces (Struct <$> pTypeList)+      , angles (braces (PackedStruct <$> pTypeList) <|> spaced (pNumType Vector))+      , string "opaque" >> return Opaque+      , PrimType <$> pPrimType+      ]++    pTypeList :: Parser [Type]+    pTypeList = sepBy (spaced pType) (char ',')++    pNumType :: (Int32 -> Type -> Type) -> Parser Type+    pNumType f =+      do n <- pInt32+         spaces >> char 'x' >> spaces+         t <- pType+         return (f n t)++    pArgList :: Type -> Parser Type+    pArgList t0 = spaces >> (p1 [] <|> return (FunTy t0 [] False))+      where+        p1 ts =+          (string "..." >> spaces >> return (FunTy t0 (reverse ts) True))+          <|> (pType >>= \t -> (spaces >> p2 (t : ts)))+        p2 ts =+          (char ',' >> spaces >> p1 ts)+          <|> return (FunTy t0 (reverse ts) False)++    pFunPtr :: Type -> Parser Type+    pFunPtr t0 = pFun <|> pPtr <|> return t0+      where+        pFun = parens (pArgList t0) >>= pFunPtr+        pPtr = char '*' >> pFunPtr (PtrTo t0)++parseType :: String -> Either ParseError Type+parseType = parse (pType <* eof) "<internal>"+++-- Utilities -------------------------------------------------------------------++angles :: Parser a -> Parser a+angles body = char '<' *> body <* char '>'++braces :: Parser a -> Parser a+braces body = char '{' *> body <* char '}'++brackets :: Parser a -> Parser a+brackets body = char '[' *> body <* char ']'++parens :: Parser a -> Parser a+parens body = char '(' *> body <* char ')'++spaced :: Parser a -> Parser a+spaced body = spaces *> body <* spaces