llvm-pretty 0.4.0.1 → 0.5
raw patch · 6 files changed
+781/−587 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Text.LLVM: instance (Show a, Show b) => Show (a :> b)
- Text.LLVM: instance Applicative BB
- Text.LLVM: instance Applicative LLVM
- Text.LLVM: instance DefineArgs () (BB ())
- Text.LLVM: instance DefineArgs (Type, Type) (Typed Value -> Typed Value -> BB ())
- Text.LLVM: instance DefineArgs (Type, Type, Type) (Typed Value -> Typed Value -> Typed Value -> BB ())
- Text.LLVM: instance DefineArgs Type (Typed Value -> BB ())
- Text.LLVM: instance DefineArgs as k => DefineArgs (Type :> as) (Typed Value -> k)
- Text.LLVM: instance Functor BB
- Text.LLVM: instance Functor LLVM
- Text.LLVM: instance IsString (BB a)
- Text.LLVM: instance IsValue Bool
- Text.LLVM: instance IsValue Double
- Text.LLVM: instance IsValue Float
- Text.LLVM: instance IsValue Ident
- Text.LLVM: instance IsValue Int
- Text.LLVM: instance IsValue Int16
- Text.LLVM: instance IsValue Int32
- Text.LLVM: instance IsValue Int64
- Text.LLVM: instance IsValue Int8
- Text.LLVM: instance IsValue Integer
- Text.LLVM: instance IsValue Symbol
- Text.LLVM: instance IsValue Value
- Text.LLVM: instance IsValue a => IsValue (Typed a)
- Text.LLVM: instance Monad BB
- Text.LLVM: instance Monad LLVM
- Text.LLVM: instance MonadFix BB
- Text.LLVM: instance MonadFix LLVM
- Text.LLVM: instance Show RW
- Text.LLVM.AST: aliasName :: GlobalAlias -> Symbol
- Text.LLVM.AST: aliasTarget :: GlobalAlias -> Value
- Text.LLVM.AST: aliasType :: GlobalAlias -> Type
- Text.LLVM.AST: angles :: Doc -> Doc
- Text.LLVM.AST: bbLabel :: BasicBlock' lab -> Maybe lab
- Text.LLVM.AST: bbStmts :: BasicBlock' lab -> [Stmt' lab]
- Text.LLVM.AST: breaks :: (a -> Bool) -> [a] -> [[a]]
- Text.LLVM.AST: colons :: [Doc] -> Doc
- Text.LLVM.AST: commas :: [Doc] -> Doc
- Text.LLVM.AST: decArgs :: Declare -> [Type]
- Text.LLVM.AST: decName :: Declare -> Symbol
- Text.LLVM.AST: decRetType :: Declare -> Type
- Text.LLVM.AST: decVarArgs :: Declare -> Bool
- Text.LLVM.AST: defArgs :: Define -> [Typed Ident]
- Text.LLVM.AST: defAttrs :: Define -> FunAttrs
- Text.LLVM.AST: defBody :: Define -> [BasicBlock]
- Text.LLVM.AST: defName :: Define -> Symbol
- Text.LLVM.AST: defRetType :: Define -> Type
- Text.LLVM.AST: defSection :: Define -> Maybe String
- Text.LLVM.AST: defVarArgs :: Define -> Bool
- Text.LLVM.AST: dlCol :: DebugLoc' lab -> Int32
- Text.LLVM.AST: dlIA :: DebugLoc' lab -> Maybe (ValMd' lab)
- Text.LLVM.AST: dlLine :: DebugLoc' lab -> Int32
- Text.LLVM.AST: dlScope :: DebugLoc' lab -> ValMd' lab
- Text.LLVM.AST: funGC :: FunAttrs -> Maybe GC
- Text.LLVM.AST: funLinkage :: FunAttrs -> Maybe Linkage
- Text.LLVM.AST: gaConstant :: GlobalAttrs -> Bool
- Text.LLVM.AST: gaLinkage :: GlobalAttrs -> Maybe Linkage
- Text.LLVM.AST: getGC :: GC -> String
- Text.LLVM.AST: globalAlign :: Global -> Maybe Align
- Text.LLVM.AST: globalAttrs :: Global -> GlobalAttrs
- Text.LLVM.AST: globalSym :: Global -> Symbol
- Text.LLVM.AST: globalType :: Global -> Type
- Text.LLVM.AST: globalValue :: Global -> Maybe Value
- Text.LLVM.AST: instance Eq ArithOp
- Text.LLVM.AST: instance Eq BlockLabel
- Text.LLVM.AST: instance Eq FloatType
- Text.LLVM.AST: instance Eq Ident
- Text.LLVM.AST: instance Eq Linkage
- Text.LLVM.AST: instance Eq Mangling
- Text.LLVM.AST: instance Eq PrimType
- Text.LLVM.AST: instance Eq Symbol
- Text.LLVM.AST: instance Eq ident => Eq (Type' ident)
- Text.LLVM.AST: instance Foldable Typed
- Text.LLVM.AST: instance Functor Clause'
- Text.LLVM.AST: instance Functor ConstExpr'
- Text.LLVM.AST: instance Functor DebugLoc'
- Text.LLVM.AST: instance Functor Instr'
- Text.LLVM.AST: instance Functor Stmt'
- Text.LLVM.AST: instance Functor Type'
- Text.LLVM.AST: instance Functor Typed
- Text.LLVM.AST: instance Functor ValMd'
- Text.LLVM.AST: instance Functor Value'
- Text.LLVM.AST: instance IsString BlockLabel
- Text.LLVM.AST: instance IsString Ident
- Text.LLVM.AST: instance IsString Symbol
- Text.LLVM.AST: instance Monoid Module
- Text.LLVM.AST: instance Ord BlockLabel
- Text.LLVM.AST: instance Ord FloatType
- Text.LLVM.AST: instance Ord Ident
- Text.LLVM.AST: instance Ord PrimType
- Text.LLVM.AST: instance Ord Symbol
- Text.LLVM.AST: instance Ord ident => Ord (Type' ident)
- Text.LLVM.AST: instance Show ArithOp
- Text.LLVM.AST: instance Show BitOp
- Text.LLVM.AST: instance Show BlockLabel
- Text.LLVM.AST: instance Show ConvOp
- Text.LLVM.AST: instance Show Declare
- Text.LLVM.AST: instance Show Define
- Text.LLVM.AST: instance Show FCmpOp
- Text.LLVM.AST: instance Show FloatType
- Text.LLVM.AST: instance Show FunAttrs
- Text.LLVM.AST: instance Show GC
- Text.LLVM.AST: instance Show Global
- Text.LLVM.AST: instance Show GlobalAlias
- Text.LLVM.AST: instance Show GlobalAttrs
- Text.LLVM.AST: instance Show ICmpOp
- Text.LLVM.AST: instance Show Ident
- Text.LLVM.AST: instance Show LayoutSpec
- Text.LLVM.AST: instance Show Linkage
- Text.LLVM.AST: instance Show Mangling
- Text.LLVM.AST: instance Show Module
- Text.LLVM.AST: instance Show NamedMd
- Text.LLVM.AST: instance Show PrimType
- Text.LLVM.AST: instance Show Symbol
- Text.LLVM.AST: instance Show TypeDecl
- Text.LLVM.AST: instance Show UnnamedMd
- Text.LLVM.AST: instance Show a => Show (Typed a)
- Text.LLVM.AST: instance Show ident => Show (Type' ident)
- Text.LLVM.AST: instance Show lab => Show (BasicBlock' lab)
- Text.LLVM.AST: instance Show lab => Show (Clause' lab)
- Text.LLVM.AST: instance Show lab => Show (ConstExpr' lab)
- Text.LLVM.AST: instance Show lab => Show (DebugLoc' lab)
- Text.LLVM.AST: instance Show lab => Show (Instr' lab)
- Text.LLVM.AST: instance Show lab => Show (Stmt' lab)
- Text.LLVM.AST: instance Show lab => Show (ValMd' lab)
- Text.LLVM.AST: instance Show lab => Show (Value' lab)
- Text.LLVM.AST: instance Traversable Typed
- Text.LLVM.AST: int32 :: Int32 -> Doc
- Text.LLVM.AST: modAliases :: Module -> [GlobalAlias]
- Text.LLVM.AST: modDataLayout :: Module -> DataLayout
- Text.LLVM.AST: modDeclares :: Module -> [Declare]
- Text.LLVM.AST: modDefines :: Module -> [Define]
- Text.LLVM.AST: modGlobals :: Module -> [Global]
- Text.LLVM.AST: modInlineAsm :: Module -> InlineAsm
- Text.LLVM.AST: modNamedMd :: Module -> [NamedMd]
- Text.LLVM.AST: modTypes :: Module -> [TypeDecl]
- Text.LLVM.AST: modUnnamedMd :: Module -> [UnnamedMd]
- Text.LLVM.AST: nmName :: NamedMd -> String
- Text.LLVM.AST: nmValues :: NamedMd -> [Int]
- Text.LLVM.AST: opt :: Bool -> Doc -> Doc
- Text.LLVM.AST: ppAlign :: Maybe Align -> Doc
- Text.LLVM.AST: ppAlloca :: Type -> Maybe (Typed Value) -> Maybe Int -> Doc
- Text.LLVM.AST: ppArgList :: Bool -> [Doc] -> Doc
- Text.LLVM.AST: ppArithOp :: ArithOp -> Doc
- Text.LLVM.AST: ppAsm :: Bool -> Bool -> String -> String -> Doc
- Text.LLVM.AST: ppAttachedMetadata :: [(String, ValMd)] -> Doc
- Text.LLVM.AST: ppBasicBlock :: BasicBlock -> Doc
- Text.LLVM.AST: ppBitOp :: BitOp -> Doc
- Text.LLVM.AST: ppBool :: Bool -> Doc
- Text.LLVM.AST: ppCall :: Bool -> Type -> Value -> [Typed Value] -> Doc
- Text.LLVM.AST: ppCallSym :: Type -> Value -> Doc
- Text.LLVM.AST: ppClause :: Clause -> Doc
- Text.LLVM.AST: ppClauses :: Bool -> [Clause] -> Doc
- Text.LLVM.AST: ppConstExpr :: ConstExpr -> Doc
- Text.LLVM.AST: ppConvOp :: ConvOp -> Doc
- Text.LLVM.AST: ppDataLayout :: DataLayout -> Doc
- Text.LLVM.AST: ppDebugLoc :: DebugLoc -> Doc
- Text.LLVM.AST: ppDeclare :: Declare -> Doc
- Text.LLVM.AST: ppDefine :: Define -> Doc
- Text.LLVM.AST: ppExact :: Bool -> Doc
- Text.LLVM.AST: ppFCmpOp :: FCmpOp -> Doc
- Text.LLVM.AST: ppFloatType :: FloatType -> Doc
- Text.LLVM.AST: ppGC :: GC -> Doc
- Text.LLVM.AST: ppGEP :: Bool -> Typed Value -> [Typed Value] -> Doc
- Text.LLVM.AST: ppGlobal :: Global -> Doc
- Text.LLVM.AST: ppGlobalAlias :: GlobalAlias -> Doc
- Text.LLVM.AST: ppGlobalAttrs :: GlobalAttrs -> Doc
- Text.LLVM.AST: ppICmpOp :: ICmpOp -> Doc
- Text.LLVM.AST: ppIdent :: Ident -> Doc
- Text.LLVM.AST: ppInlineAsm :: InlineAsm -> Doc
- Text.LLVM.AST: ppInstr :: Instr -> Doc
- Text.LLVM.AST: ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc
- Text.LLVM.AST: ppLabel :: BlockLabel -> Doc
- Text.LLVM.AST: ppLabelDef :: BlockLabel -> Doc
- Text.LLVM.AST: ppLayoutBody :: Int -> Int -> Maybe Int -> Doc
- Text.LLVM.AST: ppLayoutSpec :: LayoutSpec -> Doc
- Text.LLVM.AST: ppLinkage :: Linkage -> Doc
- Text.LLVM.AST: ppMangling :: Mangling -> Doc
- Text.LLVM.AST: ppMaybe :: (a -> Doc) -> Maybe a -> Doc
- Text.LLVM.AST: ppMetadata :: Doc -> Doc
- Text.LLVM.AST: ppMetadataNode :: [Maybe ValMd] -> Doc
- Text.LLVM.AST: ppModule :: Module -> Doc
- Text.LLVM.AST: ppNamedMd :: NamedMd -> Doc
- Text.LLVM.AST: ppPhiArg :: (Value, BlockLabel) -> Doc
- Text.LLVM.AST: ppPrimType :: PrimType -> Doc
- Text.LLVM.AST: ppSignBits :: Bool -> Bool -> Doc
- Text.LLVM.AST: ppStmt :: Stmt -> Doc
- Text.LLVM.AST: ppStringLiteral :: String -> Doc
- Text.LLVM.AST: ppSwitchEntry :: Type -> (Integer, BlockLabel) -> Doc
- Text.LLVM.AST: ppSymbol :: Symbol -> Doc
- Text.LLVM.AST: ppType :: Type -> Doc
- Text.LLVM.AST: ppTypeDecl :: TypeDecl -> Doc
- Text.LLVM.AST: ppTyped :: (a -> Doc) -> Typed a -> Doc
- Text.LLVM.AST: ppTypedLabel :: BlockLabel -> Doc
- Text.LLVM.AST: ppTypedValMd :: ValMd -> Doc
- Text.LLVM.AST: ppUnnamedMd :: UnnamedMd -> Doc
- Text.LLVM.AST: ppValMd :: ValMd -> Doc
- Text.LLVM.AST: ppValue :: Value -> Doc
- Text.LLVM.AST: ppVectorIndex :: Value -> Doc
- Text.LLVM.AST: structBraces :: Doc -> Doc
- Text.LLVM.AST: typeName :: TypeDecl -> Ident
- Text.LLVM.AST: typeValue :: TypeDecl -> Type
- Text.LLVM.AST: typedType :: Typed a -> Type
- Text.LLVM.AST: typedValue :: Typed a -> a
- Text.LLVM.AST: umDistinct :: UnnamedMd -> Bool
- Text.LLVM.AST: umIndex :: UnnamedMd -> !Int
- Text.LLVM.AST: umValues :: UnnamedMd -> [Maybe ValMd]
- Text.LLVM.AST: uncons :: MonadPlus m => [a] -> m (a, [a])
- Text.LLVM.Labels: instance HasLabel Clause'
- Text.LLVM.Labels: instance HasLabel ConstExpr'
- Text.LLVM.Labels: instance HasLabel DebugLoc'
- Text.LLVM.Labels: instance HasLabel Instr'
- Text.LLVM.Labels: instance HasLabel Stmt'
- Text.LLVM.Labels: instance HasLabel ValMd'
- Text.LLVM.Labels: instance HasLabel Value'
+ Text.LLVM: instance (GHC.Show.Show a, GHC.Show.Show b) => GHC.Show.Show (a Text.LLVM.:> b)
+ Text.LLVM: instance Control.Monad.Fix.MonadFix Text.LLVM.BB
+ Text.LLVM: instance Control.Monad.Fix.MonadFix Text.LLVM.LLVM
+ Text.LLVM: instance Data.String.IsString (Text.LLVM.BB a)
+ Text.LLVM: instance GHC.Base.Applicative Text.LLVM.BB
+ Text.LLVM: instance GHC.Base.Applicative Text.LLVM.LLVM
+ Text.LLVM: instance GHC.Base.Functor Text.LLVM.BB
+ Text.LLVM: instance GHC.Base.Functor Text.LLVM.LLVM
+ Text.LLVM: instance GHC.Base.Monad Text.LLVM.BB
+ Text.LLVM: instance GHC.Base.Monad Text.LLVM.LLVM
+ Text.LLVM: instance GHC.Show.Show Text.LLVM.RW
+ Text.LLVM: instance Text.LLVM.DefineArgs () (Text.LLVM.BB ())
+ Text.LLVM: instance Text.LLVM.DefineArgs (Text.LLVM.AST.Type, Text.LLVM.AST.Type) (Text.LLVM.AST.Typed Text.LLVM.AST.Value -> Text.LLVM.AST.Typed Text.LLVM.AST.Value -> Text.LLVM.BB ())
+ Text.LLVM: instance Text.LLVM.DefineArgs (Text.LLVM.AST.Type, Text.LLVM.AST.Type, Text.LLVM.AST.Type) (Text.LLVM.AST.Typed Text.LLVM.AST.Value -> Text.LLVM.AST.Typed Text.LLVM.AST.Value -> Text.LLVM.AST.Typed Text.LLVM.AST.Value -> Text.LLVM.BB ())
+ Text.LLVM: instance Text.LLVM.DefineArgs Text.LLVM.AST.Type (Text.LLVM.AST.Typed Text.LLVM.AST.Value -> Text.LLVM.BB ())
+ Text.LLVM: instance Text.LLVM.DefineArgs as k => Text.LLVM.DefineArgs (Text.LLVM.AST.Type Text.LLVM.:> as) (Text.LLVM.AST.Typed Text.LLVM.AST.Value -> k)
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Int.Int16
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Int.Int32
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Int.Int64
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Int.Int8
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Integer.Type.Integer
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Types.Bool
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Types.Double
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Types.Float
+ Text.LLVM: instance Text.LLVM.IsValue GHC.Types.Int
+ Text.LLVM: instance Text.LLVM.IsValue Text.LLVM.AST.Ident
+ Text.LLVM: instance Text.LLVM.IsValue Text.LLVM.AST.Symbol
+ Text.LLVM: instance Text.LLVM.IsValue Text.LLVM.AST.Value
+ Text.LLVM: instance Text.LLVM.IsValue a => Text.LLVM.IsValue (Text.LLVM.AST.Typed a)
+ Text.LLVM: switch :: IsValue a => Typed a -> Ident -> [(Integer, Ident)] -> BB ()
+ Text.LLVM.AST: [aliasName] :: GlobalAlias -> Symbol
+ Text.LLVM.AST: [aliasTarget] :: GlobalAlias -> Value
+ Text.LLVM.AST: [aliasType] :: GlobalAlias -> Type
+ Text.LLVM.AST: [bbLabel] :: BasicBlock' lab -> Maybe lab
+ Text.LLVM.AST: [bbStmts] :: BasicBlock' lab -> [Stmt' lab]
+ Text.LLVM.AST: [decArgs] :: Declare -> [Type]
+ Text.LLVM.AST: [decName] :: Declare -> Symbol
+ Text.LLVM.AST: [decRetType] :: Declare -> Type
+ Text.LLVM.AST: [decVarArgs] :: Declare -> Bool
+ Text.LLVM.AST: [defArgs] :: Define -> [Typed Ident]
+ Text.LLVM.AST: [defAttrs] :: Define -> FunAttrs
+ Text.LLVM.AST: [defBody] :: Define -> [BasicBlock]
+ Text.LLVM.AST: [defName] :: Define -> Symbol
+ Text.LLVM.AST: [defRetType] :: Define -> Type
+ Text.LLVM.AST: [defSection] :: Define -> Maybe String
+ Text.LLVM.AST: [defVarArgs] :: Define -> Bool
+ Text.LLVM.AST: [dlCol] :: DebugLoc' lab -> Int32
+ Text.LLVM.AST: [dlIA] :: DebugLoc' lab -> Maybe (ValMd' lab)
+ Text.LLVM.AST: [dlLine] :: DebugLoc' lab -> Int32
+ Text.LLVM.AST: [dlScope] :: DebugLoc' lab -> ValMd' lab
+ Text.LLVM.AST: [funGC] :: FunAttrs -> Maybe GC
+ Text.LLVM.AST: [funLinkage] :: FunAttrs -> Maybe Linkage
+ Text.LLVM.AST: [gaConstant] :: GlobalAttrs -> Bool
+ Text.LLVM.AST: [gaLinkage] :: GlobalAttrs -> Maybe Linkage
+ Text.LLVM.AST: [getGC] :: GC -> String
+ Text.LLVM.AST: [globalAlign] :: Global -> Maybe Align
+ Text.LLVM.AST: [globalAttrs] :: Global -> GlobalAttrs
+ Text.LLVM.AST: [globalSym] :: Global -> Symbol
+ Text.LLVM.AST: [globalType] :: Global -> Type
+ Text.LLVM.AST: [globalValue] :: Global -> Maybe Value
+ Text.LLVM.AST: [modAliases] :: Module -> [GlobalAlias]
+ Text.LLVM.AST: [modDataLayout] :: Module -> DataLayout
+ Text.LLVM.AST: [modDeclares] :: Module -> [Declare]
+ Text.LLVM.AST: [modDefines] :: Module -> [Define]
+ Text.LLVM.AST: [modGlobals] :: Module -> [Global]
+ Text.LLVM.AST: [modInlineAsm] :: Module -> InlineAsm
+ Text.LLVM.AST: [modNamedMd] :: Module -> [NamedMd]
+ Text.LLVM.AST: [modTypes] :: Module -> [TypeDecl]
+ Text.LLVM.AST: [modUnnamedMd] :: Module -> [UnnamedMd]
+ Text.LLVM.AST: [nmName] :: NamedMd -> String
+ Text.LLVM.AST: [nmValues] :: NamedMd -> [Int]
+ Text.LLVM.AST: [typeName] :: TypeDecl -> Ident
+ Text.LLVM.AST: [typeValue] :: TypeDecl -> Type
+ Text.LLVM.AST: [typedType] :: Typed a -> Type
+ Text.LLVM.AST: [typedValue] :: Typed a -> a
+ Text.LLVM.AST: [umDistinct] :: UnnamedMd -> Bool
+ Text.LLVM.AST: [umIndex] :: UnnamedMd -> !Int
+ Text.LLVM.AST: [umValues] :: UnnamedMd -> [Maybe ValMd]
+ Text.LLVM.AST: instance Data.Foldable.Foldable Text.LLVM.AST.Typed
+ Text.LLVM.AST: instance Data.String.IsString Text.LLVM.AST.BlockLabel
+ Text.LLVM.AST: instance Data.String.IsString Text.LLVM.AST.Ident
+ Text.LLVM.AST: instance Data.String.IsString Text.LLVM.AST.Symbol
+ Text.LLVM.AST: instance Data.Traversable.Traversable Text.LLVM.AST.Typed
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.Clause'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.ConstExpr'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.DebugLoc'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.Instr'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.Stmt'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.Type'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.Typed
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.ValMd'
+ Text.LLVM.AST: instance GHC.Base.Functor Text.LLVM.AST.Value'
+ Text.LLVM.AST: instance GHC.Base.Monoid Text.LLVM.AST.Module
+ Text.LLVM.AST: instance GHC.Base.Monoid Text.LLVM.AST.Symbol
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.ArithOp
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.BlockLabel
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.FloatType
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.Ident
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.Linkage
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.Mangling
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.PrimType
+ Text.LLVM.AST: instance GHC.Classes.Eq Text.LLVM.AST.Symbol
+ Text.LLVM.AST: instance GHC.Classes.Eq ident => GHC.Classes.Eq (Text.LLVM.AST.Type' ident)
+ Text.LLVM.AST: instance GHC.Classes.Ord Text.LLVM.AST.BlockLabel
+ Text.LLVM.AST: instance GHC.Classes.Ord Text.LLVM.AST.FloatType
+ Text.LLVM.AST: instance GHC.Classes.Ord Text.LLVM.AST.Ident
+ Text.LLVM.AST: instance GHC.Classes.Ord Text.LLVM.AST.PrimType
+ Text.LLVM.AST: instance GHC.Classes.Ord Text.LLVM.AST.Symbol
+ Text.LLVM.AST: instance GHC.Classes.Ord ident => GHC.Classes.Ord (Text.LLVM.AST.Type' ident)
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.ArithOp
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.BitOp
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.BlockLabel
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.ConvOp
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Declare
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Define
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.FCmpOp
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.FloatType
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.FunAttrs
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.GC
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Global
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.GlobalAlias
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.GlobalAttrs
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.ICmpOp
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Ident
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.LayoutSpec
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Linkage
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Mangling
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Module
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.NamedMd
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.PrimType
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.Symbol
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.TypeDecl
+ Text.LLVM.AST: instance GHC.Show.Show Text.LLVM.AST.UnnamedMd
+ Text.LLVM.AST: instance GHC.Show.Show a => GHC.Show.Show (Text.LLVM.AST.Typed a)
+ Text.LLVM.AST: instance GHC.Show.Show ident => GHC.Show.Show (Text.LLVM.AST.Type' ident)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.BasicBlock' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.Clause' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.ConstExpr' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.DebugLoc' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.Instr' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.Stmt' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.ValMd' lab)
+ Text.LLVM.AST: instance GHC.Show.Show lab => GHC.Show.Show (Text.LLVM.AST.Value' lab)
+ Text.LLVM.AST: resolveGepFull :: (Ident -> Maybe Type) -> Type -> [Typed (Value' lab)] -> Maybe Type
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.Clause'
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.ConstExpr'
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.DebugLoc'
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.Instr'
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.Stmt'
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.ValMd'
+ Text.LLVM.Labels: instance Text.LLVM.Labels.HasLabel Text.LLVM.AST.Value'
+ Text.LLVM.PP: Config :: Bool -> Bool -> Config
+ Text.LLVM.PP: [cfgGEPImplicitType] :: Config -> Bool
+ Text.LLVM.PP: [cfgLoadImplicitType] :: Config -> Bool
+ Text.LLVM.PP: angles :: Doc -> Doc
+ Text.LLVM.PP: checkConfig :: LLVM => (Config -> Bool) -> Bool
+ Text.LLVM.PP: colons :: [Doc] -> Doc
+ Text.LLVM.PP: commas :: [Doc] -> Doc
+ Text.LLVM.PP: data Config
+ Text.LLVM.PP: int32 :: Int32 -> Doc
+ Text.LLVM.PP: opt :: Bool -> Doc -> Doc
+ Text.LLVM.PP: ppAlign :: Maybe Align -> Doc
+ Text.LLVM.PP: ppAlloca :: Type -> Maybe (Typed Value) -> Maybe Int -> Doc
+ Text.LLVM.PP: ppArgList :: Bool -> [Doc] -> Doc
+ Text.LLVM.PP: ppArithOp :: ArithOp -> Doc
+ Text.LLVM.PP: ppAsm :: Bool -> Bool -> String -> String -> Doc
+ Text.LLVM.PP: ppAttachedMetadata :: [(String, ValMd)] -> Doc
+ Text.LLVM.PP: ppBasicBlock :: LLVM => BasicBlock -> Doc
+ Text.LLVM.PP: ppBitOp :: BitOp -> Doc
+ Text.LLVM.PP: ppBool :: Bool -> Doc
+ Text.LLVM.PP: ppCall :: Bool -> Type -> Value -> [Typed Value] -> Doc
+ Text.LLVM.PP: ppCallSym :: Type -> Value -> Doc
+ Text.LLVM.PP: ppClause :: Clause -> Doc
+ Text.LLVM.PP: ppClauses :: Bool -> [Clause] -> Doc
+ Text.LLVM.PP: ppConstExpr :: ConstExpr -> Doc
+ Text.LLVM.PP: ppConvOp :: ConvOp -> Doc
+ Text.LLVM.PP: ppDataLayout :: DataLayout -> Doc
+ Text.LLVM.PP: ppDebugLoc :: DebugLoc -> Doc
+ Text.LLVM.PP: ppDeclare :: Declare -> Doc
+ Text.LLVM.PP: ppDefine :: LLVM => Define -> Doc
+ Text.LLVM.PP: ppExact :: Bool -> Doc
+ Text.LLVM.PP: ppFCmpOp :: FCmpOp -> Doc
+ Text.LLVM.PP: ppFloatType :: FloatType -> Doc
+ Text.LLVM.PP: ppGC :: GC -> Doc
+ Text.LLVM.PP: ppGEP :: LLVM => Bool -> Typed Value -> [Typed Value] -> Doc
+ Text.LLVM.PP: ppGlobal :: Global -> Doc
+ Text.LLVM.PP: ppGlobalAlias :: GlobalAlias -> Doc
+ Text.LLVM.PP: ppGlobalAttrs :: GlobalAttrs -> Doc
+ Text.LLVM.PP: ppICmpOp :: ICmpOp -> Doc
+ Text.LLVM.PP: ppIdent :: Ident -> Doc
+ Text.LLVM.PP: ppInlineAsm :: InlineAsm -> Doc
+ Text.LLVM.PP: ppInstr :: LLVM => Instr -> Doc
+ Text.LLVM.PP: ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc
+ Text.LLVM.PP: ppLLVM :: (LLVM => a) -> a
+ Text.LLVM.PP: ppLLVM35 :: (LLVM => a) -> a
+ Text.LLVM.PP: ppLLVM36 :: (LLVM => a) -> a
+ Text.LLVM.PP: ppLLVM37 :: (LLVM => a) -> a
+ Text.LLVM.PP: ppLLVM38 :: (LLVM => a) -> a
+ Text.LLVM.PP: ppLabel :: BlockLabel -> Doc
+ Text.LLVM.PP: ppLabelDef :: BlockLabel -> Doc
+ Text.LLVM.PP: ppLayoutBody :: Int -> Int -> Maybe Int -> Doc
+ Text.LLVM.PP: ppLayoutSpec :: LayoutSpec -> Doc
+ Text.LLVM.PP: ppLinkage :: Linkage -> Doc
+ Text.LLVM.PP: ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe Align -> Doc
+ Text.LLVM.PP: ppMangling :: Mangling -> Doc
+ Text.LLVM.PP: ppMaybe :: (a -> Doc) -> Maybe a -> Doc
+ Text.LLVM.PP: ppMetadata :: Doc -> Doc
+ Text.LLVM.PP: ppMetadataNode :: [Maybe ValMd] -> Doc
+ Text.LLVM.PP: ppModule :: LLVM => Module -> Doc
+ Text.LLVM.PP: ppNamedMd :: NamedMd -> Doc
+ Text.LLVM.PP: ppPhiArg :: (Value, BlockLabel) -> Doc
+ Text.LLVM.PP: ppPrimType :: PrimType -> Doc
+ Text.LLVM.PP: ppSignBits :: Bool -> Bool -> Doc
+ Text.LLVM.PP: ppStmt :: LLVM => Stmt -> Doc
+ Text.LLVM.PP: ppStringLiteral :: String -> Doc
+ Text.LLVM.PP: ppSwitchEntry :: Type -> (Integer, BlockLabel) -> Doc
+ Text.LLVM.PP: ppSymbol :: Symbol -> Doc
+ Text.LLVM.PP: ppType :: Type -> Doc
+ Text.LLVM.PP: ppTypeDecl :: TypeDecl -> Doc
+ Text.LLVM.PP: ppTyped :: (a -> Doc) -> Typed a -> Doc
+ Text.LLVM.PP: ppTypedLabel :: BlockLabel -> Doc
+ Text.LLVM.PP: ppTypedValMd :: ValMd -> Doc
+ Text.LLVM.PP: ppUnnamedMd :: UnnamedMd -> Doc
+ Text.LLVM.PP: ppValMd :: ValMd -> Doc
+ Text.LLVM.PP: ppValue :: Value -> Doc
+ Text.LLVM.PP: ppVectorIndex :: Value -> Doc
+ Text.LLVM.PP: structBraces :: Doc -> Doc
+ Text.LLVM.PP: type LLVM = ?config :: Config
+ Text.LLVM.PP: withConfig :: Config -> (LLVM => a) -> a
- Text.LLVM.Labels: relabel :: (HasLabel f, Applicative m, Monad m) => (Maybe Symbol -> a -> m b) -> f a -> m (f b)
+ Text.LLVM.Labels: relabel :: (HasLabel f, Applicative m) => (Maybe Symbol -> a -> m b) -> f a -> m (f b)
Files
- llvm-pretty.cabal +5/−3
- src/Text/LLVM.hs +15/−1
- src/Text/LLVM/AST.hs +33/−527
- src/Text/LLVM/Labels.hs +63/−56
- src/Text/LLVM/PP.hs +647/−0
- src/Text/LLVM/Util.hs +18/−0
llvm-pretty.cabal view
@@ -1,5 +1,5 @@ Name: llvm-pretty-Version: 0.4.0.1+Version: 0.5 License: BSD3 License-file: LICENSE Author: Trevor Elliott@@ -22,9 +22,11 @@ Default-language: Haskell2010 Hs-source-dirs: src- Exposed-modules: Text.LLVM,- Text.LLVM.AST,+ Exposed-modules: Text.LLVM+ Text.LLVM.AST Text.LLVM.Labels+ Text.LLVM.PP+ Other-modules: Text.LLVM.Util Build-depends: base >= 4 && < 5, containers >= 0.4,
src/Text/LLVM.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeOperators #-}@@ -7,6 +8,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances #-} +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+ module Text.LLVM ( -- * LLVM Monad LLVM()@@ -95,6 +100,7 @@ , select , call, call_ , invoke+ , switch , shuffleVector -- * Re-exported@@ -103,7 +109,6 @@ import Text.LLVM.AST -import Control.Applicative ( Applicative ) import Control.Monad.Fix (MonadFix) import Data.Char (ord) import Data.Int (Int8,Int16,Int32,Int64)@@ -114,7 +119,11 @@ import qualified Data.Sequence as Seq import qualified Data.Map.Strict as Map +#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ( Applicative )+#endif + -- Fresh Names ----------------------------------------------------------------- type Names = Map.Map String Int@@ -686,3 +695,8 @@ Type -> a -> [Typed Value] -> Ident -> Ident -> BB (Typed Value) invoke rty sym vs to uw = observe rty $ Invoke rty (toValue sym) vs (Named to) (Named uw)++-- | Emit a call instruction, but don't generate a new variable for its result.+switch :: IsValue a => Typed a -> Ident -> [(Integer, Ident)] -> BB ()+switch idx def dests = effect (Switch (toValue `fmap` idx) (Named def)+ (map (\(n, l) -> (n, Named l)) dests))
src/Text/LLVM/AST.hs view
@@ -1,58 +1,30 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} +#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+ module Text.LLVM.AST where -import Control.Applicative ((<$))+import Text.LLVM.Util (breaks,uncons)+ import Control.Monad (MonadPlus(mzero),(<=<),msum,guard,liftM,liftM3)-import Data.Char (isAscii,isPrint,ord,toUpper)-import Data.Foldable (Foldable(foldMap)) import Data.Int (Int32)-import Data.List (intersperse,genericIndex,genericLength,unfoldr)-import Data.Maybe (fromMaybe)-import Data.Monoid (Monoid(..))+import Data.List (genericIndex,genericLength) import Data.String (IsString(fromString))++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<$))+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(sequenceA))-import Numeric (showHex)-import Text.PrettyPrint.HughesPJ+#endif -commas :: [Doc] -> Doc-commas = hsep . punctuate (char ',')--colons :: [Doc] -> Doc-colons = hcat . intersperse (char ':')--breaks :: (a -> Bool) -> [a] -> [[a]]-breaks p = unfoldr step- where- step [] = Nothing- step xs = case break p xs of- (as,_:bs) -> Just (as,bs)- (as, []) -> Just (as,[])--uncons :: MonadPlus m => [a] -> m (a,[a])-uncons (a:as) = return (a,as)-uncons _ = mzero--int32 :: Int32 -> Doc-int32 = integer . fromIntegral--angles :: Doc -> Doc-angles d = char '<' <> d <> char '>'--structBraces :: Doc -> Doc-structBraces body = char '{' <+> body <+> char '}'--ppMaybe :: (a -> Doc) -> Maybe a -> Doc-ppMaybe = maybe empty--opt :: Bool -> Doc -> Doc-opt True d = d-opt False _ = empty- -- Modules --------------------------------------------------------------------- data Module = Module@@ -94,18 +66,6 @@ , modAliases = mempty } -ppModule :: Module -> Doc-ppModule m = foldr ($+$) empty- $ ppDataLayout (modDataLayout m)- : ppInlineAsm (modInlineAsm m)- : concat [ map ppTypeDecl (modTypes m)- , map ppGlobal (modGlobals m)- , map ppGlobalAlias (modAliases m)- , map ppDeclare (modDeclares m)- , map ppDefine (modDefines m)- , map ppNamedMd (modNamedMd m)- , map ppUnnamedMd (modUnnamedMd m)- ] -- Named Metadata -------------------------------------------------------------- @@ -114,10 +74,6 @@ , nmValues :: [Int] } deriving (Show) -ppNamedMd :: NamedMd -> Doc-ppNamedMd nm =- sep [ ppMetadata (text (nmName nm)) <+> char '='- , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ] -- Unnamed Metadata ------------------------------------------------------------ @@ -127,13 +83,6 @@ , umDistinct :: Bool } deriving (Show) -ppUnnamedMd :: UnnamedMd -> Doc-ppUnnamedMd um =- sep [ ppMetadata (int (umIndex um)) <+> char '='- , distinct <+> ppMetadataNode (umValues um) ]- where- distinct | umDistinct um = text "distinct"- | otherwise = empty -- Aliases --------------------------------------------------------------------- @@ -143,24 +92,11 @@ , aliasTarget :: Value } deriving (Show) -ppGlobalAlias :: GlobalAlias -> Doc-ppGlobalAlias g = ppSymbol (aliasName g) <+> char '=' <+> body- where- val = aliasTarget g- body = case val of- ValSymbol _sym -> ppType (aliasType g) <+> ppValue val- _ -> ppValue val -- Data Layout ----------------------------------------------------------------- type DataLayout = [LayoutSpec] --- | Pretty print a data layout specification.-ppDataLayout :: DataLayout -> Doc-ppDataLayout [] = empty-ppDataLayout ls = text "target" <+> text "datalayout" <+> char '='- <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls)))- data LayoutSpec = BigEndian | LittleEndian@@ -181,34 +117,6 @@ | WindowsCoffMangling deriving (Show,Eq) --- | Pretty print a single layout specification.-ppLayoutSpec :: LayoutSpec -> Doc-ppLayoutSpec BigEndian = char 'E'-ppLayoutSpec LittleEndian = char 'e'-ppLayoutSpec (PointerSize sz abi pref) = text "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' <> colons (map int szs)-ppLayoutSpec (StackAlign a) = char 'S' <> int a-ppLayoutSpec (Mangling m) = char 'm' <> char ':' <> ppMangling m---- | Pretty-print the common case for data layout specifications.-ppLayoutBody :: Int -> Int -> Maybe Int -> Doc-ppLayoutBody size abi mb = int size <> char ':' <> int abi <> pref- where- pref = case mb of- Nothing -> empty- Just p -> char ':' <> int p--ppMangling :: Mangling -> Doc-ppMangling ElfMangling = char 'e'-ppMangling MipsMangling = char 'm'-ppMangling MachOMangling = char 'o'-ppMangling WindowsCoffMangling = char 'w'- -- | Parse the data layout string. parseDataLayout :: MonadPlus m => String -> m DataLayout parseDataLayout = mapM parseLayoutSpec . breaks (== '-')@@ -263,12 +171,6 @@ type InlineAsm = [String] --- | Pretty-print the inline assembly block.-ppInlineAsm :: InlineAsm -> Doc-ppInlineAsm = foldr ($+$) empty . map ppLine- where- ppLine l = text "module asm" <+> doubleQuotes (text l)- -- Identifiers ----------------------------------------------------------------- newtype Ident = Ident String@@ -277,20 +179,18 @@ instance IsString Ident where fromString = Ident -ppIdent :: Ident -> Doc-ppIdent (Ident n) = char '%' <> text n- -- Symbols --------------------------------------------------------------------- newtype Symbol = Symbol String deriving (Show,Eq,Ord) +instance Monoid Symbol where+ mappend (Symbol a) (Symbol b) = Symbol (mappend a b)+ mempty = Symbol mempty+ instance IsString Symbol where fromString = Symbol -ppSymbol :: Symbol -> Doc-ppSymbol (Symbol n) = char '@' <> text n- -- Types ----------------------------------------------------------------------- data PrimType@@ -302,14 +202,6 @@ | Metadata deriving (Eq, Ord, Show) -ppPrimType :: PrimType -> Doc-ppPrimType Label = text "label"-ppPrimType Void = text "void"-ppPrimType (Integer i) = char 'i' <> integer (toInteger i)-ppPrimType (FloatType ft) = ppFloatType ft-ppPrimType X86mmx = text "x86mmx"-ppPrimType Metadata = text "metadata"- data FloatType = Half | Float@@ -319,14 +211,6 @@ | PPC_fp128 deriving (Eq, Ord, Show) -ppFloatType :: FloatType -> Doc-ppFloatType Half = text "half"-ppFloatType Float = text "float"-ppFloatType Double = text "double"-ppFloatType Fp128 = text "fp128"-ppFloatType X86_fp80 = text "x86_fp80"-ppFloatType PPC_fp128 = text "ppc_fp128"- type Type = Type' Ident data Type' ident@@ -357,17 +241,6 @@ Opaque -> Opaque -ppType :: Type -> Doc-ppType (PrimType pt) = ppPrimType pt-ppType (Alias i) = ppIdent i-ppType (Array len ty) = brackets (int32 len <+> char 'x' <+> ppType ty)-ppType (PtrTo ty) = ppType ty <> char '*'-ppType (Struct ts) = structBraces (commas (map ppType ts))-ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts)))-ppType (FunTy r as va) = ppType r <> ppArgList va (map ppType as)-ppType (Vector len pt) = angles (int32 len <+> char 'x' <+> ppType pt)-ppType Opaque = text "opaque"- isFloatingPoint :: PrimType -> Bool isFloatingPoint (FloatType _) = True isFloatingPoint _ = False@@ -405,10 +278,6 @@ isPointer (PtrTo _) = True isPointer _ = False --- | Build a variable-argument argument list.-ppArgList :: Bool -> [Doc] -> Doc-ppArgList True ds = parens (commas (ds ++ [text "..."]))-ppArgList False ds = parens (commas ds) -- Null Values ----------------------------------------------------------------- @@ -481,9 +350,6 @@ , typeValue :: Type } deriving (Show) -ppTypeDecl :: TypeDecl -> Doc-ppTypeDecl td = ppIdent (typeName td) <+> char '='- <+> text "type" <+> ppType (typeValue td) -- Globals --------------------------------------------------------------------- @@ -495,12 +361,6 @@ , globalAlign :: Maybe Align } deriving Show -ppGlobal :: Global -> Doc-ppGlobal g = ppSymbol (globalSym g) <+> char '='- <+> ppGlobalAttrs (globalAttrs g)- <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g)- <> ppAlign (globalAlign g)- addGlobal :: Global -> Module -> Module addGlobal g m = m { modGlobals = g : modGlobals m } @@ -515,11 +375,6 @@ , gaConstant = False } -ppGlobalAttrs :: GlobalAttrs -> Doc-ppGlobalAttrs ga = ppMaybe ppLinkage (gaLinkage ga) <+> constant- where- constant | gaConstant ga = text "constant"- | otherwise = text "global" -- Declarations ---------------------------------------------------------------- @@ -534,11 +389,6 @@ decFunType :: Declare -> Type decFunType Declare { .. } = PtrTo (FunTy decRetType decArgs decVarArgs) -ppDeclare :: Declare -> Doc-ppDeclare d = text "declare"- <+> ppType (decRetType d)- <+> ppSymbol (decName d)- <> ppArgList (decVarArgs d) (map ppType (decArgs d)) -- Function Definitions -------------------------------------------------------- @@ -556,18 +406,6 @@ defFunType Define { .. } = PtrTo (FunTy defRetType (map typedType defArgs) defVarArgs) -ppDefine :: Define -> Doc-ppDefine d = text "define"- <+> ppMaybe ppLinkage (funLinkage (defAttrs d))- <+> ppType (defRetType d)- <+> ppSymbol (defName d)- <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d))- <+> ppMaybe (\s -> text "section" <+> doubleQuotes (text s)) (defSection d)- <+> ppMaybe (\gc -> text "gc" <+> ppGC gc) (funGC (defAttrs d))- <+> char '{'- $+$ vcat (map ppBasicBlock (defBody d))- $+$ char '}'- addDefine :: Define -> Module -> Module addDefine d m = m { modDefines = d : modDefines m } @@ -592,14 +430,6 @@ instance IsString BlockLabel where fromString str = Named (fromString str) -ppLabelDef :: BlockLabel -> Doc-ppLabelDef (Named (Ident l)) = text l <> char ':'-ppLabelDef (Anon i) = char ';' <+> text "<label>:" <+> int i--ppLabel :: BlockLabel -> Doc-ppLabel (Named l) = ppIdent l-ppLabel (Anon i) = char '%' <> int i- -- Basic Blocks ---------------------------------------------------------------- data BasicBlock' lab = BasicBlock@@ -609,10 +439,6 @@ type BasicBlock = BasicBlock' BlockLabel -ppBasicBlock :: BasicBlock -> Doc-ppBasicBlock bb = ppMaybe ppLabelDef (bbLabel bb)- $+$ nest 2 (vcat (map ppStmt (bbStmts bb)))- brTargets :: BasicBlock' lab -> [lab] brTargets (BasicBlock _ stmts) = case stmtInstr (last stmts) of@@ -645,32 +471,10 @@ | DLLExport deriving (Eq,Show) -ppLinkage :: Linkage -> Doc-ppLinkage linkage = case linkage of- Private -> text "private"- LinkerPrivate -> text "linker_private"- LinkerPrivateWeak -> text "linker_private_weak"- LinkerPrivateWeakDefAuto -> text "linker_private_weak_def_auto"- Internal -> text "internal"- AvailableExternally -> text "available_externally"- Linkonce -> text "linkonce"- Weak -> text "weak"- Common -> text "common"- Appending -> text "appending"- ExternWeak -> text "extern_weak"- LinkonceODR -> text "linkonce_ddr"- WeakODR -> text "weak_odr"- External -> text "external"- DLLImport -> text "dllimport"- DLLExport -> text "dllexport"- newtype GC = GC { getGC :: String } deriving (Show) -ppGC :: GC -> Doc-ppGC = doubleQuotes . text . getGC- -- Typed Things ---------------------------------------------------------------- data Typed a = Typed@@ -691,9 +495,6 @@ b <- f (typedValue t) return t { typedValue = b } -ppTyped :: (a -> Doc) -> Typed a -> Doc-ppTyped fmt ty = ppType (typedType ty) <+> fmt (typedValue ty)- -- Instructions ---------------------------------------------------------------- data ArithOp@@ -751,26 +552,6 @@ deriving (Eq,Show) -ppSignBits :: Bool -> Bool -> Doc-ppSignBits nuw nsw = opt nuw (text "nuw") <+> opt nsw (text "nsw")--ppExact :: Bool -> Doc-ppExact e = opt e (text "exact")--ppArithOp :: ArithOp -> Doc-ppArithOp (Add nuw nsw) = text "add" <+> ppSignBits nuw nsw-ppArithOp FAdd = text "fadd"-ppArithOp (Sub nuw nsw) = text "sub" <+> ppSignBits nuw nsw-ppArithOp FSub = text "fsub"-ppArithOp (Mul nuw nsw) = text "mul" <+> ppSignBits nuw nsw-ppArithOp FMul = text "fmul"-ppArithOp (UDiv e) = text "udiv" <+> ppExact e-ppArithOp (SDiv e) = text "sdiv" <+> ppExact e-ppArithOp FDiv = text "fdiv"-ppArithOp URem = text "urem"-ppArithOp SRem = text "srem"-ppArithOp FRem = text "frem"- isIArith :: ArithOp -> Bool isIArith Add{} = True isIArith Sub{} = True@@ -820,14 +601,6 @@ | Xor deriving Show -ppBitOp :: BitOp -> Doc-ppBitOp (Shl nuw nsw) = text "shl" <+> ppSignBits nuw nsw-ppBitOp (Lshr e) = text "lshr" <+> ppExact e-ppBitOp (Ashr e) = text "ashr" <+> ppExact e-ppBitOp And = text "and"-ppBitOp Or = text "or"-ppBitOp Xor = text "xor"- data ConvOp = Trunc | ZExt@@ -843,20 +616,6 @@ | BitCast deriving Show -ppConvOp :: ConvOp -> Doc-ppConvOp Trunc = text "trunc"-ppConvOp ZExt = text "zext"-ppConvOp SExt = text "sext"-ppConvOp FpTrunc = text "fptrunc"-ppConvOp FpExt = text "fpext"-ppConvOp FpToUi = text "fptoui"-ppConvOp FpToSi = text "fptosi"-ppConvOp UiToFp = text "uitofp"-ppConvOp SiToFp = text "sitofp"-ppConvOp PtrToInt = text "ptrtoint"-ppConvOp IntToPtr = text "inttoptr"-ppConvOp BitCast = text "bitcast"- type Align = Int data Instr' lab@@ -1046,179 +805,14 @@ isPhi Phi{} = True isPhi _ = False -ppInstr :: Instr -> Doc-ppInstr instr = case instr of- Ret tv -> text "ret" <+> ppTyped ppValue tv- RetVoid -> text "ret void"- Arith op l r -> ppArithOp op <+> ppTyped ppValue l- <> comma <+> ppValue r- Bit op l r -> ppBitOp op <+> ppTyped ppValue l- <> comma <+> ppValue r- Conv op a ty -> ppConvOp op <+> ppTyped ppValue a- <+> text "to" <+> ppType ty- Call tc ty f args -> ppCall tc ty f args- Alloca ty len align -> ppAlloca ty len align- Load ptr ma -> text "load" <+> ppTyped ppValue ptr- <> ppAlign ma- Store a ptr ma -> text "store" <+> ppTyped ppValue a- <> comma <+> ppTyped ppValue ptr- <> ppAlign ma- ICmp op l r -> text "icmp" <+> ppICmpOp op- <+> ppTyped ppValue l <> comma <+> ppValue r- FCmp op l r -> text "fcmp" <+> ppFCmpOp op- <+> ppTyped ppValue l <> comma <+> ppValue r- Phi ty vls -> text "phi" <+> ppType ty- <+> commas (map ppPhiArg vls)- Select c t f -> text "select" <+> ppTyped ppValue c- <> comma <+> ppTyped ppValue t- <> comma <+> ppTyped ppValue (f <$ t)- ExtractValue v is -> text "extractvalue" <+> ppTyped ppValue v- <> comma <+> (commas (map int32 is))- InsertValue a v is -> text "insertvalue" <+> ppTyped ppValue a- <> comma <+> ppTyped ppValue v- <> comma <+> commas (map int32 is)- ShuffleVector a b m -> text "shufflevector" <+> ppTyped ppValue a- <> comma <+> ppTyped ppValue (b <$ a)- <> comma <+> ppTyped ppValue m- GEP ib ptr ixs -> ppGEP ib ptr ixs- Comment str -> char ';' <+> text str- Jump i -> text "br"- <+> ppTypedLabel i- Br c t f -> text "br" <+> ppTyped ppValue c- <> comma <+> ppType (PrimType Label)- <+> ppLabel t- <> comma <+> ppType (PrimType Label)- <+> ppLabel f- Invoke ty f args to uw -> ppInvoke ty f args to uw- Unreachable -> text "unreachable"- Unwind -> text "unwind"- VaArg al t -> text "va_arg" <+> ppTyped ppValue al- <> comma <+> ppType t- ExtractElt v i -> text "extractelement"- <+> ppTyped ppValue v- <> comma <+> ppVectorIndex i- InsertElt v e i -> text "insertelement"- <+> ppTyped ppValue v- <> comma <+> ppTyped ppValue e- <> comma <+> ppVectorIndex i- IndirectBr d ls -> text "indirectbr"- <+> ppTyped ppValue d- <> comma <+> commas (map ppTypedLabel ls)- Switch c d ls -> text "switch"- <+> ppTyped ppValue c- <> comma <+> ppTypedLabel d- <+> char '['- $$ nest 2 (vcat (map (ppSwitchEntry (typedType c)) ls))- $$ char ']'- LandingPad ty fn c cs -> text "landingpad"- <+> ppType ty- <+> text "personality"- <+> ppTyped ppValue fn- $$ nest 2 (ppClauses c cs)- Resume tv -> text "resume" <+> ppTyped ppValue tv--ppClauses :: Bool -> [Clause] -> Doc-ppClauses isCleanup cs = vcat (cleanup : map ppClause cs)- where- cleanup | isCleanup = text "cleanup"- | otherwise = empty--ppClause :: Clause -> Doc-ppClause c = case c of- Catch tv -> text "catch" <+> ppTyped ppValue tv- Filter tv -> text "filter" <+> ppTyped ppValue tv---ppTypedLabel :: BlockLabel -> Doc-ppTypedLabel i = ppType (PrimType Label) <+> ppLabel i--ppSwitchEntry :: Type -> (Integer,BlockLabel) -> Doc-ppSwitchEntry ty (i,l) = ppType ty <+> integer i <> comma <+> ppTypedLabel l--ppVectorIndex :: Value -> Doc-ppVectorIndex i = ppType (PrimType (Integer 32)) <+> ppValue i--ppAlign :: Maybe Align -> Doc-ppAlign Nothing = empty-ppAlign (Just align) = comma <+> text "align" <+> int align--ppAlloca :: Type -> Maybe (Typed Value) -> Maybe Int -> Doc-ppAlloca ty mbLen mbAlign = text "alloca" <+> ppType ty <> len <> align- where- len = fromMaybe empty $ do- l <- mbLen- return (comma <+> ppTyped ppValue l)- align = fromMaybe empty $ do- a <- mbAlign- return (comma <+> text "align" <+> int a)--ppCall :: Bool -> Type -> Value -> [Typed Value] -> Doc-ppCall tc ty f args- | tc = text "tail" <+> body- | otherwise = body- where- body = text "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--ppGEP :: Bool -> Typed Value -> [Typed Value] -> Doc-ppGEP ib ptr ixs = text "getelementptr" <+> inbounds- <+> commas (map (ppTyped ppValue) (ptr:ixs))- where- inbounds | ib = text "inbounds"- | otherwise = empty--ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc-ppInvoke ty f args to uw = body- where- body = text "invoke" <+> ppType ty <+> ppValue f- <> parens (commas (map (ppTyped ppValue) args))- <+> text "to" <+> ppType (PrimType Label) <+> ppLabel to- <+> text "unwind" <+> ppType (PrimType Label) <+> ppLabel uw--ppPhiArg :: (Value,BlockLabel) -> Doc-ppPhiArg (v,l) = char '[' <+> ppValue v <> comma <+> ppLabel l <+> char ']'- data ICmpOp = Ieq | Ine | Iugt | Iuge | Iult | Iule | Isgt | Isge | Islt | Isle deriving (Show) -ppICmpOp :: ICmpOp -> Doc-ppICmpOp Ieq = text "eq"-ppICmpOp Ine = text "ne"-ppICmpOp Iugt = text "ugt"-ppICmpOp Iuge = text "uge"-ppICmpOp Iult = text "ult"-ppICmpOp Iule = text "ule"-ppICmpOp Isgt = text "sgt"-ppICmpOp Isge = text "sge"-ppICmpOp Islt = text "slt"-ppICmpOp Isle = text "sle"- data FCmpOp = Ffalse | Foeq | Fogt | Foge | Folt | Fole | Fone | Ford | Fueq | Fugt | Fuge | Fult | Fule | Fune | Funo | Ftrue deriving (Show) -ppFCmpOp :: FCmpOp -> Doc-ppFCmpOp Ffalse = text "false"-ppFCmpOp Foeq = text "oeq"-ppFCmpOp Fogt = text "ogt"-ppFCmpOp Foge = text "oge"-ppFCmpOp Folt = text "olt"-ppFCmpOp Fole = text "ole"-ppFCmpOp Fone = text "one"-ppFCmpOp Ford = text "ord"-ppFCmpOp Fueq = text "ueq"-ppFCmpOp Fugt = text "ugt"-ppFCmpOp Fuge = text "uge"-ppFCmpOp Fult = text "ult"-ppFCmpOp Fule = text "ule"-ppFCmpOp Fune = text "une"-ppFCmpOp Funo = text "uno"-ppFCmpOp Ftrue = text "true" -- Values ---------------------------------------------------------------------- @@ -1274,85 +868,6 @@ isConst ValNull = True isConst _ = False -ppValue :: Value -> Doc-ppValue val = case val of- ValInteger i -> integer i- ValBool b -> ppBool b- ValFloat i -> float i- ValDouble i -> double i- ValIdent i -> ppIdent i- ValSymbol s -> ppSymbol s- ValNull -> text "null"- ValArray ty es -> brackets- $ commas (map (ppTyped ppValue . Typed ty) es)- ValVector ty es -> angles $ commas- $ map (ppTyped ppValue . Typed ty) es- ValStruct fs -> structBraces (commas (map (ppTyped ppValue) fs))- ValPackedStruct fs -> angles- $ structBraces (commas (map (ppTyped ppValue) fs))- ValString s -> char 'c' <> ppStringLiteral s- ValConstExpr ce -> ppConstExpr ce- ValUndef -> text "undef"- ValLabel l -> ppLabel l- ValZeroInit -> text "zeroinitializer"- ValAsm s a i c -> ppAsm s a i c- ValMd m -> ppValMd m--ppValMd :: ValMd -> Doc-ppValMd m = case m of- ValMdString str -> ppMetadata (ppStringLiteral str)- ValMdValue tv -> ppTyped ppValue tv- ValMdRef i -> ppMetadata (int i)- ValMdNode vs -> ppMetadataNode vs- ValMdLoc l -> ppDebugLoc l--ppDebugLoc :: DebugLoc -> Doc-ppDebugLoc dl = text "!MDLocation"- <> parens (commas [ text "line:" <+> int32 (dlLine dl)- , text "column:" <+> int32 (dlCol dl)- , text "scope:" <+> ppValMd (dlScope dl)- ] <+> mbIA)-- where- mbIA = case dlIA dl of- Just md -> comma <+> text "inlinedAt:" <+> ppValMd md- Nothing -> empty--ppTypedValMd :: ValMd -> Doc-ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata)--ppMetadata :: Doc -> Doc-ppMetadata body = char '!' <> body--ppMetadataNode :: [Maybe ValMd] -> Doc-ppMetadataNode vs = ppMetadata (braces (commas (map arg vs)))- where- arg = maybe (text "null") ppValMd--ppBool :: Bool -> Doc-ppBool b | b = text "true"- | otherwise = text "false"--ppStringLiteral :: String -> Doc-ppStringLiteral = doubleQuotes . text . concatMap escape- where- escape c | isAscii c && isPrint c = [c]- | otherwise = '\\' : pad (ord c)-- pad n | n < 0x10 = '0' : map toUpper (showHex n "")- | otherwise = map toUpper (showHex n "")--ppAsm :: Bool -> Bool -> String -> String -> Doc-ppAsm s a i c =- text "asm" <+> sideeffect <+> alignstack- <+> ppStringLiteral i <> comma <+> ppStringLiteral c- where- sideeffect | s = text "sideeffect"- | otherwise = empty-- alignstack | a = text "alignstack"- | otherwise = empty- -- Value Elimination ----------------------------------------------------------- elimValSymbol :: MonadPlus m => Value' lab -> m Symbol@@ -1386,20 +901,7 @@ Result r i mds -> Result r i (md:mds) Effect i mds -> Effect i (md:mds) -ppStmt :: Stmt -> Doc-ppStmt stmt = case stmt of- Result var i mds -> ppIdent var <+> char '=' <+> ppInstr i- <> ppAttachedMetadata mds- Effect i mds -> ppInstr i <> ppAttachedMetadata mds -ppAttachedMetadata :: [(String,ValMd)] -> Doc-ppAttachedMetadata mds- | null mds = empty- | otherwise = comma <+> commas (map step mds)- where- step (l,md) = ppMetadata (text l) <+> ppValMd md-- -- Constant Expressions -------------------------------------------------------- data ConstExpr' lab@@ -1411,17 +913,6 @@ type ConstExpr = ConstExpr' BlockLabel -ppConstExpr :: ConstExpr -> Doc-ppConstExpr (ConstGEP inb ixs) = text "getelementptr"- <+> opt inb (text "inbounds")- <+> parens (commas (map (ppTyped ppValue) ixs))-ppConstExpr (ConstConv op tv t) = ppConvOp op <+> parens- (ppTyped ppValue tv <+> text "to" <+> ppType t)-ppConstExpr (ConstSelect c l r) = text "select" <+> parens- (commas [ ppTyped ppValue c, ppTyped ppValue l- , ppTyped ppValue r])-ppConstExpr (ConstBlockAddr t l)= text "blockaddress" <+> parens- (ppSymbol t <> comma <+> ppLabel l) -- Aggregate Utilities ---------------------------------------------------------@@ -1435,6 +926,21 @@ isInvalid ir = case ir of Invalid -> True _ -> False++-- | Resolves the type of a GEP instruction. Type aliases are resolved+-- using the given function. An invalid use of GEP or one relying+-- on unknown type aliases will return 'Nothing'+resolveGepFull ::+ (Ident -> Maybe Type) {- ^ Type alias resolution -} ->+ Type {- ^ Pointer type -} ->+ [Typed (Value' lab)] {- ^ Path -} ->+ Maybe Type {- ^ Type of result -}+resolveGepFull env t ixs = go (resolveGep t ixs)+ where+ go Invalid = Nothing+ go (HasType result) = Just result+ go (Resolve ident resume) = go . resume =<< env ident+ -- | Resolve the type of a GEP instruction. Note that the type produced is the -- type of the result, not necessarily a pointer.
src/Text/LLVM/Labels.hs view
@@ -1,111 +1,118 @@+{-# LANGUAGE CPP #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif+ module Text.LLVM.Labels where import Text.LLVM.AST +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<$>),Applicative(..))-import qualified Data.Traversable as T+import Data.Traversable (traverse)+#endif class Functor f => HasLabel f where -- | Given a function for resolving labels, where the presence of a symbol -- denotes a label in a different function, rename all labels in a function.- relabel :: (Applicative m, Monad m)- => (Maybe Symbol -> a -> m b) -> f a -> m (f b)+ relabel :: Applicative m => (Maybe Symbol -> a -> m b) -> f a -> m (f b) instance HasLabel Stmt' where relabel f stmt = case stmt of- Result r i mds -> Result r <$> relabel f i <*> T.mapM relabelMd mds- Effect i mds -> Effect <$> relabel f i <*> T.mapM relabelMd mds+ Result r i mds -> Result r <$> relabel f i <*> traverse relabelMd mds+ Effect i mds -> Effect <$> relabel f i <*> traverse relabelMd mds where relabelMd (str,md) = (\md' -> (str,md')) `fmap` relabel f md instance HasLabel Instr' where- relabel _ RetVoid = return RetVoid- relabel _ Unreachable = return Unreachable- relabel _ Unwind = return Unwind- relabel _ (Comment str) = return (Comment str)- relabel f (Ret tv) = Ret <$> T.mapM (relabel f) tv+ relabel _ RetVoid = pure RetVoid+ relabel _ Unreachable = pure Unreachable+ relabel _ Unwind = pure Unwind+ relabel _ (Comment str) = pure (Comment str)+ relabel f (Ret tv) = Ret <$> traverse (relabel f) tv relabel f (Arith op l r) = Arith op- <$> T.mapM (relabel f) l+ <$> traverse (relabel f) l <*> relabel f r relabel f (Bit op l r) = Bit op- <$> T.mapM (relabel f) l+ <$> traverse (relabel f) l <*> relabel f r- relabel f (Conv op l r) = Conv op <$> T.mapM (relabel f) l <*> pure r+ relabel f (Conv op l r) = Conv op <$> traverse (relabel f) l <*> pure r relabel f (Call t r n as) = Call t r <$> relabel f n- <*> T.mapM (T.mapM (relabel f)) as+ <*> traverse (traverse (relabel f)) as relabel f (Alloca t n a) = Alloca t- <$> T.mapM (T.mapM (relabel f)) n+ <$> traverse (traverse (relabel f)) n <*> pure a- relabel f (Load a ma) = Load <$> T.mapM (relabel f) a <*> pure ma+ relabel f (Load a ma) = Load <$> traverse (relabel f) a <*> pure ma relabel f (Store d v ma) = Store- <$> T.mapM (relabel f) d- <*> T.mapM (relabel f) v+ <$> traverse (relabel f) d+ <*> traverse (relabel f) v <*> pure ma relabel f (ICmp op l r) = ICmp op- <$> T.mapM (relabel f) l+ <$> traverse (relabel f) l <*> relabel f r relabel f (FCmp op l r) = FCmp op- <$> T.mapM (relabel f) l+ <$> traverse (relabel f) l <*> relabel f r relabel f (GEP ib a is) = GEP ib- <$> T.mapM (relabel f) a- <*> T.mapM (T.mapM (relabel f)) is+ <$> traverse (relabel f) a+ <*> traverse (traverse (relabel f)) is relabel f (Select c l r) = Select- <$> T.mapM (relabel f) c- <*> T.mapM (relabel f) l <*> relabel f r+ <$> traverse (relabel f) c+ <*> traverse (relabel f) l <*> relabel f r relabel f (ExtractValue a is) = ExtractValue- <$> T.mapM (relabel f) a+ <$> traverse (relabel f) a <*> pure is relabel f (InsertValue a i is) = InsertValue- <$> T.mapM (relabel f) a- <*> T.mapM (relabel f) i+ <$> traverse (relabel f) a+ <*> traverse (relabel f) i <*> pure is relabel f (ShuffleVector a b m) = ShuffleVector- <$> T.mapM (relabel f) a+ <$> traverse (relabel f) a <*> relabel f b- <*> T.mapM (relabel f) m+ <*> traverse (relabel f) m relabel f (Jump lab) = Jump <$> f Nothing lab relabel f (Br c l r) = Br- <$> T.mapM (relabel f) c+ <$> traverse (relabel f) c <*> f Nothing l <*> f Nothing r relabel f (Invoke r s as u e) = Invoke r <$> relabel f s- <*> T.mapM (T.mapM (relabel f)) as+ <*> traverse (traverse (relabel f)) as <*> f Nothing u <*> f Nothing e relabel f (VaArg al t) = VaArg- <$> T.mapM (relabel f) al+ <$> traverse (relabel f) al <*> pure t relabel f (ExtractElt v i) = ExtractElt- <$> T.mapM (relabel f) v+ <$> traverse (relabel f) v <*> relabel f i relabel f (InsertElt v e i) = InsertElt- <$> T.mapM (relabel f) v- <*> T.mapM (relabel f) e+ <$> traverse (relabel f) v+ <*> traverse (relabel f) e <*> relabel f i relabel f (IndirectBr d ls) = IndirectBr- <$> T.mapM (relabel f) d- <*> T.mapM (f Nothing) ls+ <$> traverse (relabel f) d+ <*> traverse (f Nothing) ls relabel f (Switch c d ls) = let step (n,i) = (\l -> (n,l)) <$> f Nothing i- in Switch <$> T.mapM (relabel f) c <*> f Nothing d <*> T.mapM step ls+ in Switch <$> traverse (relabel f) c <*> f Nothing d <*> traverse step ls relabel f (Phi t ls) = let step (a,l) = (,) <$> relabel f a <*> f Nothing l- in Phi t <$> T.mapM step ls+ in Phi t <$> traverse step ls relabel f (LandingPad ty fn c cs) = LandingPad ty- <$> T.mapM (relabel f) fn+ <$> traverse (relabel f) fn <*> pure c- <*> T.mapM (relabel f) cs+ <*> traverse (relabel f) cs - relabel f (Resume tv) = Resume <$> T.mapM (relabel f) tv+ relabel f (Resume tv) = Resume <$> traverse (relabel f) tv instance HasLabel Clause' where relabel f clause = case clause of- Catch tv -> Catch <$> T.mapM (relabel f) tv- Filter tv -> Filter <$> T.mapM (relabel f) tv+ Catch tv -> Catch <$> traverse (relabel f) tv+ Filter tv -> Filter <$> traverse (relabel f) tv instance HasLabel Value' where relabel _ (ValInteger i) = pure (ValInteger i)@@ -120,25 +127,25 @@ relabel _ ValZeroInit = pure ValZeroInit relabel _ (ValAsm s a i c) = pure (ValAsm s a i c) relabel f (ValMd m) = ValMd <$> relabel f m- relabel f (ValArray t es) = ValArray t <$> T.mapM (relabel f) es- relabel f (ValVector pt es) = ValVector pt <$> T.mapM (relabel f) es- relabel f (ValStruct fs) = ValStruct <$> T.mapM (T.mapM (relabel f)) fs+ relabel f (ValArray t es) = ValArray t <$> traverse (relabel f) es+ relabel f (ValVector pt es) = ValVector pt <$> traverse (relabel f) es+ relabel f (ValStruct fs) = ValStruct <$> traverse (traverse (relabel f)) fs relabel f (ValConstExpr ce) = ValConstExpr <$> relabel f ce relabel f (ValLabel lab) = ValLabel <$> f Nothing lab relabel f (ValPackedStruct es) =- ValPackedStruct <$> T.mapM (T.mapM (relabel f)) es+ ValPackedStruct <$> traverse (traverse (relabel f)) es instance HasLabel ValMd' where relabel f md = case md of ValMdString str -> pure (ValMdString str)- ValMdValue tv -> ValMdValue <$> T.mapM (relabel f) tv+ ValMdValue tv -> ValMdValue <$> traverse (relabel f) tv ValMdRef i -> pure (ValMdRef i)- ValMdNode es -> ValMdNode <$> T.mapM (T.mapM (relabel f)) es+ ValMdNode es -> ValMdNode <$> traverse (traverse (relabel f)) es ValMdLoc dl -> ValMdLoc <$> relabel f dl instance HasLabel DebugLoc' where relabel f dl = upd <$> relabel f (dlScope dl)- <*> T.mapM (relabel f) (dlIA dl)+ <*> traverse (relabel f) (dlIA dl) where upd scope ia = dl { dlScope = scope@@ -147,13 +154,13 @@ instance HasLabel ConstExpr' where relabel f (ConstGEP inb is) = ConstGEP inb- <$> T.mapM (T.mapM (relabel f)) is+ <$> traverse (traverse (relabel f)) is relabel f (ConstConv op a t) = ConstConv op- <$> T.mapM (relabel f) a+ <$> traverse (relabel f) a <*> pure t relabel f (ConstSelect c l r) = ConstSelect- <$> T.mapM (relabel f) c- <*> T.mapM (relabel f) l- <*> T.mapM (relabel f) r+ <$> traverse (relabel f) c+ <*> traverse (relabel f) l+ <*> traverse (relabel f) r relabel f (ConstBlockAddr t l)= ConstBlockAddr t <$> f (Just t) l
+ src/Text/LLVM/PP.hs view
@@ -0,0 +1,647 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE Rank2Types #-}++-- |+-- Module : Text.LLVM.PP+-- Copyright : Trevor Elliott 2011-2016+-- License : BSD3+--+-- Maintainer : awesomelyawesome@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This is the pretty-printer for llvm assembly versions 3.6 and lower.+--+module Text.LLVM.PP where++import Text.LLVM.AST++import Data.Char (isAscii,isPrint,ord,toUpper)+import Data.Int (Int32)+import Data.List (intersperse)+import Data.Maybe (fromMaybe)+import Numeric (showHex)+import Text.PrettyPrint.HughesPJ+++-- Pretty-printer Config -------------------------------------------------------++type LLVM = ?config :: Config++-- | The differences between various versions of the llvm textual AST.+data Config = Config { cfgLoadImplicitType :: Bool+ -- ^ True when the type of the result of a load is+ -- derived from its pointer argument, or supplied+ -- implicitly.++ , cfgGEPImplicitType :: Bool+ -- ^ True when the type of the result of the GEP+ -- instruction is implied.+ }++withConfig :: Config -> (LLVM => a) -> a+withConfig cfg body = let ?config = cfg in body+++ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38 :: (LLVM => a) -> a++ppLLVM = ppLLVM38++ppLLVM35 = ppLLVM36++ppLLVM36 = withConfig Config { cfgLoadImplicitType = True+ , cfgGEPImplicitType = True+ }+ppLLVM37 = withConfig Config { cfgLoadImplicitType = False+ , cfgGEPImplicitType = False+ }+ppLLVM38 = withConfig Config { cfgLoadImplicitType = False+ , cfgGEPImplicitType = False+ }++checkConfig :: LLVM => (Config -> Bool) -> Bool+checkConfig p = p ?config+++-- Modules ---------------------------------------------------------------------++ppModule :: LLVM => Module -> Doc+ppModule m = foldr ($+$) empty+ $ ppDataLayout (modDataLayout m)+ : ppInlineAsm (modInlineAsm m)+ : concat [ map ppTypeDecl (modTypes m)+ , map ppGlobal (modGlobals m)+ , map ppGlobalAlias (modAliases m)+ , map ppDeclare (modDeclares m)+ , map ppDefine (modDefines m)+ , map ppNamedMd (modNamedMd m)+ , map ppUnnamedMd (modUnnamedMd m)+ ]+++-- Metadata --------------------------------------------------------------------++ppNamedMd :: NamedMd -> Doc+ppNamedMd nm =+ sep [ ppMetadata (text (nmName nm)) <+> char '='+ , ppMetadata (braces (commas (map (ppMetadata . int) (nmValues nm)))) ]++ppUnnamedMd :: UnnamedMd -> Doc+ppUnnamedMd um =+ sep [ ppMetadata (int (umIndex um)) <+> char '='+ , distinct <+> ppMetadataNode (umValues um) ]+ where+ distinct | umDistinct um = text "distinct"+ | otherwise = empty+++-- Aliases ---------------------------------------------------------------------++ppGlobalAlias :: GlobalAlias -> Doc+ppGlobalAlias g = ppSymbol (aliasName g) <+> char '=' <+> body+ where+ val = aliasTarget g+ body = case val of+ ValSymbol _sym -> ppType (aliasType g) <+> ppValue val+ _ -> ppValue val+++-- Data Layout -----------------------------------------------------------------++-- | Pretty print a data layout specification.+ppDataLayout :: DataLayout -> Doc+ppDataLayout [] = empty+ppDataLayout ls = text "target" <+> text "datalayout" <+> char '='+ <+> doubleQuotes (hcat (intersperse (char '-') (map ppLayoutSpec ls)))++-- | Pretty print a single layout specification.+ppLayoutSpec :: LayoutSpec -> Doc+ppLayoutSpec BigEndian = char 'E'+ppLayoutSpec LittleEndian = char 'e'+ppLayoutSpec (PointerSize sz abi pref) = text "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' <> colons (map int szs)+ppLayoutSpec (StackAlign a) = char 'S' <> int a+ppLayoutSpec (Mangling m) = char 'm' <> char ':' <> ppMangling m++-- | Pretty-print the common case for data layout specifications.+ppLayoutBody :: Int -> Int -> Maybe Int -> Doc+ppLayoutBody size abi mb = int size <> char ':' <> int abi <> pref+ where+ pref = case mb of+ Nothing -> empty+ Just p -> char ':' <> int p++ppMangling :: Mangling -> Doc+ppMangling ElfMangling = char 'e'+ppMangling MipsMangling = char 'm'+ppMangling MachOMangling = char 'o'+ppMangling WindowsCoffMangling = char 'w'+++-- Inline Assembly -------------------------------------------------------------++-- | Pretty-print the inline assembly block.+ppInlineAsm :: InlineAsm -> Doc+ppInlineAsm = foldr ($+$) empty . map ppLine+ where+ ppLine l = text "module asm" <+> doubleQuotes (text l)+++-- Identifiers -----------------------------------------------------------------++ppIdent :: Ident -> Doc+ppIdent (Ident n) = char '%' <> text n+++-- Symbols ---------------------------------------------------------------------++ppSymbol :: Symbol -> Doc+ppSymbol (Symbol n) = char '@' <> text n+++-- Types -----------------------------------------------------------------------++ppPrimType :: PrimType -> Doc+ppPrimType Label = text "label"+ppPrimType Void = text "void"+ppPrimType (Integer i) = char 'i' <> integer (toInteger i)+ppPrimType (FloatType ft) = ppFloatType ft+ppPrimType X86mmx = text "x86mmx"+ppPrimType Metadata = text "metadata"++ppFloatType :: FloatType -> Doc+ppFloatType Half = text "half"+ppFloatType Float = text "float"+ppFloatType Double = text "double"+ppFloatType Fp128 = text "fp128"+ppFloatType X86_fp80 = text "x86_fp80"+ppFloatType PPC_fp128 = text "ppc_fp128"++ppType :: Type -> Doc+ppType (PrimType pt) = ppPrimType pt+ppType (Alias i) = ppIdent i+ppType (Array len ty) = brackets (int32 len <+> char 'x' <+> ppType ty)+ppType (PtrTo ty) = ppType ty <> char '*'+ppType (Struct ts) = structBraces (commas (map ppType ts))+ppType (PackedStruct ts) = angles (structBraces (commas (map ppType ts)))+ppType (FunTy r as va) = ppType r <> ppArgList va (map ppType as)+ppType (Vector len pt) = angles (int32 len <+> char 'x' <+> ppType pt)+ppType Opaque = text "opaque"++ppTypeDecl :: TypeDecl -> Doc+ppTypeDecl td = ppIdent (typeName td) <+> char '='+ <+> text "type" <+> ppType (typeValue td)+++-- Declarations ----------------------------------------------------------------++ppGlobal :: Global -> Doc+ppGlobal g = ppSymbol (globalSym g) <+> char '='+ <+> ppGlobalAttrs (globalAttrs g)+ <+> ppType (globalType g) <+> ppMaybe ppValue (globalValue g)+ <> ppAlign (globalAlign g)++ppGlobalAttrs :: GlobalAttrs -> Doc+ppGlobalAttrs ga = ppMaybe ppLinkage (gaLinkage ga) <+> constant+ where+ constant | gaConstant ga = text "constant"+ | otherwise = text "global"+++ppDeclare :: Declare -> Doc+ppDeclare d = text "declare"+ <+> ppType (decRetType d)+ <+> ppSymbol (decName d)+ <> ppArgList (decVarArgs d) (map ppType (decArgs d))+++ppDefine :: LLVM => Define -> Doc+ppDefine d = text "define"+ <+> ppMaybe ppLinkage (funLinkage (defAttrs d))+ <+> ppType (defRetType d)+ <+> ppSymbol (defName d)+ <> ppArgList (defVarArgs d) (map (ppTyped ppIdent) (defArgs d))+ <+> ppMaybe (\s -> text "section" <+> doubleQuotes (text s)) (defSection d)+ <+> ppMaybe (\gc -> text "gc" <+> ppGC gc) (funGC (defAttrs d))+ <+> char '{'+ $+$ vcat (map ppBasicBlock (defBody d))+ $+$ char '}'+++-- Basic Blocks ----------------------------------------------------------------++ppLabelDef :: BlockLabel -> Doc+ppLabelDef (Named (Ident l)) = text l <> char ':'+ppLabelDef (Anon i) = char ';' <+> text "<label>:" <+> int i++ppLabel :: BlockLabel -> Doc+ppLabel (Named l) = ppIdent l+ppLabel (Anon i) = char '%' <> int i++ppBasicBlock :: LLVM => BasicBlock -> Doc+ppBasicBlock bb = ppMaybe ppLabelDef (bbLabel bb)+ $+$ nest 2 (vcat (map ppStmt (bbStmts bb)))+++-- Statements ------------------------------------------------------------------++ppStmt :: LLVM => Stmt -> Doc+ppStmt stmt = case stmt of+ Result var i mds -> ppIdent var <+> char '=' <+> ppInstr i+ <> ppAttachedMetadata mds+ Effect i mds -> ppInstr i <> ppAttachedMetadata mds++ppAttachedMetadata :: [(String,ValMd)] -> Doc+ppAttachedMetadata mds+ | null mds = empty+ | otherwise = comma <+> commas (map step mds)+ where+ step (l,md) = ppMetadata (text l) <+> ppValMd md+++-- Linkage ---------------------------------------------------------------------++ppLinkage :: Linkage -> Doc+ppLinkage linkage = case linkage of+ Private -> text "private"+ LinkerPrivate -> text "linker_private"+ LinkerPrivateWeak -> text "linker_private_weak"+ LinkerPrivateWeakDefAuto -> text "linker_private_weak_def_auto"+ Internal -> text "internal"+ AvailableExternally -> text "available_externally"+ Linkonce -> text "linkonce"+ Weak -> text "weak"+ Common -> text "common"+ Appending -> text "appending"+ ExternWeak -> text "extern_weak"+ LinkonceODR -> text "linkonce_ddr"+ WeakODR -> text "weak_odr"+ External -> text "external"+ DLLImport -> text "dllimport"+ DLLExport -> text "dllexport"++ppGC :: GC -> Doc+ppGC = doubleQuotes . text . getGC+++-- Expressions -----------------------------------------------------------------++ppTyped :: (a -> Doc) -> Typed a -> Doc+ppTyped fmt ty = ppType (typedType ty) <+> fmt (typedValue ty)++ppSignBits :: Bool -> Bool -> Doc+ppSignBits nuw nsw = opt nuw (text "nuw") <+> opt nsw (text "nsw")++ppExact :: Bool -> Doc+ppExact e = opt e (text "exact")++ppArithOp :: ArithOp -> Doc+ppArithOp (Add nuw nsw) = text "add" <+> ppSignBits nuw nsw+ppArithOp FAdd = text "fadd"+ppArithOp (Sub nuw nsw) = text "sub" <+> ppSignBits nuw nsw+ppArithOp FSub = text "fsub"+ppArithOp (Mul nuw nsw) = text "mul" <+> ppSignBits nuw nsw+ppArithOp FMul = text "fmul"+ppArithOp (UDiv e) = text "udiv" <+> ppExact e+ppArithOp (SDiv e) = text "sdiv" <+> ppExact e+ppArithOp FDiv = text "fdiv"+ppArithOp URem = text "urem"+ppArithOp SRem = text "srem"+ppArithOp FRem = text "frem"++ppBitOp :: BitOp -> Doc+ppBitOp (Shl nuw nsw) = text "shl" <+> ppSignBits nuw nsw+ppBitOp (Lshr e) = text "lshr" <+> ppExact e+ppBitOp (Ashr e) = text "ashr" <+> ppExact e+ppBitOp And = text "and"+ppBitOp Or = text "or"+ppBitOp Xor = text "xor"++ppConvOp :: ConvOp -> Doc+ppConvOp Trunc = text "trunc"+ppConvOp ZExt = text "zext"+ppConvOp SExt = text "sext"+ppConvOp FpTrunc = text "fptrunc"+ppConvOp FpExt = text "fpext"+ppConvOp FpToUi = text "fptoui"+ppConvOp FpToSi = text "fptosi"+ppConvOp UiToFp = text "uitofp"+ppConvOp SiToFp = text "sitofp"+ppConvOp PtrToInt = text "ptrtoint"+ppConvOp IntToPtr = text "inttoptr"+ppConvOp BitCast = text "bitcast"++ppInstr :: LLVM => Instr -> Doc+ppInstr instr = case instr of+ Ret tv -> text "ret" <+> ppTyped ppValue tv+ RetVoid -> text "ret void"+ Arith op l r -> ppArithOp op <+> ppTyped ppValue l+ <> comma <+> ppValue r+ Bit op l r -> ppBitOp op <+> ppTyped ppValue l+ <> comma <+> ppValue r+ Conv op a ty -> ppConvOp op <+> ppTyped ppValue a+ <+> text "to" <+> ppType ty+ Call tc ty f args -> ppCall tc ty f args+ Alloca ty len align -> ppAlloca ty len align+ Load ptr ma -> ppLoad ptr ma+ Store a ptr ma -> text "store" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue ptr+ <> ppAlign ma+ ICmp op l r -> text "icmp" <+> ppICmpOp op+ <+> ppTyped ppValue l <> comma <+> ppValue r+ FCmp op l r -> text "fcmp" <+> ppFCmpOp op+ <+> ppTyped ppValue l <> comma <+> ppValue r+ Phi ty vls -> text "phi" <+> ppType ty+ <+> commas (map ppPhiArg vls)+ Select c t f -> text "select" <+> ppTyped ppValue c+ <> comma <+> ppTyped ppValue t+ <> comma <+> ppTyped ppValue (f <$ t)+ ExtractValue v is -> text "extractvalue" <+> ppTyped ppValue v+ <> comma <+> (commas (map int32 is))+ InsertValue a v is -> text "insertvalue" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue v+ <> comma <+> commas (map int32 is)+ ShuffleVector a b m -> text "shufflevector" <+> ppTyped ppValue a+ <> comma <+> ppTyped ppValue (b <$ a)+ <> comma <+> ppTyped ppValue m+ GEP ib ptr ixs -> ppGEP ib ptr ixs+ Comment str -> char ';' <+> text str+ Jump i -> text "br"+ <+> ppTypedLabel i+ Br c t f -> text "br" <+> ppTyped ppValue c+ <> comma <+> ppType (PrimType Label)+ <+> ppLabel t+ <> comma <+> ppType (PrimType Label)+ <+> ppLabel f+ Invoke ty f args to uw -> ppInvoke ty f args to uw+ Unreachable -> text "unreachable"+ Unwind -> text "unwind"+ VaArg al t -> text "va_arg" <+> ppTyped ppValue al+ <> comma <+> ppType t+ ExtractElt v i -> text "extractelement"+ <+> ppTyped ppValue v+ <> comma <+> ppVectorIndex i+ InsertElt v e i -> text "insertelement"+ <+> ppTyped ppValue v+ <> comma <+> ppTyped ppValue e+ <> comma <+> ppVectorIndex i+ IndirectBr d ls -> text "indirectbr"+ <+> ppTyped ppValue d+ <> comma <+> commas (map ppTypedLabel ls)+ Switch c d ls -> text "switch"+ <+> ppTyped ppValue c+ <> comma <+> ppTypedLabel d+ <+> char '['+ $$ nest 2 (vcat (map (ppSwitchEntry (typedType c)) ls))+ $$ char ']'+ LandingPad ty fn c cs -> text "landingpad"+ <+> ppType ty+ <+> text "personality"+ <+> ppTyped ppValue fn+ $$ nest 2 (ppClauses c cs)+ Resume tv -> text "resume" <+> ppTyped ppValue tv++ppLoad :: LLVM => Typed (Value' BlockLabel) -> Maybe Align -> Doc+ppLoad ptr ma =+ text "load" <+> (if isImplicit then empty else explicit)+ <+> ppTyped ppValue ptr+ <> ppAlign ma++ where+ isImplicit = checkConfig cfgLoadImplicitType++ explicit =+ case typedType ptr of+ PtrTo ty -> ppType ty <> comma+ ty -> ppType ty <> comma++ppClauses :: Bool -> [Clause] -> Doc+ppClauses isCleanup cs = vcat (cleanup : map ppClause cs)+ where+ cleanup | isCleanup = text "cleanup"+ | otherwise = empty++ppClause :: Clause -> Doc+ppClause c = case c of+ Catch tv -> text "catch" <+> ppTyped ppValue tv+ Filter tv -> text "filter" <+> ppTyped ppValue tv+++ppTypedLabel :: BlockLabel -> Doc+ppTypedLabel i = ppType (PrimType Label) <+> ppLabel i++ppSwitchEntry :: Type -> (Integer,BlockLabel) -> Doc+ppSwitchEntry ty (i,l) = ppType ty <+> integer i <> comma <+> ppTypedLabel l++ppVectorIndex :: Value -> Doc+ppVectorIndex i = ppType (PrimType (Integer 32)) <+> ppValue i++ppAlign :: Maybe Align -> Doc+ppAlign Nothing = empty+ppAlign (Just align) = comma <+> text "align" <+> int align++ppAlloca :: Type -> Maybe (Typed Value) -> Maybe Int -> Doc+ppAlloca ty mbLen mbAlign = text "alloca" <+> ppType ty <> len <> align+ where+ len = fromMaybe empty $ do+ l <- mbLen+ return (comma <+> ppTyped ppValue l)+ align = fromMaybe empty $ do+ a <- mbAlign+ return (comma <+> text "align" <+> int a)++ppCall :: Bool -> Type -> Value -> [Typed Value] -> Doc+ppCall tc ty f args+ | tc = text "tail" <+> body+ | otherwise = body+ where+ body = text "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++ppGEP :: LLVM => Bool -> Typed Value -> [Typed Value] -> Doc+ppGEP ib ptr ixs = text "getelementptr" <+> inbounds+ <+> (if isImplicit then empty else explicit)+ <+> commas (map (ppTyped ppValue) (ptr:ixs))+ where+ isImplicit = checkConfig cfgGEPImplicitType++ explicit =+ case typedType ptr of+ PtrTo ty -> ppType ty <> comma+ ty -> ppType ty <> comma++ inbounds | ib = text "inbounds"+ | otherwise = empty++ppInvoke :: Type -> Value -> [Typed Value] -> BlockLabel -> BlockLabel -> Doc+ppInvoke ty f args to uw = body+ where+ body = text "invoke" <+> ppType ty <+> ppValue f+ <> parens (commas (map (ppTyped ppValue) args))+ <+> text "to" <+> ppType (PrimType Label) <+> ppLabel to+ <+> text "unwind" <+> ppType (PrimType Label) <+> ppLabel uw++ppPhiArg :: (Value,BlockLabel) -> Doc+ppPhiArg (v,l) = char '[' <+> ppValue v <> comma <+> ppLabel l <+> char ']'++ppICmpOp :: ICmpOp -> Doc+ppICmpOp Ieq = text "eq"+ppICmpOp Ine = text "ne"+ppICmpOp Iugt = text "ugt"+ppICmpOp Iuge = text "uge"+ppICmpOp Iult = text "ult"+ppICmpOp Iule = text "ule"+ppICmpOp Isgt = text "sgt"+ppICmpOp Isge = text "sge"+ppICmpOp Islt = text "slt"+ppICmpOp Isle = text "sle"++ppFCmpOp :: FCmpOp -> Doc+ppFCmpOp Ffalse = text "false"+ppFCmpOp Foeq = text "oeq"+ppFCmpOp Fogt = text "ogt"+ppFCmpOp Foge = text "oge"+ppFCmpOp Folt = text "olt"+ppFCmpOp Fole = text "ole"+ppFCmpOp Fone = text "one"+ppFCmpOp Ford = text "ord"+ppFCmpOp Fueq = text "ueq"+ppFCmpOp Fugt = text "ugt"+ppFCmpOp Fuge = text "uge"+ppFCmpOp Fult = text "ult"+ppFCmpOp Fule = text "ule"+ppFCmpOp Fune = text "une"+ppFCmpOp Funo = text "uno"+ppFCmpOp Ftrue = text "true"++ppValue :: Value -> Doc+ppValue val = case val of+ ValInteger i -> integer i+ ValBool b -> ppBool b+ ValFloat i -> float i+ ValDouble i -> double i+ ValIdent i -> ppIdent i+ ValSymbol s -> ppSymbol s+ ValNull -> text "null"+ ValArray ty es -> brackets+ $ commas (map (ppTyped ppValue . Typed ty) es)+ ValVector ty es -> angles $ commas+ $ map (ppTyped ppValue . Typed ty) es+ ValStruct fs -> structBraces (commas (map (ppTyped ppValue) fs))+ ValPackedStruct fs -> angles+ $ structBraces (commas (map (ppTyped ppValue) fs))+ ValString s -> char 'c' <> ppStringLiteral s+ ValConstExpr ce -> ppConstExpr ce+ ValUndef -> text "undef"+ ValLabel l -> ppLabel l+ ValZeroInit -> text "zeroinitializer"+ ValAsm s a i c -> ppAsm s a i c+ ValMd m -> ppValMd m++ppValMd :: ValMd -> Doc+ppValMd m = case m of+ ValMdString str -> ppMetadata (ppStringLiteral str)+ ValMdValue tv -> ppTyped ppValue tv+ ValMdRef i -> ppMetadata (int i)+ ValMdNode vs -> ppMetadataNode vs+ ValMdLoc l -> ppDebugLoc l++ppDebugLoc :: DebugLoc -> Doc+ppDebugLoc dl = text "!MDLocation"+ <> parens (commas [ text "line:" <+> int32 (dlLine dl)+ , text "column:" <+> int32 (dlCol dl)+ , text "scope:" <+> ppValMd (dlScope dl)+ ] <+> mbIA)++ where+ mbIA = case dlIA dl of+ Just md -> comma <+> text "inlinedAt:" <+> ppValMd md+ Nothing -> empty++ppTypedValMd :: ValMd -> Doc+ppTypedValMd = ppTyped ppValMd . Typed (PrimType Metadata)++ppMetadata :: Doc -> Doc+ppMetadata body = char '!' <> body++ppMetadataNode :: [Maybe ValMd] -> Doc+ppMetadataNode vs = ppMetadata (braces (commas (map arg vs)))+ where+ arg = maybe (text "null") ppValMd++ppBool :: Bool -> Doc+ppBool b | b = text "true"+ | otherwise = text "false"++ppStringLiteral :: String -> Doc+ppStringLiteral = doubleQuotes . text . concatMap escape+ where+ escape c | isAscii c && isPrint c = [c]+ | otherwise = '\\' : pad (ord c)++ pad n | n < 0x10 = '0' : map toUpper (showHex n "")+ | otherwise = map toUpper (showHex n "")++ppAsm :: Bool -> Bool -> String -> String -> Doc+ppAsm s a i c =+ text "asm" <+> sideeffect <+> alignstack+ <+> ppStringLiteral i <> comma <+> ppStringLiteral c+ where+ sideeffect | s = text "sideeffect"+ | otherwise = empty++ alignstack | a = text "alignstack"+ | otherwise = empty+++ppConstExpr :: ConstExpr -> Doc+ppConstExpr (ConstGEP inb ixs) = text "getelementptr"+ <+> opt inb (text "inbounds")+ <+> parens (commas (map (ppTyped ppValue) ixs))+ppConstExpr (ConstConv op tv t) = ppConvOp op <+> parens+ (ppTyped ppValue tv <+> text "to" <+> ppType t)+ppConstExpr (ConstSelect c l r) = text "select" <+> parens+ (commas [ ppTyped ppValue c, ppTyped ppValue l+ , ppTyped ppValue r])+ppConstExpr (ConstBlockAddr t l)= text "blockaddress" <+> parens+ (ppSymbol t <> comma <+> ppLabel l)+++-- Utilities -------------------------------------------------------------------++-- | Build a variable-argument argument list.+ppArgList :: Bool -> [Doc] -> Doc+ppArgList True ds = parens (commas (ds ++ [text "..."]))+ppArgList False ds = parens (commas ds)++int32 :: Int32 -> Doc+int32 = int . fromIntegral++opt :: Bool -> Doc -> Doc+opt True = id+opt False = const empty++commas :: [Doc] -> Doc+commas = fsep . punctuate comma++angles :: Doc -> Doc+angles d = char '<' <> d <> char '>'++structBraces :: Doc -> Doc+structBraces body = char '{' <+> body <+> char '}'++ppMaybe :: (a -> Doc) -> Maybe a -> Doc+ppMaybe = maybe empty++colons :: [Doc] -> Doc+colons = fsep . punctuate (char ':')
+ src/Text/LLVM/Util.hs view
@@ -0,0 +1,18 @@+module Text.LLVM.Util where++import Control.Monad (MonadPlus,mzero)+import Data.List (unfoldr)+++breaks :: (a -> Bool) -> [a] -> [[a]]+breaks p = unfoldr step+ where+ step [] = Nothing+ step xs = case break p xs of+ (as,_:bs) -> Just (as,bs)+ (as, []) -> Just (as,[])++uncons :: MonadPlus m => [a] -> m (a,[a])+uncons (a:as) = return (a,as)+uncons _ = mzero+