diff --git a/llvm-pretty.cabal b/llvm-pretty.cabal --- a/llvm-pretty.cabal +++ b/llvm-pretty.cabal @@ -1,5 +1,5 @@ Name: llvm-pretty -Version: 0.7.1.0 +Version: 0.7.1.1 License: BSD3 License-file: LICENSE Author: Trevor Elliott diff --git a/src/Text/LLVM.hs b/src/Text/LLVM.hs --- a/src/Text/LLVM.hs +++ b/src/Text/LLVM.hs @@ -198,11 +198,12 @@ -- | Emit a global declaration. global :: GlobalAttrs -> Symbol -> Type -> Maybe Value -> LLVM (Typed Value) global attrs sym ty mbVal = emitGlobal Global - { globalSym = sym - , globalType = ty - , globalValue = toValue `fmap` mbVal - , globalAttrs = attrs - , globalAlign = Nothing + { globalSym = sym + , globalType = ty + , globalValue = toValue `fmap` mbVal + , globalAttrs = attrs + , globalAlign = Nothing + , globalMetadata = Map.empty } -- | Output a somewhat clunky representation for a string global, that deals diff --git a/src/Text/LLVM/AST.hs b/src/Text/LLVM/AST.hs --- a/src/Text/LLVM/AST.hs +++ b/src/Text/LLVM/AST.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor, DeriveGeneric #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} #ifndef MIN_VERSION_base #define MIN_VERSION_base(x,y,z) 1 @@ -10,9 +11,7 @@ module Text.LLVM.AST where -import Text.LLVM.Util (breaks,uncons) - -import Control.Monad (MonadPlus(mzero,mplus),(<=<),msum,guard,liftM,liftM3) +import Control.Monad (MonadPlus(mzero,mplus),(<=<),guard) import Data.Int (Int32,Int64) import Data.List (genericIndex,genericLength) import qualified Data.Map as Map @@ -20,6 +19,9 @@ import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic, Generic1) +import Text.Parsec +import Text.Parsec.String + #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<$)) import Data.Foldable (Foldable(foldMap)) @@ -32,16 +34,16 @@ data Module = Module { modSourceName :: Maybe String - , modDataLayout :: DataLayout - , modTypes :: [TypeDecl] + , modDataLayout :: DataLayout -- ^ type size and alignment information + , modTypes :: [TypeDecl] -- ^ top-level type aliases , modNamedMd :: [NamedMd] , modUnnamedMd :: [UnnamedMd] - , modGlobals :: [Global] - , modDeclares :: [Declare] - , modDefines :: [Define] + , modGlobals :: [Global] -- ^ global value declarations + , modDeclares :: [Declare] -- ^ external function declarations (without definitions) + , modDefines :: [Define] -- ^ internal function declarations (with definitions) , modInlineAsm :: InlineAsm , modAliases :: [GlobalAlias] - } deriving (Show) + } deriving (Show,Generic) instance Monoid Module where mempty = emptyModule @@ -78,7 +80,7 @@ data NamedMd = NamedMd { nmName :: String , nmValues :: [Int] - } deriving (Show) + } deriving (Show,Generic) -- Unnamed Metadata ------------------------------------------------------------ @@ -87,7 +89,7 @@ { umIndex :: !Int , umValues :: ValMd , umDistinct :: Bool - } deriving (Show) + } deriving (Show,Generic) -- Aliases --------------------------------------------------------------------- @@ -96,7 +98,7 @@ { aliasName :: Symbol , aliasType :: Type , aliasTarget :: Value - } deriving (Show) + } deriving (Show,Generic) -- Data Layout ----------------------------------------------------------------- @@ -106,72 +108,71 @@ data LayoutSpec = BigEndian | LittleEndian - | PointerSize !Int !Int (Maybe Int) - | IntegerSize !Int !Int (Maybe Int) - | VectorSize !Int !Int (Maybe Int) - | FloatSize !Int !Int (Maybe Int) - | AggregateSize !Int !Int (Maybe Int) - | StackObjSize !Int !Int (Maybe Int) + | PointerSize !Int !Int !Int (Maybe Int) -- ^ address space, size, abi, pref + | IntegerSize !Int !Int (Maybe Int) -- ^ size, abi, pref + | VectorSize !Int !Int (Maybe Int) -- ^ size, abi, pref + | FloatSize !Int !Int (Maybe Int) -- ^ size, abi, pref + | StackObjSize !Int !Int (Maybe Int) -- ^ size, abi, pref + | AggregateSize !Int !Int (Maybe Int) -- ^ size, abi, pref | NativeIntSize [Int] - | StackAlign !Int + | StackAlign !Int -- ^ size | Mangling Mangling - deriving (Show) + deriving (Show,Generic) data Mangling = ElfMangling | MipsMangling | MachOMangling | WindowsCoffMangling - deriving (Show,Eq) + deriving (Show,Generic,Eq) -- | Parse the data layout string. parseDataLayout :: MonadPlus m => String -> m DataLayout -parseDataLayout = mapM parseLayoutSpec . breaks (== '-') - --- | Parse a single layout specification from a string. -parseLayoutSpec :: MonadPlus m => String -> m LayoutSpec -parseLayoutSpec str = msum - [ guard (str == "E") >> return BigEndian - , guard (str == "e") >> return LittleEndian - , do (i,rest) <- uncons str - let body = breaks (== ':') rest - case i of - - 'S' -> do align <- parseInt rest - return (StackAlign align) - - 'p' -> build PointerSize (tail body) - 'i' -> build IntegerSize body - 'v' -> build VectorSize body - 'f' -> build FloatSize body - 'a' -> build AggregateSize body - 's' -> build StackObjSize body - - 'n' -> do ints <- mapM parseInt body - return (NativeIntSize ints) - - 'm' -> case tail body of - ["e"] -> return (Mangling ElfMangling) - ["m"] -> return (Mangling MipsMangling) - ["o"] -> return (Mangling MachOMangling) - ["w"] -> return (Mangling WindowsCoffMangling) - _ -> mzero +parseDataLayout str = + case parse (pDataLayout <* eof) "" str of + Left _err -> mzero + Right specs -> return specs + where + pDataLayout :: Parser DataLayout + pDataLayout = sepBy pLayoutSpec (char '-') - _ -> mzero - ] + pLayoutSpec :: Parser LayoutSpec + pLayoutSpec = + do c <- letter + case c of + 'E' -> return BigEndian + 'e' -> return LittleEndian + 'S' -> StackAlign <$> pInt + 'p' -> PointerSize <$> pInt0 <*> pCInt <*> pCInt <*> pPref + 'i' -> IntegerSize <$> pInt <*> pCInt <*> pPref + 'v' -> VectorSize <$> pInt <*> pCInt <*> pPref + 'f' -> FloatSize <$> pInt <*> pCInt <*> pPref + 's' -> StackObjSize <$> pInt <*> pCInt <*> pPref + 'a' -> AggregateSize <$> pInt <*> pCInt <*> pPref + 'n' -> NativeIntSize <$> sepBy pInt (char ':') + 'm' -> Mangling <$> (char ':' >> pMangling) + _ -> mzero - where + pMangling :: Parser Mangling + pMangling = + do c <- letter + case c of + 'e' -> return ElfMangling + 'm' -> return MipsMangling + 'o' -> return MachOMangling + 'w' -> return WindowsCoffMangling + _ -> mzero - build f lst = case lst of - [sz,abi,pref] -> liftM3 f (parseInt sz) (parseInt abi) (parsePref pref) - [sz,abi] -> liftM3 f (parseInt sz) (parseInt abi) (return Nothing) - _ -> mzero + pInt :: Parser Int + pInt = read <$> many1 digit - parsePref = liftM Just . parseInt + pInt0 :: Parser Int + pInt0 = pInt <|> return 0 - parseInt s = case reads s of - [(i,[])] -> return i - _ -> mzero + pCInt :: Parser Int + pCInt = char ':' >> pInt + pPref :: Parser (Maybe Int) + pPref = optionMaybe pCInt -- Inline Assembly ------------------------------------------------------------- @@ -180,7 +181,7 @@ -- Identifiers ----------------------------------------------------------------- newtype Ident = Ident String - deriving (Show,Eq,Ord) + deriving (Show,Generic,Eq,Ord) instance IsString Ident where fromString = Ident @@ -188,7 +189,7 @@ -- Symbols --------------------------------------------------------------------- newtype Symbol = Symbol String - deriving (Show,Eq,Ord) + deriving (Show,Generic,Eq,Ord) instance Monoid Symbol where mappend (Symbol a) (Symbol b) = Symbol (mappend a b) @@ -206,7 +207,7 @@ | FloatType FloatType | X86mmx | Metadata - deriving (Eq, Ord, Show) + deriving (Eq, Generic, Ord, Show) data FloatType = Half @@ -215,7 +216,7 @@ | Fp128 | X86_fp80 | PPC_fp128 - deriving (Eq, Ord, Show) + deriving (Eq, Generic, Ord, Show) type Type = Type' Ident @@ -229,7 +230,7 @@ | PackedStruct [Type' ident] | Vector Int32 (Type' ident) | Opaque - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Generic, Ord, Show, Functor) -- | Traverse a type, updating or removing aliases. updateAliases :: (a -> Type' b) -> (Type' a -> Type' b) @@ -354,7 +355,7 @@ data TypeDecl = TypeDecl { typeName :: Ident , typeValue :: Type - } deriving (Show) + } deriving (Show, Generic) -- Globals --------------------------------------------------------------------- @@ -365,7 +366,8 @@ , globalType :: Type , globalValue :: Maybe Value , globalAlign :: Maybe Align - } deriving Show + , globalMetadata :: GlobalMdAttachments + } deriving (Show, Generic) addGlobal :: Global -> Module -> Module addGlobal g m = m { modGlobals = g : modGlobals m } @@ -373,7 +375,7 @@ data GlobalAttrs = GlobalAttrs { gaLinkage :: Maybe Linkage , gaConstant :: Bool - } deriving (Show) + } deriving (Show, Generic) emptyGlobalAttrs :: GlobalAttrs emptyGlobalAttrs = GlobalAttrs @@ -390,7 +392,7 @@ , decArgs :: [Type] , decVarArgs :: Bool , decAttrs :: [FunAttr] - } deriving (Show) + } deriving (Show, Generic) -- | The function type of this declaration decFunType :: Declare -> Type @@ -410,7 +412,7 @@ , defGC :: Maybe GC , defBody :: [BasicBlock] , defMetadata :: FnMdAttachments - } deriving (Show) + } deriving (Show, Generic) defFunType :: Define -> Type defFunType Define { .. } = @@ -451,14 +453,14 @@ | SSPreq | SSPstrong | UWTable - deriving (Show) + deriving (Show, Generic) -- Basic Block Labels ---------------------------------------------------------- data BlockLabel = Named Ident | Anon Int - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Show, Generic) instance IsString BlockLabel where fromString str = Named (fromString str) @@ -468,7 +470,7 @@ data BasicBlock' lab = BasicBlock { bbLabel :: Maybe lab , bbStmts :: [Stmt' lab] - } deriving (Show) + } deriving (Show, Generic) type BasicBlock = BasicBlock' BlockLabel @@ -502,18 +504,18 @@ | External | DLLImport | DLLExport - deriving (Eq,Show) + deriving (Eq,Show,Generic) newtype GC = GC { getGC :: String - } deriving (Show) + } deriving (Show,Generic) -- Typed Things ---------------------------------------------------------------- data Typed a = Typed { typedType :: Type , typedValue :: a - } deriving (Show,Functor) + } deriving (Show,Generic,Functor) instance Foldable Typed where foldMap f t = f (typedValue t) @@ -583,7 +585,7 @@ -- ^ * Floating point reminder resulting from floating point division. -- * The reminder has the same sign as the divident (first parameter). - deriving (Eq,Show) + deriving (Eq,Generic,Show) isIArith :: ArithOp -> Bool isIArith Add{} = True @@ -598,6 +600,7 @@ isFArith :: ArithOp -> Bool isFArith = not . isIArith +-- | Binary bitwise operators. data BitOp = Shl Bool Bool {- ^ * Shift left. @@ -608,32 +611,33 @@ If a check fails, then the result is poisoned. The value of the second parameter must be strictly less than the - nubmer of bits in the first parameter, + number of bits in the first parameter, otherwise the result is undefined. -} | Lshr Bool {- ^ * Logical shift right. - * The boolean is for exact check: posion the result, + * The boolean is for exact check: poison the result, if we shift out a 1 bit (i.e., had to round). The value of the second parameter must be strictly less than the - nubmer of bits in the first parameter, otherwise the result is undefined. + number of bits in the first parameter, otherwise the result is undefined. -} | Ashr Bool {- ^ * Arithmetic shift right. - * The boolean is for exact check: posion the result, + * The boolean is for exact check: poison the result, if we shift out a 1 bit (i.e., had to round). The value of the second parameter must be strictly less than the - nubmer of bits in the first parameter, otherwise the result is undefined. + number of bits in the first parameter, otherwise the result is undefined. -} | And | Or | Xor - deriving Show + deriving (Show,Generic) +-- | Conversions from one type to another. data ConvOp = Trunc | ZExt @@ -647,7 +651,7 @@ | PtrToInt | IntToPtr | BitCast - deriving Show + deriving (Show,Generic) type Align = Int @@ -687,7 +691,7 @@ how many elements (1 if 'Nothing'); required alignment. * Middle of basic block. - * Returns a pointer to hold the given number of elemets. -} + * Returns a pointer to hold the given number of elements. -} | Load (Typed (Value' lab)) (Maybe Align) {- ^ * Read a value from the given address: @@ -759,7 +763,7 @@ {- ^ * Get an element from a vector: the first argument is a vector, the second an index. * Middle of basic block. - * Returns the element at the given positoin. -} + * Returns the element at the given position. -} | InsertElt (Typed (Value' lab)) (Typed (Value' lab)) (Value' lab) {- ^ * Modify an element of a vector: the first argument is the vector, @@ -838,13 +842,15 @@ isPhi Phi{} = True isPhi _ = False +-- | Integer comparison operators. data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle - deriving (Show) + deriving (Show, Generic) +-- | Floating-point comparison operators. data FCmpOp = Ffalse | Foeq | Fogt | Foge | Folt | Fole | Fone | Ford | Fueq | Fugt | Fuge | Fult | Fule | Fune | Funo | Ftrue - deriving (Show) + deriving (Show, Generic) -- Values ---------------------------------------------------------------------- @@ -885,6 +891,7 @@ type KindMd = String type FnMdAttachments = Map.Map KindMd ValMd +type GlobalMdAttachments = Map.Map KindMd ValMd data DebugLoc' lab = DebugLoc { dlLine :: Word32 @@ -996,14 +1003,14 @@ , dibtSize :: Word64 , dibtAlign :: Word64 , dibtEncoding :: DwarfAttrEncoding - } deriving (Show) + } deriving (Show,Generic) data DICompileUnit' lab = DICompileUnit { dicuLanguage :: DwarfLang , dicuFile :: Maybe (ValMd' lab) , dicuProducer :: Maybe String , dicuIsOptimized :: Bool - , dicuFlags :: DIFlags + , dicuFlags :: Maybe String , dicuRuntimeVersion :: Word16 , dicuSplitDebugFilename :: Maybe FilePath , dicuEmissionKind :: DIEmissionKind @@ -1061,12 +1068,12 @@ data DIExpression = DIExpression { dieElements :: [Word64] } - deriving (Show) + deriving (Show,Generic) data DIFile = DIFile { difFilename :: FilePath , difDirectory :: FilePath - } deriving (Show) + } deriving (Show,Generic) data DIGlobalVariable' lab = DIGlobalVariable { digvScope :: Maybe (ValMd' lab) @@ -1153,7 +1160,7 @@ { disrCount :: Int64 , disrLowerBound :: Int64 } - deriving (Show) + deriving (Show,Generic) data DISubroutineType' lab = DISubroutineType { distFlags :: DIFlags diff --git a/src/Text/LLVM/PP.hs b/src/Text/LLVM/PP.hs --- a/src/Text/LLVM/PP.hs +++ b/src/Text/LLVM/PP.hs @@ -18,6 +18,7 @@ import Text.LLVM.AST +import Control.Applicative ((<|>)) import Data.Char (isAscii,isPrint,ord,toUpper) import Data.List (intersperse) import qualified Data.Map as Map @@ -40,6 +41,8 @@ , cfgGEPImplicitType :: Bool -- ^ True when the type of the result of the GEP -- instruction is implied. + + , cfgUseDILocation :: Bool } withConfig :: Config -> (LLVM => a) -> a @@ -54,12 +57,15 @@ ppLLVM36 = withConfig Config { cfgLoadImplicitType = True , cfgGEPImplicitType = True + , cfgUseDILocation = False } ppLLVM37 = withConfig Config { cfgLoadImplicitType = False , cfgGEPImplicitType = False + , cfgUseDILocation = True } ppLLVM38 = withConfig Config { cfgLoadImplicitType = False , cfgGEPImplicitType = False + , cfgUseDILocation = True } checkConfig :: LLVM => (Config -> Bool) -> Bool @@ -89,7 +95,7 @@ sep [ ppMetadata (text (nmName nm)) <+> char '=' , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] -ppUnnamedMd :: UnnamedMd -> Doc +ppUnnamedMd :: LLVM => UnnamedMd -> Doc ppUnnamedMd um = sep [ ppMetadata (int (umIndex um)) <+> char '=' , distinct <+> ppValMd (umValues um) ] @@ -100,7 +106,7 @@ -- Aliases --------------------------------------------------------------------- -ppGlobalAlias :: GlobalAlias -> Doc +ppGlobalAlias :: LLVM => GlobalAlias -> Doc ppGlobalAlias g = ppSymbol (aliasName g) <+> char '=' <+> body where val = aliasTarget g @@ -119,18 +125,22 @@ -- | Pretty print a single layout specification. ppLayoutSpec :: LayoutSpec -> Doc -ppLayoutSpec BigEndian = char 'E' -ppLayoutSpec LittleEndian = char 'e' -ppLayoutSpec (PointerSize sz abi pref) = "p:" <> ppLayoutBody sz abi pref -ppLayoutSpec (IntegerSize sz abi pref) = char 'i' <> ppLayoutBody sz abi pref -ppLayoutSpec (VectorSize sz abi pref) = char 'v' <> ppLayoutBody sz abi pref -ppLayoutSpec (FloatSize sz abi pref) = char 'f' <> ppLayoutBody sz abi pref -ppLayoutSpec (AggregateSize sz abi pref) = char 'a' <> ppLayoutBody sz abi pref -ppLayoutSpec (StackObjSize sz abi pref) = char 's' <> ppLayoutBody sz abi pref -ppLayoutSpec (NativeIntSize szs) = - char 'n' <> hcat (punctuate (char ':') (map int szs)) -ppLayoutSpec (StackAlign a) = char 'S' <> int a -ppLayoutSpec (Mangling m) = char 'm' <> char ':' <> ppMangling m +ppLayoutSpec ls = + case ls of + BigEndian -> char 'E' + LittleEndian -> char 'e' + PointerSize 0 sz abi pref -> char 'p' <> char ':' <> ppLayoutBody sz abi pref + PointerSize n sz abi pref -> char 'p' <> int n <> char ':' + <> ppLayoutBody sz abi pref + IntegerSize sz abi pref -> char 'i' <> ppLayoutBody sz abi pref + VectorSize sz abi pref -> char 'v' <> ppLayoutBody sz abi pref + FloatSize sz abi pref -> char 'f' <> ppLayoutBody sz abi pref + StackObjSize sz abi pref -> char 's' <> ppLayoutBody sz abi pref + AggregateSize sz abi pref -> char 'a' <> ppLayoutBody sz abi pref + NativeIntSize szs -> + char 'n' <> hcat (punctuate (char ':') (map int szs)) + StackAlign a -> char 'S' <> int a + Mangling m -> char 'm' <> char ':' <> ppMangling m -- | Pretty-print the common case for data layout specifications. ppLayoutBody :: Int -> Int -> Maybe Int -> Doc @@ -204,11 +214,12 @@ -- Declarations ---------------------------------------------------------------- -ppGlobal :: Global -> Doc +ppGlobal :: LLVM => Global -> Doc ppGlobal g = ppSymbol (globalSym g) <+> char '=' <+> ppGlobalAttrs (globalAttrs g) <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g) <> ppAlign (globalAlign g) + <> ppAttachedMetadata (Map.toList (globalMetadata g)) ppGlobalAttrs :: GlobalAttrs -> Doc ppGlobalAttrs ga = ppMaybe ppLinkage (gaLinkage ga) <+> constant @@ -302,7 +313,7 @@ <> ppAttachedMetadata mds Effect i mds -> ppInstr i <> ppAttachedMetadata mds -ppAttachedMetadata :: [(String,ValMd)] -> Doc +ppAttachedMetadata :: LLVM => [(String,ValMd)] -> Doc ppAttachedMetadata mds | null mds = empty | otherwise = comma <+> commas (map step mds) @@ -466,13 +477,13 @@ PtrTo ty -> ppType ty <> comma ty -> ppType ty <> comma -ppClauses :: Bool -> [Clause] -> Doc +ppClauses :: LLVM => Bool -> [Clause] -> Doc ppClauses isCleanup cs = vcat (cleanup : map ppClause cs) where cleanup | isCleanup = "cleanup" | otherwise = empty -ppClause :: Clause -> Doc +ppClause :: LLVM => Clause -> Doc ppClause c = case c of Catch tv -> "catch" <+> ppTyped ppValue tv Filter tv -> "filter" <+> ppTyped ppValue tv @@ -484,14 +495,14 @@ ppSwitchEntry :: Type -> (Integer,BlockLabel) -> Doc ppSwitchEntry ty (i,l) = ppType ty <+> integer i <> comma <+> ppTypedLabel l -ppVectorIndex :: Value -> Doc +ppVectorIndex :: LLVM => Value -> Doc ppVectorIndex i = ppType (PrimType (Integer 32)) <+> ppValue i ppAlign :: Maybe Align -> Doc ppAlign Nothing = empty ppAlign (Just align) = comma <+> "align" <+> int align -ppAlloca :: Type -> Maybe (Typed Value) -> Maybe Int -> Doc +ppAlloca :: LLVM => Type -> Maybe (Typed Value) -> Maybe Int -> Doc ppAlloca ty mbLen mbAlign = "alloca" <+> ppType ty <> len <> align where len = fromMaybe empty $ do @@ -501,7 +512,7 @@ a <- mbAlign return (comma <+> "align" <+> int a) -ppCall :: Bool -> Type -> Value -> [Typed Value] -> Doc +ppCall :: LLVM => Bool -> Type -> Value -> [Typed Value] -> Doc ppCall tc ty f args | tc = "tail" <+> body | otherwise = body @@ -509,9 +520,9 @@ body = "call" <+> ppCallSym ty f <> parens (commas (map (ppTyped ppValue) args)) -ppCallSym :: Type -> Value -> Doc -ppCallSym (PtrTo (FunTy res _ _)) (ValSymbol sym) = ppType res <+> ppSymbol sym -ppCallSym ty val = ppType ty <+> ppValue val +ppCallSym :: LLVM => Type -> Value -> Doc +ppCallSym (PtrTo (FunTy res args va)) val = ppType res <+> ppArgList va (map ppType args) <+> ppValue val +ppCallSym ty val = ppType ty <+> ppValue val ppGEP :: LLVM => Bool -> Typed Value -> [Typed Value] -> Doc ppGEP ib ptr ixs = "getelementptr" <+> inbounds @@ -528,7 +539,7 @@ inbounds | ib = "inbounds" | otherwise = empty -ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc +ppInvoke :: LLVM => Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc ppInvoke ty f args to uw = body where body = "invoke" <+> ppType ty <+> ppValue f @@ -536,7 +547,7 @@ <+> "to" <+> ppType (PrimType Label) <+> ppLabel to <+> "unwind" <+> ppType (PrimType Label) <+> ppLabel uw -ppPhiArg :: (Value,BlockLabel) -> Doc +ppPhiArg :: LLVM => (Value,BlockLabel) -> Doc ppPhiArg (v,l) = char '[' <+> ppValue v <> comma <+> ppLabel l <+> char ']' ppICmpOp :: ICmpOp -> Doc @@ -569,7 +580,7 @@ ppFCmpOp Funo = "uno" ppFCmpOp Ftrue = "true" -ppValue :: Value -> Doc +ppValue :: LLVM => Value -> Doc ppValue val = case val of ValInteger i -> integer i ValBool b -> ppBool b @@ -593,7 +604,7 @@ ValAsm s a i c -> ppAsm s a i c ValMd m -> ppValMd m -ppValMd :: ValMd -> Doc +ppValMd :: LLVM => ValMd -> Doc ppValMd m = case m of ValMdString str -> ppMetadata (ppStringLiteral str) ValMdValue tv -> ppTyped ppValue tv @@ -602,8 +613,9 @@ ValMdLoc l -> ppDebugLoc l ValMdDebugInfo di -> ppDebugInfo di -ppDebugLoc :: DebugLoc -> Doc -ppDebugLoc dl = "!MDLocation" +ppDebugLoc :: LLVM => DebugLoc -> Doc +ppDebugLoc dl = (if cfgUseDILocation ?config then "!DILocation" + else "!MDLocation") <> parens (commas [ "line:" <+> integral (dlLine dl) , "column:" <+> integral (dlCol dl) , "scope:" <+> ppValMd (dlScope dl) @@ -614,13 +626,13 @@ Just md -> comma <+> "inlinedAt:" <+> ppValMd md Nothing -> empty -ppTypedValMd :: ValMd -> Doc +ppTypedValMd :: LLVM => ValMd -> Doc ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata) ppMetadata :: Doc -> Doc ppMetadata body = char '!' <> body -ppMetadataNode :: [Maybe ValMd] -> Doc +ppMetadataNode :: LLVM => [Maybe ValMd] -> Doc ppMetadataNode vs = ppMetadata (braces (commas (map arg vs))) where arg = maybe ("null") ppValMd @@ -628,7 +640,8 @@ ppStringLiteral :: String -> Doc ppStringLiteral = doubleQuotes . text . concatMap escape where - escape c | isAscii c && isPrint c = [c] + escape c | c == '"' || c == '\\' = '\\' : showHex (fromEnum c) "" + | isAscii c && isPrint c = [c] | otherwise = '\\' : pad (ord c) pad n | n < 0x10 = '0' : map toUpper (showHex n "") @@ -646,7 +659,7 @@ | otherwise = empty -ppConstExpr :: ConstExpr -> Doc +ppConstExpr :: LLVM => ConstExpr -> Doc ppConstExpr (ConstGEP inb mp ixs) = "getelementptr" <+> opt inb "inbounds" <+> parens (mcommas ((ppType <$> mp) : (map (pure . ppTyped ppValue) ixs))) @@ -670,7 +683,7 @@ -- DWARF Debug Info ------------------------------------------------------------ -ppDebugInfo :: DebugInfo -> Doc +ppDebugInfo :: LLVM => DebugInfo -> Doc ppDebugInfo di = case di of DebugInfoBasicType bt -> ppDIBasicType bt DebugInfoCompileUnit cu -> ppDICompileUnit cu @@ -697,7 +710,7 @@ , "encoding:" <+> integral (dibtEncoding bt) ]) -ppDICompileUnit :: DICompileUnit -> Doc +ppDICompileUnit :: LLVM => DICompileUnit -> Doc ppDICompileUnit cu = "!DICompileUnit" <> parens (mcommas [ pure ("language:" <+> integral (dicuLanguage cu)) @@ -705,7 +718,7 @@ , (("producer:" <+>) . doubleQuotes . text) <$> (dicuProducer cu) , pure ("isOptimized:" <+> ppBool (dicuIsOptimized cu)) - , pure ("flags:" <+> integral (dicuFlags cu)) + , pure ("flags:" <+> ppFlags (dicuFlags cu)) , pure ("runtimeVersion:" <+> integral (dicuRuntimeVersion cu)) , (("splitDebugFilename:" <+>) . doubleQuotes . text) <$> (dicuSplitDebugFilename cu) @@ -719,7 +732,10 @@ , pure ("dwoId:" <+> integral (dicuDWOId cu)) ]) -ppDICompositeType :: DICompositeType -> Doc +ppFlags :: Maybe String -> Doc +ppFlags mb = doubleQuotes (maybe empty text mb) + +ppDICompositeType :: LLVM => DICompositeType -> Doc ppDICompositeType ct = "!DICompositeType" <> parens (mcommas [ pure ("tag:" <+> integral (dictTag ct)) @@ -739,14 +755,14 @@ <$> (dictIdentifier ct) ]) -ppDIDerivedType :: DIDerivedType -> Doc +ppDIDerivedType :: LLVM => DIDerivedType -> Doc ppDIDerivedType dt = "!DIDerivedType" <> parens (mcommas [ pure ("tag:" <+> integral (didtTag dt)) , (("name:" <+>) . doubleQuotes . text) <$> (didtName dt) , (("file:" <+>) . ppValMd) <$> (didtFile dt) , pure ("line:" <+> integral (didtLine dt)) - , (("baseType:" <+>) . ppValMd) <$> (didtBaseType dt) + , ("baseType:" <+>) <$> (ppValMd <$> didtBaseType dt <|> Just "null") , pure ("size:" <+> integral (didtSize dt)) , pure ("align:" <+> integral (didtAlign dt)) , pure ("offset:" <+> integral (didtOffset dt)) @@ -770,7 +786,7 @@ , "directory:" <+> doubleQuotes (text (difDirectory f)) ]) -ppDIGlobalVariable :: DIGlobalVariable -> Doc +ppDIGlobalVariable :: LLVM => DIGlobalVariable -> Doc ppDIGlobalVariable gv = "!DIGlobalVariable" <> parens (mcommas [ (("scope:" <+>) . ppValMd) <$> (digvScope gv) @@ -782,19 +798,19 @@ , (("type:" <+>) . ppValMd) <$> (digvType gv) , pure ("isLocal:" <+> ppBool (digvIsLocal gv)) , pure ("isDefinition:" <+> ppBool (digvIsDefinition gv)) - , (("variable:" <+>) . ppValMd) <$> (digvType gv) + , (("variable:" <+>) . ppValMd) <$> (digvVariable gv) , (("declaration:" <+>) . ppValMd) <$> (digvDeclaration gv) , (("align:" <+>) . integral) <$> digvAlignment gv ]) -ppDIGlobalVariableExpression :: DIGlobalVariableExpression -> Doc +ppDIGlobalVariableExpression :: LLVM => DIGlobalVariableExpression -> Doc ppDIGlobalVariableExpression gve = "!DIGlobalVariableExpression" <> parens (mcommas [ (("var:" <+>) . ppValMd) <$> (digveVariable gve) , (("expr:" <+>) . ppValMd) <$> (digveExpression gve) ]) -ppDILexicalBlock :: DILexicalBlock -> Doc +ppDILexicalBlock :: LLVM => DILexicalBlock -> Doc ppDILexicalBlock ct = "!DILexicalBlock" <> parens (mcommas [ (("scope:" <+>) . ppValMd) <$> (dilbScope ct) @@ -803,7 +819,7 @@ , pure ("column:" <+> integral (dilbColumn ct)) ]) -ppDILexicalBlockFile :: DILexicalBlockFile -> Doc +ppDILexicalBlockFile :: LLVM => DILexicalBlockFile -> Doc ppDILexicalBlockFile lbf = "!DILexicalBlockFile" <> parens (mcommas [ pure ("scope:" <+> ppValMd (dilbfScope lbf)) @@ -811,7 +827,7 @@ , pure ("discriminator:" <+> integral (dilbfDiscriminator lbf)) ]) -ppDILocalVariable :: DILocalVariable -> Doc +ppDILocalVariable :: LLVM => DILocalVariable -> Doc ppDILocalVariable lv = "!DILocalVariable" <> parens (mcommas [ (("scope:" <+>) . ppValMd) <$> (dilvScope lv) @@ -823,7 +839,7 @@ , pure ("flags:" <+> integral (dilvFlags lv)) ]) -ppDISubprogram :: DISubprogram -> Doc +ppDISubprogram :: LLVM => DISubprogram -> Doc ppDISubprogram sp = "!DISubprogram" <> parens (mcommas [ (("scope:" <+>) . ppValMd) <$> (dispScope sp) @@ -852,7 +868,7 @@ , "lowerBound:" <+> integral (disrLowerBound sr) ]) -ppDISubroutineType :: DISubroutineType -> Doc +ppDISubroutineType :: LLVM => DISubroutineType -> Doc ppDISubroutineType st = "!DISubroutineType" <> parens (commas [ "flags:" <+> integral (distFlags st)