llvm-general-quote 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+1729/−1387 lines, 11 filesdep −exception-transformersdep ~llvm-general-puredep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies removed: exception-transformers

Dependency ranges changed: llvm-general-pure, mtl

API changes (from Hackage documentation)

Files

• README.md +46/−1
• llvm-general-quote.cabal +8/−8
• src/LLVM/General/Quote/AST.hs +221/−248
• src/LLVM/General/Quote/Base.hs +765/−963
• src/LLVM/General/Quote/LLVM.hs +42/−9
• src/LLVM/General/Quote/Parser.hs +4/−6
• src/LLVM/General/Quote/Parser/Lexer.x +24/−4
• src/LLVM/General/Quote/Parser/Monad.hs +21/−20
• src/LLVM/General/Quote/Parser/Parser.y +161/−121
• src/LLVM/General/Quote/Parser/Tokens.hs +26/−7
• src/LLVM/General/Quote/SSA.hs +411/−0

@@ -1,2 +1,47 @@-language-llvm-quote+llvm-general-quote ===================+`llvm-general-quote` is a quasiquoting-library for llvm-general.+It aims to support all language constructs of llvm.++In addtion to this, it supports using mutable variables and control structures instead of pure SSA form.+This is translated automatically into SSA through appropriate renaming.+++Example:+```+[lldef|+  define i64 @foo(i64 %start, i64 %end) {+    entry:+      %x = i64 0++    for:+      for i64 %i in %start to %end {+          %x = add i64 %i, %x+      }++    exit:+      ret i64 %x+  }+  |]+```+this would be transformed into:+```+define i64 @foo(i64 %start, i64 %end) {+entry:+  br label %for.head++for.head:                      ; preds = %n0, %entry+  %x.12 = phi i64 [ 0, %entry ], [ %x.6, %n0 ]+  %i.4 = phi i64 [ %start, %entry ], [ %i.9, %n0 ]+  %for.cond.3 = icmp slt i64 %i.4, %end+  br i1 %for.cond.3, label %n0, label %for.end++n0:                            ; preds = %for.head+  %x.6 = add i64 %i.4, %x.12+  %i.9 = add nuw nsw i64 %i.4, 1+  br label %for.head++for.end:                       ; preds = %for.head+  ret i64 %x.12+}+```

@@ -1,5 +1,5 @@ name:                llvm-general-quote-version:             0.1.0.0+version:             0.2.0.0 synopsis:            QuasiQuoting llvm code for llvm-general homepage:            https://github.com/tvh/llvm-general-quote description:@@ -21,33 +21,33 @@  library   exposed-modules:-    LLVM.General.Quote.LLVM-  other-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+    LLVM.General.Quote.Base,+    LLVM.General.Quote.SSA   other-extensions:    CPP   ghc-options:     -Wall   build-depends:     base >=4.7 && <4.8,     array >=0.5 && <0.6,     containers >=0.5 && <0.6,-    mtl,+    mtl >= 2.2.1,     bytestring,     symbol,     srcloc,-    exception-transformers,     mainland-pretty,-    llvm-general-pure,+    llvm-general-pure >= 3.4.3.0,     syb,     template-haskell >= 2.7,     haskell-src-meta,     th-lift,-    split      +    split   build-tools:         alex, happy   hs-source-dirs: src   default-language:    Haskell2010

