llvm-general-quote (empty) → 0.1.0.0
raw patch · 13 files changed
+4307/−0 lines, 13 filesdep +HUnitdep +arraydep +basesetup-changed
Dependencies added: HUnit, array, base, bytestring, containers, exception-transformers, haskell-src-meta, llvm-general-pure, llvm-general-quote, mainland-pretty, mtl, split, srcloc, syb, symbol, tasty, tasty-hunit, template-haskell, th-lift
Files
- LICENSE +27/−0
- README.md +2/−0
- Setup.hs +2/−0
- llvm-general-quote.cabal +72/−0
- src/LLVM/General/Quote/AST.hs +745/−0
- src/LLVM/General/Quote/Base.hs +969/−0
- src/LLVM/General/Quote/LLVM.hs +30/−0
- src/LLVM/General/Quote/Parser.hs +23/−0
- src/LLVM/General/Quote/Parser/Lexer.x +377/−0
- src/LLVM/General/Quote/Parser/Monad.hs +325/−0
- src/LLVM/General/Quote/Parser/Parser.y +1049/−0
- src/LLVM/General/Quote/Parser/Tokens.hs +682/−0
- test/test.hs +4/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Timo von Holtz+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 the {organization} nor the names of its+ 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.
+ README.md view
@@ -0,0 +1,2 @@+language-llvm-quote+===================
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ llvm-general-quote.cabal view
@@ -0,0 +1,72 @@+name: llvm-general-quote+version: 0.1.0.0+synopsis: QuasiQuoting llvm code for llvm-general+homepage: https://github.com/tvh/llvm-general-quote+description:+ This package provides a QuasiQuotation for llvm-general.++license: BSD3+license-file: LICENSE+author: Timo von Holtz <tvh@tvholtz.de>+maintainer: Timo von Holtz <tvh@tvholtz.de>+copyright: Timo von Holtz 2014+category: Compilers/Interpreters, Code Generation+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/tvh/llvm-general-quote.git++library+ exposed-modules:+ LLVM.General.Quote.LLVM+ other-modules:+ LLVM.General.Quote.Parser.Lexer,+ LLVM.General.Quote.Parser.Tokens,+ LLVM.General.Quote.Parser.Monad,+ LLVM.General.Quote.Parser.Parser,+ LLVM.General.Quote.Parser,+ LLVM.General.Quote.AST,+ LLVM.General.Quote.Base+ other-extensions: CPP+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <4.8,+ array >=0.5 && <0.6,+ containers >=0.5 && <0.6,+ mtl,+ bytestring,+ symbol,+ srcloc,+ exception-transformers,+ mainland-pretty,+ llvm-general-pure,+ syb,+ template-haskell >= 2.7,+ haskell-src-meta,+ th-lift,+ split + build-tools: alex, happy+ hs-source-dirs: src+ default-language: Haskell2010++Test-suite test+ Default-language:+ Haskell2010+ Type:+ exitcode-stdio-1.0+ Hs-source-dirs:+ test+ Main-is:+ test.hs+ Build-depends:+ base >= 4 && < 5+ , tasty >= 0.8+ , tasty-hunit >= 0.8+ , HUnit+ , llvm-general-quote+ , llvm-general-pure+ , containers+
+ src/LLVM/General/Quote/AST.hs view
@@ -0,0 +1,745 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module LLVM.General.Quote.AST (+ Module(..),+ Definition(..),+ Global(..),+ Parameter(..),+ BasicBlock(..),+ InstructionMetadata,+ Terminator(..),+ MemoryOrdering(..),+ Atomicity(..),+ LandingPadClause(..),+ Instruction(..),+ Named(..),+ MetadataNodeID(..),+ MetadataNode(..),+ Operand(..),+ CallableOperand,+ Constant(..),+ Name(..),+ FloatingPointFormat(..),+ Type(..),+ Dialect(..),+ InlineAssembly(..),+ Endianness(..),+ AlignmentInfo(..),+ AlignType(..),+ DataLayout(..),+ TargetTriple(..),+ Extensions(..), ExtensionsInt+ ) where++import qualified LLVM.General.AST.Float as A+import qualified LLVM.General.AST.Linkage as A+import qualified LLVM.General.AST.Visibility as A+import qualified LLVM.General.AST.CallingConvention as A+import qualified LLVM.General.AST.AddrSpace as A+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.IntegerPredicate as AI+import qualified LLVM.General.AST.FloatingPointPredicate as AF+import qualified LLVM.General.AST.RMWOperation as A++import Data.Word+import Data.Typeable+import Data.Data+import qualified Data.Map as M+import qualified Data.Set as S+import Language.Haskell.TH.Lift++data Extensions+ = Antiquotation+ | Loops+ deriving (Eq, Ord, Enum, Show)+type ExtensionsInt = Word32++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalValue.html>+data Global+ -- | <http://llvm.org/docs/LangRef.html#global-variables>+ = GlobalVariable {+ name :: Name,+ linkage :: A.Linkage,+ visibility :: A.Visibility,+ isThreadLocal :: Bool,+ addrSpace :: A.AddrSpace,+ hasUnnamedAddr :: Bool,+ isConstant :: Bool,+ _type' :: Type,+ initializer :: Maybe Constant,+ section :: Maybe String,+ alignmentG :: Word32+ }+ -- | <http://llvm.org/docs/LangRef.html#aliases>+ | GlobalAlias {+ name :: Name,+ linkage :: A.Linkage,+ visibility :: A.Visibility,+ _type' :: Type,+ aliasee :: Constant+ }+ -- | <http://llvm.org/docs/LangRef.html#functions>+ | Function {+ linkage :: A.Linkage,+ visibility :: A.Visibility,+ _callingConvention :: A.CallingConvention,+ _returnAttributes :: [A.ParameterAttribute],+ returnType :: Type,+ name :: Name,+ parameters :: ([Parameter],Bool), -- ^ snd indicates varargs+ _functionAttributes :: [A.FunctionAttribute],+ section :: Maybe String,+ alignment :: Word32,+ garbageCollectorName :: Maybe String,+ basicBlocks :: [BasicBlock]+ }+ deriving (Eq, Read, Show, Typeable, Data)++-- | 'Parameter's for 'Function's+data Parameter+ = Parameter Type Name [A.ParameterAttribute]+ | AntiParameter String+ | AntiParameterList String+ deriving (Eq, Read, Show, Typeable, Data)++-- | <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 {+ label :: Name,+ instructions :: [Named Instruction],+ terminator :: (Named Terminator)+ }+ | ForLoop {+ label :: Name,+ iterType :: Type,+ iterName :: Name,+ from :: Operand,+ to :: Operand,+ _elementType :: Type,+ _element :: [(Operand,Name)],+ _elementName :: Name,+ body :: [BasicBlock],+ next :: Maybe Name}+ | AntiBasicBlock String+ | AntiBasicBlockList String+ deriving (Eq, Read, Show, Typeable, Data)++-- | 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+ | AntiDefinition String+ | AntiDefinitionList String+ deriving (Eq, Read, Show, Typeable, Data)++-- | <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 :: TargetTriple,+ moduleDefinitions :: [Definition]+ } + deriving (Eq, Read, Show, Typeable, Data)++-- | <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' :: A.CallingConvention,+ returnAttributes' :: [A.ParameterAttribute],+ function' :: CallableOperand,+ arguments' :: [(Operand, [A.ParameterAttribute])],+ functionAttributes' :: [A.FunctionAttribute],+ returnDest :: Name,+ exceptionDest :: Name,+ metadata' :: InstructionMetadata+ }+ | Resume {+ operand0' :: Operand,+ metadata' :: InstructionMetadata+ }+ | Unreachable {+ metadata' :: InstructionMetadata+ }+ deriving (Eq, Read, Show, Typeable, Data)++-- | <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, Typeable, Data)++-- | For the redoubtably complex 'LandingPad' instruction+data LandingPadClause+ = Catch Constant+ | Filter Constant+ deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | 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,+ alignmentI :: Word32,+ metadata :: InstructionMetadata+ }+ | Load {+ volatile :: Bool, + address :: Operand,+ maybeAtomicity :: Maybe Atomicity,+ alignmentI :: Word32,+ metadata :: InstructionMetadata+ }+ | Store {+ volatile :: Bool, + address :: Operand,+ value :: Operand,+ maybeAtomicity :: Maybe Atomicity,+ alignmentI :: 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 :: A.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+ }+ | AddrSpaceCast {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | ICmp {+ iPredicate :: AI.IntegerPredicate,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FCmp {+ fpPredicate :: AF.FloatingPointPredicate,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | Phi {+ type' :: Type,+ incomingValues :: [ (Operand, Name) ],+ metadata :: InstructionMetadata+ } + | Call {+ isTailCall :: Bool,+ callingConvention :: A.CallingConvention,+ returnAttributes :: [A.ParameterAttribute],+ function :: CallableOperand,+ arguments :: [(Operand, [A.ParameterAttribute])],+ functionAttributes :: [A.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+ }+ | AntiInstruction String+ deriving (Eq, Read, Show, Typeable, Data)++-- | 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, Typeable, Data)++-- | 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, Typeable, Data)++-- | <http://llvm.org/docs/LangRef.html#metadata>+data MetadataNode + = MetadataNode [Maybe Operand]+ | MetadataNodeReference MetadataNodeID+ deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | 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, Typeable, Data)++-- | The 'LLVM.General.AST.Instruction.Call' instruction is special: the callee can be inline assembly+type CallableOperand = Either InlineAssembly Operand++{- |+<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 :: A.SomeFloat }+ | Null { constantType :: Type }+ | Struct { structName :: Maybe Name, _isPacked :: Bool, memberValues :: [ Constant ] }+ | Array { memberType :: Type, memberValues :: [ Constant ] }+ | Vector { memberValues :: [ Constant ] }+ | Undef { constantType :: Type }+ | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name }+ | GlobalReference Name+ | AntiConstant String+ deriving (Eq, Ord, Read, Show, Typeable, Data)++{- |+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+ | AntiName String+ deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | 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, Typeable, Data)++-- | <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 :: A.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, Typeable, Data)++-- | 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, Typeable, Data)++-- | Little Endian is the one true way :-). Sadly, we must support the infidels.+data Endianness = LittleEndian | BigEndian+ deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | 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, Typeable, Data)++-- | A type of type for which 'AlignmentInfo' may be specified+data AlignType+ = IntegerAlign+ | VectorAlign+ | FloatAlign+ | AggregateAlign+ | StackAlign+ deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | a description of the various data layout properties which may be used during+-- optimization+data DataLayout+ = DataLayout {+ endianness :: Maybe Endianness,+ stackAlignment :: Maybe Word32,+ pointerLayouts :: M.Map A.AddrSpace (Word32, AlignmentInfo),+ typeLayouts :: M.Map (AlignType, Word32) AlignmentInfo,+ nativeSizes :: Maybe (S.Set Word32)+ }+ | AntiDataLayout String+ deriving (Eq, Ord, Read, Show, Typeable, Data)++data TargetTriple+ = NoTargetTriple+ | TargetTriple String+ | AntiTargetTriple String+ deriving (Eq, Ord, Read, Show, Typeable, Data)++$(deriveLiftMany [''A.Visibility,+ ''A.Linkage,+ ''A.ParameterAttribute,+ ''Global,+ ''Constant,+ ''A.AddrSpace,+ ''A.CallingConvention,+ ''A.FunctionAttribute,+ ''A.SomeFloat,+ ''AI.IntegerPredicate,+ ''AF.FloatingPointPredicate,+ ''BasicBlock,+ ''Parameter,+ ''Named,+ ''Instruction,+ ''InlineAssembly,+ ''Dialect,+ ''A.RMWOperation,+ ''Atomicity,+ ''LandingPadClause,+ ''MemoryOrdering,+ ''Terminator,+ ''Name,+ ''MetadataNode,+ ''MetadataNodeID,+ ''Operand,+ ''Type,+ ''FloatingPointFormat,+ ''DataLayout,+ ''Endianness,+ ''M.Map,+ ''AlignType,+ ''AlignmentInfo,+ ''S.Set,+ ''Definition,+ ''Module,+ ''TargetTriple+ ])+instance Lift Word64 where+ lift = lift . toInteger+instance Lift Word32 where+ lift = lift . toInteger+instance Lift Word16 where+ lift = lift . toInteger+instance Lift Word where+ lift = lift . toInteger+instance Lift Float where+ lift = lift . toRational+instance Lift Double where+ lift = lift . toRational
+ src/LLVM/General/Quote/Base.hs view
@@ -0,0 +1,969 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++module LLVM.General.Quote.Base (+ ToDefintions(..),+ quasiquote,+ parse+ ) where++import Control.Monad ((>=>))+import qualified Data.ByteString.Char8 as B+import Data.Data (Data(..))+import Data.Generics (extQ)+import Data.Word+import Data.Loc+import Data.Typeable (Typeable)+import Language.Haskell.Meta (parseExp, parsePat)+import Language.Haskell.TH+import Language.Haskell.TH.Quote (QuasiQuoter(..),+ dataToExpQ,+ dataToPatQ)++import qualified LLVM.General.Quote.Parser as P+import qualified LLVM.General.Quote.AST as A+import qualified LLVM.General.AST.IntegerPredicate as AI+import qualified LLVM.General.AST as L+import qualified LLVM.General.AST.Constant as L+ (Constant(Int, Float, Null, Struct, Array, Vector, Undef, BlockAddress, GlobalReference))+import qualified LLVM.General.AST.Float as L+import qualified LLVM.General.AST.InlineAssembly as L+import qualified LLVM.General.AST.DataLayout as L+import qualified LLVM.General.AST.AddrSpace as A++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe++class ToDefintion a where+ toDefinition :: a -> L.Definition+instance ToDefintion L.Definition where+ toDefinition = id+instance ToDefintion L.Global where+ toDefinition = L.GlobalDefinition++class ToDefintions a where+ toDefinitions :: a -> [L.Definition]+instance ToDefintion a => ToDefintions [a] where+ toDefinitions = map toDefinition++class ToConstant a where+ toConstant :: a -> L.Constant+instance ToConstant Word8 where+ toConstant n = L.Int 8 (toInteger n)+instance ToConstant Word16 where+ toConstant n = L.Int 16 (toInteger n)+instance ToConstant Word32 where+ toConstant n = L.Int 32 (toInteger n)+instance ToConstant Word64 where+ toConstant n = L.Int 64 (toInteger n)+instance ToConstant Float where+ toConstant n = L.Float (L.Single n)+instance ToConstant Double where+ toConstant n = L.Float (L.Double n)++class ToName a where+ toName :: a -> L.Name+instance ToName L.Name where+ toName = id+instance ToName String where+ toName = L.Name+instance ToName Word where+ toName = L.UnName++class ToTargetTriple a where+ toTargetTriple :: a -> Maybe String+instance ToTargetTriple String where+ toTargetTriple = Just+instance ToTargetTriple (Maybe String) where+ toTargetTriple = id++antiVarE :: String -> ExpQ+antiVarE = either fail return . parseExp++qqDefinitionListE :: [A.Definition] -> Maybe (Q Exp)+qqDefinitionListE [] = Just [|[]|]+qqDefinitionListE (A.AntiDefinitionList v : defs) =+ Just [|toDefinitions $(antiVarE v) ++ $(qqE defs)|]+qqDefinitionListE (def : defs) =+ Just [|$(qqE def) : $(qqE defs)|]++qqDefinitionE :: A.Definition -> Maybe (Q Exp)+qqDefinitionE (A.GlobalDefinition v) =+ Just [|L.GlobalDefinition $(qqE v) :: L.Definition|]+qqDefinitionE (A.TypeDefinition n v) =+ Just [|L.TypeDefinition $(qqE n) $(qqE v) :: L.Definition|]+qqDefinitionE (A.MetadataNodeDefinition i vs) =+ Just [|L.MetadataNodeDefinition $(qqE i) $(qqE vs) :: L.Definition|]+qqDefinitionE (A.NamedMetadataDefinition i vs) =+ Just [|L.NamedMetadataDefinition $(qqE i) $(qqE vs) :: L.Definition|]+qqDefinitionE (A.ModuleInlineAssembly s) =+ Just [|L.ModuleInlineAssembly $(qqE s) :: L.Definition|]+qqDefinitionE a@(A.AntiDefinition s) =+ Just $ antiVarE s+qqDefinitionE a@(A.AntiDefinitionList _s) =+ error $ "Internal Error: unexpected antiquote " ++ show a++qqModuleE :: A.Module -> Maybe (Q Exp)+qqModuleE (A.Module n dl tt ds) = + Just [|L.Module $(qqE n) $(qqE dl) $(qqE tt) $(qqE ds) :: L.Module|]++qqGlobalE :: A.Global -> Maybe (Q Exp)+qqGlobalE (A.GlobalVariable x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB) =+ Just [|L.GlobalVariable $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6) $(qqE x7) $(qqE x8) $(qqE x9) $(qqE xA)+ $(qqE xB)|]+qqGlobalE (A.GlobalAlias x1 x2 x3 x4 x5) =+ Just [|L.GlobalAlias $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqGlobalE (A.Function x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC) =+ Just [|L.Function $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6) $(qqE x7) $(qqE x8) $(qqE x9) $(qqE xA)+ $(qqE xB) $(qqE xC)|]++qqParameterListE :: [A.Parameter] -> Maybe (Q Exp)+qqParameterListE [] = Just [|[]|]+qqParameterListE (A.AntiParameterList v : defs) =+ Just [|$(antiVarE v) ++ $(qqE defs)|]+qqParameterListE (def : defs) =+ Just [|$(qqE def) : $(qqE defs)|]++qqParameterE :: A.Parameter -> Maybe (Q Exp)+qqParameterE (A.Parameter x1 x2 x3) =+ Just [|L.Parameter $(qqE x1) $(qqE x2) $(qqE x3)|]+qqParameterE (A.AntiParameter s) =+ Just $ antiVarE s+qqParameterE a@(A.AntiParameterList _s) =+ error $ "Internal Error: unexpected antiquote " ++ show a++qqBasicBlockListE :: [A.BasicBlock] -> Maybe (Q Exp)+qqBasicBlockListE [] = Just [|[]|]+qqBasicBlockListE (for@A.ForLoop{} : defs) =+ Just [|$(qqE $ transform for) ++ $(qqE defs)|]+qqBasicBlockListE (A.AntiBasicBlockList v : defs) =+ Just [|$(antiVarE v) ++ $(qqE defs)|]+qqBasicBlockListE (def : defs) =+ Just [|$(qqE def) : $(qqE defs)|]++transform :: A.BasicBlock -> [A.BasicBlock]+transform bb@A.BasicBlock{} = [bb]+transform (A.ForLoop label iterType iterName from to elementType element elementName body next) =+ let labelString = case label of+ A.Name s -> s+ A.UnName n -> "num"++show n+ A.AntiName s -> error $ "Error: antiquotation for names not legal in for-header " ++ s+ cond = A.Name $ labelString ++ ".cond"+ iterNameNew = A.Name $ case iterName of+ A.Name s -> s ++ ".new"+ A.UnName n -> "num"++show n++".new"+ A.AntiName s -> error $ "Error: antiquotation for names not legal in for-header " ++ s+ iterBits = case iterType of+ A.IntegerType n -> n+ t -> error $ "Internal Error: unexpected type " ++ show t+ iter = (A.LocalReference iterName)+ --labels = map A.label body+ preInstrs = + [ iterName A.:= A.Phi iterType (map (\(_,l) -> (A.LocalReference iterNameNew,l)) returns ++ map (\(_,s) -> (from,s)) element) []+ , elementName A.:= A.Phi elementType (returns ++ element) []+ , cond A.:= A.ICmp AI.ULE iter to []+ , iterNameNew A.:= A.Add True True iter (A.ConstantOperand $ A.Int iterBits 1) []+ ]+ body' = body >>= transform+ bodyLabel = A.label $ head body'+ returns = body' >>= maybeToList . ret+ pre = case next of+ Just next' -> A.BasicBlock label preInstrs (A.Do $ A.CondBr (A.LocalReference cond) bodyLabel next' [])+ Nothing -> A.BasicBlock label preInstrs (A.Do $ A.Ret (Just $ A.LocalReference elementName) [])+ main = map (replaceRet label) body'+ in (pre:main)+transform A.AntiBasicBlock{}+ = error $ "Error: antiquotation of BasicBlocks not allowed inside a loop"+transform A.AntiBasicBlockList{}+ = error $ "Error: antiquotation of BasicBlocks not allowed inside a loop"++ret :: A.BasicBlock -> Maybe (A.Operand, A.Name)+ret (A.BasicBlock l _ t') = do+ let t = case t' of+ _ A.:= t'' -> t''+ A.Do t'' -> t''+ A.Ret (Just x) _ <- return t+ return (x,l)+ret x = error $ "Internal Error: only plain BasicBlocks should arrive at function ret. got: " ++ show x++replaceRet :: A.Name -> A.BasicBlock -> A.BasicBlock+replaceRet label bb@A.BasicBlock{} =+ case A.terminator bb of+ n A.:= A.Ret _ md -> bb{ A.terminator = n A.:= A.Br label md }+ A.Do (A.Ret _ md) -> bb{ A.terminator = A.Do (A.Br label md) }+ _ -> bb+replaceRet _ x = error $ "Internal Error: only plain BasicBlocks should arrive at function replaceRet. got: " ++ show x++qqBasicBlockE :: A.BasicBlock -> Maybe (Q Exp)+qqBasicBlockE (A.BasicBlock x1 x2 x3) =+ Just [|L.BasicBlock $(qqE x1) $(qqE x2) $(qqE x3)|]+qqBasicBlockE (A.AntiBasicBlock s) =+ Just $ antiVarE s+qqBasicBlockE a@A.ForLoop{} =+ error $ "Internal Error: unexpected loop " ++ show a+qqBasicBlockE a@(A.AntiBasicBlockList _s) =+ error $ "Internal Error: unexpected antiquote " ++ show a++qqTerminatorE :: A.Terminator -> Maybe (Q Exp)+qqTerminatorE (A.Ret x1 x2) =+ Just [|L.Ret $(qqE x1) $(qqE x2)|]+qqTerminatorE (A.CondBr x1 x2 x3 x4) =+ Just [|L.CondBr $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqTerminatorE (A.Br x1 x2) =+ Just [|L.Br $(qqE x1) $(qqE x2)|]+qqTerminatorE (A.Switch x1 x2 x3 x4) =+ Just [|L.Switch $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqTerminatorE (A.IndirectBr x1 x2 x3) =+ Just [|L.IndirectBr $(qqE x1) $(qqE x2) $(qqE x3)|]+qqTerminatorE (A.Invoke x1 x2 x3 x4 x5 x6 x7 x8) =+ Just [|L.Invoke $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6) $(qqE x7) $(qqE x8)|]+qqTerminatorE (A.Resume x1 x2) =+ Just [|L.Resume $(qqE x1) $(qqE x2)|]+qqTerminatorE (A.Unreachable x1) =+ Just [|L.Unreachable $(qqE x1)|]++qqMemoryOrderingE :: A.MemoryOrdering -> Maybe (Q Exp)+qqMemoryOrderingE A.Unordered =+ Just [|L.Unordered|]+qqMemoryOrderingE A.Monotonic =+ Just [|L.Monotonic|]+qqMemoryOrderingE A.Acquire =+ Just [|L.Acquire|]+qqMemoryOrderingE A.Release =+ Just [|L.Release|]+qqMemoryOrderingE A.AcquireRelease =+ Just [|L.AcquireRelease|]+qqMemoryOrderingE A.SequentiallyConsistent =+ Just [|L.SequentiallyConsistent|]++qqAtomicityE :: A.Atomicity -> Maybe (Q Exp)+qqAtomicityE (A.Atomicity x1 x2) =+ Just [|L.Atomicity $(qqE x1) $(qqE x2)|]++qqLandingPadClauseE :: A.LandingPadClause -> Maybe (Q Exp)+qqLandingPadClauseE (A.Catch x1) =+ Just [|L.Catch $(qqE x1)|]+qqLandingPadClauseE (A.Filter x1) =+ Just [|L.Filter $(qqE x1)|]++qqInstructionE :: A.Instruction -> Maybe (Q Exp)+qqInstructionE (A.Add x1 x2 x3 x4 x5) =+ Just [|L.Add $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqInstructionE (A.FAdd x1 x2 x3) =+ Just [|L.FAdd $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Sub x1 x2 x3 x4 x5) =+ Just [|L.Sub $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqInstructionE (A.FSub x1 x2 x3) =+ Just [|L.FSub $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Mul x1 x2 x3 x4 x5) =+ Just [|L.Mul $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqInstructionE (A.FMul x1 x2 x3) =+ Just [|L.FMul $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.UDiv x1 x2 x3 x4) =+ Just [|L.UDiv $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.SDiv x1 x2 x3 x4) =+ Just [|L.SDiv $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.FDiv x1 x2 x3) =+ Just [|L.FDiv $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.URem x1 x2 x3) =+ Just [|L.URem $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.SRem x1 x2 x3) =+ Just [|L.SRem $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.FRem x1 x2 x3) =+ Just [|L.FRem $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Shl x1 x2 x3 x4 x5) =+ Just [|L.Shl $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqInstructionE (A.LShr x1 x2 x3 x4) =+ Just [|L.LShr $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.AShr x1 x2 x3 x4) =+ Just [|L.AShr $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.And x1 x2 x3) =+ Just [|L.And $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Or x1 x2 x3) =+ Just [|L.Or $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Xor x1 x2 x3) =+ Just [|L.Xor $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Alloca x1 x2 x3 x4) =+ Just [|L.Alloca $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.Load x1 x2 x3 x4 x5) =+ Just [|L.Load $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqInstructionE (A.Store x1 x2 x3 x4 x5 x6) =+ Just [|L.Store $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6)|]+qqInstructionE (A.GetElementPtr x1 x2 x3 x4) =+ Just [|L.GetElementPtr $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.Fence x1 x2) =+ Just [|L.Fence $(qqE x1) $(qqE x2)|]+qqInstructionE (A.CmpXchg x1 x2 x3 x4 x5 x6) =+ Just [|L.CmpXchg $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6)|]+qqInstructionE (A.AtomicRMW x1 x2 x3 x4 x5 x6) =+ Just [|L.AtomicRMW $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6)|]+qqInstructionE (A.Trunc x1 x2 x3) =+ Just [|L.Trunc $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.ZExt x1 x2 x3) =+ Just [|L.ZExt $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.SExt x1 x2 x3) =+ Just [|L.SExt $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.FPToUI x1 x2 x3) =+ Just [|L.FPToUI $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.FPToSI x1 x2 x3) =+ Just [|L.FPToSI $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.UIToFP x1 x2 x3) =+ Just [|L.UIToFP $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.SIToFP x1 x2 x3) =+ Just [|L.SIToFP $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.FPTrunc x1 x2 x3) =+ Just [|L.FPTrunc $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.FPExt x1 x2 x3) =+ Just [|L.FPExt $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.PtrToInt x1 x2 x3) =+ Just [|L.PtrToInt $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.IntToPtr x1 x2 x3) =+ Just [|L.IntToPtr $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.BitCast x1 x2 x3) =+ Just [|L.BitCast $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.AddrSpaceCast x1 x2 x3) =+ Just [|L.AddrSpaceCast $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.ICmp x1 x2 x3 x4) =+ Just [|L.ICmp $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.FCmp x1 x2 x3 x4) =+ Just [|L.FCmp $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.Phi x1 x2 x3) =+ Just [|L.Phi $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.Call x1 x2 x3 x4 x5 x6 x7) =+ Just [|L.Call $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6) $(qqE x7)|]+qqInstructionE (A.Select x1 x2 x3 x4) =+ Just [|L.Select $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.VAArg x1 x2 x3) =+ Just [|L.VAArg $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.ExtractElement x1 x2 x3) =+ Just [|L.ExtractElement $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.InsertElement x1 x2 x3 x4) =+ Just [|L.InsertElement $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.ShuffleVector x1 x2 x3 x4) =+ Just [|L.ShuffleVector $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.ExtractValue x1 x2 x3) =+ Just [|L.ExtractValue $(qqE x1) $(qqE x2) $(qqE x3)|]+qqInstructionE (A.InsertValue x1 x2 x3 x4) =+ Just [|L.InsertValue $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4)|]+qqInstructionE (A.LandingPad x1 x2 x3 x4 x5) =+ Just [|L.LandingPad $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqInstructionE (A.AntiInstruction s) =+ Just $ antiVarE s++qqNamedE :: (Typeable a, Data a) => A.Named a -> Maybe (Q Exp)+qqNamedE ((A.:=) x1 x2) =+ Just [|(L.:=) $(qqE x1) $(qqE x2)|]+qqNamedE (A.Do x1) =+ Just [|L.Do $(qqE x1)|]++qqMetadataNodeIDE :: A.MetadataNodeID -> Maybe (Q Exp)+qqMetadataNodeIDE (A.MetadataNodeID x1) =+ Just [|L.MetadataNodeID $(qqE x1)|]++qqMetadataNodeE :: A.MetadataNode -> Maybe (Q Exp)+qqMetadataNodeE (A.MetadataNode x1) =+ Just [|L.MetadataNode $(qqE x1)|]+qqMetadataNodeE (A.MetadataNodeReference x1) =+ Just [|L.MetadataNodeReference $(qqE x1)|]++qqOperandE :: A.Operand -> Maybe (Q Exp)+qqOperandE (A.LocalReference x1) =+ Just [|L.LocalReference $(qqE x1)|]+qqOperandE (A.ConstantOperand x1) =+ Just [|L.ConstantOperand $(qqE x1)|]+qqOperandE (A.MetadataStringOperand x1) =+ Just [|L.MetadataStringOperand $(qqE x1)|]+qqOperandE (A.MetadataNodeOperand x1) =+ Just [|L.MetadataNodeOperand $(qqE x1)|]++qqConstantE :: A.Constant -> Maybe (Q Exp)+qqConstantE (A.Int x1 x2) =+ Just [|L.Int $(qqE x1) $(qqE x2)|]+qqConstantE (A.Float x1) =+ Just [|L.Float $(qqE x1)|]+qqConstantE (A.Null x1) =+ Just [|L.Null $(qqE x1)|]+qqConstantE (A.Struct x1 x2 x3) =+ Just [|L.Struct $(qqE x1) $(qqE x2) $(qqE x3)|]+qqConstantE (A.Array x1 x2) =+ Just [|L.Array $(qqE x1) $(qqE x2)|]+qqConstantE (A.Vector x1) =+ Just [|L.Vector $(qqE x1)|]+qqConstantE (A.Undef x1) =+ Just [|L.Undef $(qqE x1)|]+qqConstantE (A.BlockAddress x1 x2) =+ Just [|L.BlockAddress $(qqE x1) $(qqE x2)|]+qqConstantE (A.GlobalReference x1) =+ Just [|L.GlobalReference $(qqE x1)|]+qqConstantE (A.AntiConstant s) =+ Just [|toConstant $(antiVarE s)|]++qqNameE :: A.Name -> Maybe (Q Exp)+qqNameE (A.Name x1) =+ Just [|L.Name $(qqE x1)|]+qqNameE (A.UnName x1) =+ Just [|L.UnName $(qqE x1)|]+qqNameE (A.AntiName s) =+ Just [|toName $(antiVarE s)|]++qqFloatingPointFormatE :: A.FloatingPointFormat -> Maybe (Q Exp)+qqFloatingPointFormatE A.IEEE =+ Just [|L.IEEE|]+qqFloatingPointFormatE A.DoubleExtended =+ Just [|L.DoubleExtended|]+qqFloatingPointFormatE A.PairOfFloats =+ Just [|L.PairOfFloats|]++qqTypeE :: A.Type -> Maybe (Q Exp)+qqTypeE A.VoidType =+ Just [|L.VoidType|]+qqTypeE (A.IntegerType x1) =+ Just [|L.IntegerType $(qqE x1)|]+qqTypeE (A.PointerType x1 x2) =+ Just [|L.PointerType $(qqE x1) $(qqE x2)|]+qqTypeE (A.FloatingPointType x1 x2) =+ Just [|L.FloatingPointType $(qqE x1) $(qqE x2)|]+qqTypeE (A.FunctionType x1 x2 x3) =+ Just [|L.FunctionType $(qqE x1) $(qqE x2) $(qqE x3)|]+qqTypeE (A.VectorType x1 x2) =+ Just [|L.VectorType $(qqE x1) $(qqE x2)|]+qqTypeE (A.StructureType x1 x2) =+ Just [|L.StructureType $(qqE x1) $(qqE x2)|]+qqTypeE (A.ArrayType x1 x2) =+ Just [|L.ArrayType $(qqE x1) $(qqE x2)|]+qqTypeE (A.NamedTypeReference x1) =+ Just [|L.NamedTypeReference $(qqE x1)|]+qqTypeE A.MetadataType =+ Just [|L.MetadataType|]++qqDialectE :: A.Dialect -> Maybe (Q Exp)+qqDialectE A.ATTDialect =+ Just [|L.ATTDialect|]+qqDialectE A.IntelDialect =+ Just [|L.IntelDialect|]++qqInlineAssemblyE :: A.InlineAssembly -> Maybe (Q Exp)+qqInlineAssemblyE (A.InlineAssembly x1 x2 x3 x4 x5 x6) =+ Just [|L.InlineAssembly $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)+ $(qqE x6)|]++qqMapE :: (Data a, Data b) => M.Map a b -> Maybe (Q Exp)+qqMapE m =+ Just [|M.fromList $(qqE (M.toList m))|]++qqSetE :: Data a => S.Set a -> Maybe (Q Exp)+qqSetE m =+ Just [|S.fromList $(qqE (S.toList m))|]++qqEndiannessE :: A.Endianness -> Maybe (Q Exp)+qqEndiannessE A.LittleEndian =+ Just [|L.LittleEndian|]+qqEndiannessE A.BigEndian =+ Just [|L.BigEndian|]++qqAlignmentInfoE :: A.AlignmentInfo -> Maybe (Q Exp)+qqAlignmentInfoE (A.AlignmentInfo x1 x2) =+ Just [|L.AlignmentInfo $(qqE x1) $(qqE x2)|]++qqAlignTypeE :: A.AlignType -> Maybe (Q Exp)+qqAlignTypeE A.IntegerAlign =+ Just [|L.IntegerAlign|]+qqAlignTypeE A.VectorAlign =+ Just [|L.VectorAlign|]+qqAlignTypeE A.FloatAlign =+ Just [|L.FloatAlign|]+qqAlignTypeE A.AggregateAlign =+ Just [|L.AggregateAlign|]+qqAlignTypeE A.StackAlign =+ Just [|L.StackAlign|]++qqDataLayoutE :: A.DataLayout -> Maybe (Q Exp)+qqDataLayoutE (A.DataLayout x1 x2 x3 x4 x5) =+ Just [|L.DataLayout $(qqE x1) $(qqE x2) $(qqE x3) $(qqE x4) $(qqE x5)|]+qqDataLayoutE (A.AntiDataLayout s) =+ Just $ antiVarE s++qqTargetTripleE :: A.TargetTriple -> Maybe (Q Exp)+qqTargetTripleE A.NoTargetTriple =+ Just [|Nothing|]+qqTargetTripleE (A.TargetTriple v) =+ Just [|Just $(qqE v)|]+qqTargetTripleE (A.AntiTargetTriple v) =+ Just [|toTargetTriple $(antiVarE v)|]+++qqE :: Data a => a -> Q Exp+qqE x = dataToExpQ qqExp x++qqExp :: Typeable a => a -> Maybe (Q Exp)+qqExp = const Nothing `extQ` qqDefinitionE+ `extQ` qqDefinitionListE+ `extQ` qqModuleE+ `extQ` qqGlobalE+ `extQ` qqParameterListE+ `extQ` qqParameterE+ `extQ` qqBasicBlockE+ `extQ` qqBasicBlockListE+ `extQ` qqTerminatorE+ `extQ` qqMemoryOrderingE+ `extQ` qqAtomicityE+ `extQ` qqLandingPadClauseE+ `extQ` qqInstructionE+ `extQ` (qqNamedE :: A.Named A.Instruction -> Maybe (Q Exp))+ `extQ` (qqNamedE :: A.Named A.Terminator -> Maybe (Q Exp))+ `extQ` qqMetadataNodeIDE+ `extQ` qqMetadataNodeE+ `extQ` qqOperandE+ `extQ` qqConstantE+ `extQ` qqNameE+ `extQ` qqFloatingPointFormatE+ `extQ` qqTypeE+ `extQ` qqDialectE+ `extQ` qqInlineAssemblyE+ `extQ` (qqMapE :: M.Map A.AddrSpace (Word32, A.AlignmentInfo) -> Maybe (Q Exp))+ `extQ` (qqMapE :: M.Map (A.AlignType, Word32) A.AlignmentInfo -> Maybe (Q Exp))+ `extQ` (qqSetE :: S.Set Word32 -> Maybe (Q Exp))+ `extQ` qqEndiannessE+ `extQ` qqAlignmentInfoE+ `extQ` qqAlignTypeE+ `extQ` qqDataLayoutE+ `extQ` qqTargetTripleE+++antiVarP :: String -> PatQ+antiVarP = either fail return . parsePat++qqDefinitionListP :: [A.Definition] -> Maybe (Q Pat)+qqDefinitionListP [] = Just [p|[]|]+qqDefinitionListP [A.AntiDefinitionList v] =+ Just $ antiVarP v+qqDefinitionListP (A.AntiDefinitionList _ : _ : _) =+ error "Antiquoted list of definitions must be last item in quoted list"+qqDefinitionListP (def : defs) =+ Just [p|$(qqP def) : $(qqP defs)|]++qqDefinitionP :: A.Definition -> Maybe (Q Pat)+qqDefinitionP (A.GlobalDefinition v) =+ Just [p|L.GlobalDefinition $(qqP v)|]+qqDefinitionP (A.TypeDefinition n v) =+ Just [p|L.TypeDefinition $(qqP n) $(qqP v)|]+qqDefinitionP (A.MetadataNodeDefinition i vs) =+ Just [p|L.MetadataNodeDefinition $(qqP i) $(qqP vs)|]+qqDefinitionP (A.NamedMetadataDefinition i vs) =+ Just [p|L.NamedMetadataDefinition $(qqP i) $(qqP vs)|]+qqDefinitionP (A.ModuleInlineAssembly s) =+ Just [p|L.ModuleInlineAssembly $(qqP s)|]+qqDefinitionP (A.AntiDefinition s) =+ Just $ antiVarP s+qqDefinitionP a@(A.AntiDefinitionList _s) =+ error $ "Internal Error: unexpected antiquote " ++ show a++qqModuleP :: A.Module -> Maybe (Q Pat)+qqModuleP (A.Module n dl tt ds) = + Just [p|L.Module $(qqP n) $(qqP dl) $(qqP tt) $(qqP ds)|]++qqGlobalP :: A.Global -> Maybe (Q Pat)+qqGlobalP (A.GlobalVariable x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB) =+ Just [p|L.GlobalVariable $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6) $(qqP x7) $(qqP x8) $(qqP x9) $(qqP xA)+ $(qqP xB)|]+qqGlobalP (A.GlobalAlias x1 x2 x3 x4 x5) =+ Just [p|L.GlobalAlias $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqGlobalP (A.Function x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC) =+ Just [p|L.Function $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6) $(qqP x7) $(qqP x8) $(qqP x9) $(qqP xA)+ $(qqP xB) $(qqP xC)|]++qqParameterListP :: [A.Parameter] -> Maybe (Q Pat)+qqParameterListP [] = Just [p|[]|]+qqParameterListP [A.AntiParameterList v] =+ Just $ antiVarP v+qqParameterListP (A.AntiParameterList v : _) =+ error "Antiquoted list of Parameters must be last item in quoted list"+qqParameterListP (def : defs) =+ Just [p|$(qqP def) : $(qqP defs)|]++qqParameterP :: A.Parameter -> Maybe (Q Pat)+qqParameterP (A.Parameter x1 x2 x3) =+ Just [p|L.Parameter $(qqP x1) $(qqP x2) $(qqP x3)|]+qqParameterP (A.AntiParameter s) =+ Just $ antiVarP s+qqParameterP a@(A.AntiParameterList _s) =+ error $ "Internal Error: unexpected antiquote " ++ show a++qqBasicBlockListP :: [A.BasicBlock] -> Maybe (Q Pat)+qqBasicBlockListP [] = Just [p|[]|]+qqBasicBlockListP [A.AntiBasicBlockList v] =+ Just $ antiVarP v+qqBasicBlockListP (A.AntiBasicBlockList v : defs) =+ error "Antiquoted list of BasicBlocks must be last item in quoted list"+qqBasicBlockListP (def : defs) =+ Just [p|$(qqP def) : $(qqP defs)|]++qqBasicBlockP :: A.BasicBlock -> Maybe (Q Pat)+qqBasicBlockP (A.BasicBlock x1 x2 x3) =+ Just [p|L.BasicBlock $(qqP x1) $(qqP x2) $(qqP x3)|]+qqBasicBlockP (A.AntiBasicBlock s) =+ Just $ antiVarP s+qqBasicBlockP a@A.ForLoop{} =+ error $ "Error: for-loop not allowed in pattern quote " ++ show a+qqBasicBlockP a@(A.AntiBasicBlockList _s) =+ error $ "Internal Error: unexpected antiquote " ++ show a++qqTerminatorP :: A.Terminator -> Maybe (Q Pat)+qqTerminatorP (A.Ret x1 x2) =+ Just [p|L.Ret $(qqP x1) $(qqP x2)|]+qqTerminatorP (A.CondBr x1 x2 x3 x4) =+ Just [p|L.CondBr $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqTerminatorP (A.Br x1 x2) =+ Just [p|L.Br $(qqP x1) $(qqP x2)|]+qqTerminatorP (A.Switch x1 x2 x3 x4) =+ Just [p|L.Switch $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqTerminatorP (A.IndirectBr x1 x2 x3) =+ Just [p|L.IndirectBr $(qqP x1) $(qqP x2) $(qqP x3)|]+qqTerminatorP (A.Invoke x1 x2 x3 x4 x5 x6 x7 x8) =+ Just [p|L.Invoke $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6) $(qqP x7) $(qqP x8)|]+qqTerminatorP (A.Resume x1 x2) =+ Just [p|L.Resume $(qqP x1) $(qqP x2)|]+qqTerminatorP (A.Unreachable x1) =+ Just [p|L.Unreachable $(qqP x1)|]++qqMemoryOrderingP :: A.MemoryOrdering -> Maybe (Q Pat)+qqMemoryOrderingP A.Unordered =+ Just [p|L.Unordered|]+qqMemoryOrderingP A.Monotonic =+ Just [p|L.Monotonic|]+qqMemoryOrderingP A.Acquire =+ Just [p|L.Acquire|]+qqMemoryOrderingP A.Release =+ Just [p|L.Release|]+qqMemoryOrderingP A.AcquireRelease =+ Just [p|L.AcquireRelease|]+qqMemoryOrderingP A.SequentiallyConsistent =+ Just [p|L.SequentiallyConsistent|]++qqAtomicityP :: A.Atomicity -> Maybe (Q Pat)+qqAtomicityP (A.Atomicity x1 x2) =+ Just [p|L.Atomicity $(qqP x1) $(qqP x2)|]++qqLandingPadClauseP :: A.LandingPadClause -> Maybe (Q Pat)+qqLandingPadClauseP (A.Catch x1) =+ Just [p|L.Catch $(qqP x1)|]+qqLandingPadClauseP (A.Filter x1) =+ Just [p|L.Filter $(qqP x1)|]++qqInstructionP :: A.Instruction -> Maybe (Q Pat)+qqInstructionP (A.Add x1 x2 x3 x4 x5) =+ Just [p|L.Add $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqInstructionP (A.FAdd x1 x2 x3) =+ Just [p|L.FAdd $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Sub x1 x2 x3 x4 x5) =+ Just [p|L.Sub $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqInstructionP (A.FSub x1 x2 x3) =+ Just [p|L.FSub $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Mul x1 x2 x3 x4 x5) =+ Just [p|L.Mul $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqInstructionP (A.FMul x1 x2 x3) =+ Just [p|L.FMul $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.UDiv x1 x2 x3 x4) =+ Just [p|L.UDiv $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.SDiv x1 x2 x3 x4) =+ Just [p|L.SDiv $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.FDiv x1 x2 x3) =+ Just [p|L.FDiv $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.URem x1 x2 x3) =+ Just [p|L.URem $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.SRem x1 x2 x3) =+ Just [p|L.SRem $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.FRem x1 x2 x3) =+ Just [p|L.FRem $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Shl x1 x2 x3 x4 x5) =+ Just [p|L.Shl $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqInstructionP (A.LShr x1 x2 x3 x4) =+ Just [p|L.LShr $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.AShr x1 x2 x3 x4) =+ Just [p|L.AShr $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.And x1 x2 x3) =+ Just [p|L.And $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Or x1 x2 x3) =+ Just [p|L.Or $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Xor x1 x2 x3) =+ Just [p|L.Xor $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Alloca x1 x2 x3 x4) =+ Just [p|L.Alloca $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.Load x1 x2 x3 x4 x5) =+ Just [p|L.Load $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqInstructionP (A.Store x1 x2 x3 x4 x5 x6) =+ Just [p|L.Store $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6)|]+qqInstructionP (A.GetElementPtr x1 x2 x3 x4) =+ Just [p|L.GetElementPtr $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.Fence x1 x2) =+ Just [p|L.Fence $(qqP x1) $(qqP x2)|]+qqInstructionP (A.CmpXchg x1 x2 x3 x4 x5 x6) =+ Just [p|L.CmpXchg $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6)|]+qqInstructionP (A.AtomicRMW x1 x2 x3 x4 x5 x6) =+ Just [p|L.AtomicRMW $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6)|]+qqInstructionP (A.Trunc x1 x2 x3) =+ Just [p|L.Trunc $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.ZExt x1 x2 x3) =+ Just [p|L.ZExt $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.SExt x1 x2 x3) =+ Just [p|L.SExt $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.FPToUI x1 x2 x3) =+ Just [p|L.FPToUI $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.FPToSI x1 x2 x3) =+ Just [p|L.FPToSI $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.UIToFP x1 x2 x3) =+ Just [p|L.UIToFP $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.SIToFP x1 x2 x3) =+ Just [p|L.SIToFP $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.FPTrunc x1 x2 x3) =+ Just [p|L.FPTrunc $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.FPExt x1 x2 x3) =+ Just [p|L.FPExt $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.PtrToInt x1 x2 x3) =+ Just [p|L.PtrToInt $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.IntToPtr x1 x2 x3) =+ Just [p|L.IntToPtr $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.BitCast x1 x2 x3) =+ Just [p|L.BitCast $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.AddrSpaceCast x1 x2 x3) =+ Just [p|L.AddrSpaceCast $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.ICmp x1 x2 x3 x4) =+ Just [p|L.ICmp $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.FCmp x1 x2 x3 x4) =+ Just [p|L.FCmp $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.Phi x1 x2 x3) =+ Just [p|L.Phi $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.Call x1 x2 x3 x4 x5 x6 x7) =+ Just [p|L.Call $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6) $(qqP x7)|]+qqInstructionP (A.Select x1 x2 x3 x4) =+ Just [p|L.Select $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.VAArg x1 x2 x3) =+ Just [p|L.VAArg $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.ExtractElement x1 x2 x3) =+ Just [p|L.ExtractElement $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.InsertElement x1 x2 x3 x4) =+ Just [p|L.InsertElement $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.ShuffleVector x1 x2 x3 x4) =+ Just [p|L.ShuffleVector $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.ExtractValue x1 x2 x3) =+ Just [p|L.ExtractValue $(qqP x1) $(qqP x2) $(qqP x3)|]+qqInstructionP (A.InsertValue x1 x2 x3 x4) =+ Just [p|L.InsertValue $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4)|]+qqInstructionP (A.LandingPad x1 x2 x3 x4 x5) =+ Just [p|L.LandingPad $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqInstructionP (A.AntiInstruction s) =+ Just $ antiVarP s++qqNamedP :: (Typeable a, Data a) => A.Named a -> Maybe (Q Pat)+qqNamedP ((A.:=) x1 x2) =+ Just [p|(L.:=) $(qqP x1) $(qqP x2)|]+qqNamedP (A.Do x1) =+ Just [p|L.Do $(qqP x1)|]++qqMetadataNodeIDP :: A.MetadataNodeID -> Maybe (Q Pat)+qqMetadataNodeIDP (A.MetadataNodeID x1) =+ Just [p|L.MetadataNodeID $(qqP x1)|]++qqMetadataNodeP :: A.MetadataNode -> Maybe (Q Pat)+qqMetadataNodeP (A.MetadataNode x1) =+ Just [p|L.MetadataNode $(qqP x1)|]+qqMetadataNodeP (A.MetadataNodeReference x1) =+ Just [p|L.MetadataNodeReference $(qqP x1)|]++qqOperandP :: A.Operand -> Maybe (Q Pat)+qqOperandP (A.LocalReference x1) =+ Just [p|L.LocalReference $(qqP x1)|]+qqOperandP (A.ConstantOperand x1) =+ Just [p|L.ConstantOperand $(qqP x1)|]+qqOperandP (A.MetadataStringOperand x1) =+ Just [p|L.MetadataStringOperand $(qqP x1)|]+qqOperandP (A.MetadataNodeOperand x1) =+ Just [p|L.MetadataNodeOperand $(qqP x1)|]++qqConstantP :: A.Constant -> Maybe (Q Pat)+qqConstantP (A.Int x1 x2) =+ Just [p|L.Int $(qqP x1) $(qqP x2)|]+qqConstantP (A.Float x1) =+ Just [p|L.Float $(qqP x1)|]+qqConstantP (A.Null x1) =+ Just [p|L.Null $(qqP x1)|]+qqConstantP (A.Struct x1 x2 x3) =+ Just [p|L.Struct $(qqP x1) $(qqP x2) $(qqP x3)|]+qqConstantP (A.Array x1 x2) =+ Just [p|L.Array $(qqP x1) $(qqP x2)|]+qqConstantP (A.Vector x1) =+ Just [p|L.Vector $(qqP x1)|]+qqConstantP (A.Undef x1) =+ Just [p|L.Undef $(qqP x1)|]+qqConstantP (A.BlockAddress x1 x2) =+ Just [p|L.BlockAddress $(qqP x1) $(qqP x2)|]+qqConstantP (A.GlobalReference x1) =+ Just [p|L.GlobalReference $(qqP x1)|]+qqConstantP (A.AntiConstant s) =+ Just $ antiVarP s++qqNameP :: A.Name -> Maybe (Q Pat)+qqNameP (A.Name x1) =+ Just [p|L.Name $(qqP x1)|]+qqNameP (A.UnName x1) =+ Just [p|L.UnName $(qqP x1)|]+qqNameP (A.AntiName s) =+ Just $ antiVarP s++qqFloatingPointFormatP :: A.FloatingPointFormat -> Maybe (Q Pat)+qqFloatingPointFormatP A.IEEE =+ Just [p|L.IEEE|]+qqFloatingPointFormatP A.DoubleExtended =+ Just [p|L.DoubleExtended|]+qqFloatingPointFormatP A.PairOfFloats =+ Just [p|L.PairOfFloats|]++qqTypeP :: A.Type -> Maybe (Q Pat)+qqTypeP A.VoidType =+ Just [p|L.VoidType|]+qqTypeP (A.IntegerType x1) =+ Just [p|L.IntegerType $(qqP x1)|]+qqTypeP (A.PointerType x1 x2) =+ Just [p|L.PointerType $(qqP x1) $(qqP x2)|]+qqTypeP (A.FloatingPointType x1 x2) =+ Just [p|L.FloatingPointType $(qqP x1) $(qqP x2)|]+qqTypeP (A.FunctionType x1 x2 x3) =+ Just [p|L.FunctionType $(qqP x1) $(qqP x2) $(qqP x3)|]+qqTypeP (A.VectorType x1 x2) =+ Just [p|L.VectorType $(qqP x1) $(qqP x2)|]+qqTypeP (A.StructureType x1 x2) =+ Just [p|L.StructureType $(qqP x1) $(qqP x2)|]+qqTypeP (A.ArrayType x1 x2) =+ Just [p|L.ArrayType $(qqP x1) $(qqP x2)|]+qqTypeP (A.NamedTypeReference x1) =+ Just [p|L.NamedTypeReference $(qqP x1)|]+qqTypeP A.MetadataType =+ Just [p|L.MetadataType|]++qqDialectP :: A.Dialect -> Maybe (Q Pat)+qqDialectP A.ATTDialect =+ Just [p|L.ATTDialect|]+qqDialectP A.IntelDialect =+ Just [p|L.IntelDialect|]++qqInlineAssemblyP :: A.InlineAssembly -> Maybe (Q Pat)+qqInlineAssemblyP (A.InlineAssembly x1 x2 x3 x4 x5 x6) =+ Just [p|L.InlineAssembly $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)+ $(qqP x6)|]++qqEndiannessP :: A.Endianness -> Maybe (Q Pat)+qqEndiannessP A.LittleEndian =+ Just [p|L.LittleEndian|]+qqEndiannessP A.BigEndian =+ Just [p|L.BigEndian|]++qqAlignmentInfoP :: A.AlignmentInfo -> Maybe (Q Pat)+qqAlignmentInfoP (A.AlignmentInfo x1 x2) =+ Just [p|L.AlignmentInfo $(qqP x1) $(qqP x2)|]++qqAlignTypeP :: A.AlignType -> Maybe (Q Pat)+qqAlignTypeP A.IntegerAlign =+ Just [p|L.IntegerAlign|]+qqAlignTypeP A.VectorAlign =+ Just [p|L.VectorAlign|]+qqAlignTypeP A.FloatAlign =+ Just [p|L.FloatAlign|]+qqAlignTypeP A.AggregateAlign =+ Just [p|L.AggregateAlign|]+qqAlignTypeP A.StackAlign =+ Just [p|L.StackAlign|]++qqDataLayoutP :: A.DataLayout -> Maybe (Q Pat)+qqDataLayoutP (A.DataLayout x1 x2 x3 x4 x5) =+ Just [p|L.DataLayout $(qqP x1) $(qqP x2) $(qqP x3) $(qqP x4) $(qqP x5)|]+qqDataLayoutP (A.AntiDataLayout s) =+ Just $ antiVarP s++qqTargetTripleP :: A.TargetTriple -> Maybe (Q Pat)+qqTargetTripleP A.NoTargetTriple =+ Just [p|Nothing|]+qqTargetTripleP (A.TargetTriple v) =+ Just [p|Just $(qqP v)|]+qqTargetTripleP (A.AntiTargetTriple v) =+ Just $ antiVarP v++qqP :: Data a => a -> Q Pat+qqP x = dataToPatQ qqPat x++qqPat :: Typeable a => a -> Maybe (Q Pat)+qqPat = const Nothing `extQ` qqDefinitionP+ `extQ` qqDefinitionListP+ `extQ` qqModuleP+ `extQ` qqGlobalP+ `extQ` qqParameterListP+ `extQ` qqParameterP+ `extQ` qqBasicBlockP+ `extQ` qqBasicBlockListP+ `extQ` qqTerminatorP+ `extQ` qqMemoryOrderingP+ `extQ` qqAtomicityP+ `extQ` qqLandingPadClauseP+ `extQ` qqInstructionP+ `extQ` (qqNamedP :: A.Named A.Instruction -> Maybe (Q Pat))+ `extQ` (qqNamedP :: A.Named A.Terminator -> Maybe (Q Pat))+ `extQ` qqMetadataNodeIDP+ `extQ` qqMetadataNodeP+ `extQ` qqOperandP+ `extQ` qqConstantP+ `extQ` qqNameP+ `extQ` qqFloatingPointFormatP+ `extQ` qqTypeP+ `extQ` qqDialectP+ `extQ` qqInlineAssemblyP+ `extQ` qqEndiannessP+ `extQ` qqAlignmentInfoP+ `extQ` qqAlignTypeP+ `extQ` qqDataLayoutP+ `extQ` qqTargetTripleP++parse :: [A.Extensions]+ -> P.P a+ -> String+ -> Q a+parse exts p s = do+ loc <- location+ case P.parse (A.Antiquotation : exts) p (B.pack s) (locToPos loc) of+ Left err -> fail (show err)+ Right x -> return x+ where+ locToPos :: Language.Haskell.TH.Loc -> Pos+ locToPos loc = Pos (loc_filename loc)+ ((fst . loc_start) loc)+ ((snd . loc_start) loc)+ 0++quasiquote :: Data a+ => [A.Extensions]+ -> P.P a+ -> QuasiQuoter+quasiquote exts p =+ QuasiQuoter { quoteExp = parse exts p >=> qqE+ , quotePat = parse exts p >=> qqP+ , quoteType = fail "LLVM type quasiquoter undefined"+ , quoteDec = fail "LLVM declaration quasiquoter undefined"+ }
+ src/LLVM/General/Quote/LLVM.hs view
@@ -0,0 +1,30 @@+module LLVM.General.Quote.LLVM (+ llmod,+ lldef,+ llbb,+ lli+ ) where++import qualified LLVM.General.Quote.Parser.Parser as P+import qualified LLVM.General.Quote.AST as A+import LLVM.General.Quote.Base (quasiquote)+import Language.Haskell.TH.Quote (QuasiQuoter)++exts :: [A.Extensions]+exts = [A.Loops]++-- |Quasiquoter for 'LLVM.General.AST.Module'+llmod :: QuasiQuoter+llmod = quasiquote exts P.parseModule++-- |Quasiquoter for 'LLVM.General.AST.Definition'+lldef :: QuasiQuoter+lldef = quasiquote exts P.parseDefinition++-- |Quasiquoter for 'LLVM.General.AST.BasicBlock'+llbb :: QuasiQuoter+llbb = quasiquote exts P.parseBasicBlock++-- |Quasiquoter for 'LLVM.General.AST.Instruction.Instruction'+lli :: QuasiQuoter+lli = quasiquote exts P.parseInstruction
+ src/LLVM/General/Quote/Parser.hs view
@@ -0,0 +1,23 @@+module LLVM.General.Quote.Parser (+ module LLVM.General.Quote.Parser.Lexer,+ module LLVM.General.Quote.Parser.Tokens,+ module LLVM.General.Quote.Parser.Monad,+ parse+ ) where++import Control.Exception++import qualified Data.ByteString.Char8 as B+import Data.Loc++import LLVM.General.Quote.Parser.Lexer+import LLVM.General.Quote.Parser.Tokens+import LLVM.General.Quote.Parser.Monad++parse :: [Extensions]+ -> P a+ -> B.ByteString+ -> Pos+ -> Either SomeException a+parse exts p bs pos =+ evalP p (emptyPState exts bs pos)
+ src/LLVM/General/Quote/Parser/Lexer.x view
@@ -0,0 +1,377 @@+{+-- |+-- Module : Language.LLVM.Parser.Lexer+-- Copyright : (c) Harvard University 2006-2011+-- (c) Geoffrey Mainland 2011-2013+-- (c) Drexel University 2013+-- (c) Timo von Holtz 2014+-- License : BSD-style+-- Maintainer : tvh@tvholtz.de++{-# OPTIONS_GHC -w #-}++module LLVM.General.Quote.Parser.Lexer (+ lexToken+ ) where++import Control.Applicative+import Control.Monad.Error+import Control.Monad.State+import qualified Data.ByteString.Char8 as B+import qualified Data.Map as Map+import Data.Char (isDigit,+ isLower,+ isAlphaNum,+ isOctDigit,+ isHexDigit,+ chr,+ toLower)+import Data.Loc+import Data.Ratio ((%))+import Text.PrettyPrint.Mainland++import LLVM.General.Quote.Parser.Tokens+import LLVM.General.Quote.Parser.Monad+}++$nondigit = [a-z A-Z \_ \.]+$digit = [0-9]+$nonzerodigit = [1-9]+$octalDigit = [0-7]+$hexadecimalDigit = [0-9A-Fa-f]+$whitechar = [\ \t\n\r\f\v]++@fractionalConstant = $digit* "." $digit++ | $digit+ "."+@exponentPart = [eE] [\+\-]? $digit+++@floatingConstant = @fractionalConstant @exponentPart?+ | $digit+ @exponentPart++@decimalConstant = $nonzerodigit $digit* | "0"+@octalConstant = "0" $octalDigit*+@hexadecimalConstant = "0" [xX] $hexadecimalDigit+++@idText = [a-z A-Z \_ \. \-] [a-z A-Z \_ \. \- 0-9]*+@identifier = [@\%\!] ( @decimalConstant+ | @idText)+@jumpLabel = @idText ":"++@integerType = "i" $nonzerodigit $digit*+@keyword = [a-z \_]+ ($nonzerodigit $digit*)?++tokens :-++<0> {+ "$dl:" / { allowAnti } { lexAnti Tanti_dl }+ "$tt:" / { allowAnti } { lexAnti Tanti_tt }+ "$def:" / { allowAnti } { lexAnti Tanti_def }+ "$defs:" / { allowAnti } { lexAnti Tanti_defs }+ "$bb:" / { allowAnti } { lexAnti Tanti_bb }+ "$bbs:" / { allowAnti } { lexAnti Tanti_bbs }+ "$instr:" / { allowAnti } { lexAnti Tanti_instr }+ "$const:" / { allowAnti } { lexAnti Tanti_const }+ "$id:" / { allowAnti } { lexAnti Tanti_id }+ "$gid:" / { allowAnti } { lexAnti Tanti_gid }+ "$param:" / { allowAnti } { lexAnti Tanti_param }+ "$params:" / { allowAnti } { lexAnti Tanti_params }+}++<0> {+ ";" .* ;+ $whitechar+ ; ++ @identifier { identifier }+ @jumpLabel { jumpLabel }+ @integerType { numberedToken TintegerType }+ @keyword { keyword }++ @floatingConstant { lexFloat }+ @decimalConstant { lexInteger 0 decimal }+ @octalConstant { lexInteger 1 octal }+ @hexadecimalConstant { lexInteger 2 hexadecimal }++ \" { lexStringTok }++ "(" { token Tlparen }+ ")" { token Trparen }+ "[" { token Tlbrack }+ "]" { token Trbrack }+ "{" { token Tlbrace }+ "}" { token Trbrace }+ "<" { token Tlt }+ ">" { token Tgt }+ "," { token Tcomma }+ "*" { token Tstar }+ "=" { token Tassign }+ "-" { token Tminus }+ "!" { token Tbang }+ "..." { token Tpoints }+}++{+type Action = AlexInput -> AlexInput -> P (L Token)++inputString :: AlexInput -> AlexInput -> String+inputString beg end =+ (B.unpack . B.take (alexOff end - alexOff beg)) (alexInput beg)++locateTok :: AlexInput -> AlexInput -> Token -> L Token+locateTok beg end tok =+ L (Loc (alexPos beg) (alexPos end)) tok++token :: Token -> Action+token tok beg end =+ return $ locateTok beg end tok++identifier :: Action+identifier beg end = do+ v <- case head ident of+ '%' -> return Local+ '@' -> return Global+ '!' -> return Meta+ case isDigit $ head $ tail ident of+ False -> return $ locateTok beg end $ Tnamed v (tail ident)+ True -> return $ locateTok beg end $ Tunnamed v (read $ tail ident)+ where+ ident :: String+ ident = inputString beg end++jumpLabel :: Action+jumpLabel beg end = do+ token (TjumpLabel $ init ident) beg end+ where+ ident :: String+ ident = inputString beg end++numberedToken :: (Num a, Read a) => (a -> Token) -> Action+numberedToken f beg end = do+ return $ locateTok beg end $ f (read $ tail ident)+ where+ ident :: String+ ident = inputString beg end++keyword :: Action+keyword beg end = do+ case Map.lookup ident keywordMap of+ Nothing -> identError+ Just (tok, Nothing) -> token tok beg end+ Just (tok, Just i) -> do isKw <- useExts i+ if isKw then token tok beg end else identError+ where+ ident :: String+ ident = inputString beg end++ identError = fail $ "not a valid keyword: " ++ show ident++lexStringTok :: Action+lexStringTok beg _ = do+ s <- lexString ""+ end <- getInput+ return $ locateTok beg end (TstringConst s)+ where+ lexString :: String -> P String+ lexString s = do+ c <- nextChar+ case c of+ '"' -> return (reverse s)+ '\\' -> do c' <- lexCharEscape+ lexString (c' : s)+ _ -> lexString (c : s)++lexAnti ::(String -> Token) -> Action+lexAnti antiTok beg end = do+ c <- nextChar+ s <- case c of+ '(' -> lexExpression 0 ""+ _ | isIdStartChar c -> lexIdChars [c]+ | otherwise -> lexerError beg (text "illegal anitquotation")+ return $ locateTok beg end (antiTok s)+ where+ lexIdChars :: String -> P String+ lexIdChars s = do+ maybe_c <- maybePeekChar+ case maybe_c of+ Just c | isIdChar c -> skipChar >> lexIdChars (c : s)+ _ -> return (reverse s)++ lexExpression :: Int -> String -> P String+ lexExpression depth s = do+ maybe_c <- maybePeekChar+ case maybe_c of+ Nothing -> do end' <- getInput+ parserError (Loc (alexPos beg) (alexPos end'))+ (text "unterminated antiquotation")+ Just '(' -> skipChar >> lexExpression (depth+1) ('(' : s)+ Just ')' | depth == 0 -> skipChar >> return (unescape (reverse s))+ | otherwise -> skipChar >> lexExpression (depth-1) (')' : s)+ Just c -> skipChar >> lexExpression depth (c : s)+ where+ unescape :: String -> String+ unescape ('\\':'|':'\\':']':s') = '|' : ']' : unescape s'+ unescape (c:s') = c : unescape s'+ unescape [] = []++ isIdStartChar :: Char -> Bool+ isIdStartChar '_' = True+ isIdStartChar c = isLower c++ isIdChar :: Char -> Bool+ isIdChar '_' = True+ isIdChar '\'' = True+ isIdChar c = isAlphaNum c++lexCharEscape :: P Char+lexCharEscape = do+ cur <- getInput+ c <- nextChar+ case c of+ 'a' -> return '\a'+ 'b' -> return '\b'+ 'f' -> return '\f'+ 'n' -> return '\n'+ 'r' -> return '\r'+ 't' -> return '\t'+ 'v' -> return '\v'+ '\\' -> return '\\'+ '\'' -> return '\''+ '"' -> return '"'+ '?' -> return '?'+ 'x' -> chr <$> checkedReadNum isHexDigit 16 hexDigit+ n | isOctDigit n -> setInput cur >> chr <$> checkedReadNum isOctDigit 8 octDigit+ _c -> return c++lexInteger :: Int -> Radix -> Action+lexInteger ndrop radix@(_, isRadixDigit, _) beg end =+ case i of+ [n] -> return $ locateTok beg end (toToken n)+ _ -> fail "bad parse for integer"+ where+ num :: String+ num = (takeWhile isRadixDigit . drop ndrop) s++ s :: String+ s = inputString beg end++ i :: [Integer]+ i = do (n, _) <- readInteger radix num+ return n++ toToken :: Integer -> Token+ toToken n = TintConst n++lexFloat :: Action+lexFloat beg end =+ case i of+ [n] -> token (toToken n) beg end+ _ -> fail "bad parse for integer"+ where+ s :: String+ s = inputString beg end++ i :: [Rational]+ i = do (n, _) <- readRational s+ return n++ toToken :: Rational -> Token+ toToken n = TfloatConst n++type Radix = (Integer, Char -> Bool, Char -> Int)++decDigit :: Char -> Int+decDigit c | c >= '0' && c <= '9' = ord c - ord '0'+ | otherwise = error "error in decimal constant"++octDigit :: Char -> Int+octDigit c | c >= '0' && c <= '7' = ord c - ord '0'+ | otherwise = error "error in octal constant"++hexDigit :: Char -> Int+hexDigit c | c >= 'a' && c <= 'f' = 10 + ord c - ord 'a'+ | c >= 'A' && c <= 'F' = 10 + ord c - ord 'A'+ | c >= '0' && c <= '9' = ord c - ord '0'+ | otherwise = error "error in hexadecimal constant"++decimal :: Radix+decimal = (10, isDigit, decDigit)++octal :: Radix+octal = (8, isOctDigit, octDigit)++hexadecimal :: Radix+hexadecimal = (16, isHexDigit, hexDigit)++readInteger :: Radix -> ReadS Integer+readInteger (radix, isRadixDigit, charToInt) =+ go 0+ where+ go :: Integer -> ReadS Integer+ go x [] = return (x, "")+ go x (c : cs)+ | isRadixDigit c = go (x * radix + toInteger (charToInt c)) cs+ | otherwise = return (x, c : cs)++readDecimal :: ReadS Integer+readDecimal = readInteger decimal++readRational :: ReadS Rational+readRational s = do+ (n, d, t) <- readFix+ (x, t') <- readExponent t+ return ((n % 1) * 10^^(x - toInteger d), t')+ where+ readFix :: [(Integer, Int, String)]+ readFix =+ return (read (i ++ f), length f, u)+ where+ (i, t) = span isDigit s+ (f, u) = case t of+ '.' : u' -> span isDigit u'+ _ -> ("", t)++ readExponent :: ReadS Integer+ readExponent "" = return (0, "")+ readExponent (e : s') | e `elem` "eE" = go s'+ | otherwise = return (0, s')+ where+ go :: ReadS Integer+ go ('+' : s'') = readDecimal s''+ go ('-' : s'') = do (x, t) <- readDecimal s''+ return (-x, t)+ go s'' = readDecimal s''++checkedReadNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Int+checkedReadNum isDigit' base conv = do+ cur <- getInput+ c <- peekChar+ when (not $ isDigit' c) $+ illegalNumericalLiteral cur+ readNum isDigit base conv++readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Int+readNum isDigit' base conv =+ readI 0+ where+ readI :: Int -> P Int+ readI n = do+ c <- peekChar+ if isDigit' c+ then do let n' = n*base + conv c+ n' `seq` skipChar >> readI n'+ else return n++lexToken :: P (L Token)+lexToken = do+ beg <- getInput+ sc <- getLexState+ st <- get+ case alexScanUser st beg sc of+ AlexEOF -> token Teof beg beg+ AlexError end -> lexerError end (text rest)+ where+ rest :: String+ rest = B.unpack $ B.take 80 (alexInput beg)+ AlexSkip end _ -> setInput end >> lexToken+ AlexToken end _len t -> setInput end >> t beg end+}+
+ src/LLVM/General/Quote/Parser/Monad.hs view
@@ -0,0 +1,325 @@+-- |+-- Module : Language.LLVM.Parser.Monad+-- Copyright : (c) Harvard University 2006-2011+-- (c) Geoffrey Mainland 2011-2013+-- (c) Timo von Holtz 2014+-- License : BSD-style+-- Maintainer : tvh@tvholtz.de++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module LLVM.General.Quote.Parser.Monad (+ P,+ runP,+ evalP,++ PState,+ emptyPState,++ getInput,+ setInput,+ pushLexState,+ popLexState,+ getLexState,+ getCurToken,+ setCurToken,++ useExts,+ antiquotationExts,++ LexerException(..),+ ParserException(..),+ quoteTok,+ failAt,+ lexerError,+ unexpectedEOF,+ emptyCharacterLiteral,+ illegalCharacterLiteral,+ illegalNumericalLiteral,+ parserError,+ unclosed,+ expected,+ expectedAt,++ AlexInput(..),+ alexGetChar,+ alexGetByte,+ alexInputPrevChar,+ nextChar,+ peekChar,+ maybePeekChar,+ skipChar,++ AlexPredicate,+ allowAnti,+ ifExtension+ ) where++import Control.Applicative (Applicative(..))+import Control.Monad.Exception+import Control.Monad.Identity+import Control.Monad.State+import Data.Bits+import qualified Data.ByteString.Char8 as B+import Data.ByteString.Internal (c2w)+import Data.List (foldl')+import Data.Loc+import Data.Typeable (Typeable)+import Data.Word+import Text.PrettyPrint.Mainland++import LLVM.General.Quote.Parser.Tokens++data PState = PState+ { input :: !AlexInput+ , curToken :: L Token+ , lexState :: ![Int]+ , extensions :: !ExtensionsInt+ }++emptyPState :: [Extensions]+ -> B.ByteString+ -> Pos+ -> PState+emptyPState exts buf pos = PState+ { input = inp+ , curToken = error "no token"+ , lexState = [0]+ , extensions = foldl' setBit 0 (map fromEnum exts)+ }+ where+ inp :: AlexInput+ inp = AlexInput+ { alexPos = pos+ , alexPrevChar = '\n'+ , alexInput = buf+ , alexOff = 0+ }++newtype P a = P { runP :: PState -> Either SomeException (a, PState) }++instance Functor P where+ fmap f x = x >>= return . f++instance Applicative P where+ pure = return+ (<*>) = ap++instance Monad P where+ m >>= k = P $ \s ->+ case runP m s of+ Left e -> Left e+ Right (a, s') -> runP (k a) s'++ m1 >> m2 = P $ \s ->+ case runP m1 s of+ Left e -> Left e+ Right (_, s') -> runP m2 s'++ return a = P $ \s -> Right (a, s)++ fail msg = do+ inp <- getInput+ throw $ ParserException (Loc (alexPos inp) (alexPos inp))+ (ppr (alexPos inp) <> colon <+> text msg)++instance MonadState PState P where+ get = P $ \s -> Right (s, s)+ put s = P $ \_ -> Right ((), s)++instance MonadException P where+ throw e = P $ \_ -> Left (toException e)++ m `catch` h = P $ \s ->+ case runP m s of+ Left e ->+ case fromException e of+ Just e' -> runP (h e') s+ Nothing -> Left e+ Right (a, s') -> Right (a, s')++evalP :: P a -> PState -> Either SomeException a+evalP comp st =+ case runP comp st of+ Left e -> Left e+ Right (a, _) -> Right a++getInput :: P AlexInput+getInput = gets input++setInput :: AlexInput -> P ()+setInput inp = modify $ \s ->+ s { input = inp }++pushLexState :: Int -> P ()+pushLexState ls = modify $ \s ->+ s { lexState = ls : lexState s }++popLexState :: P Int+popLexState = do+ ls <- getLexState+ modify $ \s ->+ s { lexState = tail (lexState s) }+ return ls++getLexState :: P Int+getLexState = gets (head . lexState)++getCurToken :: P (L Token)+getCurToken = gets curToken++setCurToken :: L Token -> P ()+setCurToken tok = modify $ \s -> s { curToken = tok }++antiquotationExts :: ExtensionsInt+antiquotationExts = (bit . fromEnum) Antiquotation++useExts :: ExtensionsInt -> P Bool+useExts ext = gets $ \s ->+ extensions s .&. ext /= 0++data LexerException = LexerException Pos Doc+ deriving (Typeable)++instance Exception LexerException where++instance Show LexerException where+ show (LexerException pos msg) =+ show $ nest 4 $ ppr pos <> text ":" </> msg++data ParserException = ParserException Loc Doc+ deriving (Typeable)++instance Exception ParserException where++instance Show ParserException where+ show (ParserException loc msg) =+ show $ nest 4 $ ppr loc <> text ":" </> msg++quoteTok :: Doc -> Doc+quoteTok = enclose (char '`') (char '\'')++failAt :: Loc -> String -> P a+failAt loc msg =+ throw $ ParserException loc (text msg)++lexerError :: AlexInput -> Doc -> P a+lexerError inp s =+ throw $ LexerException (alexPos inp) (text "lexer error on" <+> s)++unexpectedEOF :: AlexInput -> P a+unexpectedEOF inp =+ lexerError inp (text "unexpected end of file")++emptyCharacterLiteral :: AlexInput -> P a+emptyCharacterLiteral inp =+ lexerError inp (text "empty character literal")++illegalCharacterLiteral :: AlexInput -> P a+illegalCharacterLiteral inp =+ lexerError inp (text "illegal character literal")++illegalNumericalLiteral :: AlexInput -> P a+illegalNumericalLiteral inp =+ lexerError inp (text "illegal numerical literal")++parserError :: Loc -> Doc -> P a+parserError loc msg =+ throw $ ParserException loc msg++unclosed :: Loc -> String -> P a+unclosed loc x =+ parserError (locEnd loc) (text "unclosed" <+> quoteTok (text x))++expected :: [String] -> Maybe String -> P b+expected alts after = do+ tok <- getCurToken+ expectedAt tok alts after++expectedAt :: L Token -> [String] -> Maybe String -> P b+expectedAt tok@(L loc _) alts after = do+ parserError (locStart loc) (text "expected" <+> pprAlts alts <+> pprGot tok <> pprAfter after)+ where+ pprAlts :: [String] -> Doc+ pprAlts [] = empty+ pprAlts [s] = text s+ pprAlts [s1, s2] = text s1 <+> text "or" <+> text s2+ pprAlts (s : ss) = text s <> comma <+> pprAlts ss++ pprGot :: L Token -> Doc+ pprGot (L _ Teof) = text "but reached end of file"+ pprGot (L _ t) = text "but got" <+> quoteTok (ppr t)++ pprAfter :: Maybe String -> Doc+ pprAfter Nothing = empty+ pprAfter (Just what) = text " after" <+> text what++data AlexInput = AlexInput+ { alexPos :: {-#UNPACK#-} !Pos+ , alexPrevChar :: {-#UNPACK#-} !Char+ , alexInput :: {-#UNPACK#-} !B.ByteString+ , alexOff :: {-#UNPACK#-} !Int+ }++alexGetChar :: AlexInput -> Maybe (Char, AlexInput)+alexGetChar inp =+ case B.uncons (alexInput inp) of+ Nothing -> Nothing+ Just (c, bs) -> Just (c, inp { alexPos = advancePos (alexPos inp) c+ , alexPrevChar = c+ , alexInput = bs+ , alexOff = alexOff inp + 1+ })++alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)+alexGetByte inp =+ case alexGetChar inp of+ Nothing -> Nothing+ Just (c, inp') -> Just (c2w c, inp')++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar = alexPrevChar++nextChar :: P Char+nextChar = do+ inp <- getInput+ case alexGetChar inp of+ Nothing -> unexpectedEOF inp+ Just (c, inp') -> setInput inp' >> return c++peekChar ::P Char+peekChar = do+ inp <- getInput+ case B.uncons (alexInput inp) of+ Nothing -> unexpectedEOF inp+ Just (c, _) -> return c++maybePeekChar :: P (Maybe Char)+maybePeekChar = do+ inp <- getInput+ case alexGetChar inp of+ Nothing -> return Nothing+ Just (c, _) -> return (Just c)++skipChar :: P ()+skipChar = do+ inp <- getInput+ case alexGetChar inp of+ Nothing -> unexpectedEOF inp+ Just (_, inp') -> setInput inp'++-- | The components of an 'AlexPredicate' are the predicate state, input stream+-- before the token, length of the token, input stream after the token.+type AlexPredicate = PState+ -> AlexInput+ -> Int+ -> AlexInput+ -> Bool++allowAnti :: AlexPredicate+allowAnti = ifExtension antiquotationExts++ifExtension :: ExtensionsInt -> AlexPredicate+ifExtension i s _ _ _ = extensions s .&. i /= 0
+ src/LLVM/General/Quote/Parser/Parser.y view
@@ -0,0 +1,1049 @@+{+module LLVM.General.Quote.Parser.Parser where++import Control.Monad (forM_,+ when,+ unless,+ liftM)+import Control.Monad.Exception+import Data.List (intersperse)+import Data.List.Split+import Data.Loc+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe (fromMaybe, catMaybes, listToMaybe)+import Data.Word+import Text.PrettyPrint.Mainland++import LLVM.General.Quote.Parser.Lexer+import LLVM.General.Quote.Parser.Monad+import qualified LLVM.General.Quote.Parser.Tokens as T+import qualified LLVM.General.Quote.AST as A+import qualified LLVM.General.AST.Float as A+import qualified LLVM.General.AST.Linkage as A+import qualified LLVM.General.AST.Visibility as A+import qualified LLVM.General.AST.CallingConvention as A+import qualified LLVM.General.AST.AddrSpace as A+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.IntegerPredicate as AI+import qualified LLVM.General.AST.FloatingPointPredicate as AF+import qualified LLVM.General.AST.RMWOperation as AR+}++%token+ INT { L _ (T.TintConst $$) }+ FLOAT { L _ (T.TfloatConst $$) }+ STRING { L _ (T.TstringConst $$) }+ NAMED_GLOBAL { L _ (T.Tnamed T.Global $$) }+ NAMED_LOCAL { L _ (T.Tnamed T.Local $$) }+ NAMED_META { L _ (T.Tnamed T.Meta $$) }+ UNNAMED_GLOBAL { L _ (T.Tunnamed T.Global $$) }+ UNNAMED_LOCAL { L _ (T.Tunnamed T.Local $$) }+ UNNAMED_META { L _ (T.Tunnamed T.Meta $$) }+ JUMPLABEL { L _ (T.TjumpLabel $$) }+ '(' { L _ T.Tlparen }+ ')' { L _ T.Trparen }+ '[' { L _ T.Tlbrack }+ ']' { L _ T.Trbrack }+ '{' { L _ T.Tlbrace }+ '}' { L _ T.Trbrace }+ '<' { L _ T.Tlt }+ '>' { L _ T.Tgt }+ ',' { L _ T.Tcomma }+ '=' { L _ T.Tassign }+ '*' { L _ T.Tstar }+ '-' { L _ T.Tminus }+ '!' { L _ T.Tbang }+ '...' { L _ T.Tpoints }+ 'x' { L _ T.Tx }+ 'zeroinitializer' { L _ T.Tzeroinitializer }+ 'undef' { L _ T.Tundef }+ 'ret' { L _ T.Tret }+ 'br' { L _ T.Tbr }+ 'switch' { L _ T.Tswitch }+ 'indirectbr' { L _ T.Tindirectbr }+ 'invoke' { L _ T.Tinvoke }+ 'resume' { L _ T.Tresume }+ 'unreachable' { L _ T.Tunreachable }+ 'add' { L _ T.Tadd }+ 'fadd' { L _ T.Tfadd }+ 'sub' { L _ T.Tsub }+ 'fsub' { L _ T.Tfsub }+ 'mul' { L _ T.Tmul }+ 'fmul' { L _ T.Tfmul }+ 'udiv' { L _ T.Tudiv }+ 'sdiv' { L _ T.Tsdiv }+ 'fdiv' { L _ T.Tfdiv }+ 'urem' { L _ T.Turem }+ 'srem' { L _ T.Tsrem }+ 'frem' { L _ T.Tfrem }+ 'shl' { L _ T.Tshl }+ 'lshr' { L _ T.Tlshr }+ 'ashr' { L _ T.Tashr }+ 'and' { L _ T.Tand }+ 'or' { L _ T.Tor }+ 'xor' { L _ T.Txor }+ 'alloca' { L _ T.Talloca }+ 'load' { L _ T.Tload }+ 'store' { L _ T.Tstore }+ 'getelementptr' { L _ T.Tgetelementptr }+ 'fence' { L _ T.Tfence }+ 'cmpxchg' { L _ T.Tcmpxchg }+ 'atomicrmw' { L _ T.Tatomicrmw }+ 'trunc' { L _ T.Ttrunc }+ 'zext' { L _ T.Tzext }+ 'sext' { L _ T.Tsext }+ 'fptoui' { L _ T.Tfptoui }+ 'fptosi' { L _ T.Tfptosi }+ 'uitofp' { L _ T.Tuitofp }+ 'sitofp' { L _ T.Tsitofp }+ 'fptrunc' { L _ T.Tfptrunc }+ 'fpext' { L _ T.Tfpext }+ 'ptrtoint' { L _ T.Tptrtoint }+ 'inttoptr' { L _ T.Tinttoptr }+ 'bitcast' { L _ T.Tbitcast }+ 'addrspacecast' { L _ T.Taddrspacecast }+ 'icmp' { L _ T.Ticmp }+ 'fcmp' { L _ T.Tfcmp }+ 'phi' { L _ T.Tphi }+ 'call' { L _ T.Tcall }+ 'select' { L _ T.Tselect }+ 'va_arg' { L _ T.Tvaarg }+ 'extractelement' { L _ T.Textractelement }+ 'insertelement' { L _ T.Tinsertelement }+ 'shufflevector' { L _ T.Tshufflevector }+ 'extractvalue' { L _ T.Textractvalue }+ 'insertvalue' { L _ T.Tinsertvalue }+ 'landingpad' { L _ T.Tlandingpad }+ 'eq' { L _ T.Teq }+ 'ne' { L _ T.Tne }+ 'ugt' { L _ T.Tugt }+ 'uge' { L _ T.Tuge }+ 'ult' { L _ T.Tult }+ 'ule' { L _ T.Tule }+ 'sgt' { L _ T.Tsgt }+ 'sge' { L _ T.Tsge }+ 'slt' { L _ T.Tslt }+ 'sle' { L _ T.Tsle }+ 'false' { L _ T.Tfalse }+ 'oeq' { L _ T.Toeq }+ 'ogt' { L _ T.Togt }+ 'oge' { L _ T.Toge }+ 'olt' { L _ T.Tolt }+ 'ole' { L _ T.Tole }+ 'one' { L _ T.Tone }+ 'ord' { L _ T.Tord }+ 'uno' { L _ T.Tuno }+ 'ueq' { L _ T.Tueq }+ 'une' { L _ T.Tune }+ 'true' { L _ T.Ttrue }+ 'label' { L _ T.Tlabel }+ 'volatile' { L _ T.Tvolatile }+ 'inbounds' { L _ T.Tinbounds }+ 'align' { L _ T.Talign }+ 'nnan' { L _ T.Tnnan }+ 'ninf' { L _ T.Tninf }+ 'nsz' { L _ T.Tnsz }+ 'arcp' { L _ T.Tarcp }+ 'fast' { L _ T.Tfast }+ 'to' { L _ T.Tto }+ 'nsw' { L _ T.Tnsw }+ 'nuw' { L _ T.Tnuw }+ 'target' { L _ T.Ttarget }+ 'datalayout' { L _ T.Tdatalayout }+ 'triple' { L _ T.Ttriple }+ 'define' { L _ T.Tdefine }+ 'void' { L _ T.Tvoid }+ 'half' { L _ T.Thalf }+ 'float' { L _ T.Tfloat }+ 'double' { L _ T.Tdouble }+ INTEGERTYPE { L _ (T.TintegerType $$) }+ 'metadata' { L _ T.Tmetadata }+ 'zeroext' { L _ T.Tzeroext }+ 'signext' { L _ T.Tsignext }+ 'inreg' { L _ T.Tinreg }+ 'byval' { L _ T.Tbyval }+ 'sret' { L _ T.Tsret }+ 'noalias' { L _ T.Tnoalias }+ 'nocapture' { L _ T.Tnocapture }+ 'nest' { L _ T.Tnest }+ 'alignstack' { L _ T.Talignstack }+ 'alwaysinline' { L _ T.Talwaysinline }+ 'inlinehint' { L _ T.Tinlinehint }+ 'naked' { L _ T.Tnaked }+ 'noimplicitfloat' { L _ T.Tnoimplicitfloat }+ 'noinline' { L _ T.Tnoinline }+ 'nonlazybind' { L _ T.Tnonlazybind }+ 'noredzone' { L _ T.Tnoredzone }+ 'noreturn' { L _ T.Tnoreturn }+ 'nounwind' { L _ T.Tnounwind }+ 'optsize' { L _ T.Toptsize }+ 'readnone' { L _ T.Treadnone }+ 'readonly' { L _ T.Treadonly }+ 'ssp' { L _ T.Tssp }+ 'sspreq' { L _ T.Tsspreq }+ 'uwtable' { L _ T.Tuwtable }+ 'global' { L _ T.Tglobal }+ 'constant' { L _ T.Tconstant }+ 'alias' { L _ T.Talias }+ 'unwind' { L _ T.Tunwind }+ 'unordered' { L _ T.Tunordered }+ 'monotonic' { L _ T.Tmonotonic }+ 'acquire' { L _ T.Tacquire }+ 'release' { L _ T.Trelease }+ 'acq_rel' { L _ T.Tacq_rel }+ 'seq_cst' { L _ T.Tseq_cst }+ 'singlethread' { L _ T.Tsinglethread }+ 'xchg' { L _ T.Txchg }+ 'nand' { L _ T.Tnand }+ 'max' { L _ T.Tmax }+ 'min' { L _ T.Tmin }+ 'umax' { L _ T.Tumax }+ 'umin' { L _ T.Tumin }+ 'cleanup' { L _ T.Tcleanup }+ 'catch' { L _ T.Tcatch }+ 'filter' { L _ T.Tfilter }+ 'personality' { L _ T.Tpersonality }+ 'private' { L _ T.Tprivate }+ 'internal' { L _ T.Tinternal }+ 'available_externally'+ { L _ T.Tavailable_externally }+ 'linkonce' { L _ T.Tlinkonce }+ 'weak' { L _ T.Tweak }+ 'common' { L _ T.Tcommon }+ 'appending' { L _ T.Tappending }+ 'extern_weak' { L _ T.Textern_weak }+ 'linkonce_odr' { L _ T.Tlinkonce_odr }+ 'weak_odr' { L _ T.Tweak_odr }+ 'external' { L _ T.Texternal }+ 'default' { L _ T.Tdefault }+ 'hidden' { L _ T.Thidden }+ 'protected' { L _ T.Tprotected }+ 'ccc' { L _ T.Tccc }+ 'fastcc' { L _ T.Tfastcc }+ 'coldcc' { L _ T.Tcoldcc }+ 'cc' { L _ T.Tcc }+ 'atomic' { L _ T.Tatomic }+ 'null' { L _ T.Tnull }+ 'exact' { L _ T.Texact }+ 'addrspace' { L _ T.Taddrspace }+ 'blockaddress' { L _ T.Tblockaddress }+ 'module' { L _ T.Tmodule }+ 'asm' { L _ T.Tasm }+ 'type' { L _ T.Ttype }+ 'opaque' { L _ T.Topaque }+ 'sideeffect' { L _ T.Tsideeffect }+ 'inteldialect' { L _ T.Tinteldialect }+ 'section' { L _ T.Tsection }+ 'gc' { L _ T.Tgc }+ 'tail' { L _ T.Ttail }++ 'for' { L _ T.Tfor }+ 'in' { L _ T.Tin }+ 'with' { L _ T.Twith }+ 'as' { L _ T.Tas }++ ANTI_DL { L _ (T.Tanti_dl $$) }+ ANTI_TT { L _ (T.Tanti_tt $$) }+ ANTI_DEF { L _ (T.Tanti_def $$) }+ ANTI_DEFS { L _ (T.Tanti_defs $$) }+ ANTI_BB { L _ (T.Tanti_bb $$) }+ ANTI_BBS { L _ (T.Tanti_bbs $$) }+ ANTI_INSTR { L _ (T.Tanti_instr $$) }+ ANTI_CONST { L _ (T.Tanti_const $$) }+ ANTI_ID { L _ (T.Tanti_id $$) }+ ANTI_GID { L _ (T.Tanti_gid $$) }+ ANTI_PARAM { L _ (T.Tanti_param $$) }+ ANTI_PARAMS { L _ (T.Tanti_params $$) }++%monad { P } { >>= } { return }+%lexer { lexer } { L _ T.Teof }+%tokentype { (L T.Token) }+%error { happyError }++%name parseModule module+%name parseDefinition definition+%name parseBasicBlock basicBlock+%name parseInstruction instruction++%%++{------------------------------------------------------------------------------+ -+ - Constants+ -+ -----------------------------------------------------------------------------}++constant :: { A.Type -> A.Constant }+constant :+ INT { intConstant $1 }+ | '-' INT { intConstant (-$2) }+ | 'true' { intConstant 1 }+ | 'false' { intConstant 0 }+ | FLOAT { floatConstant $1 }+ | '-' FLOAT { floatConstant (-$2) }+ | 'zeroinitializer' { A.Null }+ | 'null' { A.Null }+ | '{' constantList '}' { \_ -> A.Struct Nothing False (rev $2) }+ | '[' constantList ']' { \t -> A.Array (A.elementType t) (rev $2) }+ | '<' constantList '>' { \_ -> A.Vector (rev $2) }+ | 'blockaddress' '(' globalName ',' name ')'+ { \_ -> A.BlockAddress $3 $5 }+ | 'undef' { A.Undef }+ | globalName { \_ -> A.GlobalReference $1 }+ | ANTI_CONST { \_ -> A.AntiConstant $1 }++tConstant :: { A.Constant }+tConstant :+ type constant { $2 $1 }++mConstant :: { A.Type -> Maybe A.Constant }+mConstant :+ {- empty -} { \_ -> Nothing }+ | constant { Just . $1 }++constantList :: { RevList A.Constant }+constantList :+ tConstant { RCons $1 RNil }+ | constantList ',' tConstant { RCons $3 $1 }++{------------------------------------------------------------------------------+ -+ - Operands+ -+ -----------------------------------------------------------------------------}++operand :: { A.Type -> A.Operand }+operand :+ constant { A.ConstantOperand . $1 }+ | name { \_ -> A.LocalReference $1 }+ | '!' STRING { \A.MetadataType -> A.MetadataStringOperand $2 }+ | metadataNode { \A.MetadataType -> A.MetadataNodeOperand $1 }++mOperand :: { Maybe A.Operand }+mOperand :+ {- empty -} { Nothing }+ | ',' tOperand { Just $2 }++tOperand :: { A.Operand }+tOperand :+ type operand { $2 $1 }++{------------------------------------------------------------------------------+ -+ - Instructions+ -+ -----------------------------------------------------------------------------}++nuw :: { Bool }+nuw :+ {- empty -} { False }+ | 'nuw' { True }++nsw :: { Bool }+nsw :+ {- empty -} { False }+ | 'nsw' { True }++fmflag :: { () }+fmflag :+ 'nnan' { () }+ | 'ninf' { () }+ | 'nsz' { () }+ | 'arcp' { () }+ | 'fast' { () }++fmflags :: { () }+fmflags :+ {- empty -} { () }+ | fmflags fmflag {% fail "fast-math flags are not supported at this time" }++volatile :: { Bool }+volatile :+ {- empty -} { False }+ | 'volatile' { True }++alignment :: { Word32 }+alignment :+ {- empty -} { 0 }+ | ',' 'align' INT { fromIntegral $3 }++inBounds :: { Bool }+inBounds :+ {- empty -} { False }+ | 'inbounds' { True }++indices :: { RevList A.Operand }+indices :+ {- empty -} { RNil }+ | indices ',' tOperand { RCons $3 $1 }++intP :: { AI.IntegerPredicate }+intP :+ 'eq' { AI.EQ }+ | 'ne' { AI.NE }+ | 'ugt' { AI.UGT }+ | 'uge' { AI.UGE }+ | 'ult' { AI.ULT }+ | 'ule' { AI.ULE }+ | 'sgt' { AI.SGT }+ | 'sge' { AI.SGE }+ | 'slt' { AI.SLT }+ | 'sle' { AI.SLE }++fpP :: { AF.FloatingPointPredicate }+fpP :+ 'false' { AF.False } + | 'oeq' { AF.OEQ } + | 'ogt' { AF.OGT } + | 'oge' { AF.OGE } + | 'olt' { AF.OLT } + | 'ole' { AF.OLE } + | 'one' { AF.ONE } + | 'ord' { AF.ORD } + | 'uno' { AF.UNO } + | 'ueq' { AF.UEQ } + | 'ugt' { AF.UGT } + | 'uge' { AF.UGE } + | 'ult' { AF.ULT } + | 'ule' { AF.ULE } + | 'une' { AF.UNE } + | 'true' { AF.True }++memoryOrdering :: { A.MemoryOrdering }+memoryOrdering :+ 'unordered' { A.Unordered }+ | 'monotonic' { A.Monotonic }+ | 'acquire' { A.Acquire }+ | 'release' { A.Release }+ | 'acq_rel' { A.AcquireRelease }+ | 'seq_cst' { A.SequentiallyConsistent }++atomicity :: { A.Atomicity }+atomicity :+ 'singlethread' memoryOrdering { A.Atomicity False $2 }+ | memoryOrdering { A.Atomicity True $1 }++rmwOperation :: { AR.RMWOperation }+rmwOperation :+ 'xchg' { AR.Xchg }+ | 'add' { AR.Add }+ | 'sub' { AR.Sub }+ | 'and' { AR.And }+ | 'nand' { AR.Nand }+ | 'or' { AR.Or }+ | 'xor' { AR.Xor }+ | 'max' { AR.Max }+ | 'min' { AR.Min }+ | 'umax' { AR.UMax }+ | 'umin' { AR.UMin }++cleanup :: { Bool }+cleanup :+ {- empty -} { False }+ | 'cleanup' { True }++exact :: { Bool }+exact :+ {- empty -} { False }+ | 'exact' { True }++clause :: { A.LandingPadClause }+clause :+ 'catch' tConstant { A.Catch $2 }+ | 'filter' tConstant { A.Filter $2 }++clauses :: { RevList A.LandingPadClause }+clauses :+ {- empty -} { RNil }+ | clauses clause { RCons $2 $1 }++phiItem :: { A.Type -> (A.Operand, A.Name) }+phiItem :+ '[' operand ',' name ']' { \t -> ($2 t, $4) }++phiList :: { A.Type -> RevList (A.Operand, A.Name) }+phiList :+ phiItem { \t -> RCons ($1 t) RNil }+ | phiList ',' phiItem { \t -> RCons ($3 t) ($1 t) }++parameterAttribute :: { A.ParameterAttribute }+parameterAttribute :+ 'zeroext' { A.ZeroExt }+ | 'signext' { A.SignExt }+ | 'inreg' { A.InReg }+ | 'sret' { A.SRet }+ | 'noalias' { A.NoAlias }+ | 'byval' { A.ByVal }+ | 'nocapture' { A.NoCapture }+ | 'nest' { A.Nest }++parameterAttributes :: { RevList A.ParameterAttribute }+parameterAttributes :+ {- empty -} { RNil }+ | parameterAttributes parameterAttribute { RCons $2 $1 }++argument :: { (A.Type, (A.Operand, [A.ParameterAttribute])) }+argument :+ type parameterAttributes operand { ($1, ($3 $1, rev $2)) }++argumentList_ :: { RevList (A.Type, (A.Operand, [A.ParameterAttribute])) }+argumentList_ :+ argument { RCons $1 RNil }+ | argumentList_ ',' argument { RCons $3 $1 }++argumentList :: { RevList (A.Type, (A.Operand, [A.ParameterAttribute])) }+argumentList :+ {- empty -} { RNil }+ | argumentList_ { $1 }++sideeffect :: { Bool }+sideeffect :+ {- empty -} { False }+ | 'sideeffect' { True }++alignstack :: { Bool }+alignstack :+ {- empty -} { False }+ | 'alignstack' { True }++dialect :: { A.Dialect }+dialect :+ {- empty -} { A.ATTDialect }+ | 'inteldialect' { A.IntelDialect }++callableOperand :: { [A.Type] -> A.CallableOperand }+callableOperand :+ type operand { \ts -> Right ($2 (A.FunctionType $1 ts False)) }+ | type 'asm' sideeffect alignstack dialect STRING ',' STRING + { \ts -> Left (A.InlineAssembly (A.FunctionType $1 ts False) $6 $8 $3 $4 $5) }++tail :: { Bool }+tail :+ {- empty -} { False }+ | 'tail' { True }++idx :: { Word32 }+idx :+ INT { fromIntegral $1 }++idxs :: { RevList Word32 }+idxs :+ idx { RCons $1 RNil }+ | idxs ',' idx { RCons $3 $1 }++metadataNodeID :: { A.MetadataNodeID }+metadataNodeID :+ UNNAMED_META { A.MetadataNodeID $1 }++metadataNodeIDs :: { RevList A.MetadataNodeID }+metadataNodeIDs :+ metadataNodeID { RCons $1 RNil }+ | metadataNodeIDs ',' metadataNodeID { RCons $3 $1 }++metadataNode :: { A.MetadataNode }+metadataNode :+ metadataNodeID { A.MetadataNodeReference $1 }+ | '!' '{' metadataList '}' { A.MetadataNode (rev $3) }++instructionMetaDataItem :: { (String, A.MetadataNode) }+instructionMetaDataItem :+ ',' NAMED_META metadataNode { ($2,$3) }++instructionMetadata :: { RevList (String, A.MetadataNode) }+instructionMetadata :+ {- empty -} { RNil }+ | instructionMetadata instructionMetaDataItem+ { RCons $2 $1 }++instruction_ :: { A.InstructionMetadata -> A.Instruction }+instruction_ :+ 'add' nuw nsw type operand ',' operand { A.Add $3 $2 ($5 $4) ($7 $4) }+ | 'fadd' fmflags type operand ',' operand { A.FAdd ($4 $3) ($6 $3) }+ | 'sub' nuw nsw type operand ',' operand { A.Sub $3 $2 ($5 $4) ($7 $4) }+ | 'fsub' fmflags type operand ',' operand { A.FSub ($4 $3) ($6 $3) }+ | 'mul' nuw nsw type operand ',' operand { A.Mul $3 $2 ($5 $4) ($7 $4) }+ | 'fmul' fmflags type operand ',' operand { A.FMul ($4 $3) ($6 $3) }+ | 'udiv' exact type operand ',' operand { A.UDiv $2 ($4 $3) ($6 $3) }+ | 'sdiv' exact type operand ',' operand { A.SDiv $2 ($4 $3) ($6 $3) }+ | 'fdiv' fmflags type operand ',' operand { A.FDiv ($4 $3) ($6 $3) }+ | 'urem' type operand ',' operand { A.URem ($3 $2) ($5 $2) }+ | 'srem' type operand ',' operand { A.SRem ($3 $2) ($5 $2) }+ | 'frem' fmflags type operand ',' operand { A.FRem ($4 $3) ($6 $3) }+ | 'shl' nuw nsw type operand ',' operand { A.Shl $3 $2 ($5 $4) ($7 $4) }+ | 'lshr' exact type operand ',' operand { A.LShr $2 ($4 $3) ($6 $3) }+ | 'ashr' exact type operand ',' operand { A.AShr $2 ($4 $3) ($6 $3) }+ | 'and' type operand ',' operand { A.And ($3 $2) ($5 $2) }+ | 'or' type operand ',' operand { A.Or ($3 $2) ($5 $2) }+ | 'xor' type operand ',' operand { A.Xor ($3 $2) ($5 $2) }+ | 'alloca' type mOperand alignment { A.Alloca $2 $3 $4 }+ | 'load' volatile tOperand alignment { A.Load $2 $3 Nothing $4 }+ | 'load' 'atomic' volatile tOperand atomicity alignment { A.Load $3 $4 (Just $5) $6 }+ | 'store' volatile tOperand ',' tOperand alignment + { A.Store $2 $5 $3 Nothing $6 }+ | 'store' 'atomic' volatile tOperand ',' tOperand atomicity alignment + { A.Store $3 $6 $4 (Just $7) $8 }+ | 'getelementptr' inBounds tOperand indices+ { A.GetElementPtr $2 $3 (rev $4) }+ | 'fence' atomicity { A.Fence $2 }+ | 'cmpxchg' volatile tOperand ',' tOperand ',' tOperand atomicity+ { A.CmpXchg $2 $3 $5 $7 $8 }+ | 'cmpxchg' volatile tOperand ',' tOperand ',' tOperand atomicity memoryOrdering+ {% if A.memoryOrdering $8 == $9 + then return (A.CmpXchg $2 $3 $5 $7 $8)+ else fail "cmpxchg: both orderings must be the same at this point, sry" }+ | 'atomicrmw' volatile rmwOperation tOperand ',' tOperand atomicity+ { A.AtomicRMW $2 $3 $4 $6 $7 }+ | 'trunc' tOperand 'to' type { A.Trunc $2 $4 }+ | 'zext' tOperand 'to' type { A.ZExt $2 $4 }+ | 'sext' tOperand 'to' type { A.SExt $2 $4 }+ | 'fptoui' tOperand 'to' type { A.FPToUI $2 $4 }+ | 'fptosi' tOperand 'to' type { A.FPToSI $2 $4 }+ | 'uitofp' tOperand 'to' type { A.UIToFP $2 $4 }+ | 'sitofp' tOperand 'to' type { A.SIToFP $2 $4 }+ | 'fptrunc' tOperand 'to' type { A.FPTrunc $2 $4 }+ | 'fpext' tOperand 'to' type { A.FPExt $2 $4 }+ | 'ptrtoint' tOperand 'to' type { A.PtrToInt $2 $4 }+ | 'inttoptr' tOperand 'to' type { A.IntToPtr $2 $4 }+ | 'bitcast' tOperand 'to' type { A.BitCast $2 $4 }+ | 'addrspacecast' tOperand 'to' type { A.AddrSpaceCast $2 $4 }+ | 'icmp' intP type operand ',' operand { A.ICmp $2 ($4 $3) ($6 $3) }+ | 'fcmp' fpP type operand ',' operand { A.FCmp $2 ($4 $3) ($6 $3) }+ | 'phi' type phiList { A.Phi $2 (rev ($3 $2)) }+ | tail 'call' cconv pAttributes callableOperand '(' argumentList ')' fAttributes+ { A.Call $1 $3 (rev $4) ($5 (map fst (rev $7))) (map snd (rev $7)) (rev $9) }+ | 'select' tOperand ',' tOperand ',' tOperand+ { A.Select $2 $4 $6 }+ | 'va_arg' tOperand ',' type { A.VAArg $2 $4 }+ | 'extractelement' tOperand ',' tOperand { A.ExtractElement $2 $4 }+ | 'insertelement' tOperand ',' tOperand ',' tOperand+ { A.InsertElement $2 $4 $6 }+ | 'shufflevector' tOperand ',' tOperand ',' type constant+ { A.ShuffleVector $2 $4 ($7 $6) }+ | 'extractvalue' tOperand ',' idxs { A.ExtractValue $2 (rev $4) }+ | 'insertvalue' tOperand ',' tOperand ',' idxs+ { A.InsertValue $2 $4 (rev $6) }+ | 'landingpad' type 'personality' tOperand cleanup clauses+ { A.LandingPad $2 $4 $5 (rev $6) }+ | ANTI_INSTR {\[] -> A.AntiInstruction $1 }++instruction :: { A.Instruction }+instruction :+ instruction_ instructionMetadata { $1 (rev $2) }++name :: { A.Name }+name :+ NAMED_LOCAL { A.Name $1 }+ | UNNAMED_LOCAL { A.UnName $1 }+ | ANTI_ID { A.AntiName $1 }++namedI :: { A.Named A.Instruction }+namedI :+ instruction { A.Do $1 }+ | name '=' instruction { $1 A.:= $3 }++instructions :: { RevList (A.Named A.Instruction) } +instructions :+ {- empty -} { RNil }+ | instructions namedI { RCons $2 $1 }++destination :: { (A.Constant, A.Name) }+destination :+ tConstant ',' label { ($1, $3) }++destinations :: { RevList (A.Constant, A.Name) }+destinations :+ {- empty -} { RNil }+ | destinations destination { RCons $2 $1 }++label :: { A.Name }+label :+ 'label' name { $2 }++labels :: { RevList A.Name }+labels :+ label { RCons $1 RNil }+ | labels ','label { RCons $3 $1 }++namedT :: { A.Named A.Terminator }+namedT :+ terminator { A.Do $1 }+ | name '=' terminator { $1 A.:= $3 }++terminator_ :: { A.InstructionMetadata -> A.Terminator }+terminator_ :+ 'ret' 'void' { A.Ret Nothing }+ | 'ret' typeNoVoid operand+ { A.Ret (Just ($3 $2)) }+ | 'br' 'label' name { A.Br $3 }+ | 'br' type operand ',' 'label' name ',' 'label' name+ { A.CondBr ($3 $2) $6 $9 }+ | 'switch' type operand ',' 'label' name '[' destinations ']'+ { A.Switch ($3 $2) $6 (rev $8) }+ | 'indirectbr' tOperand ',' '[' labels ']'+ { A.IndirectBr $2 (rev $5) }+ | 'invoke' cconv pAttributes callableOperand '(' argumentList ')' fAttributes 'to' 'label' name 'unwind' 'label' name+ { A.Invoke $2 (rev $3) ($4 (map fst (rev $6))) (map snd (rev $6)) (rev $8) $11 $14 }+ | 'resume' tOperand { A.Resume $2 }+ | 'unreachable' { A.Unreachable }++terminator :: { A.Terminator }+terminator :+ terminator_ instructionMetadata { $1 (rev $2) }++{------------------------------------------------------------------------------+ -+ - Basic Blocks+ -+ -----------------------------------------------------------------------------}++mLabel :: { Maybe A.Name }+mLabel :+ ',' 'label' name { Just $3 }++basicBlock :: { A.BasicBlock }+basicBlock :+ JUMPLABEL instructions namedT+ { A.BasicBlock (A.Name $1) (rev $2) $3 }+ | instructions namedT+ {% fail "BasicBlocks must always have names, sry" }+ | JUMPLABEL 'for' type name 'in' operand 'to' operand 'with' type phiList 'as' name mLabel '{' basicBlocks '}'+ { A.ForLoop (A.Name $1) $3 $4 ($6 $3) ($8 $3) $10 (rev ($11 $10)) $13 (rev $16) $14 } + | ANTI_BB+ { A.AntiBasicBlock $1 }+ | ANTI_BBS+ { A.AntiBasicBlockList $1 }++basicBlocks :: { RevList (A.BasicBlock) }+basicBlocks :+ {- empty -} { RNil }+ | basicBlocks basicBlock { RCons $2 $1 }++{------------------------------------------------------------------------------+ -+ - Global Definitions+ -+ -----------------------------------------------------------------------------}++globalName :: { A.Name }+globalName :+ NAMED_GLOBAL { A.Name $1 }+ | UNNAMED_GLOBAL { A.UnName $1 }+ | ANTI_GID { A.AntiName $1 }++addrSpace :: { A.AddrSpace }+addrSpace :+ {- empty -} { A.AddrSpace 0 }+ | 'addrspace' '(' INT ')' { A.AddrSpace (fromIntegral $3) }++typeNoVoid :: { A.Type }+typeNoVoid :+ INTEGERTYPE { A.IntegerType $1 }+ | 'half' { A.FloatingPointType 16 A.IEEE }+ | 'float' { A.FloatingPointType 32 A.IEEE }+ | 'double' { A.FloatingPointType 64 A.IEEE }+ | type addrSpace '*' { A.PointerType $1 $2 }+ | type '(' typeListVar ')' { A.FunctionType $1 (fst $3) (snd $3) }+ | '<' INT 'x' type '>' { A.VectorType (fromIntegral $2) $4 }+ | '{' typeList '}' { A.StructureType False (rev $2) }+ | '<' '{' typeList '}' '>' { A.StructureType True (rev $3) }+ | '[' INT 'x' type ']' { A.ArrayType (fromIntegral $2) $4 }+ | name { A.NamedTypeReference $1 }+ | 'metadata' { A.MetadataType }++type :: { A.Type }+type :+ 'void' { A.VoidType }+ | typeNoVoid { $1 }++mType :: { Maybe A.Type }+mType :+ type { Just $1 }+ | 'opaque' { Nothing }++typeList_ :: { RevList A.Type }+typeList_ :+ type { RCons $1 RNil }+ | typeList_ ',' type { RCons $3 $1 }++typeList :: { RevList A.Type }+typeList :+ {- empty -} { RNil }+ | typeList_ { $1 }++typeListVar :: { ([A.Type], Bool) }+typeListVar :+ {- empty -} { ([], False) }+ | typeList_ { (rev $1, False) }+ | '...' { ([], True) }+ | typeList_ ',' '...' { (rev $1, True) }++linkage :: { A.Linkage }+linkage :+ {- empty -} { A.External }+ | 'private' { A.Private }+ | 'internal' { A.Internal }+ | 'available_externally' { A.AvailableExternally }+ | 'linkonce' { A.LinkOnce }+ | 'weak' { A.Weak }+ | 'common' { A.Common }+ | 'appending' { A.Appending }+ | 'extern_weak' { A.ExternWeak }+ | 'linkonce_odr' { A.LinkOnceODR }+ | 'weak_odr' { A.WeakODR }+ | 'external' { A.External }++visibility :: { A.Visibility }+visibility :+ {- empty -} { A.Default }+ | 'default' { A.Default }+ | 'hidden' { A.Hidden }+ | 'protected' { A.Protected }++cconv :: { A.CallingConvention }+cconv :+ {- empty -} { A.C }+ | 'ccc' { A.C }+ | 'fastcc' { A.Fast }+ | 'coldcc' { A.Cold }+ | 'cc' INT { if $2 == 10 then A.GHC else A.Numbered (fromInteger $2) }++pAttribute :: { A.ParameterAttribute }+pAttribute :+ 'nocapture' { A.NoCapture }++pAttributes :: { RevList A.ParameterAttribute }+pAttributes :+ {- empty -} { RNil }+ | pAttributes pAttribute { RCons $2 $1 }++parameter :: { A.Parameter }+parameter :+ type pAttributes name { A.Parameter $1 $3 (rev $2) }+ | ANTI_PARAM { A.AntiParameter $1 }+ | ANTI_PARAMS { A.AntiParameterList $1 }++parameterList_ :: { RevList A.Parameter }+parameterList_ :+ parameter { RCons $1 RNil }+ | parameterList_ ',' parameter { RCons $3 $1 }++parameterList :: { ([A.Parameter], Bool) }+parameterList :+ {- empty -} { ([], False) }+ | parameterList_ { (rev $1, False) }+ | '...' { ([], True) }+ | parameterList_ '...' { (rev $1, True) }++fAttribute :: { A.FunctionAttribute } +fAttribute :+ 'alignstack' '(' INT ')' { A.StackAlignment (fromIntegral $3) }+ | 'alwaysinline' { A.AlwaysInline }+ | 'inlinehint' { A.InlineHint }+ | 'naked' { A.Naked }+ | 'noimplicitfloat' { A.NoImplicitFloat }+ | 'noinline' { A.NoInline }+ | 'nonlazybind' { A.NonLazyBind }+ | 'noredzone' { A.NoRedZone }+ | 'noreturn' { A.NoReturn }+ | 'nounwind' { A.NoUnwind }+ | 'optsize' { A.OptimizeForSize }+ | 'readnone' { A.ReadNone }+ | 'readonly' { A.ReadOnly }+ | 'ssp' { A.StackProtect }+ | 'sspreq' { A.StackProtectReq }+ | 'uwtable' { A.UWTable }++fAttributes :: { RevList A.FunctionAttribute }+fAttributes :+ {- empty -} { RNil }+ | fAttributes fAttribute { RCons $2 $1 }++section :: { Maybe String }+section :+ {- empty -} { Nothing }+ | 'section' STRING { Just $2 }++gc :: { Maybe String }+gc :+ {- empty -} { Nothing }+ | 'gc' STRING { Just $2 }++isConstant :: { Bool }+isConstant :+ 'global' { False }+ | 'constant' { True }++global :: { A.Global }+global :+ 'define' linkage visibility cconv pAttributes type globalName '(' parameterList ')' fAttributes section alignment gc '{' basicBlocks '}'+ { A.Function $2 $3 $4 (rev $5) $6 $7 $9 (rev $11) $12 $13 $14 (rev $16) }+ | globalName '=' linkage visibility isConstant type mConstant alignment+ { A.GlobalVariable $1 $3 $4 False (A.AddrSpace 0) False $5 $6 ($7 $6) Nothing $8 }+ | globalName '=' visibility 'alias' linkage type constant+ { A.GlobalAlias $1 $5 $3 $6 ($7 $6) }++{------------------------------------------------------------------------------+ -+ - Definitions+ -+ -----------------------------------------------------------------------------}++metadataItem :: { Maybe A.Operand }+metadataItem :+ tOperand { Just $1 }+ | 'null' { Nothing }++metadataList_ :: { RevList (Maybe A.Operand) }+metadataList_ :+ metadataItem { RCons $1 RNil }+ | metadataList_ ',' metadataItem { RCons $3 $1 }++metadataList :: { RevList (Maybe A.Operand) }+metadataList :+ {- empty -} { RNil }+ | metadataList_ { $1 }++definition :: { A.Definition }+definition :+ global { A.GlobalDefinition $1 }+ | name '=' 'type' mType+ { A.TypeDefinition $1 $4 }+ | metadataNodeID '=' 'metadata' '!' '{' metadataList '}'+ { A.MetadataNodeDefinition $1 (rev $6) }+ | NAMED_META '=' '!' '{' metadataNodeIDs '}'+ { A.NamedMetadataDefinition $1 (rev $5) }+ | 'module' 'asm' STRING+ { A.ModuleInlineAssembly $3 }+ | ANTI_DEF { A.AntiDefinition $1 }+ | ANTI_DEFS { A.AntiDefinitionList $1 }++definitions :: { RevList A.Definition }+definitions :+ {- empty -} { RNil }+ | definitions definition { RCons $2 $1 }++{------------------------------------------------------------------------------+ -+ - Modules+ -+ -----------------------------------------------------------------------------}++dataLayout :: { Maybe A.DataLayout }+dataLayout :+ {- empty -} { Nothing }+ | 'target' 'datalayout' '=' STRING { Just (dataLayout $4) }+ | ANTI_DL { Just (A.AntiDataLayout $1) }++targetTriple :: { A.TargetTriple }+targetTriple :+ {- empty -} { A.NoTargetTriple }+ | 'target' 'triple' '=' STRING { A.TargetTriple $4 }+ | ANTI_TT { A.AntiTargetTriple $1 }++module :: { A.Module }+module :+ dataLayout targetTriple definitions { A.Module "<string>" $1 $2 (rev $3) }++{+intConstant :: Integer -> A.Type -> A.Constant+intConstant n (A.IntegerType bs) = A.Int bs n++floatConstant :: Rational -> A.Type -> A.Constant+floatConstant x (A.FloatingPointType 32 _) = A.Float (A.Single (fromRational x))+floatConstant x (A.FloatingPointType 64 _) = A.Float (A.Double (fromRational x))++dataLayout :: String -> A.DataLayout+dataLayout s = A.DataLayout endianness stackAlignment pointerLayouts typeLayouts nativeSizes+ where+ infos :: [String]+ infos = splitOn "-" s+ endianness :: Maybe A.Endianness+ endianness = listToMaybe $ do+ [c] <- infos+ case c of+ 'E' -> return A.BigEndian+ 'e' -> return A.LittleEndian+ _ -> []+ stackAlignment :: Maybe Word32+ stackAlignment = listToMaybe $ do+ ('S':s) <- infos+ (n,"") <- reads s+ return n+ pointerLayouts :: M.Map A.AddrSpace (Word32, A.AlignmentInfo)+ pointerLayouts = M.fromList $ do+ ('p':s@(x:_)) <- infos+ let parts = splitOn ":" s+ (n,size,abi,pref) <- case parts of+ ("":size:abi:pref) -> return (0,size,abi,pref)+ (s:size:abi:pref) -> do+ (n,"") <- reads s+ return (n,size,abi,pref)+ _ -> []+ (size',"") <- reads size+ (abi',"") <- reads abi+ pref' <- case pref of+ [p] -> do+ (pref',"") <- reads p+ return $ Just pref'+ _ -> return Nothing+ return (A.AddrSpace n, (size', A.AlignmentInfo abi' pref'))+ typeLayouts :: M.Map (A.AlignType, Word32) A.AlignmentInfo+ typeLayouts = M.fromList $ do+ ((t:size):abi:pref) <- map (splitOn ":") infos+ k <- case t of+ 'i' -> reads size >>= \(size,"") -> return (A.IntegerAlign, size)+ 'v' -> reads size >>= \(size,"") -> return (A.VectorAlign, size)+ 'f' -> reads size >>= \(size,"") -> return (A.FloatAlign, size)+ 's' -> reads size >>= \(size,"") -> return (A.StackAlign, size)+ 'a' -> return (A.AggregateAlign, 0)+ _ -> []+ (abi',"") <- reads abi+ pref' <- case pref of+ [p] -> do+ (pref',"") <- reads p+ return $ Just pref'+ return (k, A.AlignmentInfo abi' pref')+ nativeSizes :: Maybe (S.Set Word32)+ nativeSizes = do+ let sizes = do+ ('n':s) <- infos+ size <- splitOn ":" s+ (size',"") <- reads size+ return size'+ case sizes of+ [] -> Nothing+ xs -> Just $ S.fromList xs+++happyError :: L T.Token -> P a+happyError (L loc t) =+ parserError (locStart loc) (text "parse error on" <+> quoteTok (ppr t))++lexer :: (L T.Token -> P a) -> P a+lexer cont = do+ t <- lexToken+ setCurToken t+ cont t++locate :: Loc -> (SrcLoc -> a) -> L a+locate loc f = L loc (f (SrcLoc loc))++data RevList a = RNil+ | RCons a (RevList a)++rnil :: RevList a+rnil = RNil++rsingleton :: a -> RevList a+rsingleton x = RCons x RNil++rcons :: a -> RevList a -> RevList a+rcons x xs = RCons x xs++rev :: RevList a -> [a]+rev xs = go [] xs+ where+ go l RNil = l+ go l (RCons x xs) = go (x : l) xs+}
+ src/LLVM/General/Quote/Parser/Tokens.hs view
@@ -0,0 +1,682 @@+module LLVM.General.Quote.Parser.Tokens (+ Token(..),+ Visibility(..),+ Extensions(..),+ ExtensionsInt,+ keywords,+ keywordMap+ ) where++import qualified Data.Map as Map+import Data.Bits+import Data.Word+import Text.PrettyPrint.Mainland+import LLVM.General.Quote.AST+import Data.List (foldl')++data Visibility+ = Global+ | Local+ | Meta+ deriving (Eq, Ord, Show)++data Token+ = Teof+ | TintConst Integer+ | TfloatConst Rational+ | TstringConst String+ | Tnamed Visibility String+ | Tunnamed Visibility Word+ | TjumpLabel String+ | Tlparen+ | Trparen+ | Tlbrack+ | Trbrack+ | Tlbrace+ | Trbrace+ | Tlt+ | Tgt+ | Tcomma+ | Tassign+ | Tstar+ | Tminus+ | Tbang+ | Tpoints+ | Tx+ | Tzeroinitializer+ | Tundef+ | Tglobal+ | Tconstant+ | Talias+ | Tunwind+ | Tunordered+ | Tmonotonic+ | Tacquire+ | Trelease+ | Tacq_rel+ | Tseq_cst+ | Tsinglethread+ | Txchg+ | Tnand+ | Tmax+ | Tmin+ | Tumax+ | Tumin+ | Tcleanup+ | Tcatch+ | Tfilter+ | Tpersonality+ | Tprivate+ | Tinternal+ | Tavailable_externally+ | Tlinkonce+ | Tweak+ | Tcommon+ | Tappending+ | Textern_weak+ | Tlinkonce_odr+ | Tweak_odr+ | Texternal+ | Tdefault+ | Thidden+ | Tprotected+ | Tccc+ | Tfastcc+ | Tcoldcc+ | Tcc+ | Tatomic+ | Tnull+ | Texact+ | Taddrspace+ | Tblockaddress+ | Tmodule+ | Tasm+ | Ttype+ | Topaque+ | Tsideeffect+ | Tinteldialect+ | Tsection+ | Tgc+ | Ttail+ -- Finalizer+ | Tret+ | Tbr+ | Tswitch+ | Tindirectbr+ | Tinvoke+ | Tresume+ | Tunreachable+ -- Operations+ | Tadd+ | Tfadd+ | Tsub+ | Tfsub+ | Tmul+ | Tfmul+ | Tudiv+ | Tsdiv+ | Tfdiv+ | Turem+ | Tsrem+ | Tfrem+ | Tshl+ | Tlshr+ | Tashr+ | Tand+ | Tor+ | Txor+ | Talloca+ | Tload+ | Tstore+ | Tgetelementptr+ | Tfence+ | Tcmpxchg+ | Tatomicrmw+ | Ttrunc+ | Tzext+ | Tsext+ | Tfptoui+ | Tfptosi+ | Tuitofp+ | Tsitofp+ | Tfptrunc+ | Tfpext+ | Tptrtoint+ | Tinttoptr+ | Tbitcast+ | Taddrspacecast+ | Ticmp+ | Tfcmp+ | Tphi+ | Tcall+ | Tselect+ | Tvaarg+ | Textractelement+ | Tinsertelement+ | Tshufflevector+ | Textractvalue+ | Tinsertvalue+ | Tlandingpad++ | Teq+ | Tne+ | Tugt+ | Tuge+ | Tult+ | Tule+ | Tsgt+ | Tsge+ | Tslt+ | Tsle+ | Tfalse+ | Toeq+ | Togt+ | Toge+ | Tolt+ | Tole+ | Tone+ | Tord+ | Tuno+ | Tueq+ | Tune+ | Ttrue++ | Tlabel+ | Tvolatile+ | Tinbounds+ | Talign+ | Tnnan+ | Tninf+ | Tnsz+ | Tarcp+ | Tfast+ | Tto+ | Tnsw+ | Tnuw++ | Ttarget+ | Tdatalayout+ | Ttriple+ | Tdefine+ -- Types+ | Thalf+ | Tfloat+ | Tdouble+ | TintegerType Word32+ | Tvoid+ | Tmetadata+ -- Parameter Attributes+ | Tzeroext+ | Tsignext+ | Tinreg+ | Tbyval+ | Tsret+ | Tnoalias+ | Tnocapture+ | Tnest+ -- Function Attributes+ | Talignstack+ | Talwaysinline+ | Tinlinehint+ | Tnaked+ | Tnoimplicitfloat+ | Tnoinline+ | Tnonlazybind+ | Tnoredzone+ | Tnoreturn+ | Tnounwind+ | Toptsize+ | Treadnone+ | Treadonly+ | Tssp+ | Tsspreq+ | Tuwtable+ -- Loops+ | Tfor+ | Tin+ | Twith+ | Tas+ -- Anti-Quotation+ | Tanti_dl String+ | Tanti_tt String+ | Tanti_def String+ | Tanti_defs String+ | Tanti_bb String+ | Tanti_bbs String+ | Tanti_instr String+ | Tanti_const String+ | Tanti_id String+ | Tanti_gid String+ | Tanti_param String+ | Tanti_params String+ deriving (Eq, Ord)++instance Show Token where+ show (TintConst _) = "INT"+ show (TfloatConst _) = "FLOAT"+ show (TstringConst _) = "STRING"+ show (Tnamed Global _) = "NAMED_GLOBAL"+ show (Tnamed Local _) = "NAMED_LOCAL"+ show (Tnamed Meta _) = "NAMED_META"+ show (Tunnamed Global _) = "UNNAMED_GLOBAL"+ show (Tunnamed Local _) = "UNNAMED_LOCAL"+ show (Tunnamed Meta _) = "UNNAMED_META"+ show (TjumpLabel _) = "JUMPLABEL"+ show (TintegerType _) = "INTEGERTYPE"+ show (Tanti_dl _) = "ANTI_DL"+ show (Tanti_tt _) = "ANTI_TT"+ show (Tanti_def _) = "ANTI_DEF"+ show (Tanti_defs _) = "ANTI_DEFS"+ show (Tanti_bb _) = "ANTI_BB"+ show (Tanti_bbs _) = "ANTI_BBS"+ show (Tanti_instr _) = "ANTI_INSTR"+ show (Tanti_const _) = "ANTI_CONST"+ show (Tanti_id _) = "ANTI_ID"+ show (Tanti_gid _) = "ANTI_GID"+ show (Tanti_param _) = "ANTI_PARAM"+ show (Tanti_params _) = "ANTI_PARAMS"+ show Tlparen = "("+ show Trparen = ")"+ show Tlbrack = "["+ show Trbrack = "]"+ show Tlbrace = "{"+ show Trbrace = "}"+ show Tlt = "<"+ show Tgt = ">"+ show Tcomma = ","+ show Tassign = "="+ show Tstar = "*"+ show Tminus = "-"+ show Tbang = "!"+ show Tpoints = "..."+ show Tx = "x"+ show Tzeroinitializer = "zeroinitializer"+ show Tundef = "undef"+ show Tret = "ret"+ show Tbr = "br"+ show Tswitch = "switch"+ show Tindirectbr = "indirectbr"+ show Tinvoke = "invoke"+ show Tresume = "resume"+ show Tunreachable = "unreachable"+ show Tadd = "add"+ show Tfadd = "fadd"+ show Tsub = "sub"+ show Tfsub = "fsub"+ show Tmul = "mul"+ show Tfmul = "fmul"+ show Tudiv = "udiv"+ show Tsdiv = "sdiv"+ show Tfdiv = "fdiv"+ show Turem = "urem"+ show Tsrem = "srem"+ show Tfrem = "frem"+ show Tshl = "shl"+ show Tlshr = "lshr"+ show Tashr = "ashr"+ show Tand = "and"+ show Tor = "or"+ show Txor = "xor"+ show Talloca = "alloca"+ show Tload = "load"+ show Tstore = "store"+ show Tgetelementptr = "getelementptr"+ show Tfence = "fence"+ show Tcmpxchg = "cmpxchg"+ show Tatomicrmw = "atomicrmw"+ show Ttrunc = "trunc"+ show Tzext = "zext"+ show Tsext = "sext"+ show Tfptoui = "fptoui"+ show Tfptosi = "fptosi"+ show Tuitofp = "uitofp"+ show Tsitofp = "sitofp"+ show Tfptrunc = "fptrunc"+ show Tfpext = "fpext"+ show Tptrtoint = "ptrtoint"+ show Tinttoptr = "inttoptr"+ show Tbitcast = "bitcast"+ show Taddrspacecast = "addrspacecast"+ show Ticmp = "icmp"+ show Tfcmp = "fcmp"+ show Tphi = "phi"+ show Tcall = "call"+ show Tselect = "select"+ show Tvaarg = "va_arg"+ show Textractelement = "extractelement"+ show Tinsertelement = "insertelement"+ show Tshufflevector = "shufflevector"+ show Textractvalue = "extractvalue"+ show Tinsertvalue = "insertvalue"+ show Tlandingpad = "landingpad"+ show Teq = "eq"+ show Tne = "ne"+ show Tugt = "ugt"+ show Tuge = "uge"+ show Tult = "ult"+ show Tule = "ule"+ show Tsgt = "sgt"+ show Tsge = "sge"+ show Tslt = "slt"+ show Tsle = "sle"+ show Tfalse = "false"+ show Toeq = "oeq"+ show Togt = "ogt"+ show Toge = "oge"+ show Tolt = "olt"+ show Tole = "ole"+ show Tone = "one"+ show Tord = "ord"+ show Tuno = "uno"+ show Tueq = "ueq"+ show Tune = "une"+ show Ttrue = "true"+ show Tlabel = "label"+ show Tvolatile = "volatile"+ show Tinbounds = "inbounds"+ show Talign = "align"+ show Tnnan = "nnan"+ show Tninf = "ninf"+ show Tnsz = "nsz"+ show Tarcp = "arcp"+ show Tfast = "fast"+ show Tto = "to"+ show Tnsw = "nsw"+ show Tnuw = "nuw"+ show Ttarget = "target"+ show Tdatalayout = "datalayout"+ show Ttriple = "triple"+ show Tdefine = "define"+ show Tvoid = "void"+ show Thalf = "half"+ show Tfloat = "float"+ show Tdouble = "double"+ show Tmetadata = "metadata"+ show Tzeroext = "zeroext"+ show Tsignext = "signext"+ show Tinreg = "inreg"+ show Tbyval = "byval"+ show Tsret = "sret"+ show Tnoalias = "noalias"+ show Tnocapture = "nocapture"+ show Tnest = "nest"+ show Talignstack = "alignstack"+ show Talwaysinline = "alwaysinline"+ show Tinlinehint = "inlinehint"+ show Tnaked = "naked"+ show Tnoimplicitfloat = "noimplicitfloat"+ show Tnoinline = "noinline"+ show Tnonlazybind = "nonlazybind"+ show Tnoredzone = "noredzone"+ show Tnoreturn = "noreturn"+ show Tnounwind = "nounwind"+ show Toptsize = "optsize"+ show Treadnone = "readnone"+ show Treadonly = "readonly"+ show Tssp = "ssp"+ show Tsspreq = "sspreq"+ show Tuwtable = "uwtable"+ show Tglobal = "global"+ show Tconstant = "constant"+ show Talias = "alias"+ show Tunwind = "unwind"+ show Tunordered = "unordered"+ show Tmonotonic = "monotonic"+ show Tacquire = "acquire"+ show Trelease = "release"+ show Tacq_rel = "acq_rel"+ show Tseq_cst = "seq_cst"+ show Tsinglethread = "singlethread"+ show Txchg = "xchg"+ show Tnand = "nand"+ show Tmax = "max"+ show Tmin = "min"+ show Tumax = "umax"+ show Tumin = "umin"+ show Tcleanup = "cleanup"+ show Tcatch = "catch"+ show Tfilter = "filter"+ show Tpersonality = "personality"+ show Tprivate = "private"+ show Tinternal = "internal"+ show Tavailable_externally = "available_externall"+ show Tlinkonce = "linkonce"+ show Tweak = "weak"+ show Tcommon = "common"+ show Tappending = "appending"+ show Textern_weak = "extern_weak"+ show Tlinkonce_odr = "linkonce_odr"+ show Tweak_odr = "weak_odr"+ show Texternal = "external"+ show Tdefault = "default"+ show Thidden = "hidden"+ show Tprotected = "protected"+ show Tccc = "ccc"+ show Tfastcc = "fastcc"+ show Tcoldcc = "coldcc"+ show Tcc = "cc"+ show Tatomic = "atomic"+ show Tnull = "null"+ show Texact = "exact"+ show Taddrspace = "addrspace"+ show Tblockaddress = "blockaddress"+ show Tmodule = "module"+ show Tasm = "asm"+ show Ttype = "type"+ show Topaque = "opaque"+ show Tsideeffect = "sideeffect"+ show Tinteldialect = "inteldialect"+ show Tsection = "section"+ show Tgc = "gc"+ show Ttail = "tail"+ show Tfor = "for"+ show Tin = "in"+ show Twith = "with"+ show Tas = "as"+ show Teof = "EOF"++instance Pretty Token where+ ppr = text . show+ +keywords :: [(String, Token, Maybe [Extensions])]+keywords = [("define", Tdefine, Nothing),+ ("ret", Tret, Nothing),+ ("target", Ttarget, Nothing),+ ("datalayout", Tdatalayout, Nothing),+ ("triple", Ttriple, Nothing),+ ("float", Tfloat, Nothing),+ ("icmp", Ticmp, Nothing),+ ("add", Tadd, Nothing),+ ("fadd", Tfadd, Nothing),+ ("sub", Tsub, Nothing),+ ("fsub", Tfsub, Nothing),+ ("mul", Tmul, Nothing),+ ("fmul", Tfmul, Nothing),+ ("udiv", Tudiv, Nothing),+ ("sdiv", Tsdiv, Nothing),+ ("fdiv", Tfdiv, Nothing),+ ("urem", Turem, Nothing),+ ("srem", Tsrem, Nothing),+ ("frem", Tfrem, Nothing),+ ("shl", Tshl, Nothing),+ ("lshr", Tlshr, Nothing),+ ("ashr", Tashr, Nothing),+ ("and", Tand, Nothing),+ ("or", Tor, Nothing),+ ("xor", Txor, Nothing),+ ("alloca", Talloca, Nothing),+ ("load", Tload, Nothing),+ ("store", Tstore, Nothing),+ ("getelementptr", Tgetelementptr, Nothing),+ ("fence", Tfence, Nothing),+ ("cmpxchg", Tcmpxchg, Nothing),+ ("atomicrmw", Tatomicrmw, Nothing),+ ("trunc", Ttrunc, Nothing),+ ("zext", Tzext, Nothing),+ ("sext", Tsext, Nothing),+ ("fptoui", Tfptoui, Nothing),+ ("fptosi", Tfptosi, Nothing),+ ("uitofp", Tuitofp, Nothing),+ ("sitofp", Tsitofp, Nothing),+ ("fptrunc", Tfptrunc, Nothing),+ ("fpext", Tfpext, Nothing),+ ("ptrtoint", Tptrtoint, Nothing),+ ("inttoptr", Tinttoptr, Nothing),+ ("bitcast", Tbitcast, Nothing),+ ("addrspacecast", Taddrspacecast, Nothing),+ ("icmp", Ticmp, Nothing),+ ("fcmp", Tfcmp, Nothing),+ ("phi", Tphi, Nothing),+ ("call", Tcall, Nothing),+ ("select", Tselect, Nothing),+ ("va_arg", Tvaarg, Nothing),+ ("extractelement", Textractelement, Nothing),+ ("insertelement", Tinsertelement, Nothing),+ ("shufflevector", Tshufflevector, Nothing),+ ("extractvalue", Textractvalue, Nothing),+ ("insertvalue", Tinsertvalue, Nothing),+ ("landingpad", Tlandingpad, Nothing),+ ("ret", Tret, Nothing),+ ("br", Tbr, Nothing),+ ("switch", Tswitch, Nothing),+ ("indirectbr", Tindirectbr, Nothing),+ ("invoke", Tinvoke, Nothing),+ ("resume", Tresume, Nothing),+ ("unreachable", Tunreachable, Nothing),+ ("label", Tlabel, Nothing),+ ("volatile", Tvolatile, Nothing),+ ("inbounds", Tinbounds, Nothing),+ ("align", Talign, Nothing),+ ("nnan", Tnnan, Nothing),+ ("ninf", Tninf, Nothing),+ ("nsz", Tnsz, Nothing),+ ("arcp", Tarcp, Nothing),+ ("fast", Tfast, Nothing),+ ("eq", Teq, Nothing),+ ("ne", Tne, Nothing),+ ("ugt", Tugt, Nothing),+ ("uge", Tuge, Nothing),+ ("ult", Tult, Nothing),+ ("ule", Tule, Nothing),+ ("sgt", Tsgt, Nothing),+ ("sge", Tsge, Nothing),+ ("slt", Tslt, Nothing),+ ("sle", Tsle, Nothing),+ ("false", Tfalse, Nothing),+ ("oeq", Toeq, Nothing),+ ("ogt", Togt, Nothing),+ ("oge", Toge, Nothing),+ ("olt", Tolt, Nothing),+ ("ole", Tole, Nothing),+ ("one", Tone, Nothing),+ ("ord", Tord, Nothing),+ ("uno", Tuno, Nothing),+ ("ueq", Tueq, Nothing),+ ("une", Tune, Nothing),+ ("true", Ttrue, Nothing),+ ("to", Tto, Nothing),+ ("nsw", Tnsw, Nothing),+ ("nuw", Tnuw, Nothing),+ ("zeroext", Tzeroext, Nothing),+ ("signext", Tsignext, Nothing),+ ("inreg", Tinreg, Nothing),+ ("byval", Tbyval, Nothing),+ ("sret", Tsret, Nothing),+ ("noalias", Tnoalias, Nothing),+ ("nest", Tnest, Nothing),+ ("x", Tx, Nothing),+ ("zeroinitializer", Tzeroinitializer, Nothing),+ ("undef", Tundef, Nothing),+ ("nounwind", Tnounwind, Nothing),+ ("nocapture", Tnocapture, Nothing),+ ("double", Tdouble, Nothing),+ ("float", Tfloat, Nothing),+ ("half", Thalf, Nothing),+ ("void", Tvoid, Nothing),+ ("metadata", Tmetadata, Nothing),+ ("alignstack", Talignstack, Nothing),+ ("alwaysinline", Talwaysinline, Nothing),+ ("inlinehint", Tinlinehint, Nothing),+ ("naked", Tnaked, Nothing),+ ("noimplicitfloat", Tnoimplicitfloat, Nothing),+ ("noinline", Tnoinline, Nothing),+ ("nonlazybind", Tnonlazybind, Nothing),+ ("noredzone", Tnoredzone, Nothing),+ ("noreturn", Tnoreturn, Nothing),+ ("nounwind", Tnounwind, Nothing),+ ("optsize", Toptsize, Nothing),+ ("readnone", Treadnone, Nothing),+ ("readonly", Treadonly, Nothing),+ ("ssp", Tssp, Nothing),+ ("sspreq", Tsspreq, Nothing),+ ("uwtable", Tuwtable, Nothing),+ ("global", Tglobal, Nothing),+ ("constant", Tconstant, Nothing),+ ("alias", Talias, Nothing),+ ("unwind", Tunwind, Nothing),+ ("unordered", Tunordered, Nothing),+ ("monotonic", Tmonotonic, Nothing),+ ("acquire", Tacquire, Nothing),+ ("release", Trelease, Nothing),+ ("acq_rel", Tacq_rel, Nothing),+ ("seq_cst", Tseq_cst, Nothing),+ ("singlethread", Tsinglethread, Nothing),+ ("xchg", Txchg, Nothing),+ ("nand", Tnand, Nothing),+ ("max", Tmax, Nothing),+ ("min", Tmin, Nothing),+ ("umax", Tumax, Nothing),+ ("umin", Tumin, Nothing),+ ("cleanup", Tcleanup, Nothing),+ ("catch", Tcatch, Nothing),+ ("filter", Tfilter, Nothing),+ ("personality", Tpersonality, Nothing),+ ("private", Tprivate, Nothing),+ ("internal", Tinternal, Nothing),+ ("available_externally",+ Tavailable_externally,+ Nothing),+ ("linkonce", Tlinkonce, Nothing),+ ("weak", Tweak, Nothing),+ ("common", Tcommon, Nothing),+ ("appending", Tappending, Nothing),+ ("extern_weak", Textern_weak, Nothing),+ ("linkonce_odr", Tlinkonce_odr, Nothing),+ ("weak_odr", Tweak_odr, Nothing),+ ("external", Texternal, Nothing),+ ("default", Tdefault, Nothing),+ ("hidden", Thidden, Nothing),+ ("protected", Tprotected, Nothing),+ ("ccc", Tccc, Nothing),+ ("fastcc", Tfastcc, Nothing),+ ("coldcc", Tcoldcc, Nothing),+ ("cc", Tcc, Nothing),+ ("atomic", Tatomic, Nothing),+ ("null", Tnull, Nothing),+ ("exact", Texact, Nothing),+ ("addrspace", Taddrspace, Nothing),+ ("blockaddress", Tblockaddress, Nothing),+ ("module", Tmodule, Nothing),+ ("asm", Tasm, Nothing),+ ("type", Ttype, Nothing),+ ("opaque", Topaque, Nothing),+ ("sideeffect", Tsideeffect, Nothing),+ ("inteldialect", Tinteldialect, Nothing),+ ("section", Tsection, Nothing),+ ("gc", Tgc, Nothing),+ ("tail", Ttail, Nothing),+ ("for", Tfor, Just [Loops]),+ ("in", Tin, Just [Loops]),+ ("with", Twith, Just [Loops]),+ ("as", Tas, Just [Loops])+ ]++keywordMap :: Map.Map String (Token, Maybe ExtensionsInt)+keywordMap = Map.fromList (map f keywords)+ where+ f :: (String, Token, Maybe [Extensions])+ -> (String, (Token, Maybe ExtensionsInt))+ f (s, t, Nothing) = (s, (t, Nothing))+ f (s, t, Just exts) = (s, (t, Just i))+ where+ i = foldl' setBit 0 (map fromEnum exts)
+ test/test.hs view
@@ -0,0 +1,4 @@+import Test.Tasty+import qualified LLVM.General.Quote.Test.Tests as Quote++main = defaultMain Quote.tests