llvm-general-pure (empty) → 3.2.7.0
raw patch · 25 files changed
+1750/−0 lines, 25 filesdep +HUnitdep +QuickCheckdep +arraybuild-type:Customsetup-changed
Dependencies added: HUnit, QuickCheck, array, base, bytestring, containers, llvm-general-pure, mtl, parsec, setenv, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +24/−0
- llvm-general-pure.cabal +89/−0
- src/LLVM/General/AST.hs +53/−0
- src/LLVM/General/AST/AddrSpace.hs +8/−0
- src/LLVM/General/AST/Attribute.hs +38/−0
- src/LLVM/General/AST/CallingConvention.hs +10/−0
- src/LLVM/General/AST/Constant.hs +230/−0
- src/LLVM/General/AST/DataLayout.hs +51/−0
- src/LLVM/General/AST/Float.hs +19/−0
- src/LLVM/General/AST/FloatingPointPredicate.hs +27/−0
- src/LLVM/General/AST/Global.hs +109/−0
- src/LLVM/General/AST/InlineAssembly.hs +27/−0
- src/LLVM/General/AST/Instruction.hs +386/−0
- src/LLVM/General/AST/IntegerPredicate.hs +21/−0
- src/LLVM/General/AST/Linkage.hs +23/−0
- src/LLVM/General/AST/Name.hs +31/−0
- src/LLVM/General/AST/Operand.hs +33/−0
- src/LLVM/General/AST/RMWOperation.hs +22/−0
- src/LLVM/General/AST/Type.hs +40/−0
- src/LLVM/General/AST/Visibility.hs +8/−0
- src/LLVM/General/Internal/PrettyPrint.hs +207/−0
- src/LLVM/General/PrettyPrint.hs +160/−0
- test/LLVM/General/Test/PrettyPrint.hs +98/−0
- test/Test.hs +6/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Benjamin S. Scarlet+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Benjamin S. Scarlet nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,24 @@+import Control.Exception (SomeException, try)+import Control.Monad+import Data.Maybe+import Data.List (isPrefixOf, (\\), intercalate, stripPrefix)+import Data.Map (Map)+import qualified Data.Map as Map+import Distribution.Simple+import Distribution.Simple.Program+import Distribution.Simple.Setup hiding (Flag)+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import Distribution.Version+import System.Environment+import System.SetEnv+import Distribution.System++main = defaultMainWithHooks simpleUserHooks {+ haddockHook = \packageDescription localBuildInfo userHooks haddockFlags -> do+ let v = "GHCRTS"+ oldGhcRts <- try $ getEnv v :: IO (Either SomeException String)+ setEnv v (either (const id) (\o n -> o ++ " " ++ n) oldGhcRts "-K32M")+ haddockHook simpleUserHooks packageDescription localBuildInfo userHooks haddockFlags+ either (const (unsetEnv v)) (setEnv v) oldGhcRts+ }
+ llvm-general-pure.cabal view
@@ -0,0 +1,89 @@+name: llvm-general-pure+version: 3.2.7.0+license: BSD3+license-file: LICENSE+author: Benjamin S.Scarlet <fgthb0@greynode.net>+maintainer: Benjamin S. Scarlet <fgthb0@greynode.net>+copyright: Benjamin S. Scarlet 2013+build-type: Custom+stability: experimental+cabal-version: >= 1.8+category: Compilers/Interpreters, Code Generation+synopsis: Pure Haskell LLVM functionality (no FFI).+description:+ llvm-general-pure is a set of pure Haskell types and functions for interacting with LLVM <http://llvm.org/>.+ It includes an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>). The llvm-general package+ builds on this one with FFI bindings to LLVM, but llvm-general-pure does not require LLVM to be available.+ .+ For haddock, see <http://bscarlet.github.io/llvm-general/3.4.0.0/doc/html/llvm-general-pure/index.html>.+ +source-repository head+ type: git+ location: git://github.com/bscarlet/llvm-general.git++library+ ghc-options: -fwarn-unused-imports+ build-depends: + base >= 4.5.0.0 && < 5,+ text >= 0.11.2.1,+ bytestring >= 0.9.1.10,+ transformers >= 0.3.0.0,+ mtl >= 2.0.1.0,+ template-haskell >= 2.5.0.0,+ containers >= 0.4.2.1,+ parsec >= 3.1.3,+ array >= 0.4.0.0,+ setenv >= 0.1.0+ hs-source-dirs: src+ extensions:+ TupleSections+ DeriveDataTypeable+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ StandaloneDeriving+ ConstraintKinds+ exposed-modules:+ LLVM.General.AST+ LLVM.General.AST.AddrSpace+ LLVM.General.AST.InlineAssembly+ LLVM.General.AST.Attribute+ LLVM.General.AST.CallingConvention+ LLVM.General.AST.Constant+ LLVM.General.AST.DataLayout+ LLVM.General.AST.Float+ LLVM.General.AST.FloatingPointPredicate+ LLVM.General.AST.Global+ LLVM.General.AST.Instruction+ LLVM.General.AST.IntegerPredicate+ LLVM.General.AST.Linkage+ LLVM.General.AST.Name+ LLVM.General.AST.Operand+ LLVM.General.AST.RMWOperation+ LLVM.General.AST.Type+ LLVM.General.AST.Visibility+ LLVM.General.PrettyPrint++ other-modules:+ LLVM.General.Internal.PrettyPrint++test-suite test+ type: exitcode-stdio-1.0+ build-depends: + base >= 3 && < 5,+ test-framework >= 0.5,+ test-framework-hunit >= 0.2.7,+ HUnit >= 1.2.4.2,+ test-framework-quickcheck2 >= 0.3.0.1,+ QuickCheck >= 2.5.1.1,+ llvm-general-pure == 3.2.7.0,+ containers >= 0.4.2.1,+ mtl >= 2.0.1.0+ hs-source-dirs: test+ extensions:+ TupleSections+ FlexibleInstances+ FlexibleContexts+ main-is: Test.hs+ other-modules:+ LLVM.General.Test.PrettyPrint
+ src/LLVM/General/AST.hs view
@@ -0,0 +1,53 @@+-- | This module and descendants define AST data types to represent LLVM code.+-- Note that these types are designed for fidelity rather than convenience - if the truth+-- of what LLVM supports is less than pretty, so be it.+module LLVM.General.AST (+ Module(..), defaultModule,+ Definition(..),+ Global(GlobalVariable, GlobalAlias, Function), + globalVariableDefaults,+ globalAliasDefaults,+ functionDefaults,+ Parameter(..),+ BasicBlock(..),+ module LLVM.General.AST.Instruction,+ module LLVM.General.AST.Name,+ module LLVM.General.AST.Operand,+ module LLVM.General.AST.Type+ ) where++import LLVM.General.AST.Name+import LLVM.General.AST.Type+import LLVM.General.AST.Global+import LLVM.General.AST.Operand+import LLVM.General.AST.Instruction+import LLVM.General.AST.DataLayout++-- | Any thing which can be at the top level of a 'Module'+data Definition + = GlobalDefinition Global+ | TypeDefinition Name (Maybe Type)+ | MetadataNodeDefinition MetadataNodeID [Maybe Operand]+ | NamedMetadataDefinition String [MetadataNodeID]+ | ModuleInlineAssembly String+ deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#modulestructure>+data Module = + Module {+ moduleName :: String,+ -- | a 'DataLayout', if specified, must match that of the eventual code generator+ moduleDataLayout :: Maybe DataLayout, + moduleTargetTriple :: Maybe String,+ moduleDefinitions :: [Definition]+ } + deriving (Eq, Read, Show)++-- | helper for making 'Module's+defaultModule = + Module {+ moduleName = "<string>",+ moduleDataLayout = Nothing,+ moduleTargetTriple = Nothing,+ moduleDefinitions = []+ }
+ src/LLVM/General/AST/AddrSpace.hs view
@@ -0,0 +1,8 @@+-- | Pointers exist in Address Spaces +module LLVM.General.AST.AddrSpace where++import Data.Word++-- | See <http://llvm.org/docs/LangRef.html#pointer-type>+data AddrSpace = AddrSpace Word32+ deriving (Eq, Ord, Read, Show)
+ src/LLVM/General/AST/Attribute.hs view
@@ -0,0 +1,38 @@+-- | Module to allow importing 'Attribute' distinctly qualified.+module LLVM.General.AST.Attribute where++import Data.Word++-- | <http://llvm.org/docs/LangRef.html#parameter-attributes>+data ParameterAttribute+ = ZeroExt+ | SignExt+ | InReg+ | SRet+ | NoAlias+ | ByVal+ | NoCapture+ | Nest+ deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#function-attributes>+data FunctionAttribute+ = NoReturn+ | NoUnwind+ | ReadNone+ | ReadOnly+ | NoInline+ | AlwaysInline+ | OptimizeForSize+ | StackProtect+ | StackProtectReq+ | Alignment Word32+ | NoRedZone+ | NoImplicitFloat+ | Naked+ | InlineHint+ | StackAlignment Word32+ | ReturnsTwice+ | UWTable+ | NonLazyBind+ deriving (Eq, Read, Show)
+ src/LLVM/General/AST/CallingConvention.hs view
@@ -0,0 +1,10 @@+-- | Module to allow importing 'CallingConvention' distinctly qualified.+module LLVM.General.AST.CallingConvention where++import Data.Data+import Data.Word++-- | <http://llvm.org/docs/LangRef.html#callingconv>+data CallingConvention = C | Fast | Cold | GHC | Numbered Word32+ deriving (Eq, Read, Show, Typeable, Data)+
+ src/LLVM/General/AST/Constant.hs view
@@ -0,0 +1,230 @@+-- | A representation of LLVM constants+module LLVM.General.AST.Constant where++import Data.Word (Word32)+import Data.Bits ((.|.), (.&.), complement, testBit, shiftL)++import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate)+import LLVM.General.AST.IntegerPredicate (IntegerPredicate)+import qualified LLVM.General.AST.Float as F++{- |+<http://llvm.org/docs/LangRef.html#constants>++N.B. - <http://llvm.org/docs/LangRef.html#constant-expressions>++Although constant expressions and instructions have many similarites, there are important+differences - so they're represented using different types in this AST. At the cost of making it+harder to move an code back and forth between being constant and not, this approach embeds more of+the rules of what IR is legal into the Haskell types.+-} +data Constant+ = Int { integerBits :: Word32, integerValue :: Integer }+ | Float { floatValue :: F.SomeFloat }+ | Null { constantType :: Type }+ | Struct { isPacked :: Bool, memberValues :: [ Constant ] }+ | Array { memberType :: Type, memberValues :: [ Constant ] }+ | Vector { memberValues :: [ Constant ] }+ | Undef { constantType :: Type }+ | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name }+ | GlobalReference Name + | Add { + nsw :: Bool,+ nuw :: Bool,+ operand0 :: Constant,+ operand1 :: Constant+ }+ | FAdd {+ operand0 :: Constant,+ operand1 :: Constant+ }+ | Sub {+ nsw :: Bool,+ nuw :: Bool,+ operand0 :: Constant,+ operand1 :: Constant+ }+ | FSub { + operand0 :: Constant, + operand1 :: Constant+ }+ | Mul { + nsw :: Bool,+ nuw :: Bool,+ operand0 :: Constant, + operand1 :: Constant+ }+ | FMul { + operand0 :: Constant, + operand1 :: Constant+ }+ | UDiv { + exact :: Bool,+ operand0 :: Constant, + operand1 :: Constant+ }+ | SDiv { + exact :: Bool,+ operand0 :: Constant, + operand1 :: Constant+ }+ | FDiv { + operand0 :: Constant, + operand1 :: Constant+ }+ | URem { + operand0 :: Constant, + operand1 :: Constant+ }+ | SRem { + operand0 :: Constant, + operand1 :: Constant+ }+ | FRem { + operand0 :: Constant, + operand1 :: Constant+ }+ | Shl { + nsw :: Bool,+ nuw :: Bool,+ operand0 :: Constant, + operand1 :: Constant+ }+ | LShr { + exact :: Bool,+ operand0 :: Constant, + operand1 :: Constant+ }+ | AShr { + exact :: Bool,+ operand0 :: Constant, + operand1 :: Constant+ }+ | And { + operand0 :: Constant, + operand1 :: Constant+ }+ | Or { + operand0 :: Constant, + operand1 :: Constant+ }+ | Xor { + operand0 :: Constant, + operand1 :: Constant+ }+ | GetElementPtr { + inBounds :: Bool,+ address :: Constant,+ indices :: [Constant]+ }+ | Trunc { + operand0 :: Constant,+ type' :: Type+ }+ | ZExt {+ operand0 :: Constant,+ type' :: Type+ }+ | SExt {+ operand0 :: Constant,+ type' :: Type+ }+ | FPToUI {+ operand0 :: Constant,+ type' :: Type+ }+ | FPToSI {+ operand0 :: Constant,+ type' :: Type+ }+ | UIToFP {+ operand0 :: Constant,+ type' :: Type+ }+ | SIToFP {+ operand0 :: Constant,+ type' :: Type+ }+ | FPTrunc {+ operand0 :: Constant,+ type' :: Type+ }+ | FPExt {+ operand0 :: Constant,+ type' :: Type+ }+ | PtrToInt {+ operand0 :: Constant,+ type' :: Type+ }+ | IntToPtr {+ operand0 :: Constant,+ type' :: Type+ }+ | BitCast {+ operand0 :: Constant,+ type' :: Type+ }+ | ICmp {+ iPredicate :: IntegerPredicate,+ operand0 :: Constant,+ operand1 :: Constant+ }+ | FCmp {+ fpPredicate :: FloatingPointPredicate,+ operand0 :: Constant,+ operand1 :: Constant+ }+ | Select { + condition' :: Constant,+ trueValue :: Constant,+ falseValue :: Constant+ }+ | ExtractElement { + vector :: Constant,+ index :: Constant+ }+ | InsertElement { + vector :: Constant,+ element :: Constant,+ index :: Constant+ }+ | ShuffleVector { + operand0 :: Constant,+ operand1 :: Constant,+ mask :: Constant+ }+ | ExtractValue { + aggregate :: Constant,+ indices' :: [Word32]+ }+ | InsertValue { + aggregate :: Constant,+ element :: Constant,+ indices' :: [Word32]+ }+ deriving (Eq, Ord, Read, Show)+++-- | Since LLVM types don't include signedness, there's ambiguity in interpreting+-- an constant as an Integer. The LLVM assembly printer prints integers as signed, but+-- cheats for 1-bit integers and prints them as 'true' or 'false'. That way it circuments the+-- otherwise awkward fact that a twos complement 1-bit number only has the values -1 and 0.+signedIntegerValue :: Constant -> Integer+signedIntegerValue (Int nBits' bits) =+ let nBits = fromIntegral nBits'+ in+ if bits `testBit` (nBits - 1) then bits .|. (-1 `shiftL` nBits) else bits++-- | This library's conversion from LLVM C++ objects will always produce integer constants+-- as unsigned, so this function in many cases is not necessary. However, nothing's to keep+-- stop direct construction of an 'Int' with a negative 'integerValue'. There's nothing in principle+-- wrong with such a value - it has perfectly good low order bits like any integer, and will be used+-- as such, likely producing the intended result if lowered to C++. If, however one wishes to interpret+-- an 'Int' of unknown provenance as unsigned, then this function will serve.+unsignedIntegerValue :: Constant -> Integer+unsignedIntegerValue (Int nBits bits) =+ bits .&. (complement (-1 `shiftL` (fromIntegral nBits)))+
+ src/LLVM/General/AST/DataLayout.hs view
@@ -0,0 +1,51 @@+-- | <http://llvm.org/docs/LangRef.html#data-layout>+module LLVM.General.AST.DataLayout where++import Data.Word++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)++import LLVM.General.AST.AddrSpace++-- | Little Endian is the one true way :-). Sadly, we must support the infidels.+data Endianness = LittleEndian | BigEndian+ deriving (Eq, Ord, Read, Show)++-- | An AlignmentInfo describes how a given type must and would best be aligned+data AlignmentInfo = AlignmentInfo {+ abiAlignment :: Word32,+ preferredAlignment :: Maybe Word32+ }+ deriving (Eq, Ord, Read, Show)++-- | A type of type for which 'AlignmentInfo' may be specified+data AlignType+ = IntegerAlign+ | VectorAlign+ | FloatAlign+ | AggregateAlign+ | StackAlign+ deriving (Eq, Ord, Read, Show)++-- | a description of the various data layout properties which may be used during+-- optimization+data DataLayout = DataLayout {+ endianness :: Maybe Endianness,+ stackAlignment :: Maybe Word32,+ pointerLayouts :: Map AddrSpace (Word32, AlignmentInfo),+ typeLayouts :: Map (AlignType, Word32) AlignmentInfo,+ nativeSizes :: Maybe (Set Word32)+ }+ deriving (Eq, Ord, Read, Show)++-- | a 'DataLayout' which specifies nothing+defaultDataLayout = DataLayout {+ endianness = Nothing,+ stackAlignment = Nothing,+ pointerLayouts = Map.empty,+ typeLayouts = Map.empty,+ nativeSizes = Nothing+ }+
+ src/LLVM/General/AST/Float.hs view
@@ -0,0 +1,19 @@+-- | This module provides a sub-namespace for a type to support the various sizes of floating point+-- numbers LLVM supports. It is most definitely intended to be imported qualified.+module LLVM.General.AST.Float where++import Prelude as P+import Data.Word (Word16, Word64)++-- | A type summing up the various float types.+-- N.B. Note that in the constructors with multiple fields, the lower significance bits are on the right+-- - e.g. Quadruple highbits lowbits+data SomeFloat+ = Half Word16 + | Single Float+ | Double P.Double+ | Quadruple Word64 Word64+ | X86_FP80 Word16 Word64+ | PPC_FP128 Word64 Word64+ deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/AST/FloatingPointPredicate.hs view
@@ -0,0 +1,27 @@+-- | Predicates for the 'LLVM.General.AST.Instruction.FCmp' instruction+module LLVM.General.AST.FloatingPointPredicate where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#fcmp-instruction>+data FloatingPointPredicate+ = False+ | OEQ+ | OGT+ | OGE+ | OLT+ | OLE+ | ONE+ | ORD+ | UNO+ | UEQ+ | UGT+ | UGE+ | ULT+ | ULE+ | UNE+ | True+ deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Global.hs view
@@ -0,0 +1,109 @@+-- | 'Global's - top-level values in 'Module's - and supporting structures.+module LLVM.General.AST.Global where++import Data.Word++import LLVM.General.AST.Name+import LLVM.General.AST.Type+import LLVM.General.AST.Constant (Constant)+import LLVM.General.AST.AddrSpace+import LLVM.General.AST.Instruction (Named, Instruction, Terminator)+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalValue.html>+data Global+ -- | <http://llvm.org/docs/LangRef.html#global-variables>+ = GlobalVariable {+ name :: Name,+ linkage :: L.Linkage,+ visibility :: V.Visibility,+ isThreadLocal :: Bool,+ addrSpace :: AddrSpace,+ hasUnnamedAddr :: Bool,+ isConstant :: Bool,+ type' :: Type,+ initializer :: Maybe Constant,+ section :: Maybe String,+ alignment :: Word32+ }+ -- | <http://llvm.org/docs/LangRef.html#aliases>+ | GlobalAlias {+ name :: Name,+ linkage :: L.Linkage,+ visibility :: V.Visibility,+ type' :: Type,+ aliasee :: Constant+ }+ -- | <http://llvm.org/docs/LangRef.html#functions>+ | Function {+ linkage :: L.Linkage,+ visibility :: V.Visibility,+ callingConvention :: CC.CallingConvention,+ returnAttributes :: [A.ParameterAttribute],+ returnType :: Type,+ name :: Name,+ parameters :: ([Parameter],Bool),+ functionAttributes :: [A.FunctionAttribute],+ section :: Maybe String,+ alignment :: Word32,+ basicBlocks :: [BasicBlock]+ }+ deriving (Eq, Read, Show)++-- | 'Parameter's for 'Function's+data Parameter = Parameter Type Name [A.ParameterAttribute]+ deriving (Eq, Read, Show)++-- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html>+-- LLVM code in a function is a sequence of 'BasicBlock's each with a label,+-- some instructions, and a terminator.+data BasicBlock = BasicBlock Name [Named Instruction] (Named Terminator)+ deriving (Eq, Read, Show)++-- | helper for making 'GlobalVariable's+globalVariableDefaults :: Global+globalVariableDefaults = + GlobalVariable {+ name = error "global variable name not defined",+ linkage = L.External,+ visibility = V.Default,+ isThreadLocal = False,+ addrSpace = AddrSpace 0,+ hasUnnamedAddr = False,+ isConstant = False,+ type' = error "global variable type not defined",+ initializer = Nothing,+ section = Nothing,+ alignment = 0+ }++-- | helper for making 'GlobalAlias's+globalAliasDefaults :: Global+globalAliasDefaults =+ GlobalAlias {+ name = error "global alias name not defined",+ linkage = L.External,+ visibility = V.Default,+ type' = error "global alias type not defined",+ aliasee = error "global alias aliasee not defined"+ }++-- | helper for making 'Function's+functionDefaults :: Global+functionDefaults = + Function {+ linkage = L.External,+ visibility = V.Default,+ callingConvention = CC.C,+ returnAttributes = [],+ returnType = error "function return type not defined",+ name = error "function name not defined",+ parameters = ([], False),+ functionAttributes = [],+ section = Nothing,+ alignment = 0,+ basicBlocks = []+ }
+ src/LLVM/General/AST/InlineAssembly.hs view
@@ -0,0 +1,27 @@+-- | A representation of an LLVM inline assembly+module LLVM.General.AST.InlineAssembly where++import Data.Data++import LLVM.General.AST.Type++-- | the dialect of assembly used in an inline assembly string+-- <http://en.wikipedia.org/wiki/X86_assembly_language#Syntax>+data Dialect+ = ATTDialect+ | IntelDialect+ deriving (Eq, Read, Show, Typeable, Data)++-- | <http://llvm.org/docs/LangRef.html#inline-assembler-expressions>+-- to be used through 'LLVM.General.AST.Operand.CallableOperand' with a+-- 'LLVM.General.AST.Instruction.Call' instruction+data InlineAssembly+ = InlineAssembly {+ type' :: Type,+ assembly :: String,+ constraints :: String,+ hasSideEffects :: Bool,+ alignStack :: Bool,+ dialect :: Dialect+ }+ deriving (Eq, Read, Show)
+ src/LLVM/General/AST/Instruction.hs view
@@ -0,0 +1,386 @@+-- | LLVM instructions +-- <http://llvm.org/docs/LangRef.html#instruction-reference>+module LLVM.General.AST.Instruction where++import Data.Data+import Data.Word++import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.Constant+import LLVM.General.AST.Operand+import LLVM.General.AST.IntegerPredicate (IntegerPredicate)+import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate)+import LLVM.General.AST.RMWOperation (RMWOperation)+import LLVM.General.AST.CallingConvention (CallingConvention)+import LLVM.General.AST.Attribute (ParameterAttribute, FunctionAttribute)++-- | <http://llvm.org/docs/LangRef.html#metadata-nodes-and-metadata-strings>+-- Metadata can be attached to an instruction+type InstructionMetadata = [(String, MetadataNode)]++-- | <http://llvm.org/docs/LangRef.html#terminators>+data Terminator + = Ret { + returnOperand :: Maybe Operand,+ metadata' :: InstructionMetadata+ }+ | CondBr { + condition :: Operand, + trueDest :: Name, + falseDest :: Name,+ metadata' :: InstructionMetadata+ }+ | Br { + dest :: Name,+ metadata' :: InstructionMetadata+ }+ | Switch {+ operand0' :: Operand,+ defaultDest :: Name,+ dests :: [(Constant, Name)],+ metadata' :: InstructionMetadata+ }+ | IndirectBr {+ operand0' :: Operand,+ possibleDests :: [Name],+ metadata' :: InstructionMetadata+ }+ | Invoke {+ callingConvention' :: CallingConvention,+ returnAttributes' :: [ParameterAttribute],+ function' :: CallableOperand,+ arguments' :: [(Operand, [ParameterAttribute])],+ functionAttributes' :: [FunctionAttribute],+ returnDest :: Name,+ exceptionDest :: Name,+ metadata' :: InstructionMetadata+ }+ | Resume {+ operand0' :: Operand,+ metadata' :: InstructionMetadata+ }+ | Unreachable {+ metadata' :: InstructionMetadata+ }+ deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#atomic-memory-ordering-constraints>+-- <http://llvm.org/docs/Atomics.html>+data MemoryOrdering+ = Unordered+ | Monotonic+ | Acquire+ | Release+ | AcquireRelease+ | SequentiallyConsistent+ deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction+data Atomicity = Atomicity { + crossThread :: Bool, -- ^ <http://llvm.org/docs/LangRef.html#singlethread>+ memoryOrdering :: MemoryOrdering+ }+ deriving (Eq, Ord, Read, Show)++-- | For the redoubtably complex 'LandingPad' instruction+data LandingPadClause+ = Catch Constant+ | Filter Constant+ deriving (Eq, Ord, Read, Show)++-- | non-terminator instructions:+-- <http://llvm.org/docs/LangRef.html#binaryops>+-- <http://llvm.org/docs/LangRef.html#bitwiseops>+-- <http://llvm.org/docs/LangRef.html#memoryops>+-- <http://llvm.org/docs/LangRef.html#otherops>+data Instruction+ = Add { + nsw :: Bool,+ nuw :: Bool,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FAdd {+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | Sub {+ nsw :: Bool,+ nuw :: Bool,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FSub { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Mul { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + }+ | FMul { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | UDiv { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | SDiv { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | FDiv { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | URem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | SRem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | FRem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Shl { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | LShr { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | AShr { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | And { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Or { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Xor { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Alloca { + allocatedType :: Type,+ numElements :: Maybe Operand,+ alignment :: Word32,+ metadata :: InstructionMetadata+ }+ | Load {+ volatile :: Bool, + address :: Operand,+ maybeAtomicity :: Maybe Atomicity,+ alignment :: Word32,+ metadata :: InstructionMetadata+ }+ | Store {+ volatile :: Bool, + address :: Operand,+ value :: Operand,+ maybeAtomicity :: Maybe Atomicity,+ alignment :: Word32,+ metadata :: InstructionMetadata+ }+ | GetElementPtr { + inBounds :: Bool,+ address :: Operand,+ indices :: [Operand],+ metadata :: InstructionMetadata+ }+ | Fence { + atomicity :: Atomicity,+ metadata :: InstructionMetadata + }+ | CmpXchg { + volatile :: Bool,+ address :: Operand,+ expected :: Operand,+ replacement :: Operand,+ atomicity :: Atomicity,+ metadata :: InstructionMetadata + }+ | AtomicRMW { + volatile :: Bool,+ rmwOperation :: RMWOperation,+ address :: Operand,+ value :: Operand,+ atomicity :: Atomicity,+ metadata :: InstructionMetadata + }+ | Trunc { + operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata + }+ | ZExt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata + }+ | SExt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPToUI {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPToSI {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | UIToFP {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | SIToFP {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPTrunc {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPExt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | PtrToInt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | IntToPtr {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | BitCast {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | ICmp {+ iPredicate :: IntegerPredicate,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FCmp {+ fpPredicate :: FloatingPointPredicate,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | Phi {+ type' :: Type,+ incomingValues :: [ (Operand, Name) ],+ metadata :: InstructionMetadata+ } + | Call {+ isTailCall :: Bool,+ callingConvention :: CallingConvention,+ returnAttributes :: [ParameterAttribute],+ function :: CallableOperand,+ arguments :: [(Operand, [ParameterAttribute])],+ functionAttributes :: [FunctionAttribute],+ metadata :: InstructionMetadata+ }+ | Select { + condition' :: Operand,+ trueValue :: Operand,+ falseValue :: Operand,+ metadata :: InstructionMetadata+ }+ | VAArg { + argList :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata + }+ | ExtractElement { + vector :: Operand,+ index :: Operand,+ metadata :: InstructionMetadata + }+ | InsertElement { + vector :: Operand,+ element :: Operand,+ index :: Operand,+ metadata :: InstructionMetadata+ }+ | ShuffleVector { + operand0 :: Operand,+ operand1 :: Operand,+ mask :: Constant,+ metadata :: InstructionMetadata+ }+ | ExtractValue { + aggregate :: Operand,+ indices' :: [Word32],+ metadata :: InstructionMetadata+ }+ | InsertValue { + aggregate :: Operand,+ element :: Operand,+ indices' :: [Word32],+ metadata :: InstructionMetadata+ }+ | LandingPad { + type' :: Type,+ personalityFunction :: Operand,+ cleanup :: Bool,+ clauses :: [LandingPadClause],+ metadata :: InstructionMetadata + }+ deriving (Eq, Read, Show)++-- | Instances of instructions may be given a name, allowing their results to be referenced as 'Operand's.+-- Sometimes instructions - e.g. a call to a function returning void - don't need names.+data Named a + = Name := a+ | Do a+ deriving (Eq, Read, Show)
+ src/LLVM/General/AST/IntegerPredicate.hs view
@@ -0,0 +1,21 @@+-- | Predicates for the 'LLVM.General.AST.Instruction.ICmp' instruction+module LLVM.General.AST.IntegerPredicate where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#icmp-instruction>+data IntegerPredicate+ = EQ+ | NE+ | UGT+ | UGE+ | ULT+ | ULE+ | SGT+ | SGE+ | SLT+ | SLE+ deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Linkage.hs view
@@ -0,0 +1,23 @@+-- | Module to allow importing 'Linkage' distinctly qualified.+module LLVM.General.AST.Linkage where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#linkage>+data Linkage+ = Private+ | LinkerPrivate+ | LinkerPrivateWeak+ | Internal+ | AvailableExternally+ | LinkOnce+ | Weak+ | Common+ | Appending+ | ExternWeak+ | LinkOnceODR+ | WeakODR+ | External+ | DLLImport+ | DLLExport+ deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/AST/Name.hs view
@@ -0,0 +1,31 @@+-- | Names as used in LLVM IR+module LLVM.General.AST.Name where++import Data.Word++{- |+Objects of various sorts in LLVM IR are identified by address in the LLVM C++ API, and+may be given a string name. When printed to (resp. read from) human-readable LLVM assembly, objects without+string names are numbered sequentially (resp. must be numbered sequentially). String names may be quoted, and+are quoted when printed if they would otherwise be misread - e.g. when containing special characters. ++> 7++means the seventh unnamed object, while++> "7"++means the object named with the string "7".++This libraries handling of 'UnName's during translation of the AST down into C++ IR is somewhat more+forgiving than the LLVM assembly parser: it does not require that unnamed values be numbered sequentially;+however, the numbers of 'UnName's passed into C++ cannot be preserved in the C++ objects. If the C++ IR is+printed as assembly or translated into a Haskell AST, unnamed nodes will be renumbered sequentially. Thus+unnamed node numbers should be thought of as having any scope limited to the 'LLVM.General.AST.Module' in+which they are used.+-}+data Name + = Name String -- ^ a string name + | UnName Word -- ^ a number for a nameless thing+ deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/AST/Operand.hs view
@@ -0,0 +1,33 @@+-- | A type to represent operands to LLVM 'LLVM.General.AST.Instruction.Instruction's+module LLVM.General.AST.Operand where+ +import Data.Word++import LLVM.General.AST.Name+import LLVM.General.AST.Constant+import LLVM.General.AST.InlineAssembly++-- | A 'MetadataNodeID' is a number for identifying a metadata node.+-- Note this is different from "named metadata", which are represented with+-- 'LLVM.General.AST.NamedMetadataDefinition'.+newtype MetadataNodeID = MetadataNodeID Word+ deriving (Eq, Ord, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#metadata>+data MetadataNode + = MetadataNode [Maybe Operand]+ | MetadataNodeReference MetadataNodeID+ deriving (Eq, Ord, Read, Show)++-- | An 'Operand' is roughly that which is an argument to an 'LLVM.General.AST.Instruction.Instruction'+data Operand + -- | %foo+ = LocalReference Name+ -- | 'Constant's include 'LLVM.General.AST.Constant.GlobalReference', for \@foo+ | ConstantOperand Constant+ | MetadataStringOperand String+ | MetadataNodeOperand MetadataNode+ deriving (Eq, Ord, Read, Show)++-- | The 'LLVM.General.AST.Instruction.Call' instruction is special: the callee can be inline assembly+type CallableOperand = Either InlineAssembly Operand
+ src/LLVM/General/AST/RMWOperation.hs view
@@ -0,0 +1,22 @@+-- | Operations for the 'LLVM.General.AST.Instruction.AtomicRMW' instruction+module LLVM.General.AST.RMWOperation where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#atomicrmw-instruction>+data RMWOperation+ = Xchg+ | Add+ | Sub+ | And+ | Nand+ | Or+ | Xor+ | Max+ | Min+ | UMax+ | UMin+ deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Type.hs view
@@ -0,0 +1,40 @@+-- | A representation of an LLVM type+module LLVM.General.AST.Type where++import LLVM.General.AST.AddrSpace+import LLVM.General.AST.Name++import Data.Word (Word32, Word64)++-- | LLVM supports some special formats floating point format. This type is to distinguish those format.+-- I believe it's treated as a format for "a" float, as opposed to a vector of two floats, because+-- its intended usage is to represent a single number with a combined significand.+data FloatingPointFormat+ = IEEE+ | DoubleExtended+ | PairOfFloats+ deriving (Eq, Ord, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#type-system>+data Type+ -- | <http://llvm.org/docs/LangRef.html#void-type>+ = VoidType+ -- | <http://llvm.org/docs/LangRef.html#integer-type>+ | IntegerType { typeBits :: Word32 }+ -- | <http://llvm.org/docs/LangRef.html#pointer-type>+ | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace }+ -- | <http://llvm.org/docs/LangRef.html#floating-point-types>+ | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat }+ -- | <http://llvm.org/docs/LangRef.html#function-type>+ | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool }+ -- | <http://llvm.org/docs/LangRef.html#vector-type>+ | VectorType { nVectorElements :: Word32, elementType :: Type }+ -- | <http://llvm.org/docs/LangRef.html#structure-type>+ | StructureType { isPacked :: Bool, elementTypes :: [Type] }+ -- | <http://llvm.org/docs/LangRef.html#array-type>+ | ArrayType { nArrayElements :: Word64, elementType :: Type }+ -- | <http://llvm.org/docs/LangRef.html#opaque-structure-types>+ | NamedTypeReference Name+ -- | <http://llvm.org/docs/LangRef.html#metadata-type>+ | MetadataType -- only to be used as a parameter type for a few intrinsics+ deriving (Eq, Ord, Read, Show)
+ src/LLVM/General/AST/Visibility.hs view
@@ -0,0 +1,8 @@+-- | Module to allow importing 'Visibility' distinctly qualified.+module LLVM.General.AST.Visibility where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#visibility>+data Visibility = Default | Hidden | Protected+ deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/Internal/PrettyPrint.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE+ TemplateHaskell,+ QuasiQuotes,+ ViewPatterns,+ OverloadedStrings+ #-}+module LLVM.General.Internal.PrettyPrint where++import Language.Haskell.TH +import Language.Haskell.TH.Quote++import Data.Monoid+import Data.String+import Data.Data+import Data.Word+import Data.Maybe++import Data.List+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Applicative ((<$>),(<*>))+import Control.Monad.Reader++data Branch+ = Fixed String+ | Variable String String+ | IndentGroup Tree+ deriving (Eq, Ord, Show)++type Tree = [Branch]++data PrettyShowEnv = PrettyShowEnv {+ prefixes :: Map String (Maybe String),+ precedence :: Int+ }+ deriving (Show)++defaultPrettyShowEnv :: PrettyShowEnv+defaultPrettyShowEnv = PrettyShowEnv {+ prefixes = Map.empty,+ precedence = 0+ }++type Qual a = Reader PrettyShowEnv a ++prec :: Int -> Qual a -> Qual a+prec p = local (\env -> env { precedence = p })++type QTree = Qual Tree++variable :: String -> String -> QTree+variable t f = return [Variable t f]++indentGroup :: QTree -> QTree+indentGroup = fmap (return . IndentGroup)++instance IsString QTree where+ fromString = return . return . Fixed++instance Monoid QTree where+ mempty = return mempty+ mappend a b = mappend <$> a <*> b++renderEx :: Int -> String -> PrettyShowEnv -> QTree -> String+renderEx threshold indent env ts =+ (\(l, t, f) -> if (l < threshold) then t else f) $ fit 0 (runReader ts env)+ where+ ind i = concat $ replicate i indent+ fit i branches = (sum ls, concat ts, concat fs)+ where+ bit (Fixed s) = (length s, s, s)+ bit (Variable t f) = (length f, f, concat [ s:(if s == '\n' then ind i else "") | s <- t ])+ bit (IndentGroup tree) = + let (l, t, f) = fit (i+1) tree+ in (l, t, if (l < threshold) then t else "\n" ++ ind (i+1) ++ f ++ "\n" ++ ind i)+ (ls, ts, fs) = unzip3 . map bit $ branches+ +render = renderEx 80 " " defaultPrettyShowEnv++comma = "," <> variable "\n" " "+a <+> b = a <> " " <> b++punctuate :: QTree -> [QTree] -> QTree+punctuate a as = intercalate <$> a <*> sequence as++gParens o c content = o <> prec 0 (indentGroup content) <> c+parens = gParens "(" ")"+brackets = gParens "[" "]"+braces = gParens ("{" <> variable "" " ") (variable "" " " <> "}")++record :: QTree -> [(QTree,QTree)] -> QTree+record name fields = do+ name <+> braces (punctuate comma [ n <+> "=" <+> v | (n,v) <- fields ])++ctor :: QTree -> [QTree] -> QTree+ctor name fields = do+ p <- asks precedence+ parensIfNeeded appPrec (foldl (<+>) name fields)++-- | a class for simple pretty-printing with indentation a function only of syntactic depth.+class Show a => PrettyShow a where+ prettyShow :: a -> QTree+ prettyShowList :: [a] -> QTree++ prettyShow = fromString . show+ prettyShowList = brackets . punctuate comma . map prettyShow++instance PrettyShow a => PrettyShow [a] where+ prettyShow = prettyShowList+++appPrec = 10+appPrec1 = 11++parensIfNeeded p' b = do+ p <- asks precedence+ let b' = prec (p'+1) b+ if (p > p') then parens b' else b'++instance PrettyShow Int+instance PrettyShow Bool+instance PrettyShow Integer+instance PrettyShow Double+instance PrettyShow Float+instance PrettyShow Word+instance PrettyShow Word16+instance PrettyShow Word32+instance PrettyShow Word64++instance PrettyShow Char where+ prettyShowList = fromString . show++instance PrettyShow a => PrettyShow (Set a) where+ prettyShow s = ctor "Set.fromList" [prettyShow (Set.toList s)]++instance (PrettyShow a, PrettyShow b) => PrettyShow (a, b) where+ prettyShow (a,b) = parens (prec appPrec1 (prettyShow a <> comma <> prettyShow b))++instance (PrettyShow k, PrettyShow a) => PrettyShow (Map k a) where+ prettyShow m = ctor "Map.fromList" [prettyShow (Map.toList m)]++data SimpleName = SimpleName (Maybe String) String+ deriving (Eq, Ord, Read, Show)++instance PrettyShow SimpleName where+ prettyShow (SimpleName mMod n) = do+ prs <- asks prefixes+ fromString $ fromMaybe n $ do+ mod <- mMod+ pr <- Map.findWithDefault (Just mod) mod prs+ return $ pr ++ "." ++ n++simpleName :: Name -> ExpQ+simpleName n = do+ let d :: Data d => d -> ExpQ+ d = dataToExpQ (const Nothing)+ [| prettyShow (SimpleName $(d (nameModule n)) $(d (nameBase n))) |]++makePrettyShowInstance :: Name -> DecsQ+makePrettyShowInstance n = do+ info <- reify n+ let (tvb, cons) = + case info of+ TyConI (DataD _ _ tvb cons _) -> (tvb, cons)+ TyConI (NewtypeD _ _ tvb con _) -> (tvb, [con])+ x -> error $ "unexpected info: " ++ show x+ cs <- mapM (const $ newName "a") tvb+ let cvs = map varT cs+ sequence . return $ instanceD (cxt [classP (mkName "PrettyShow") [cv] | cv <- cvs]) [t| PrettyShow $(foldl appT (conT n) cvs) |] [+ funD (mkName "prettyShow") [+ clause+ [varP (mkName "a")] (+ normalB $ caseE (dyn "a") $ flip map cons $ \con -> do+ case con of+ RecC conName (unzip3 -> (ns, _, _)) -> do+ pvs <- mapM (const $ newName "f") ns+ let ss = [| record $(simpleName conName) $(listE [[|($(simpleName n), prettyShow $(varE pv))|] | (n, pv) <- zip ns pvs]) |]+ match + (conP conName (map varP pvs))+ (normalB ss)+ []+ NormalC conName fs -> do+ pvs <- mapM (const $ newName "f") fs+ let ss = [| ctor $(simpleName conName) $(listE [[| prettyShow $(varE pv)|] | pv <- pvs]) |]+ match + (conP conName (map varP pvs))+ (normalB ss)+ []+ InfixC (_, n0) conName (_, n1) -> do+ DataConI _ _ _ (Fixity prec _) <- reify conName+ let ns = [n0, n1]+ [p0,p1] <- mapM (const $ newName "f") ns+ let ss = [| parensIfNeeded prec (prettyShow $(varE p0) <+> $(simpleName conName) <+> prettyShow $(varE p1)) |]+ match+ (uInfixP (varP p0) conName (varP p1))+ (normalB ss)+ []+ x -> error $ "unexpected constructor pattern: " ++ show x+ )+ []+ ]+ ]++ +
+ src/LLVM/General/PrettyPrint.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE+ TemplateHaskell,+ GeneralizedNewtypeDeriving+ #-}+-- | Tools for printing out AST.'LLVM.General.AST.Module' code so that it's actually useful.+module LLVM.General.PrettyPrint (+ PrettyShow(..),+ showPretty,+ showPrettyEx,+ PrefixScheme(..),+ shortPrefixScheme,+ longPrefixScheme,+ defaultPrefixScheme,+ basePrefixScheme, + shortASTPrefixScheme,+ longASTPrefixScheme,+ imports+ ) where++import Control.Monad+import Data.Functor+import Data.Monoid+import Data.Map (Map)+import qualified Data.Map as Map+import LLVM.General.Internal.PrettyPrint++import qualified LLVM.General.AST as A+import qualified LLVM.General.AST.DataLayout as A+import qualified LLVM.General.AST.Constant as A.C+import qualified LLVM.General.AST.AddrSpace as A+import qualified LLVM.General.AST.Float as A+import qualified LLVM.General.AST.FloatingPointPredicate as A+import qualified LLVM.General.AST.IntegerPredicate as A+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.CallingConvention as A+import qualified LLVM.General.AST.Visibility as A+import qualified LLVM.General.AST.Linkage as A+import qualified LLVM.General.AST.InlineAssembly as A+import qualified LLVM.General.AST.RMWOperation as A++liftM concat $ mapM makePrettyShowInstance [+ ''A.Module,+ ''A.Definition,+ ''A.DataLayout,+ ''A.Operand,+ ''A.MetadataNodeID,+ ''A.MetadataNode,+ ''A.Type,+ ''A.Name,+ ''A.Global,+ ''A.AlignmentInfo,+ ''A.AlignType,+ ''A.C.Constant,+ ''A.AddrSpace,+ ''A.Endianness,+ ''A.BasicBlock,+ ''A.FloatingPointPredicate,+ ''A.IntegerPredicate,+ ''A.FloatingPointFormat,+ ''A.FunctionAttribute,+ ''A.ParameterAttribute,+ ''A.Parameter,+ ''A.CallingConvention,+ ''A.Visibility,+ ''A.Linkage,+ ''A.SomeFloat,+ ''A.Named,+ ''A.Terminator,+ ''A.Instruction,+ ''A.LandingPadClause,+ ''A.InlineAssembly,+ ''A.RMWOperation,+ ''A.Atomicity,+ ''A.Dialect,+ ''A.MemoryOrdering,+ ''Either,+ ''Maybe+ ]++-- | Show an AST.'LLVM.General.AST.Module' or part thereof both with qualified+-- identifiers (resolving some ambiguity, making the output usable Haskell) and+-- with indentation (making the output readable).+showPretty :: PrettyShow a => a -> String+showPretty = showPrettyEx 80 " " defaultPrefixScheme++-- | Like 'showPretty' but allowing configuration of the format+showPrettyEx+ :: PrettyShow a+ => Int -- ^ line length before attempting breaking+ -> String -- ^ one unit of indentation+ -> PrefixScheme -- ^ prefixes to use for qualifying names+ -> a+ -> String+showPrettyEx width indent (PrefixScheme ps) = renderEx width indent (defaultPrettyShowEnv { prefixes = ps }) . prettyShow++-- | A 'PrefixScheme' is a mapping between haskell module names and+-- the prefixes with which they should be rendered when printing code.+newtype PrefixScheme = PrefixScheme (Map String (Maybe String))+ deriving (Eq, Ord, Read, Show, Monoid)++-- | a 'PrefixScheme' for types not of llvm-general, but nevertheless used+-- in the AST. Useful for building other 'PrefixScheme's.+basePrefixScheme :: PrefixScheme+basePrefixScheme = PrefixScheme $ Map.fromList [+ ("Data.Maybe", Nothing),+ ("Data.Either", Nothing),+ ("Data.Map", Just "Map"),+ ("Data.Set", Just "Set")+ ]++-- | a terse 'PrefixScheme' for types in the AST, leaving most names unqualified.+-- Useful for building other 'PrefixScheme's. If you think you want to use this, you+-- probably want 'shortPrefixScheme' instead.+shortASTPrefixScheme :: PrefixScheme+shortASTPrefixScheme = PrefixScheme $ Map.fromList [+ ("LLVM.General.AST", Nothing),+ ("LLVM.General.AST.AddrSpace", Nothing),+ ("LLVM.General.AST.DataLayout", Nothing),+ ("LLVM.General.AST.Float", Nothing),+ ("LLVM.General.AST.InlineAssembly", Nothing),+ ("LLVM.General.AST.Instruction", Nothing),+ ("LLVM.General.AST.Name", Nothing),+ ("LLVM.General.AST.Operand", Nothing),+ ("LLVM.General.AST.Type", Nothing),+ ("LLVM.General.AST.FloatingPointPredicate", Just "FPred"),+ ("LLVM.General.AST.IntegerPredicate", Just "IPred"),+ ("LLVM.General.AST.Constant", Just "C"),+ ("LLVM.General.AST.Attribute", Just "A"),+ ("LLVM.General.AST.Global", Just "G"),+ ("LLVM.General.AST.CallingConvention", Just "CC"),+ ("LLVM.General.AST.Visibility", Just "V"),+ ("LLVM.General.AST.Linkage", Just "L")+ ]++-- | a conservative 'PrefixScheme' for types in the AST which qualifies everything.+-- Useful for building other 'PrefixScheme's. If you think you want to use this, you+-- probably want 'longPrefixScheme' instead.+longASTPrefixScheme :: PrefixScheme+longASTPrefixScheme = case shortASTPrefixScheme of+ PrefixScheme m -> PrefixScheme $ maybe (Just "A") (Just . ("A."++)) <$> m++-- | a terse 'PrefixScheme', leaving most names unqualified.+shortPrefixScheme :: PrefixScheme+shortPrefixScheme = shortASTPrefixScheme <> basePrefixScheme++-- | a conservative 'PrefixScheme' which qualifies everything.+longPrefixScheme :: PrefixScheme+longPrefixScheme = longASTPrefixScheme <> basePrefixScheme++-- | the default 'PrefixScheme' used by 'showPretty'+defaultPrefixScheme :: PrefixScheme+defaultPrefixScheme = longPrefixScheme++-- | print Haskell imports to define the correct prefixes for use with the output+-- of a given 'PrefixScheme'.+imports :: PrefixScheme -> String+imports (PrefixScheme p) = unlines . flip map (Map.toList p) $ \(mod, mAbbr) ->+ "import " ++ maybe mod (\abbr -> "qualified " ++ mod ++ " as " ++ abbr) mAbbr++
+ test/LLVM/General/Test/PrettyPrint.hs view
@@ -0,0 +1,98 @@+module LLVM.General.Test.PrettyPrint where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.PrettyPrint++import LLVM.General.AST+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Constant as C++tests = testGroup "PrettyPrint" [+ testCase "basic" $ do+ let ast = Module "<string>" Nothing Nothing [+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False)+ [] Nothing 0 + [+ BasicBlock (UnName 0) [+ UnName 1 := Mul {+ nsw = True,+ nuw = False,+ operand0 = ConstantOperand (C.Int 32 1),+ operand1 = ConstantOperand (C.Int 32 1),+ metadata = []+ }+ ] (+ Do $ Br (Name "here") []+ ),+ BasicBlock (Name "here") [+ ] (+ Do $ Ret (Just (LocalReference (UnName 1))) []+ )+ ]+ ]+ s = "A.Module {\n\+ \ A.moduleName = \"<string>\",\n\+ \ A.moduleDataLayout = Nothing,\n\+ \ A.moduleTargetTriple = Nothing,\n\+ \ A.moduleDefinitions = [\n\+ \ A.GlobalDefinition A.G.Function {\n\+ \ A.G.linkage = A.L.External,\n\+ \ A.G.visibility = A.V.Default,\n\+ \ A.G.callingConvention = A.CC.C,\n\+ \ A.G.returnAttributes = [],\n\+ \ A.G.returnType = A.IntegerType {A.typeBits = 32},\n\+ \ A.G.name = A.Name \"foo\",\n\+ \ A.G.parameters = ([A.G.Parameter A.IntegerType { A.typeBits = 32 } (A.Name \"x\") []], False),\n\+ \ A.G.functionAttributes = [],\n\+ \ A.G.section = Nothing,\n\+ \ A.G.alignment = 0,\n\+ \ A.G.basicBlocks = [\n\+ \ A.G.BasicBlock (A.UnName 0) [\n\+ \ A.UnName 1 A.:= A.Mul {\n\+ \ A.nsw = True,\n\+ \ A.nuw = False,\n\+ \ A.operand0 = A.ConstantOperand A.C.Int {A.C.integerBits = 32, A.C.integerValue = 1},\n\+ \ A.operand1 = A.ConstantOperand A.C.Int {A.C.integerBits = 32, A.C.integerValue = 1},\n\+ \ A.metadata = []\n\+ \ }\n\+ \ ] (A.Do A.Br { A.dest = A.Name \"here\", A.metadata' = [] }),\n\+ \ A.G.BasicBlock (A.Name \"here\") [] (\n\+ \ A.Do A.Ret {A.returnOperand = Just (A.LocalReference (A.UnName 1)), A.metadata' = []}\n\+ \ )\n\+ \ ]\n\+ \ }\n\+ \ ]\n\+ \}"+ showPretty ast @?= s,+ testCase "imports" $ do+ imports defaultPrefixScheme @?= + "import Data.Either\n\+ \import qualified Data.Map as Map\n\+ \import Data.Maybe\n\+ \import qualified Data.Set as Set\n\+ \import qualified LLVM.General.AST as A\n\+ \import qualified LLVM.General.AST.AddrSpace as A\n\+ \import qualified LLVM.General.AST.Attribute as A.A\n\+ \import qualified LLVM.General.AST.CallingConvention as A.CC\n\+ \import qualified LLVM.General.AST.Constant as A.C\n\+ \import qualified LLVM.General.AST.DataLayout as A\n\+ \import qualified LLVM.General.AST.Float as A\n\+ \import qualified LLVM.General.AST.FloatingPointPredicate as A.FPred\n\+ \import qualified LLVM.General.AST.Global as A.G\n\+ \import qualified LLVM.General.AST.InlineAssembly as A\n\+ \import qualified LLVM.General.AST.Instruction as A\n\+ \import qualified LLVM.General.AST.IntegerPredicate as A.IPred\n\+ \import qualified LLVM.General.AST.Linkage as A.L\n\+ \import qualified LLVM.General.AST.Name as A\n\+ \import qualified LLVM.General.AST.Operand as A\n\+ \import qualified LLVM.General.AST.Type as A\n\+ \import qualified LLVM.General.AST.Visibility as A.V\n"+ ]+
+ test/Test.hs view
@@ -0,0 +1,6 @@+import Test.Framework+import qualified LLVM.General.Test.Tests as LLVM.General++main = defaultMain [+ LLVM.General.tests+ ]