@@ -6,27 +6,21 @@   Definition(..),   Global(..),   Parameter(..),-  BasicBlock(..),+  Direction(..),   InstructionMetadata,-  Terminator(..),-  MemoryOrdering(..),-  Atomicity(..),   LandingPadClause(..),+  FastMathFlags(..),   Instruction(..),-  Named(..),+  NamedInstruction(..),+  LabeledInstruction(..),   MetadataNodeID(..),   MetadataNode(..),   Operand(..),   CallableOperand,   Constant(..),   Name(..),-  FloatingPointFormat(..),   Type(..),-  Dialect(..),   InlineAssembly(..),-  Endianness(..),-  AlignmentInfo(..),-  AlignType(..),   DataLayout(..),   TargetTriple(..),   Extensions(..), ExtensionsInt@@ -38,9 +32,13 @@ 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.Instruction as A+import qualified LLVM.General.AST.InlineAssembly 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 qualified LLVM.General.AST.Type as A+import qualified LLVM.General.AST.DataLayout as A  import Data.Word import Data.Typeable@@ -92,7 +90,7 @@         section :: Maybe String,         alignment :: Word32,         garbageCollectorName :: Maybe String,-        basicBlocks :: [BasicBlock]+        instructions :: [LabeledInstruction]       }   deriving (Eq, Read, Show, Typeable, Data) @@ -103,32 +101,13 @@   | AntiParameterList String   deriving (Eq, Read, Show, Typeable, Data) --- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html>--- LLVM code in a function is a sequence of 'BasicBlock's each with a label,--- some instructions, and a terminator.-data BasicBlock-  = BasicBlock {-    label :: Name,-    instructions :: [Named Instruction],-    terminator :: (Named Terminator)-  }-  | ForLoop {-    label :: Name,-    iterType :: Type,-    iterName :: Name,-    from :: Operand,-    to :: Operand,-    _elementType :: Type,-    _element :: [(Operand,Name)],-    _elementName :: Name,-    body :: [BasicBlock],-    next :: Maybe Name}-  | AntiBasicBlock String-  | AntiBasicBlockList String+data Direction+  = Up+  | Down   deriving (Eq, Read, Show, Typeable, Data)  -- | Any thing which can be at the top level of a 'Module'-data Definition +data Definition   = GlobalDefinition Global   | TypeDefinition Name (Maybe Type)   | MetadataNodeDefinition MetadataNodeID [Maybe Operand]@@ -139,97 +118,45 @@     deriving (Eq, Read, Show, Typeable, Data)  -- | <http://llvm.org/docs/LangRef.html#modulestructure>-data Module = +data Module =   Module {     moduleName :: String,     -- | a 'DataLayout', if specified, must match that of the eventual code generator-    moduleDataLayout :: Maybe DataLayout, +    moduleDataLayout :: Maybe DataLayout,     moduleTargetTriple :: TargetTriple,     moduleDefinitions :: [Definition]-  } +  }   deriving (Eq, Read, Show, Typeable, Data)  -- | <http://llvm.org/docs/LangRef.html#metadata-nodes-and-metadata-strings> -- Metadata can be attached to an instruction type InstructionMetadata = [(String, MetadataNode)] --- | <http://llvm.org/docs/LangRef.html#terminators>-data Terminator -  = Ret { -      returnOperand :: Maybe Operand,-      metadata' :: InstructionMetadata-    }-  | CondBr { -      condition :: Operand, -      trueDest :: Name, -      falseDest :: Name,-      metadata' :: InstructionMetadata-    }-  | Br { -      dest :: Name,-      metadata' :: InstructionMetadata-    }-  | Switch {-      operand0' :: Operand,-      defaultDest :: Name,-      dests :: [(Constant, Name)],-      metadata' :: InstructionMetadata-    }-  | IndirectBr {-      operand0' :: Operand,-      possibleDests :: [Name],-      metadata' :: InstructionMetadata-    }-  | Invoke {-      callingConvention' :: A.CallingConvention,-      returnAttributes' :: [A.ParameterAttribute],-      function' :: CallableOperand,-      arguments' :: [(Operand, [A.ParameterAttribute])],-      functionAttributes' :: [A.FunctionAttribute],-      returnDest :: Name,-      exceptionDest :: Name,-      metadata' :: InstructionMetadata-    }-  | Resume {-      operand0' :: Operand,-      metadata' :: InstructionMetadata-    }-  | Unreachable {-      metadata' :: InstructionMetadata-    }-  deriving (Eq, Read, Show, Typeable, Data)---- | <http://llvm.org/docs/LangRef.html#atomic-memory-ordering-constraints>--- <http://llvm.org/docs/Atomics.html>-data MemoryOrdering-  = Unordered-  | Monotonic-  | Acquire-  | Release-  | AcquireRelease-  | SequentiallyConsistent-  deriving (Eq, Ord, Read, Show, Data, Typeable)---- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction-data Atomicity = Atomicity { -  crossThread :: Bool, -- ^ <http://llvm.org/docs/LangRef.html#singlethread>-  memoryOrdering :: MemoryOrdering- }- deriving (Eq, Ord, Read, Show, Typeable, Data)- -- | For the redoubtably complex 'LandingPad' instruction data LandingPadClause     = Catch Constant     | Filter Constant     deriving (Eq, Ord, Read, Show, Typeable, Data) +-- | <http://llvm.org/docs/LangRef.html#fast-math-flags>+data FastMathFlags +  = NoFastMathFlags+  | UnsafeAlgebra+  | FastMathFlags {+      noNaNs :: Bool,+      noInfs :: Bool,+      noSignedZeros :: Bool,+      allowReciprocal :: Bool+    }+  deriving (Eq, Ord, Read, Show, Data, Typeable)+ -- | non-terminator instructions: -- <http://llvm.org/docs/LangRef.html#binaryops> -- <http://llvm.org/docs/LangRef.html#bitwiseops> -- <http://llvm.org/docs/LangRef.html#memoryops> -- <http://llvm.org/docs/LangRef.html#otherops> data Instruction-  = Add { +  = Add {       nsw :: Bool,       nuw :: Bool,       operand0 :: Operand,@@ -237,6 +164,7 @@       metadata :: InstructionMetadata     }   | FAdd {+      fastMathFlags :: FastMathFlags,       operand0 :: Operand,       operand1 :: Operand,       metadata :: InstructionMetadata@@ -248,145 +176,149 @@       operand1 :: Operand,       metadata :: InstructionMetadata     }-  | FSub { -      operand0 :: Operand, -      operand1 :: Operand, +  | FSub {+      fastMathFlags :: FastMathFlags,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | Mul { -      nsw :: Bool, -      nuw :: Bool, -      operand0 :: Operand, -      operand1 :: Operand, -      metadata :: InstructionMetadata +  | Mul {+      nsw :: Bool,+      nuw :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,+      metadata :: InstructionMetadata     }-  | FMul { -      operand0 :: Operand, -      operand1 :: Operand, +  | FMul {+      fastMathFlags :: FastMathFlags,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | UDiv { -      exact :: Bool, -      operand0 :: Operand, -      operand1 :: Operand, +  | UDiv {+      exact :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | SDiv { -      exact :: Bool, -      operand0 :: Operand, -      operand1 :: Operand, +  | SDiv {+      exact :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | FDiv { -      operand0 :: Operand, -      operand1 :: Operand, +  | FDiv {+      fastMathFlags :: FastMathFlags,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | URem { -      operand0 :: Operand, -      operand1 :: Operand, +  | URem {+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | SRem { -      operand0 :: Operand, -      operand1 :: Operand, +  | SRem {+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | FRem { -      operand0 :: Operand, -      operand1 :: Operand, +  | FRem {+      fastMathFlags :: FastMathFlags,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | Shl { -      nsw :: Bool, -      nuw :: Bool, -      operand0 :: Operand, -      operand1 :: Operand, +  | Shl {+      nsw :: Bool,+      nuw :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | LShr { -      exact :: Bool, -      operand0 :: Operand, -      operand1 :: Operand, +  | LShr {+      exact :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | AShr { -      exact :: Bool, -      operand0 :: Operand, -      operand1 :: Operand, +  | AShr {+      exact :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | And { -      operand0 :: Operand, -      operand1 :: Operand, +  | And {+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | Or { -      operand0 :: Operand, -      operand1 :: Operand, +  | Or {+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | Xor { -      operand0 :: Operand, -      operand1 :: Operand, +  | Xor {+      operand0 :: Operand,+      operand1 :: Operand,       metadata :: InstructionMetadata     }-  | Alloca { +  | Alloca {       allocatedType :: Type,       numElements :: Maybe Operand,       alignmentI :: Word32,       metadata :: InstructionMetadata     }   | Load {-      volatile :: Bool, +      volatile :: Bool,       address :: Operand,-      maybeAtomicity :: Maybe Atomicity,+      maybeAtomicity :: Maybe A.Atomicity,       alignmentI :: Word32,       metadata :: InstructionMetadata     }   | Store {-      volatile :: Bool, +      volatile :: Bool,       address :: Operand,       value :: Operand,-      maybeAtomicity :: Maybe Atomicity,+      maybeAtomicity :: Maybe A.Atomicity,       alignmentI :: Word32,       metadata :: InstructionMetadata     }-  | GetElementPtr { +  | GetElementPtr {       inBounds :: Bool,       address :: Operand,       indices :: [Operand],       metadata :: InstructionMetadata     }-  | Fence { -      atomicity :: Atomicity,-      metadata :: InstructionMetadata +  | Fence {+      atomicity :: A.Atomicity,+      metadata :: InstructionMetadata     }-  | CmpXchg { +  | CmpXchg {       volatile :: Bool,       address :: Operand,       expected :: Operand,       replacement :: Operand,-      atomicity :: Atomicity,-      metadata :: InstructionMetadata +      atomicity :: A.Atomicity,+      metadata :: InstructionMetadata     }-  | AtomicRMW { +  | AtomicRMW {       volatile :: Bool,       rmwOperation :: A.RMWOperation,       address :: Operand,       value :: Operand,-      atomicity :: Atomicity,-      metadata :: InstructionMetadata +      atomicity :: A.Atomicity,+      metadata :: InstructionMetadata     }-  | Trunc { +  | Trunc {       operand0 :: Operand,       type' :: Type,-      metadata :: InstructionMetadata +      metadata :: InstructionMetadata     }   | ZExt {       operand0 :: Operand,       type' :: Type,-      metadata :: InstructionMetadata +      metadata :: InstructionMetadata     }   | SExt {       operand0 :: Operand,@@ -459,7 +391,7 @@       type' :: Type,       incomingValues :: [ (Operand, Name) ],       metadata :: InstructionMetadata-  } +    }   | Call {       isTailCall :: Bool,       callingConvention :: A.CallingConvention,@@ -469,46 +401,46 @@       functionAttributes :: [A.FunctionAttribute],       metadata :: InstructionMetadata   }-  | Select { +  | Select {       condition' :: Operand,       trueValue :: Operand,       falseValue :: Operand,       metadata :: InstructionMetadata     }-  | VAArg { +  | VAArg {       argList :: Operand,       type' :: Type,-      metadata :: InstructionMetadata +      metadata :: InstructionMetadata     }-  | ExtractElement { +  | ExtractElement {       vector :: Operand,       index :: Operand,-      metadata :: InstructionMetadata +      metadata :: InstructionMetadata     }-  | InsertElement { +  | InsertElement {       vector :: Operand,       element :: Operand,       index :: Operand,       metadata :: InstructionMetadata     }-  | ShuffleVector { +  | ShuffleVector {       operand0 :: Operand,       operand1 :: Operand,       mask :: Constant,       metadata :: InstructionMetadata     }-  | ExtractValue { +  | ExtractValue {       aggregate :: Operand,       indices' :: [Word32],       metadata :: InstructionMetadata     }-  | InsertValue { +  | InsertValue {       aggregate :: Operand,       element :: Operand,       indices' :: [Word32],       metadata :: InstructionMetadata     }-  | LandingPad { +  | LandingPad {       type' :: Type,       personalityFunction :: Operand,       cleanup :: Bool,@@ -516,13 +448,85 @@       metadata :: InstructionMetadata     }   | AntiInstruction String+  | 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+    }+  | OperandInstruction Operand   deriving (Eq, Read, Show, Typeable, Data) +data LabeledInstruction+  = Labeled {+    label :: Name,+    instruction :: NamedInstruction }+  | ForLoop {+    label :: Name,+    iterType :: Type,+    iterName :: Name,+    direction :: Direction,+    from :: Operand,+    to :: Operand,+    step :: Operand,+    body :: [LabeledInstruction]}+  | ITE {+    label :: Name,+    cond :: Operand,+    then_body :: [LabeledInstruction],+    else_body :: [LabeledInstruction]+    }+  | While {+    label :: Name,+    cond :: Operand,+    body :: [LabeledInstruction]+    }+  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+data NamedInstruction+  = Name := Instruction+  | Do Instruction+  | AntiInstructionList String+  | AntiBasicBlock String+  | AntiBasicBlockList String   deriving (Eq, Read, Show, Typeable, Data)  -- | A 'MetadataNodeID' is a number for identifying a metadata node.@@ -532,19 +536,20 @@   deriving (Eq, Ord, Read, Show, Typeable, Data)  -- | <http://llvm.org/docs/LangRef.html#metadata>-data MetadataNode +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 +data Operand   -- | %foo-  = LocalReference Name+  = LocalReference Type Name   -- | 'Constant's include 'LLVM.General.AST.Constant.GlobalReference', for \@foo   | ConstantOperand Constant   | MetadataStringOperand String   | MetadataNodeOperand MetadataNode+  | AntiOperand String   deriving (Eq, Ord, Read, Show, Typeable, Data)  -- | The 'LLVM.General.AST.Instruction.Call' instruction is special: the callee can be inline assembly@@ -559,9 +564,10 @@ 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 }+    | IntAntiBs { antiIntegerBits :: String, integerValue :: Integer }     | Float { floatValue :: A.SomeFloat }     | Null { constantType :: Type }     | Struct { structName :: Maybe Name, _isPacked :: Bool, memberValues :: [ Constant ] }@@ -569,7 +575,7 @@     | Vector { memberValues :: [ Constant ] }     | Undef { constantType :: Type }     | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name }-    | GlobalReference Name+    | GlobalReference Type Name     | AntiConstant String     deriving (Eq, Ord, Read, Show, Typeable, Data) @@ -577,7 +583,7 @@ 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. +are quoted when printed if they would otherwise be misread - e.g. when containing special characters.  > 7 @@ -594,21 +600,13 @@ 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 +data Name+    = Name String -- ^ a string name     | UnName Word -- ^ a number for a nameless thing+    | NeedsName     | AntiName String    deriving (Eq, Ord, Read, Show, Typeable, Data) --- | LLVM supports some special formats floating point format. This type is to distinguish those format.--- I believe it's treated as a format for "a" float, as opposed to a vector of two floats, because--- its intended usage is to represent a single number with a combined significand.-data FloatingPointFormat-  = IEEE-  | DoubleExtended-  | PairOfFloats-  deriving (Eq, Ord, Read, Show, Typeable, Data)- -- | <http://llvm.org/docs/LangRef.html#type-system> data Type   -- | <http://llvm.org/docs/LangRef.html#void-type>@@ -618,7 +616,7 @@   -- | <http://llvm.org/docs/LangRef.html#pointer-type>   | PointerType { pointerReferent :: Type, pointerAddrSpace :: A.AddrSpace }   -- | <http://llvm.org/docs/LangRef.html#floating-point-types>-  | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat }+  | FloatingPointType { typeBits :: Word32, floatingPointFormat :: A.FloatingPointFormat }   -- | <http://llvm.org/docs/LangRef.html#function-type>   | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool }   -- | <http://llvm.org/docs/LangRef.html#vector-type>@@ -631,15 +629,9 @@   | NamedTypeReference Name   -- | <http://llvm.org/docs/LangRef.html#metadata-type>   | MetadataType -- only to be used as a parameter type for a few intrinsics+  | AntiType String   deriving (Eq, Ord, Read, Show, Typeable, Data) --- | the dialect of assembly used in an inline assembly string--- <http://en.wikipedia.org/wiki/X86_assembly_language#Syntax>-data Dialect-  = ATTDialect-  | IntelDialect-  deriving (Eq, Read, Show, Typeable, Data)- -- | <http://llvm.org/docs/LangRef.html#inline-assembler-expressions> -- to be used through 'LLVM.General.AST.Operand.CallableOperand' with a -- 'LLVM.General.AST.Instruction.Call' instruction@@ -650,38 +642,18 @@       constraints :: String,       hasSideEffects :: Bool,       alignStack :: Bool,-      dialect :: Dialect+      dialect :: A.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,+    endianness :: Maybe A.Endianness,     stackAlignment :: Maybe Word32,-    pointerLayouts :: M.Map A.AddrSpace (Word32, AlignmentInfo),-    typeLayouts :: M.Map (AlignType, Word32) AlignmentInfo,+    pointerLayouts :: M.Map A.AddrSpace (Word32, A.AlignmentInfo),+    typeLayouts :: M.Map (A.AlignType, Word32) A.AlignmentInfo,     nativeSizes :: Maybe (S.Set Word32)   }   | AntiDataLayout String@@ -704,32 +676,33 @@                   ''A.SomeFloat,                   ''AI.IntegerPredicate,                   ''AF.FloatingPointPredicate,-                  ''BasicBlock,+                  ''Direction,                   ''Parameter,-                  ''Named,+                  ''NamedInstruction,+                  ''LabeledInstruction,                   ''Instruction,                   ''InlineAssembly,-                  ''Dialect,+                  ''A.Dialect,                   ''A.RMWOperation,-                  ''Atomicity,+                  ''A.Atomicity,                   ''LandingPadClause,-                  ''MemoryOrdering,-                  ''Terminator,+                  ''A.MemoryOrdering,                   ''Name,                   ''MetadataNode,                   ''MetadataNodeID,                   ''Operand,                   ''Type,-                  ''FloatingPointFormat,+                  ''A.FloatingPointFormat,                   ''DataLayout,-                  ''Endianness,+                  ''A.Endianness,                   ''M.Map,-                  ''AlignType,-                  ''AlignmentInfo,+                  ''A.AlignType,+                  ''A.AlignmentInfo,                   ''S.Set,                   ''Definition,                   ''Module,-                  ''TargetTriple+                  ''TargetTriple,+                  ''FastMathFlags                   ]) instance Lift Word64 where   lift = lift . toInteger

