diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,2 @@ +language-llvm-quote +=================== diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/llvm-general-quote.cabal b/llvm-general-quote.cabal new file mode 100644 --- /dev/null +++ b/llvm-general-quote.cabal @@ -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 +maintainer: Timo von Holtz +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 + diff --git a/src/LLVM/General/Quote/AST.hs b/src/LLVM/General/Quote/AST.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/AST.hs @@ -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 + +-- | +data Global + -- | + = 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 + } + -- | + | GlobalAlias { + name :: Name, + linkage :: A.Linkage, + visibility :: A.Visibility, + _type' :: Type, + aliasee :: Constant + } + -- | + | 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) + +-- | +-- 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) + +-- | +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) + +-- | +-- Metadata can be attached to an instruction +type InstructionMetadata = [(String, MetadataNode)] + +-- | +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) + +-- | +-- +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, -- ^ + 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: +-- +-- +-- +-- +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) + +-- | +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 + +{- | + + +N.B. - + +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) + +-- | +data Type + -- | + = VoidType + -- | + | IntegerType { typeBits :: Word32 } + -- | + | PointerType { pointerReferent :: Type, pointerAddrSpace :: A.AddrSpace } + -- | + | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat } + -- | + | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool } + -- | + | VectorType { nVectorElements :: Word32, elementType :: Type } + -- | + | StructureType { isPacked :: Bool, elementTypes :: [Type] } + -- | + | ArrayType { nArrayElements :: Word64, elementType :: Type } + -- | + | NamedTypeReference Name + -- | + | 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 +-- +data Dialect + = ATTDialect + | IntelDialect + deriving (Eq, Read, Show, Typeable, Data) + +-- | +-- 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 diff --git a/src/LLVM/General/Quote/Base.hs b/src/LLVM/General/Quote/Base.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/Base.hs @@ -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" + } diff --git a/src/LLVM/General/Quote/LLVM.hs b/src/LLVM/General/Quote/LLVM.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/LLVM.hs @@ -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 diff --git a/src/LLVM/General/Quote/Parser.hs b/src/LLVM/General/Quote/Parser.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/Parser.hs @@ -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) diff --git a/src/LLVM/General/Quote/Parser/Lexer.x b/src/LLVM/General/Quote/Parser/Lexer.x new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/Parser/Lexer.x @@ -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 +} + diff --git a/src/LLVM/General/Quote/Parser/Monad.hs b/src/LLVM/General/Quote/Parser/Monad.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/Parser/Monad.hs @@ -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 diff --git a/src/LLVM/General/Quote/Parser/Parser.y b/src/LLVM/General/Quote/Parser/Parser.y new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/Parser/Parser.y @@ -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 "" $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 +} diff --git a/src/LLVM/General/Quote/Parser/Tokens.hs b/src/LLVM/General/Quote/Parser/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Quote/Parser/Tokens.hs @@ -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) diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,4 @@ +import Test.Tasty +import qualified LLVM.General.Quote.Test.Tests as Quote + +main = defaultMain Quote.tests