@@ -4,966 +4,768 @@ {-# 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"-                }+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++module LLVM.General.Quote.Base (+    CodeGen,+    CodeGenMonad(..),+    ToDefintions(..),+    quasiquote,+    quasiquoteM,+    TQuasiQuoter(..),+    parse+  ) where++import Control.Applicative+import Control.Monad.Identity+import qualified Data.ByteString.Char8 as B+import Control.Monad.State.Strict+import Control.Monad.Writer.Strict+import Data.Word+import Data.Loc+import Data.Data (Data(..))+import Language.Haskell.Meta (parseExp)+import Language.Haskell.TH+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax+import Data.IORef (atomicModifyIORef')+import Language.Haskell.TH.Quote (QuasiQuoter(..))++import qualified LLVM.General.Quote.Parser as P+import qualified LLVM.General.Quote.AST as A+import LLVM.General.Quote.SSA+import qualified LLVM.General.AST.IntegerPredicate as LI+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.Attribute as L++import qualified Data.Map as M++class (Applicative m, Monad m) => CodeGenMonad m where+  newVariable    :: m L.Name+  exec     :: m () -> m [L.BasicBlock]++type CodeGen = State (Int, M.Map L.Name [L.Operand])++instance CodeGenMonad CodeGen where+  newVariable      = state $ \(i,vs) -> (L.UnName (fromIntegral i), (i+1,vs))+  exec     = error "not defined: exec"++class ToBasicBlockList a where+  toBasicBlockList :: CodeGenMonad m => m a -> m [L.BasicBlock]+instance ToBasicBlockList () where+  toBasicBlockList = exec+instance ToBasicBlockList [L.BasicBlock] where+  toBasicBlockList = id++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 s = [|$(either fail return $ parseExp s)|]++type Conversion a b = forall m.(CodeGenMonad m) => a -> TExpQ (m b)+type Conversion' m a b = (CodeGenMonad m) => a -> TExpQ (m b)++class QQExp a b where+  qqExpM :: Conversion a b+  qqExp :: a -> TExpQ b+  qqExp x = [||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]++instance (Lift a) => QQExp a a where+  qqExpM x = [||pure x||]++instance QQExp [A.MetadataNodeID] [L.MetadataNodeID] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp A.InstructionMetadata L.InstructionMetadata where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [(A.Constant, A.Name)] [(L.Constant, L.Name)] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [A.Name] [L.Name] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [(A.Operand, [L.ParameterAttribute])]+               [(L.Operand, [L.ParameterAttribute])] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [A.Operand] [L.Operand] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [(A.Operand, A.Name)] [(L.Operand, L.Name)] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [A.LandingPadClause] [L.LandingPadClause] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [Maybe A.Operand] [Maybe L.Operand] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [A.Constant] [L.Constant] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++instance QQExp [A.Type] [L.Type] where+  qqExpM (x:xs) = [||(:) <$> $$(qqExpM x) <*> $$(qqExpM xs)||]+  qqExpM []     = [||pure []||]++-- instance (QQExp a b) => QQExp (Maybe a) (Maybe b) where+--   qqExpM Nothing  = [||pure Nothing||]+--   qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]++instance QQExp (Maybe A.Operand) (Maybe L.Operand) where+  qqExpM Nothing  = [||pure Nothing||]+  qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]++instance QQExp (Maybe A.Name) (Maybe L.Name) where+  qqExpM Nothing  = [||pure Nothing||]+  qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]++instance QQExp (Maybe A.Type) (Maybe L.Type) where+  qqExpM Nothing  = [||pure Nothing||]+  qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]++instance QQExp (Maybe A.DataLayout) (Maybe L.DataLayout) where+  qqExpM Nothing  = [||pure Nothing||]+  qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]++instance QQExp (Maybe A.Constant) (Maybe L.Constant) where+  qqExpM Nothing  = [||pure Nothing||]+  qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]+  +instance QQExp (Maybe (A.Type, A.Operand, A.Name))+               (Maybe (L.Type, L.Operand, L.Name)) where+  qqExpM Nothing  = [||pure Nothing||]+  qqExpM (Just x) = [||Just <$> $$(qqExpM x)||]+  +instance (QQExp a c, QQExp b d) => QQExp (Either a b) (Either c d) where+  qqExpM (Left x)  = [||Left <$> $$(qqExpM x)||]+  qqExpM (Right x) = [||Right <$> $$(qqExpM x)||]++instance (QQExp a c, QQExp b d) => QQExp (a,b) (c,d) where+  qqExpM (x,y) = [||(,) <$> $$(qqExpM x) <*> $$(qqExpM y)||]++instance (QQExp a d, QQExp b e, QQExp c f) => QQExp (a,b,c) (d,e,f) where+  qqExpM (x,y,z) = [||(,,) <$> $$(qqExpM x) <*> $$(qqExpM y) <*> $$(qqExpM z)||]++instance QQExp A.Definition L.Definition where+  qqExpM = qqDefinitionE+instance QQExp [A.Definition] [L.Definition] where+  qqExpM = qqDefinitionListE+instance QQExp A.Module L.Module where+  qqExpM = qqModuleE+instance QQExp A.Global L.Global where+  qqExpM = qqGlobalE+instance QQExp [A.Parameter] [L.Parameter] where+  qqExpM = qqParameterListE+instance QQExp A.Parameter L.Parameter where+  qqExpM = qqParameterE+instance QQExp A.LandingPadClause L.LandingPadClause where+  qqExpM = qqLandingPadClauseE+instance QQExp A.FastMathFlags L.FastMathFlags where+  qqExpM = qqFastMathFlagsE+instance QQExp A.InlineAssembly L.InlineAssembly where+  qqExpM = qqInlineAssemblyE+instance QQExp A.Instruction (Either L.Instruction L.Terminator) where+  qqExpM = qqInstructionE+instance QQExp A.Instruction L.Instruction where+  qqExpM x1 = [||do x1' <- $$(qqExpM x1)+                    case x1' :: Either L.Instruction L.Terminator of+                      Left  x1'' -> return x1''+                      Right x1'' -> fail $ show x1'' ++ " is no Instruction"||]+instance QQExp [A.LabeledInstruction] [L.BasicBlock] where+  qqExpM = qqLabeledInstructionListE+instance QQExp A.NamedInstruction [L.BasicBlock] where+  qqExpM = qqNamedInstructionE+instance QQExp A.LabeledInstruction [L.BasicBlock] where+  qqExpM = qqLabeledInstructionE+instance QQExp A.MetadataNodeID L.MetadataNodeID where+  qqExpM = qqMetadataNodeIDE+instance QQExp A.MetadataNode L.MetadataNode where+  qqExpM = qqMetadataNodeE+instance QQExp A.Operand L.Operand where+  qqExpM = qqOperandE+instance QQExp A.Constant L.Constant where+  qqExpM = qqConstantE+instance QQExp A.Name L.Name where+  qqExpM = qqNameE+instance QQExp A.Type L.Type where+  qqExpM = qqTypeE+instance QQExp A.DataLayout L.DataLayout where+  qqExpM = qqDataLayoutE+instance QQExp A.TargetTriple (Maybe String) where+  qqExpM = qqTargetTripleE++qqDefinitionListE :: Conversion [A.Definition] [L.Definition]+qqDefinitionListE [] = [||pure []||]+qqDefinitionListE (A.AntiDefinitionList v : defs) =+    [||(++) <$> $$(unsafeTExpCoerce [|$(antiVarE v) >>= return . toDefinitions|])+       <*> $$(qqExpM defs)||]+qqDefinitionListE (def : defs) =+    [||(:) <$> $$(qqExpM def) <*> $$(qqExpM defs)||]++qqDefinitionE :: Conversion A.Definition L.Definition+qqDefinitionE (A.GlobalDefinition v) =+    [||L.GlobalDefinition <$> $$(qqExpM v)||]+qqDefinitionE (A.TypeDefinition n v) =+    [||L.TypeDefinition <$> $$(qqExpM n) <*> $$(qqExpM v)||]+qqDefinitionE (A.MetadataNodeDefinition i vs) =+    [||L.MetadataNodeDefinition <$> $$(qqExpM i) <*> $$(qqExpM vs)||]+qqDefinitionE (A.NamedMetadataDefinition i vs) =+    [||L.NamedMetadataDefinition <$> $$(qqExpM i) <*> $$(qqExpM vs)||]+qqDefinitionE (A.ModuleInlineAssembly s) =+    [||L.ModuleInlineAssembly <$> $$(qqExpM s)||]+qqDefinitionE (A.AntiDefinition s) =+    unsafeTExpCoerce $ [|$(antiVarE s) >>= return . toDefinition|]+qqDefinitionE a@(A.AntiDefinitionList _s) =+    error $ "Internal Error: unexpected antiquote " ++ show a++qqModuleE :: Conversion A.Module L.Module+qqModuleE (A.Module n dl tt ds) =+  [||L.Module <$> $$(qqExpM n) <*> $$(qqExpM dl) <*> $$(qqExpM tt) <*> $$(qqExpM ds)||]++qqGlobalE :: Conversion A.Global L.Global+qqGlobalE (A.GlobalVariable x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB) =+  [||L.GlobalVariable <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                      <*> $$(qqExpM x5) <*> $$(qqExpM x6) <*> $$(qqExpM x7) <*> $$(qqExpM x8)+                      <*> $$(qqExpM x9) <*> $$(qqExpM xA) <*> $$(qqExpM xB)||]+qqGlobalE (A.GlobalAlias x1 x2 x3 x4 x5) =+  [||L.GlobalAlias <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                   <*> $$(qqExpM x5)||]+qqGlobalE (A.Function x1 x2 x3 x4 x5 x6 x7 x8 x9 xA xB xC) =+  [||L.Function <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                <*> $$(qqExpM x5) <*> $$(qqExpM x6) <*> $$(qqExpM x7) <*> $$(qqExpM x8)+                <*> $$(qqExpM x9) <*> $$(qqExpM xA) <*> $$(qqExpM xB) <*> toSSA `fmap` $$(qqExpM xC)||]++qqParameterListE :: Conversion [A.Parameter] [L.Parameter]+qqParameterListE [] = [||pure []||]+qqParameterListE (A.AntiParameterList v : defs) =+    [||(++) <$> $$(unsafeTExpCoerce $ antiVarE v) <*> $$(qqExpM defs)||]+qqParameterListE (def : defs) =+    [||(:) <$> $$(qqExpM def) <*> $$(qqExpM defs)||]++qqParameterE :: Conversion A.Parameter L.Parameter+qqParameterE (A.Parameter x1 x2 x3) =+  [||L.Parameter <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3)||]+qqParameterE (A.AntiParameter s) =+  unsafeTExpCoerce $ antiVarE s+qqParameterE a@(A.AntiParameterList _s) =+  error $ "Internal Error: unexpected antiquote " ++ show a++qqLandingPadClauseE :: Conversion A.LandingPadClause L.LandingPadClause+qqLandingPadClauseE (A.Catch x1) =+  [||L.Catch <$> $$(qqExpM x1)||]+qqLandingPadClauseE (A.Filter x1) =+  [||L.Filter <$> $$(qqExpM x1)||]++qqFastMathFlagsE :: Conversion A.FastMathFlags L.FastMathFlags+qqFastMathFlagsE A.NoFastMathFlags =+  [||pure L.NoFastMathFlags||]+qqFastMathFlagsE A.UnsafeAlgebra =+  [||pure L.UnsafeAlgebra||]+qqFastMathFlagsE (A.FastMathFlags x1 x2 x3 x4) =+  [||L.FastMathFlags <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)||]++qqInlineAssemblyE :: Conversion A.InlineAssembly L.InlineAssembly+qqInlineAssemblyE (A.InlineAssembly x1 x2 x3 x4 x5 x6) =+  [||L.InlineAssembly <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                      <*> $$(qqExpM x5) <*> $$(qqExpM x6)||]++qqInstructionE :: Conversion A.Instruction (Either L.Instruction L.Terminator)+qqInstructionE (A.Add x1 x2 x3 x4 x5) =+  [||Left <$> (L.Add <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5))||]+qqInstructionE (A.FAdd x1 x2 x3 x4) =+  [||Left <$> (L.FAdd <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Sub x1 x2 x3 x4 x5) =+  [||Left <$> (L.Sub <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5))||]+qqInstructionE (A.FSub x1 x2 x3 x4) =+  [||Left <$> (L.FSub <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Mul x1 x2 x3 x4 x5) =+  [||Left <$> (L.Mul <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5))||]+qqInstructionE (A.FMul x1 x2 x3 x4) =+  [||Left <$> (L.FMul <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.UDiv x1 x2 x3 x4) =+  [||Left <$> (L.UDiv <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.SDiv x1 x2 x3 x4) =+  [||Left <$> (L.SDiv <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.FDiv x1 x2 x3 x4) =+  [||Left <$> (L.FDiv <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.URem x1 x2 x3) =+  [||Left <$> (L.URem <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.SRem x1 x2 x3) =+  [||Left <$> (L.SRem <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.FRem x1 x2 x3 x4) =+  [||Left <$> (L.FRem <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Shl x1 x2 x3 x4 x5) =+  [||Left <$> (L.Shl <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5))||]+qqInstructionE (A.LShr x1 x2 x3 x4) =+  [||Left <$> (L.LShr <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.AShr x1 x2 x3 x4) =+  [||Left <$> (L.AShr <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.And x1 x2 x3) =+  [||Left <$> (L.And <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.Or x1 x2 x3) =+  [||Left <$> (L.Or <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.Xor x1 x2 x3) =+  [||Left <$> (L.Xor <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.Alloca x1 x2 x3 x4) =+  [||Left <$> (L.Alloca <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Load x1 x2 x3 x4 x5) =+  [||Left <$> (L.Load <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5))||]+qqInstructionE (A.Store x1 x2 x3 x4 x5 x6) =+  [||Left <$> (L.Store <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5)+             <*> $$(qqExpM x6))||]+qqInstructionE (A.GetElementPtr x1 x2 x3 x4) =+  [||Left <$> (L.GetElementPtr <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Fence x1 x2) =+  [||Left <$> (L.Fence <$> $$(qqExpM x1) <*> $$(qqExpM x2))||]+qqInstructionE (A.CmpXchg x1 x2 x3 x4 x5 x6) =+  [||Left <$> (L.CmpXchg <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5)+               <*> $$(qqExpM x6))||]+qqInstructionE (A.AtomicRMW x1 x2 x3 x4 x5 x6) =+  [||Left <$> (L.AtomicRMW <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                 <*> $$(qqExpM x5) <*> $$(qqExpM x6))||]+qqInstructionE (A.Trunc x1 x2 x3) =+  [||Left <$> (L.Trunc <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.ZExt x1 x2 x3) =+  [||Left <$> (L.ZExt <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.SExt x1 x2 x3) =+  [||Left <$> (L.SExt <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.FPToUI x1 x2 x3) =+  [||Left <$> (L.FPToUI <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.FPToSI x1 x2 x3) =+  [||Left <$> (L.FPToSI <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.UIToFP x1 x2 x3) =+  [||Left <$> (L.UIToFP <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.SIToFP x1 x2 x3) =+  [||Left <$> (L.SIToFP <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.FPTrunc x1 x2 x3) =+  [||Left <$> (L.FPTrunc <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.FPExt x1 x2 x3) =+  [||Left <$> (L.FPExt <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.PtrToInt x1 x2 x3) =+  [||Left <$> (L.PtrToInt <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.IntToPtr x1 x2 x3) =+  [||Left <$> (L.IntToPtr <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.BitCast x1 x2 x3) =+  [||Left <$> (L.BitCast <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.AddrSpaceCast x1 x2 x3) =+  [||Left <$> (L.AddrSpaceCast <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.ICmp x1 x2 x3 x4) =+  [||Left <$> (L.ICmp <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.FCmp x1 x2 x3 x4) =+  [||Left <$> (L.FCmp <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Phi x1 x2 x3) =+  [||Left <$> (L.Phi <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.Call x1 x2 x3 x4 x5 x6 x7) =+  [||Left <$> (L.Call <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5)+            <*> $$(qqExpM x6) <*> $$(qqExpM x7))||]+qqInstructionE (A.Select x1 x2 x3 x4) =+  [||Left <$> (L.Select <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.VAArg x1 x2 x3) =+  [||Left <$> (L.VAArg <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.ExtractElement x1 x2 x3) =+  [||Left <$> (L.ExtractElement <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.InsertElement x1 x2 x3 x4) =+  [||Left <$> (L.InsertElement <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.ShuffleVector x1 x2 x3 x4) =+  [||Left <$> (L.ShuffleVector <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.ExtractValue x1 x2 x3) =+  [||Left <$> (L.ExtractValue <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.InsertValue x1 x2 x3 x4) =+  [||Left <$> (L.InsertValue <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.LandingPad x1 x2 x3 x4 x5) =+  [||Left <$> (L.LandingPad <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                  <*> $$(qqExpM x5))||]+qqInstructionE (A.OperandInstruction x1) =+  [||do x1' <- $$(qqExpM x1)+        let true = L.ConstantOperand $ L.Int 1 1+        return $ Left $ L.Select true x1' x1' []||]+qqInstructionE (A.AntiInstruction s) =+  unsafeTExpCoerce $ antiVarE s+qqInstructionE (A.Ret x1 x2) =+  [||Right <$> (L.Ret <$> $$(qqExpM x1) <*> $$(qqExpM x2))||]+qqInstructionE (A.CondBr x1 x2 x3 x4) =+  [||Right <$> (L.CondBr <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.Br x1 x2) =+  [||Right <$> (L.Br <$> $$(qqExpM x1) <*> $$(qqExpM x2))||]+qqInstructionE (A.Switch x1 x2 x3 x4) =+  [||Right <$> (L.Switch <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4))||]+qqInstructionE (A.IndirectBr x1 x2 x3) =+  [||Right <$> (L.IndirectBr <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3))||]+qqInstructionE (A.Invoke x1 x2 x3 x4 x5 x6 x7 x8) =+  [||Right <$> (L.Invoke <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4) <*> $$(qqExpM x5)+              <*> $$(qqExpM x6) <*> $$(qqExpM x7) <*> $$(qqExpM x8))||]+qqInstructionE (A.Resume x1 x2) =+  [||Right <$> (L.Resume <$> $$(qqExpM x1) <*> $$(qqExpM x2))||]+qqInstructionE (A.Unreachable x1) =+  [||Right <$> (L.Unreachable <$> $$(qqExpM x1))||]++qqLabeledInstructionListE :: Conversion [A.LabeledInstruction] [L.BasicBlock]+qqLabeledInstructionListE [] =+  [||pure []||]+qqLabeledInstructionListE (x:xs) =+  [||let nextLabel :: L.Name+         nextLabel = L.Name "nextblock"++         jumpNext :: L.BasicBlock -> Bool+         jumpNext (L.BasicBlock _ _ t) =+           case t of+             _ L.:= L.Br l2 _ | l2 == nextLabel -> True+             L.Do (L.Br l2 _) | l2 == nextLabel -> True+             _                                   -> False++         replacePhiFroms :: [(L.Name,L.Name)] -> L.BasicBlock -> L.BasicBlock+         replacePhiFroms labels (L.BasicBlock n is t) =+           L.BasicBlock n (map (replacePhiFrom labels) is) t++         replacePhiFrom :: [(L.Name,L.Name)] -> L.Named L.Instruction -> L.Named L.Instruction+         replacePhiFrom names (n L.:= phi@L.Phi{}) =+           n L.:= replacePhiFrom' names phi+         replacePhiFrom names (L.Do phi@L.Phi{}) =+           L.Do $ replacePhiFrom' names phi+         replacePhiFrom _ named = named+         +         replacePhiFrom' :: [(L.Name,L.Name)] -> L.Instruction -> L.Instruction+         replacePhiFrom' names phi@L.Phi{} =+           phi{ L.incomingValues =+                   [ (op,n') | (op,n) <- L.incomingValues phi,+                               let n' = maybe n id (lookup n names)] }+         replacePhiFrom' _ _ =+           error "this should never happen"++         fuse :: L.BasicBlock -> L.BasicBlock -> Writer [(L.Name,L.Name)] L.BasicBlock+         fuse (L.BasicBlock n1 i1 _t1) (L.BasicBlock n2 i2 t2) = do+           tell [(n2,n1)]+           return $ L.BasicBlock n1 (i1++i2) t2+         +         fuseBlocks' :: [L.BasicBlock] -> Writer [(L.Name,L.Name)] [L.BasicBlock]+         fuseBlocks' bbs@[] = return bbs+         fuseBlocks' bbs@[_] = return bbs+         fuseBlocks' (bb1:bbs@(bb2:bbs')) =+           case jumpNext bb1 of+             True  -> do+               fused <- fuse bb1 bb2+               fuseBlocks' (fused:bbs')+             False -> do+               bbs_ <- fuseBlocks' bbs+               return $ bb1 : bbs_++         fuseBlocks :: [L.BasicBlock] -> [L.BasicBlock]+         fuseBlocks bbs =+           let (bbs',labels) = runWriter $ fuseBlocks' bbs+           in map (replacePhiFroms labels) bbs'++     in fuseBlocks <$> ((++) <$> $$(qqExpM x) <*> $$(qqExpM xs))||]++qqLabeledInstructionE :: forall m. Conversion' m A.LabeledInstruction [L.BasicBlock]+qqLabeledInstructionE (A.Labeled label instr) =+  [||do label' <- $$(qqExpM label)+        L.BasicBlock _ is t:bbs <- $$(qqExpM instr)+        return $ L.BasicBlock label' is t:bbs||]+qqLabeledInstructionE (A.ForLoop label iterType iterName direction from to step body) =+  [||do+    label' <- $$(qqExpM label)+    body' <- $$(qqExpM body :: TExpQ (m [L.BasicBlock]))+    iterName' <- $$(qqExpM iterName :: TExpQ (m L.Name))+    iterType' <- $$(qqExpM iterType :: TExpQ (m L.Type))+    from' <- $$(qqExpM from :: TExpQ (m L.Operand))+    to' <- $$(qqExpM to)+    step' <- $$(qqExpM step :: TExpQ (m L.Operand))++    let labelString = case label' of+                        L.Name s -> s+                        L.UnName n -> "num"++show n+        cond = L.Name (labelString ++ ".cond")+        labelHead = L.Name (labelString ++ ".head")+        labelEnd = L.Name (labelString ++ ".end")+        labelLast = L.Name (labelString ++ ".last")++        iter = L.LocalReference iterType' iterName'+        newIterInstr = case direction of+          A.Up -> [ iterName' L.:= L.Add True True iter step' [] ]+          A.Down -> [ iterName' L.:= L.Sub True True iter step' [] ]+        preInstrs = case direction of+            A.Up ->+              [ cond L.:= L.ICmp LI.SLT iter to' [] ]+            A.Down ->+              [ cond L.:= L.ICmp LI.SGT iter to' [] ]+        branchTo l = case body'' of+          [] -> error "empty body of for-loop"+          (L.BasicBlock bodyLabel _ _:_) -> L.Do (L.CondBr (L.LocalReference (L.IntegerType 1) cond) bodyLabel l [])+        retTerm = L.Do (L.Br (L.Name "nextblock") [])+        true = L.ConstantOperand $ L.Int 1 1+        initIter = iterName' L.:= L.Select true from' from' []++        (pre,post) =+                ([L.BasicBlock label' [initIter] (L.Do (L.Br labelHead [])), L.BasicBlock labelHead preInstrs (branchTo labelEnd)]+                ,[L.BasicBlock labelEnd [] retTerm])+        body'' = body' ++ [L.BasicBlock labelLast newIterInstr (L.Do (L.Br labelHead []))]++    return (pre ++ body'' ++ post)+  ||]+qqLabeledInstructionE (A.ITE label cond then_body else_body) =+  [||do+    label' <- $$(qqExpM label)+    cond' <- $$(qqExpM cond)+    then_body' <- $$(qqExpM then_body)+    else_body' <- $$(qqExpM else_body)+    let labelString = case label' of+          L.Name n -> n+          L.UnName n -> show n+        thenLabel = L.Name (labelString ++ ".then")+        thenLastLabel = L.Name (labelString ++ ".then.last")+        elseLabel = L.Name (labelString ++ ".else")+        elseLastLabel = L.Name (labelString ++ ".else.last")+        endLabel = L.Name (labelString ++ ".end")+        headLabel = L.Name (labelString ++ ".head")++        brEnd l = [L.BasicBlock l [] (L.Do (L.Br endLabel []))]+        pre = [L.BasicBlock label' [] (L.Do (L.Br headLabel []))+              ,L.BasicBlock headLabel [] (L.Do (L.CondBr cond' thenLabel elseLabel []))]+        brNext l = [L.BasicBlock l [] (L.Do (L.Br (L.Name "nextblock") []))]+        end = brNext endLabel+        then_body'' = brNext thenLabel ++ then_body' ++ brEnd thenLastLabel+        else_body'' = brNext elseLabel ++ else_body' ++ brEnd elseLastLabel+    return (pre ++ then_body'' ++ else_body'' ++ end)+  ||]+qqLabeledInstructionE (A.While label cond body) =+  [||do+    label' <- $$(qqExpM label)+    cond' <- $$(qqExpM cond)+    body' <- $$(qqExpM body)+    let labelString = case label' of+          L.Name n -> n+          L.UnName n -> show n+        bodyLabel = L.Name (labelString ++ ".body")+        bodyLastLabel = L.Name (labelString ++ ".body.last")+        endLabel = L.Name (labelString ++ ".end")+        headLabel = L.Name (labelString ++ ".head")++        pre = [L.BasicBlock label' [] (L.Do (L.Br headLabel []))+              ,L.BasicBlock headLabel [] (L.Do (L.CondBr cond' bodyLabel endLabel []))]+        brNext l = [L.BasicBlock l [] (L.Do (L.Br (L.Name "nextblock") []))]+        end = brNext endLabel+        brTop = [L.BasicBlock bodyLastLabel [] (L.Do (L.Br headLabel []))]+        body'' = brNext bodyLabel ++ body' ++ brTop+    return (pre ++ body'' ++ end)+  ||]++qqNamedInstructionE :: Conversion A.NamedInstruction [L.BasicBlock]+qqNamedInstructionE (x1 A.:= x2) =+  [||do x1' <- $$(qqExpM x1)+        x2' <- $$(qqExpM x2)+        n <- newVariable+        case x2' of+          Left ins -> return [L.BasicBlock n [x1' L.:= ins] (L.Do $ L.Br (L.Name "nextblock") [])]+          Right term -> return [L.BasicBlock n [] (x1' L.:= term)]||]+qqNamedInstructionE (A.Do x2) =+  [||do x2' <- $$(qqExpM x2)+        n <- newVariable+        case x2' of+          Left ins -> return [L.BasicBlock n [L.Do ins] (L.Do $ L.Br (L.Name "nextblock") [])]+          Right term -> return [L.BasicBlock n [] (L.Do term)]||]+qqNamedInstructionE (A.AntiInstructionList s) =+  unsafeTExpCoerce $ antiVarE s+qqNamedInstructionE (A.AntiBasicBlock v)+  = [||(:[]) <$> $$(unsafeTExpCoerce $ antiVarE v)||]+qqNamedInstructionE (A.AntiBasicBlockList v)+  = unsafeTExpCoerce $ [|toBasicBlockList $(antiVarE v)|]++qqMetadataNodeIDE :: Conversion A.MetadataNodeID L.MetadataNodeID+qqMetadataNodeIDE (A.MetadataNodeID x1) =+  [||L.MetadataNodeID <$> $$(qqExpM x1)||]++qqMetadataNodeE :: Conversion A.MetadataNode L.MetadataNode+qqMetadataNodeE (A.MetadataNode x1) =+  [||L.MetadataNode <$> $$(qqExpM x1)||]+qqMetadataNodeE (A.MetadataNodeReference x1) =+  [||L.MetadataNodeReference <$> $$(qqExpM x1)||]++qqOperandE :: Conversion A.Operand L.Operand+qqOperandE (A.LocalReference x1 x2) =+  [||L.LocalReference <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqOperandE (A.ConstantOperand x1) =+  [||L.ConstantOperand <$> $$(qqExpM x1)||]+qqOperandE (A.MetadataStringOperand x1) =+  [||L.MetadataStringOperand <$> $$(qqExpM x1)||]+qqOperandE (A.MetadataNodeOperand x1) =+  [||L.MetadataNodeOperand <$> $$(qqExpM x1)||]+qqOperandE (A.AntiOperand s) =+  [||$$(unsafeTExpCoerce $ antiVarE s)||]++qqConstantE :: Conversion A.Constant L.Constant+qqConstantE (A.Int x1 x2) =+  [||L.Int <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqConstantE (A.IntAntiBs x1 x2) =+  [||let typeBits (L.IntegerType bs) = return bs+         typeBits t                  = fail $ "unexpected type: " ++ show t+     in L.Int <$> ($$(unsafeTExpCoerce (antiVarE x1)) >>= typeBits) <*> $$(qqExpM x2)||]+qqConstantE (A.Float x1) =+  [||L.Float <$> $$(qqExpM x1)||]+qqConstantE (A.Null x1) =+  [||L.Null <$> $$(qqExpM x1)||]+qqConstantE (A.Struct x1 x2 x3) =+  [||L.Struct <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3)||]+qqConstantE (A.Array x1 x2) =+  [||L.Array <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqConstantE (A.Vector x1) =+  [||L.Vector <$> $$(qqExpM x1)||]+qqConstantE (A.Undef x1) =+  [||L.Undef <$> $$(qqExpM x1)||]+qqConstantE (A.BlockAddress x1 x2) =+  [||L.BlockAddress <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqConstantE (A.GlobalReference x1 x2) =+  [||L.GlobalReference <$> $$(qqExpM x1)<*> $$(qqExpM x2)||]+qqConstantE (A.AntiConstant s) =+  unsafeTExpCoerce [|$(antiVarE s) >>= (return . toConstant)|]++qqNameE :: Conversion A.Name L.Name+qqNameE (A.Name x1) =+  [||L.Name <$> $$(qqExpM x1)||]+qqNameE (A.UnName x1) =+  [||L.UnName <$> $$(qqExpM x1)||]+qqNameE A.NeedsName = do+  n <- runIO $ atomicModifyIORef' counter $ \n -> (n+1,n)+  [||pure $ L.Name $ "n" ++ show (n :: Int)||]+qqNameE (A.AntiName s) =+  unsafeTExpCoerce [|$(antiVarE s) >>= return . toName|]++qqTypeE :: Conversion A.Type L.Type+qqTypeE A.VoidType =+  [||pure L.VoidType||]+qqTypeE (A.IntegerType x1) =+  [||L.IntegerType <$> $$(qqExpM x1)||]+qqTypeE (A.PointerType x1 x2) =+  [||L.PointerType <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqTypeE (A.FloatingPointType x1 x2) =+  [||L.FloatingPointType <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqTypeE (A.FunctionType x1 x2 x3) =+  [||L.FunctionType <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3)||]+qqTypeE (A.VectorType x1 x2) =+  [||L.VectorType <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqTypeE (A.StructureType x1 x2) =+  [||L.StructureType <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqTypeE (A.ArrayType x1 x2) =+  [||L.ArrayType <$> $$(qqExpM x1) <*> $$(qqExpM x2)||]+qqTypeE (A.NamedTypeReference x1) =+  [||L.NamedTypeReference <$> $$(qqExpM x1)||]+qqTypeE A.MetadataType =+  [||pure L.MetadataType||]+qqTypeE (A.AntiType s) =+  [||$$(unsafeTExpCoerce $ antiVarE s)||]++qqDataLayoutE :: Conversion A.DataLayout L.DataLayout+qqDataLayoutE (A.DataLayout x1 x2 x3 x4 x5) =+  [||L.DataLayout <$> $$(qqExpM x1) <*> $$(qqExpM x2) <*> $$(qqExpM x3) <*> $$(qqExpM x4)+                  <*> $$(qqExpM x5)||]+qqDataLayoutE (A.AntiDataLayout s) =+  unsafeTExpCoerce $ antiVarE s++qqTargetTripleE :: Conversion A.TargetTriple (Maybe String)+qqTargetTripleE A.NoTargetTriple =+  [||pure Nothing||]+qqTargetTripleE (A.TargetTriple v) =+  [||Just <$> $$(qqExpM v)||]+qqTargetTripleE (A.AntiTargetTriple v) =+  unsafeTExpCoerce [|$(antiVarE v) >>= return . toTargetTriple|]++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++newtype TQuasiQuoter a = TQuasiQuoter { unTQuasiQuoter :: QuasiQuoter }++quasiquote :: forall a b. (Data a, QQExp a b)+           => [A.Extensions]+           -> P.P a+           -> TQuasiQuoter b+quasiquote exts p = TQuasiQuoter $+  QuasiQuoter { quoteExp  = parse exts p >=> unTypeQ . (qqExp :: a -> TExpQ b)+              , quotePat  = fail "LLVM pattern quasiquoter undefined"+              , quoteType = fail "LLVM type quasiquoter undefined"+              , quoteDec  = fail "LLVM declaration quasiquoter undefined"+              }++quasiquoteM :: forall a b m. (Data a, QQExp a b, CodeGenMonad m)+           => [A.Extensions]+           -> P.P a+           -> TQuasiQuoter (m b)+quasiquoteM exts p = TQuasiQuoter $+  QuasiQuoter { quoteExp  = parse exts p >=> unTypeQ . (qqExpM :: Conversion' m a b)+              , quotePat  = fail "LLVM monadic pattern quasiquoter undefined"+              , quoteType = fail "LLVM type quasiquoter undefined"+              , quoteDec  = fail "LLVM declaration quasiquoter undefined"+              }

@@ -1,30 +1,63 @@ module LLVM.General.Quote.LLVM (     llmod,     lldef,-    llbb,-    lli+    llg,+    -- llbb,+    -- llbbs,+    lli,+    llmodM,+    lldefM,+    llgM,+    -- llbbM,+    -- llbbsM,+    lliM   ) 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 LLVM.General.Quote.Base (CodeGen, quasiquote, quasiquoteM, TQuasiQuoter(unTQuasiQuoter)) import Language.Haskell.TH.Quote (QuasiQuoter) +import qualified LLVM.General.AST as L+ exts :: [A.Extensions] exts = [A.Loops]  -- |Quasiquoter for 'LLVM.General.AST.Module' llmod :: QuasiQuoter-llmod = quasiquote exts P.parseModule+llmod = unTQuasiQuoter+          (quasiquote exts P.parseModule :: TQuasiQuoter L.Module)  -- |Quasiquoter for 'LLVM.General.AST.Definition' lldef :: QuasiQuoter-lldef = quasiquote exts P.parseDefinition+lldef = unTQuasiQuoter+          (quasiquote exts P.parseDefinition :: TQuasiQuoter L.Definition) --- |Quasiquoter for 'LLVM.General.AST.BasicBlock'-llbb :: QuasiQuoter-llbb = quasiquote exts P.parseBasicBlock+-- |Quasiquoter for 'LLVM.General.AST.Global'+llg :: QuasiQuoter+llg = unTQuasiQuoter (quasiquote exts P.parseGlobal :: TQuasiQuoter L.Global)  -- |Quasiquoter for 'LLVM.General.AST.Instruction.Instruction' lli :: QuasiQuoter-lli = quasiquote exts P.parseInstruction+lli = unTQuasiQuoter+        (quasiquote exts P.parseInstruction :: TQuasiQuoter L.Instruction)+++-- |Quasiquoter for 'LLVM.General.AST.Module'+llmodM :: QuasiQuoter+llmodM = unTQuasiQuoter+          (quasiquoteM exts P.parseModule :: TQuasiQuoter (CodeGen L.Module))++-- |Quasiquoter for 'LLVM.General.AST.Definition'+lldefM :: QuasiQuoter+lldefM = unTQuasiQuoter+          (quasiquoteM exts P.parseDefinition :: TQuasiQuoter (CodeGen L.Definition))++-- |Quasiquoter for 'LLVM.General.AST.Global'+llgM :: QuasiQuoter+llgM = unTQuasiQuoter (quasiquoteM exts P.parseGlobal :: TQuasiQuoter (CodeGen L.Global))++-- |Quasiquoter for 'LLVM.General.AST.Instruction.Instruction'+lliM :: QuasiQuoter+lliM = unTQuasiQuoter+        (quasiquoteM exts P.parseInstruction :: TQuasiQuoter (CodeGen L.Instruction))

@@ -1,7 +1,5 @@ module LLVM.General.Quote.Parser (-    module LLVM.General.Quote.Parser.Lexer,-    module LLVM.General.Quote.Parser.Tokens,-    module LLVM.General.Quote.Parser.Monad,+    module P,     parse   ) where @@ -10,9 +8,9 @@ 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+import LLVM.General.Quote.Parser.Lexer as P+import LLVM.General.Quote.Parser.Tokens as P+import LLVM.General.Quote.Parser.Monad as P  parse :: [Extensions]       -> P a

@@ -64,22 +64,40 @@  <0> {  "$dl:"           / { allowAnti } { lexAnti Tanti_dl }+ "$dlM:"           / { allowAnti } { lexAntiM Tanti_dl }  "$tt:"           / { allowAnti } { lexAnti Tanti_tt }+ "$ttM:"           / { allowAnti } { lexAntiM Tanti_tt }  "$def:"          / { allowAnti } { lexAnti Tanti_def }+ "$defM:"          / { allowAnti } { lexAntiM Tanti_def }  "$defs:"         / { allowAnti } { lexAnti Tanti_defs }+ "$defsM:"         / { allowAnti } { lexAntiM Tanti_defs }  "$bb:"           / { allowAnti } { lexAnti Tanti_bb }+ "$bbM:"           / { allowAnti } { lexAntiM Tanti_bb }  "$bbs:"          / { allowAnti } { lexAnti Tanti_bbs }+ "$bbsM:"          / { allowAnti } { lexAntiM Tanti_bbs }  "$instr:"        / { allowAnti } { lexAnti Tanti_instr }+ "$instrM:"        / { allowAnti } { lexAntiM Tanti_instr }+ "$instrs:"       / { allowAnti } { lexAnti Tanti_instrs }+ "$instrsM:"       / { allowAnti } { lexAntiM Tanti_instrs }+ "$type:"         / { allowAnti } { lexAnti Tanti_type }+ "$typeM:"         / { allowAnti } { lexAntiM Tanti_type }+ "$opr:"          / { allowAnti } { lexAnti Tanti_opr }+ "$oprM:"          / { allowAnti } { lexAntiM Tanti_opr }  "$const:"        / { allowAnti } { lexAnti Tanti_const }+ "$constM:"        / { allowAnti } { lexAntiM Tanti_const }  "$id:"           / { allowAnti } { lexAnti Tanti_id }+ "$idM:"           / { allowAnti } { lexAntiM Tanti_id }  "$gid:"          / { allowAnti } { lexAnti Tanti_gid }+ "$gidM:"          / { allowAnti } { lexAntiM Tanti_gid }  "$param:"        / { allowAnti } { lexAnti Tanti_param }+ "$paramM:"        / { allowAnti } { lexAntiM Tanti_param }  "$params:"       / { allowAnti } { lexAnti Tanti_params }+ "$paramsM:"       / { allowAnti } { lexAntiM Tanti_params } }  <0> {  ";" .* ;- $whitechar+          ; + $whitechar+          ;   @identifier { identifier }  @jumpLabel { jumpLabel }@@ -179,8 +197,11 @@                       lexString (c' : s)           _    -> lexString (c : s) -lexAnti ::(String -> Token) ->  Action-lexAnti antiTok beg end = do+lexAnti :: (String -> Token) -> Action+lexAnti antiTok = lexAntiM (antiTok . \s -> "return (" ++ s ++ ")")++lexAntiM :: (String -> Token) -> Action+lexAntiM antiTok beg end = do     c <- nextChar     s <- case c of            '('                 -> lexExpression 0 ""@@ -374,4 +395,3 @@       AlexSkip end _       -> setInput end >> lexToken       AlexToken end _len t  -> setInput end >> t beg end }-  

@@ -58,8 +58,8 @@   ) where  import Control.Applicative (Applicative(..))-import Control.Monad.Exception-import Control.Monad.Identity+import Control.Monad.Except+import Control.Exception (SomeException, Exception, toException) import Control.Monad.State import Data.Bits import qualified Data.ByteString.Char8 as B@@ -101,7 +101,7 @@ newtype P a = P { runP :: PState -> Either SomeException (a, PState) }  instance Functor P where-    fmap f x = x >>= return . f+    fmap = liftM  instance Applicative P where     pure  = return@@ -129,17 +129,16 @@     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 ->+instance MonadError SomeException P where+    throwError e = P $ \_ -> Left e+    m `catchError` h = P $ \s ->         case runP m s of-          Left e ->-              case fromException e of-                Just e'  -> runP (h e') s-                Nothing  -> Left e+          Left e -> runP (h e) s           Right (a, s')  -> Right (a, s') +throw :: Exception e => e -> P a+throw e = P $ \_ -> Left (toException e)+ evalP :: P a -> PState -> Either SomeException a evalP comp st =     case runP comp st of@@ -239,8 +238,10 @@     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)+expectedAt tok@(L loc _) alts after =+    parserError+      (locStart loc)+      (text "expected" <+> pprAlts alts <+> pprGot tok <> pprAfter after)   where     pprAlts :: [String] -> Doc     pprAlts []        = empty@@ -265,13 +266,13 @@  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-                                     })+  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 =

@@ -5,7 +5,7 @@                       when,                       unless,                       liftM)-import Control.Monad.Exception+import Control.Monad.Except import Data.List (intersperse) import Data.List.Split import Data.Loc@@ -25,9 +25,14 @@ 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.InlineAssembly as A ( Dialect(..) )+import qualified LLVM.General.AST.Instruction as A ( Atomicity(..), MemoryOrdering(..) ) import qualified LLVM.General.AST.IntegerPredicate as AI import qualified LLVM.General.AST.FloatingPointPredicate as AF import qualified LLVM.General.AST.RMWOperation as AR+import qualified LLVM.General.AST.Type as A ( FloatingPointFormat(..) )+import qualified LLVM.General.AST.DataLayout as A+  ( Endianness(..), AlignmentInfo(..), AlignType(..) ) }  %token@@ -147,12 +152,14 @@  'arcp'             { L _ T.Tarcp }  'fast'             { L _ T.Tfast }  'to'               { L _ T.Tto }+ 'downto'           { L _ T.Tdownto }  'nsw'              { L _ T.Tnsw }  'nuw'              { L _ T.Tnuw }  'target'           { L _ T.Ttarget }  'datalayout'       { L _ T.Tdatalayout }  'triple'           { L _ T.Ttriple }  'define'           { L _ T.Tdefine }+ 'declare'          { L _ T.Tdeclare }  'void'             { L _ T.Tvoid }  'half'             { L _ T.Thalf }  'float'            { L _ T.Tfloat }@@ -240,8 +247,10 @@   'for'              { L _ T.Tfor }  'in'               { L _ T.Tin }- 'with'             { L _ T.Twith }- 'as'               { L _ T.Tas }+ 'step'             { L _ T.Tstep }+ 'if'               { L _ T.Tif }+ 'else'             { L _ T.Telse }+ 'while'            { L _ T.Twhile }   ANTI_DL            { L _ (T.Tanti_dl $$) }  ANTI_TT            { L _ (T.Tanti_tt $$) }@@ -250,6 +259,9 @@  ANTI_BB            { L _ (T.Tanti_bb $$) }  ANTI_BBS           { L _ (T.Tanti_bbs $$) }  ANTI_INSTR         { L _ (T.Tanti_instr $$) }+ ANTI_INSTRS        { L _ (T.Tanti_instrs $$) }+ ANTI_TYPE          { L _ (T.Tanti_type $$) }+ ANTI_OPR           { L _ (T.Tanti_opr $$) }  ANTI_CONST         { L _ (T.Tanti_const $$) }  ANTI_ID            { L _ (T.Tanti_id $$) }  ANTI_GID           { L _ (T.Tanti_gid $$) }@@ -263,7 +275,7 @@  %name parseModule       module %name parseDefinition   definition-%name parseBasicBlock   basicBlock+%name parseGlobal       global %name parseInstruction  instruction  %%@@ -290,7 +302,7 @@   | 'blockaddress' '(' globalName ',' name ')'                           { \_ -> A.BlockAddress $3 $5 }   | 'undef'               { A.Undef }-  | globalName            { \_ -> A.GlobalReference $1 }+  | globalName            { \t -> A.GlobalReference t $1 }   | ANTI_CONST            { \_ -> A.AntiConstant $1 }  tConstant :: { A.Constant }@@ -316,9 +328,10 @@ operand :: { A.Type -> A.Operand } operand :     constant            { A.ConstantOperand . $1 }-  | name                { \_ -> A.LocalReference $1 }+  | name                { \t -> A.LocalReference t $1 }   | '!' STRING          { \A.MetadataType -> A.MetadataStringOperand $2 }   | metadataNode        { \A.MetadataType -> A.MetadataNodeOperand $1 }+  | ANTI_OPR            { \_ -> A.AntiOperand $1 }  mOperand :: { Maybe A.Operand } mOperand :@@ -345,18 +358,32 @@     {- empty  -}        { False }   | 'nsw'               { True } -fmflag :: { () }-fmflag :-    'nnan'       { () }-  | 'ninf'       { () }-  | 'nsz'        { () }-  | 'arcp'       { () }-  | 'fast'       { () }+nnan :: { Bool }+nnan :+    {- empty -}    { False }+  | 'nnan'         { True } -fmflags :: { () }+ninf :: { Bool }+ninf :+    {- empty -}    { False }+  | 'ninf'         { True }++nsz :: { Bool }+nsz :+    {- empty -}    { False }+  | 'nsz'          { True }++arcp :: { Bool }+arcp :+    {- empty -}    { False }+  | 'arcp'         { True }++fmflags :: { A.FastMathFlags } fmflags :-    {- empty -}         { () }-  | fmflags fmflag      {% fail "fast-math flags are not supported at this time" }+    nnan ninf nsz arcp  { if not (or [$1, $2, $3, $4])+                            then A.NoFastMathFlags+			    else A.FastMathFlags $1 $2 $3 $4 }+  | 'fast'              { A.UnsafeAlgebra }  volatile :: { Bool } volatile :@@ -393,21 +420,21 @@  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 }  +      '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 }@@ -515,7 +542,7 @@ callableOperand :: { [A.Type] -> A.CallableOperand } callableOperand :     type operand       { \ts -> Right ($2 (A.FunctionType $1 ts False)) }-  | type 'asm' sideeffect alignstack dialect STRING ',' STRING  +  | type 'asm' sideeffect alignstack dialect STRING ',' STRING                        { \ts -> Left (A.InlineAssembly (A.FunctionType $1 ts False) $6 $8 $3 $4 $5) }  tail :: { Bool }@@ -532,6 +559,24 @@     idx            { RCons $1 RNil }   | idxs ',' idx   { RCons $3 $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 }+ metadataNodeID :: { A.MetadataNodeID } metadataNodeID :     UNNAMED_META       { A.MetadataNodeID $1 }@@ -559,17 +604,17 @@ 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) }+  | 'fadd' fmflags type operand ',' operand { A.FAdd $2 ($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) }+  | 'fsub' fmflags type operand ',' operand { A.FSub $2 ($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) }+  | 'fmul' fmflags type operand ',' operand { A.FMul $2 ($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) }+  | 'fdiv' fmflags type operand ',' operand { A.FDiv $2 ($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) }+  | 'frem' fmflags type operand ',' operand { A.FRem $2 ($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) }@@ -579,9 +624,9 @@   | '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 +  | 'store' volatile tOperand ',' tOperand alignment                                             { A.Store $2 $5 $3 Nothing $6 }-  | 'store' 'atomic' volatile tOperand ',' tOperand atomicity alignment +  | '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) }@@ -589,7 +634,7 @@   | '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 +                                            {% 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@@ -610,7 +655,7 @@   | '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+  | tail 'call' cconv parameterAttributes 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 }@@ -625,11 +670,25 @@                                             { A.InsertValue $2 $4 (rev $6) }   | 'landingpad' type 'personality' tOperand cleanup clauses                                             { A.LandingPad $2 $4 $5 (rev $6) }+  | '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 parameterAttributes 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 }   | ANTI_INSTR                              {\[] -> A.AntiInstruction $1 }  instruction :: { A.Instruction } instruction :-  instruction_ instructionMetadata   { $1 (rev $2) }+    instruction_ instructionMetadata   { $1 (rev $2) }+  | tOperand                           { A.OperandInstruction $1 }  name :: { A.Name } name :@@ -637,59 +696,36 @@   | UNNAMED_LOCAL   { A.UnName $1 }   | ANTI_ID         { A.AntiName $1 } -namedI :: { A.Named A.Instruction }+namedI :: { A.NamedInstruction } namedI :     instruction                     { A.Do $1 }   | name '=' instruction            { $1 A.:= $3 }+  | ANTI_BB+      { A.AntiBasicBlock $1 }+  | ANTI_BBS+      { A.AntiBasicBlockList $1 }+  | ANTI_INSTRS                     { A.AntiInstructionList $1 } -instructions :: { RevList (A.Named A.Instruction) } -instructions :-    {- empty -}                   { RNil }-  | instructions namedI           { RCons $2 $1 }+elseInstrs :: { [A.LabeledInstruction] }+elseInstrs :+    {- empty -}         { [] }+  | 'else' '{' instructions '}'+      { rev $3 } -destination :: { (A.Constant, A.Name) }-destination :-    tConstant ',' label    { ($1, $3) }+labeledI :: { A.LabeledInstruction }+labeledI :+    jumpLabel namedI                { A.Labeled $1 $2 }+  | jumpLabel 'for' type name 'in' operand direction operand mStep '{' instructions '}'+      { A.ForLoop $1 $3 $4 $7 ($6 $3) ($8 $3) ($9 $3) (rev $11) }+  | jumpLabel 'if' operand '{' instructions '}' elseInstrs+      { A.ITE $1 ($3 (A.IntegerType 1)) (rev $5) $7 }+  | jumpLabel 'while' operand '{' instructions '}'+      { A.While $1 ($3 (A.IntegerType 1)) (rev $5) } -destinations :: { RevList (A.Constant, A.Name) }-destinations :+instructions :: { RevList (A.LabeledInstruction) }+instructions :     {- 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) }+  | instructions labeledI         { RCons $2 $1 }  {------------------------------------------------------------------------------  -@@ -697,27 +733,20 @@  -  -----------------------------------------------------------------------------} -mLabel :: { Maybe A.Name }-mLabel :-    ',' 'label' name     { Just $3 }+mStep :: { A.Type -> A.Operand }+mStep :+    {- empty -}        { A.ConstantOperand . intConstant 1 }+  | 'step' operand     { $2 } -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 }+jumpLabel :: { A.Name }+jumpLabel :+    JUMPLABEL           { A.Name $1 }+  | {- empty -}         { A.NeedsName } -basicBlocks :: { RevList (A.BasicBlock) }-basicBlocks :-    {- empty -}             { RNil }-  | basicBlocks basicBlock  { RCons $2 $1 }+direction :: { A.Direction }+direction :+    'to'        { A.Up }+  | 'downto'    { A.Down }  {------------------------------------------------------------------------------  -@@ -750,6 +779,7 @@   | '[' INT 'x' type ']'      { A.ArrayType (fromIntegral $2) $4 }   | name                      { A.NamedTypeReference $1 }   | 'metadata'                { A.MetadataType }+  | ANTI_TYPE                 { A.AntiType $1 }  type :: { A.Type } type :@@ -808,18 +838,9 @@   | '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) }+    type parameterAttributes name { A.Parameter $1 $3 (rev $2) }   | ANTI_PARAM                    { A.AntiParameter $1 }   | ANTI_PARAMS                   { A.AntiParameterList $1 } @@ -833,9 +854,25 @@     {- empty -}                      { ([], False) }   | parameterList_                   { (rev $1, False) }   | '...'                            { ([], True) }-  | parameterList_ '...'             { (rev $1, True) }+  | parameterList_ ',' '...'         { (rev $1, True) } -fAttribute :: { A.FunctionAttribute }    +parameterD :: { A.Parameter }+parameterD :+    type parameterAttributes { A.Parameter $1 (A.UnName 0) (rev $2) }++parameterListD_ :: { RevList A.Parameter }+parameterListD_ :+    parameterD                       { RCons $1 RNil }+  | parameterListD_ ',' parameterD   { RCons $3 $1 }++parameterListD :: { ([A.Parameter], Bool) }+parameterListD :+    {- empty -}                      { ([], False) }+  | parameterListD_                  { (rev $1, False) }+  | '...'                            { ([], True) }+  | parameterListD_ ',' '...'        { (rev $1, True) }++fAttribute :: { A.FunctionAttribute } fAttribute :     'alignstack' '(' INT ')'         { A.StackAlignment (fromIntegral $3) }   | 'alwaysinline'                   { A.AlwaysInline }@@ -876,8 +913,10 @@  global :: { A.Global } global :-    'define' linkage visibility cconv pAttributes type globalName '(' parameterList ')' fAttributes section alignment gc '{' basicBlocks '}'+    'define' linkage visibility cconv parameterAttributes type globalName '(' parameterList ')' fAttributes section alignment gc '{' instructions '}'       { A.Function $2 $3 $4 (rev $5) $6 $7 $9 (rev $11) $12 $13 $14 (rev $16) }+  | 'declare' linkage visibility cconv parameterAttributes type globalName '(' parameterListD ')' alignment gc+      { A.Function $2 $3 $4 (rev $5) $6 $7 $9 [] Nothing $11 $12 [] }   | 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@@ -948,6 +987,8 @@ { intConstant :: Integer -> A.Type -> A.Constant intConstant n (A.IntegerType bs) = A.Int bs n+intConstant n (A.AntiType bs) = A.IntAntiBs bs n+intConstant n t = error $ "intConstant: unexpected type " ++ show t  floatConstant :: Rational -> A.Type -> A.Constant floatConstant x (A.FloatingPointType 32 _) = A.Float (A.Single (fromRational x))@@ -1014,7 +1055,6 @@     case sizes of       [] -> Nothing       xs -> Just $ S.fromList xs-  happyError :: L T.Token -> P a happyError (L loc t) =

@@ -198,6 +198,7 @@   | Tdatalayout   | Ttriple   | Tdefine+  | Tdeclare   -- Types   | Thalf   | Tfloat@@ -234,8 +235,11 @@   -- Loops   | Tfor   | Tin-  | Twith-  | Tas+  | Tstep+  | Tdownto+  | Tif+  | Telse+  | Twhile   -- Anti-Quotation   | Tanti_dl String   | Tanti_tt String@@ -244,6 +248,9 @@   | Tanti_bb String   | Tanti_bbs String   | Tanti_instr String+  | Tanti_instrs String+  | Tanti_type String+  | Tanti_opr String   | Tanti_const String   | Tanti_id String   | Tanti_gid String@@ -270,6 +277,9 @@   show (Tanti_bb _) = "ANTI_BB"   show (Tanti_bbs _) = "ANTI_BBS"   show (Tanti_instr _) = "ANTI_INSTR"+  show (Tanti_instrs _) = "ANTI_INSTRS"+  show (Tanti_type _) = "ANTI_TYPE"+  show (Tanti_opr _) = "ANTI_OPR"   show (Tanti_const _) = "ANTI_CONST"   show (Tanti_id _) = "ANTI_ID"   show (Tanti_gid _) = "ANTI_GID"@@ -387,6 +397,7 @@   show Tdatalayout = "datalayout"   show Ttriple = "triple"   show Tdefine = "define"+  show Tdeclare = "declare"   show Tvoid = "void"   show Thalf = "half"   show Tfloat = "float"@@ -471,15 +482,19 @@   show Ttail = "tail"   show Tfor = "for"   show Tin = "in"-  show Twith = "with"-  show Tas = "as"+  show Tdownto = "downto"+  show Tstep = "step"+  show Tif = "if"+  show Telse = "else"+  show Twhile = "while"   show Teof = "EOF"  instance Pretty Token where     ppr = text . show-  + keywords :: [(String,             Token,            Maybe [Extensions])] keywords = [("define",            Tdefine,          Nothing),+            ("declare",           Tdeclare,         Nothing),             ("ret",               Tret,             Nothing),             ("target",            Ttarget,          Nothing),             ("datalayout",        Tdatalayout,      Nothing),@@ -667,8 +682,11 @@             ("tail",              Ttail,            Nothing),             ("for",               Tfor,             Just [Loops]),             ("in",                Tin,              Just [Loops]),-            ("with",              Twith,            Just [Loops]),-            ("as",                Tas,              Just [Loops])+            ("downto",            Tdownto,          Just [Loops]),+            ("step",              Tstep,            Just [Loops]),+            ("if",                Tif,              Just [Loops]),+            ("else",              Telse,            Just [Loops]),+            ("while",             Twhile,           Just [Loops])            ]  keywordMap :: Map.Map String (Token, Maybe ExtensionsInt)@@ -680,3 +698,4 @@     f (s, t, Just exts)  = (s, (t, Just i))       where         i = foldl' setBit 0 (map fromEnum exts)+

@@ -0,0 +1,411 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ScopedTypeVariables      #-}+module LLVM.General.Quote.SSA ( toSSA, typeOfConstant, typeOfOperand, typeOfInstruction ) where++import Prelude hiding (pred)++import LLVM.General.AST+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.InlineAssembly as I+import qualified LLVM.General.AST.Constant as C++import Control.Monad+import qualified Data.Map.Strict as M+import Data.List++import Control.Monad.ST.Strict+import Data.STRef++import Data.Generics+++typeOfConstant :: C.Constant -> Type+typeOfConstant C.Int{..} = IntegerType integerBits+typeOfConstant C.Float{..} = case floatValue of+  _ -> undefined+typeOfConstant C.Null{..} = constantType+typeOfConstant C.Struct{..} =+  StructureType isPacked (map typeOfConstant memberValues)+typeOfConstant C.Array{..} = ArrayType (genericLength memberValues) memberType+typeOfConstant C.Vector{..} = case memberValues of+  (x:_) -> VectorType (genericLength memberValues) (typeOfConstant x)+  [] -> error "typeOfConstant: empty Vector"+typeOfConstant C.Undef{..} = constantType+typeOfConstant C.BlockAddress{} = PointerType (IntegerType 8) (AddrSpace 0)+typeOfConstant (C.GlobalReference t _) = t+typeOfConstant C.Add{..} = typeOfConstant operand0+typeOfConstant C.FAdd{..} = typeOfConstant operand0+typeOfConstant C.Sub{..} = typeOfConstant operand0+typeOfConstant C.FSub{..} = typeOfConstant operand0+typeOfConstant C.Mul{..} = typeOfConstant operand0+typeOfConstant C.FMul{..} = typeOfConstant operand0+typeOfConstant C.UDiv{..} = typeOfConstant operand0+typeOfConstant C.SDiv{..} = typeOfConstant operand0+typeOfConstant C.FDiv{..} = typeOfConstant operand0+typeOfConstant C.URem{..} = typeOfConstant operand0+typeOfConstant C.SRem{..} = typeOfConstant operand0+typeOfConstant C.FRem{..} = typeOfConstant operand0+typeOfConstant C.Shl{..} = typeOfConstant operand0+typeOfConstant C.LShr{..} = typeOfConstant operand0+typeOfConstant C.AShr{..} = typeOfConstant operand0+typeOfConstant C.And{..} = typeOfConstant operand0+typeOfConstant C.Or{..} = typeOfConstant operand0+typeOfConstant C.Xor{..} = typeOfConstant operand0+typeOfConstant C.GetElementPtr{..} = typeOfConstant address+typeOfConstant C.Trunc{..} = type'+typeOfConstant C.ZExt{..} = type'+typeOfConstant C.SExt{..} = type'+typeOfConstant C.FPToUI{..} = type'+typeOfConstant C.FPToSI{..} = type'+typeOfConstant C.UIToFP{..} = type'+typeOfConstant C.SIToFP{..} = type'+typeOfConstant C.FPTrunc{..} = type'+typeOfConstant C.FPExt{..} = type'+typeOfConstant C.PtrToInt{..} = type'+typeOfConstant C.IntToPtr{..} = type'+typeOfConstant C.BitCast{..} = type'+typeOfConstant C.ICmp{..} = case typeOfConstant operand0 of+  VectorType{..} -> VectorType nVectorElements (IntegerType 1)+  _              -> IntegerType 1+typeOfConstant C.FCmp{..} = case typeOfConstant operand0 of+  VectorType{..} -> VectorType nVectorElements (IntegerType 1)+  _              -> IntegerType 1+typeOfConstant C.Select{..} = typeOfConstant trueValue+typeOfConstant C.ExtractElement{..} = case C.memberValues vector of+  (x:_) -> typeOfConstant x+  [] -> error "typeOfConstant: empty Vector"+typeOfConstant C.InsertElement{..} = typeOfConstant vector+typeOfConstant C.ShuffleVector{..} =+  case (typeOfConstant operand0, typeOfConstant mask) of+    (VectorType _ t, VectorType n _) -> VectorType n t+    _ -> error "typeOfConstant: expected vector arguments to ShuffleVector"+typeOfConstant C.ExtractValue{..} =+  extractTypes indices' (typeOfConstant aggregate)+ where+  extractTypes []     t = t+  extractTypes (n:ns) t = case t of+    StructureType{..} -> extractTypes ns (elementTypes !! fromIntegral n)+    ArrayType{..}     -> extractTypes ns elementType+    _                 -> error "typeOfConstant: expected aggregate value in ExtractValue"+typeOfConstant C.InsertValue{..} = typeOfConstant aggregate++typeOfOperand :: Operand -> Type+typeOfOperand (LocalReference t _) = t+typeOfOperand (ConstantOperand c) = typeOfConstant c+typeOfOperand MetadataStringOperand{} = MetadataType+typeOfOperand MetadataNodeOperand{} = MetadataType++typeOfInstruction :: Instruction -> Type+typeOfInstruction instr = case instr of+  Add{..} -> typeOfOperand operand0+  FAdd{..} -> typeOfOperand operand0+  Sub{..} -> typeOfOperand operand0+  FSub{..} -> typeOfOperand operand0+  Mul{..} -> typeOfOperand operand0+  FMul{..} -> typeOfOperand operand0+  UDiv{..} -> typeOfOperand operand0+  SDiv{..} -> typeOfOperand operand0+  FDiv{..} -> typeOfOperand operand0+  URem{..} -> typeOfOperand operand0+  SRem{..} -> typeOfOperand operand0+  FRem{..} -> typeOfOperand operand0+  Shl{..} -> typeOfOperand operand0+  LShr{..} -> typeOfOperand operand0+  AShr{..} -> typeOfOperand operand0+  And{..} -> typeOfOperand operand0+  Or{..} -> typeOfOperand operand0+  Xor{..} -> typeOfOperand operand0+  Alloca{..} -> PointerType allocatedType (AddrSpace 0)+  Load{..} -> pointerReferent $ typeOfOperand address+  Store{..} -> typeOfOperand address+--  GetElementPtr{..} -> undefined+  Fence{..} -> VoidType+  CmpXchg{..} -> typeOfOperand expected+  AtomicRMW{..} -> typeOfOperand value+  Trunc{..} -> type'+  ZExt{..} -> type'+  SExt{..} -> type'+  FPToUI{..} -> type'+  FPToSI{..} -> type'+  UIToFP{..} -> type'+  SIToFP{..} -> type'+  FPTrunc{..} -> type'+  FPExt{..} -> type'+  PtrToInt{..} -> type'+  IntToPtr{..} -> type'+  BitCast{..} -> type'+  AddrSpaceCast{..} -> type'+  ICmp{..} -> case typeOfOperand operand0 of+    VectorType{..} -> VectorType nVectorElements (IntegerType 1)+    _              -> IntegerType 1+  FCmp{..} -> case typeOfOperand operand0 of+    VectorType{..} -> VectorType nVectorElements (IntegerType 1)+    _              -> IntegerType 1+  Phi{..} -> type'+  Call{..} -> case function of+    Left I.InlineAssembly{..} -> type'+    Right op -> typeOfOperand op+  Select{..} -> typeOfOperand trueValue+  VAArg{..} -> type'+  ExtractElement{..} -> elementType $ typeOfOperand vector+  InsertElement{..} -> typeOfOperand vector+  ShuffleVector{..} -> let VectorType _ t = typeOfOperand operand0+                           VectorType n _ = typeOfConstant mask+                       in VectorType n t+--  ExtractValue{..} -> undefined+  InsertValue{..} -> typeOfOperand aggregate+  LandingPad{..} -> type'++++++type CFG s =[(Name, MutableBlock s)]++data MutableBlock s = MutableBlock {+  blockName :: Name,+  blockIncompletePhis :: STRef s (M.Map Name (MutableInstruction s)),+  blockPhis :: STRef s [MutableInstruction s],+  blockInstructions :: [MutableInstruction s],+  blockTerminator :: MutableTerminator s,+  blockPreds :: [Name],+  blockDefs :: STRef s (M.Map Name Name)+  }++type MutableInstruction s = STRef s (Named Instruction)+type MutableTerminator  s = STRef s (Named Terminator)++++toCFG :: [BasicBlock] -> ST s (CFG s)+toCFG blocks =+  flip mapM blocks $ \b@(BasicBlock n _ _) -> do+    b' <- toMutableBlock b $ froms blocks b+    return $ (n,b')++toMutableBlock :: BasicBlock -> [Name] -> ST s (MutableBlock s)+toMutableBlock (BasicBlock n is t) preds = do+  let (phis, is') = partition isPhi is+  phis' <- mapM newSTRef phis >>= newSTRef+  incompletePhis <- newSTRef M.empty+  is'' <- mapM newSTRef is'+  t'  <- newSTRef t+  defs <- newSTRef M.empty+  return $ MutableBlock{+    blockName = n,+    blockIncompletePhis = incompletePhis,+    blockPhis = phis',+    blockInstructions = is'',+    blockTerminator = t',+    blockPreds = preds,+    blockDefs = defs+    }++unNamed :: Named a -> (Maybe Name, a)+unNamed (Do x)   = (Nothing, x)+unNamed (n := x) = (Just n, x)++named :: (Maybe Name, a) -> Named a+named (Nothing, x) = Do x+named (Just n, x)  = n := x++termDests :: Terminator -> [Name]+termDests Ret{}          = []+termDests CondBr{..}     = [trueDest, falseDest]+termDests Br{..}         = [dest]+termDests Switch{..}     = [ d | (_,d) <- dests ]+termDests IndirectBr{..} = possibleDests+termDests Invoke{..}     = [returnDest, exceptionDest]+termDests Resume{}       = []+termDests Unreachable{}  = []++froms :: [BasicBlock] -> BasicBlock -> [Name]+froms blocks (BasicBlock n _ _) = do+  BasicBlock n' _ t <- blocks+  let (_, t') = unNamed t+  d <- termDests t'+  guard $ n==d+  return n'++isPhi :: Named Instruction -> Bool+isPhi instr = case unNamed instr of+  (_, Phi{}) -> True+  _          -> False++fromCFG :: CFG s -> ST s [BasicBlock]+fromCFG cfg = do+  mapM fromMutableBlock $ map snd cfg++fromMutableBlock :: MutableBlock s -> ST s BasicBlock+fromMutableBlock MutableBlock{..} = do+  incompletePhis <- readSTRef blockIncompletePhis+  when (not $ M.null incompletePhis) (error "internal error: incomplete phi nodes")+  phis <- readSTRef blockPhis+  phis' <- mapM readSTRef phis+  is <- mapM readSTRef blockInstructions+  t <- readSTRef blockTerminator+  return $ BasicBlock blockName (phis'++is) t++writeVariable+  :: Name                -- ^ Name of the Variable+  -> Name                -- ^ The new Name+  -> MutableBlock s      -- ^ The Block being updated+  -> ST s ()+writeVariable var varNew MutableBlock{..} =+  modifySTRef' blockDefs $ M.insert var varNew++readVariable+  :: Name                -- ^ Name of the Variable+  -> Type                -- ^ Type of the Variable+  -> MutableBlock s      -- ^ The Block being updated+  -> STRef s Int+  -> ST s Name+readVariable var ty block@MutableBlock{..} ctr = do+  defs' <- readSTRef blockDefs+  case M.lookup var defs' of+    -- local value numbering+    Just n  -> return n+    -- global value numbering+    Nothing ->+      case blockPreds of+        -- entry block, name is function parameter+        []     -> do writeVariable var var block+                     return var+        preds  -> do+          varNew <- freshName ctr var+          phi <- newSTRef $ varNew := Phi ty (map (undefined,) preds) []+          modifySTRef' blockIncompletePhis (M.insert var phi)+          writeVariable var varNew block+          return varNew++freshName :: STRef s Int -> Name -> ST s Name+freshName ctr baseName = do+  i <- readSTRef ctr+  writeSTRef ctr (i+1)+  let nameString = case baseName of+        Name n -> n+        UnName n -> "v" ++ show n+  return $ Name $ nameString ++ "." ++ show i++addPhiOperands+  :: Name+  -> STRef s (Named Instruction)+  -> CFG s+  -> STRef s Int+  -> ST s ()+addPhiOperands var phi cfg ctr = do+  phi' <- readSTRef phi+  let (n, phi'') = unNamed phi'+      preds = map snd $ incomingValues phi''+      ty = type' phi''+  incoming <- flip mapM preds $ \pred -> do+    let Just block = lookup pred cfg+    phiOp <- readVariable var ty block ctr+    return (LocalReference ty phiOp, pred)+  let phi''' = named (n, phi''{incomingValues = incoming})+  writeSTRef phi phi'''++toSSA :: [BasicBlock] -> [BasicBlock]+toSSA bbs = runST $ do+  cfg <- toCFG bbs+  ctr <- newSTRef 1++  -- process all Instructions+  mapM_ (blockToSSAPre ctr) (map snd cfg)+  -- replace names in Phis with correct references+  mapM_ (blockToSSAPhi ctr cfg) (map snd cfg)+  -- replace names in newly added Phis with correct references+  handleIncompletePhis ctr cfg++  fromCFG cfg++handleIncompletePhis+  :: STRef s Int+  -> CFG s+  -> ST s ()+handleIncompletePhis ctr cfg = do+  changed <- mapM (handleIncompletePhis' ctr cfg) (map snd cfg)+  case or changed of+    True -> handleIncompletePhis ctr cfg+    False -> return ()++handleIncompletePhis'+  :: STRef s Int+  -> CFG s+  -> MutableBlock s+  -> ST s Bool+handleIncompletePhis' ctr cfg MutableBlock{..} = do+  incompletePhis <- readSTRef blockIncompletePhis+  case M.null incompletePhis of+    True ->+      return False+    False -> do+      phis <- readSTRef blockPhis+      writeSTRef blockIncompletePhis M.empty+      let incompletePhis' = M.toList incompletePhis+      flip mapM_ incompletePhis' $ \(n, phi) -> addPhiOperands n phi cfg ctr+      let phis' = map snd incompletePhis' ++ phis+      writeSTRef blockPhis phis'+      return True++blockToSSAPhi+  :: STRef s Int+  -> CFG s+  -> MutableBlock s+  -> ST s ()+blockToSSAPhi ctr cfg MutableBlock{..} = do+  -- replace names in Phi with correct references+  phis <- readSTRef blockPhis+  flip mapM_ phis $ \phi -> do+    phi' <- readSTRef phi+    let (n, phi''@Phi{..}) = unNamed phi'+    incomingValues' <- flip mapM incomingValues $ \(op,pred) ->+      case op of+        LocalReference ty var -> do+          let Just blockPred = lookup pred cfg+          phiOp <- readVariable var ty blockPred ctr+          return (LocalReference ty phiOp, pred)+        _ -> return (op,pred)+    let completePhi = named (n, phi''{incomingValues = incomingValues'})+    writeSTRef phi completePhi++blockToSSAPre+  :: STRef s Int+  -> MutableBlock s+  -> ST s ()+blockToSSAPre ctr block@MutableBlock{..} = do+  phis <- readSTRef blockPhis+  mapM_ (namedToSSA ctr block) phis+  mapM_ (namedToSSA ctr block) blockInstructions+  namedToSSA ctr block blockTerminator+++namedToSSA+  :: forall s a.+     Data a+  => STRef s Int+  -> MutableBlock s+  -> STRef s (Named a)+  -> ST s ()+namedToSSA ctr block@MutableBlock{..} x = do+  x' <- readSTRef x+  let (n,instr) = unNamed x'+  n' <- maybe (return Nothing) (\n' -> Just `fmap` freshName ctr n') n+  case cast instr of+    Just Phi{} -> writeSTRef x $ named (n', instr)+    _ -> do+      instr' <- trans instr+      writeSTRef x $ named (n', instr')+  case (n,n') of+    (Just n1, Just n1') -> writeVariable n1 n1' block+    (_      , _       ) -> return ()+ where+  trans :: (Data d) => d -> ST s d+  trans = gmapM trans `extM` rename++  rename :: Operand -> ST s (Operand)+  rename (LocalReference t n) = do+    n' <- readVariable n t block ctr+    return $ LocalReference t n'+  rename op = return op