llvm-hs-pure 6.0.0 → 6.1.0

raw patch · 14 files changed

+910/−411 lines, 14 filesdep −hspecdep −semigroupsdep −textdep ~basedep ~bytestringdep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: hspec, semigroups, text

Dependency ranges changed: base, bytestring, containers, mtl, transformers, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• llvm-hs-pure.cabal +10/−39
• src/LLVM/AST.hs +8/−3
• src/LLVM/AST/Global.hs +9/−4
• src/LLVM/AST/Instruction.hs +1/−1
• src/LLVM/AST/Operand.hs +483/−18
• src/LLVM/IRBuilder/Instruction.hs +6/−2
• src/LLVM/IRBuilder/Internal/SnocList.hs +0/−5
• src/LLVM/IRBuilder/Module.hs +3/−0
• src/LLVM/IRBuilder/Monad.hs +36/−4
• src/LLVM/Prelude.hs +5/−4
• test/IRBuilder.hs +0/−329
• test/LLVM/Test/IRBuilder.hs +329/−0
• test/LLVM/Test/Tests.hs +4/−2

@@ -1,3 +1,19 @@+## 6.1.0 (2018-05-05)++* IRBuilder: Ensure that automatically generated block labels are+  assigned smaller identifiers than the instructions following+  them. This is only important when you use+  `llvm-hs-pretty`. `llvm-hs` does not care about the order of+  identifiers assigned to unnamed values.+* IRBuilder: add `currentBlock` which returns name of the currently+  active block.+* Remove the `MetadataNodeReference` constructor. References to+  metadata nodes are now encoded using the polymorphic `MDRef` type.+* Add debug metadata to the AST in `LLVM.AST.Operand`. Thanks to+  @xldenis who started that effort!+* Drop support for GHC 7.10.+* Add `metadata` field to `GlobalVariable` and `Function`.+ ## 6.0.0 (2018-03-06)  * Support for LLVM 6.0

@@ -1,5 +1,5 @@ name: llvm-hs-pure-version: 6.0.0+version: 6.1.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Benjamin S. Scarlet@@ -9,14 +9,14 @@ bug-reports: http://github.com/llvm-hs/llvm-hs/issues build-type: Simple stability: experimental-cabal-version: >= 1.8+cabal-version: 1.24 category: Compilers/Interpreters, Code Generation synopsis: Pure Haskell LLVM functionality (no FFI). description:   llvm-hs-pure is a set of pure Haskell types and functions for interacting with LLVM <http://llvm.org/>.   It includes an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>). The llvm-hs package   builds on this one with FFI bindings to LLVM, but llvm-hs-pure does not require LLVM to be available.-tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 extra-source-files: CHANGELOG.md  source-repository head@@ -24,20 +24,11 @@   location: git://github.com/llvm-hs/llvm-hs.git   branch: llvm-5 -flag semigroups-  description: Add semigroups to build-depends for Data.List.NonEmpty. This will be selected automatically by cabal.-  default: False- library+  default-language: Haskell2010   ghc-options: -Wall-  if flag(semigroups)-    build-depends:-      base >= 4.8 && < 4.9,-      semigroups >= 0.18 && < 0.19-  else-    build-depends:-      base >= 4.9 && < 5   build-depends:+    base >= 4.9 && < 5,     attoparsec >= 0.13,     bytestring >= 0.10 && < 0.11,     fail,@@ -47,7 +38,7 @@     containers >= 0.4.2.1,     unordered-containers >= 0.2   hs-source-dirs: src-  extensions:+  default-extensions:     NoImplicitPrelude     TupleSections     DeriveDataTypeable@@ -92,15 +83,10 @@     LLVM.Prelude  test-suite test+  default-language: Haskell2010   type: exitcode-stdio-1.0-  if flag(semigroups)-    build-depends:-      base >= 4.8 && < 4.9,-      semigroups >= 0.18 && < 0.19-  else-    build-depends:-      base >= 4.9 && < 5   build-depends:+    base >= 4.9 && < 5,     tasty >= 0.11,     tasty-hunit >= 0.9,     tasty-quickcheck >= 0.8,@@ -109,27 +95,12 @@     containers >= 0.4.2.1,     mtl >= 2.1   hs-source-dirs: test-  extensions:+  default-extensions:     TupleSections     FlexibleInstances     FlexibleContexts   main-is: Test.hs   other-modules:     LLVM.Test.DataLayout+    LLVM.Test.IRBuilder     LLVM.Test.Tests--test-suite test-irbuilder-  type: exitcode-stdio-1.0-  main-is: IRBuilder.hs-  hs-source-dirs:-      test-  build-depends:-      base >=4.8 && <4.11-    , bytestring-    , containers-    , hspec-    , llvm-hs-pure-    , mtl-    , text-    , transformers-    , unordered-containers

@@ -12,9 +12,14 @@   UnnamedAddr(..),   Parameter(..),   BasicBlock(..),+  Operand(..),+  CallableOperand,+  Metadata(..),+  MetadataNodeID(..),+  MDRef(..),+  MDNode(..),   module LLVM.AST.Instruction,   module LLVM.AST.Name,-  module LLVM.AST.Operand,   module LLVM.AST.Type   ) where @@ -23,7 +28,7 @@ import LLVM.AST.Name import LLVM.AST.Type (Type(..), FloatingPointType(..)) import LLVM.AST.Global-import LLVM.AST.Operand+import LLVM.AST.Operand hiding (Module) import LLVM.AST.Instruction import LLVM.AST.DataLayout import qualified LLVM.AST.Attribute as A@@ -33,7 +38,7 @@ data Definition   = GlobalDefinition Global   | TypeDefinition Name (Maybe Type)-  | MetadataNodeDefinition MetadataNodeID [Maybe Metadata]+  | MetadataNodeDefinition MetadataNodeID MDNode   | NamedMetadataDefinition ShortByteString [MetadataNodeID]   | ModuleInlineAssembly ByteString   | FunctionAttributes A.GroupID [A.FunctionAttribute]

@@ -14,6 +14,7 @@ import qualified LLVM.AST.CallingConvention as CC import qualified LLVM.AST.ThreadLocalStorage as TLS import qualified LLVM.AST.Attribute as A+import LLVM.AST.Operand (MDRef, MDNode)  -- | <http://llvm.org/doxygen/classllvm_1_1GlobalValue.html> data Global@@ -31,7 +32,8 @@         initializer :: Maybe Constant,         section :: Maybe ShortByteString,         comdat :: Maybe ShortByteString,-        alignment :: Word32+        alignment :: Word32,+        metadata :: [(ShortByteString, MDRef MDNode)]       }     -- | <http://llvm.org/docs/LangRef.html#aliases>     | GlobalAlias {@@ -62,7 +64,8 @@         garbageCollectorName :: Maybe ShortByteString,         prefix :: Maybe Constant,         basicBlocks :: [BasicBlock],-        personalityFunction :: Maybe Constant+        personalityFunction :: Maybe Constant,+        metadata :: [(ShortByteString, MDRef MDNode)]       }   deriving (Eq, Read, Show, Typeable, Data, Generic) @@ -95,7 +98,8 @@   initializer = Nothing,   section = Nothing,   comdat = Nothing,-  alignment = 0+  alignment = 0,+  metadata = []   }  -- | helper for making 'GlobalAlias's@@ -132,5 +136,6 @@     garbageCollectorName = Nothing,     prefix = Nothing,     basicBlocks = [],-    personalityFunction = Nothing+    personalityFunction = Nothing,+    metadata = []   }

@@ -19,7 +19,7 @@  -- | <http://llvm.org/docs/LangRef.html#metadata-nodes-and-metadata-strings> -- Metadata can be attached to an instruction-type InstructionMetadata = [(ShortByteString, MetadataNode)]+type InstructionMetadata = [(ShortByteString, MDRef MDNode)]  -- | <http://llvm.org/docs/LangRef.html#terminators> data Terminator 

@@ -1,5 +1,9 @@+{-# LANGUAGE DuplicateRecordFields #-} -- | A type to represent operands to LLVM 'LLVM.AST.Instruction.Instruction's-module LLVM.AST.Operand where+module LLVM.AST.Operand+( module LLVM.AST.Operand+)+where  import LLVM.Prelude @@ -8,33 +12,494 @@ import LLVM.AST.InlineAssembly import LLVM.AST.Type ++-- | An 'Operand' is roughly that which is an argument to an 'LLVM.AST.Instruction.Instruction'+data Operand+  -- | %foo+  = LocalReference Type Name+  -- | 'Constant's include 'LLVM.AST.Constant.GlobalReference', for \@foo+  | ConstantOperand Constant+  | MetadataOperand Metadata+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | The 'LLVM.AST.Instruction.Call' instruction is special: the callee can be inline assembly+type CallableOperand  = Either InlineAssembly Operand++-- | <http://llvm.org/docs/LangRef.html#metadata>+data Metadata+  = MDString ShortByteString -- ^ <http://llvm.org/docs/doxygen/html/classllvm_1_1MDNode.html>+  | MDNode (MDRef MDNode) -- ^ <http://llvm.org/docs/doxygen/html/classllvm_1_1MDNode.html>+  | MDValue Operand -- ^ <http://llvm.org/docs/doxygen/html/classllvm_1_1ValueAsMetadata.html>+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- | A 'MetadataNodeID' is a number for identifying a metadata node. -- Note this is different from "named metadata", which are represented with -- 'LLVM.AST.NamedMetadataDefinition'. newtype MetadataNodeID = MetadataNodeID Word   deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- | <http://llvm.org/docs/LangRef.html#metadata>-data MetadataNode -  = MetadataNode [Maybe Metadata]-  | MetadataNodeReference MetadataNodeID+-- | `MDRef` can either represent a reference to some piece of+-- metadata or the metadata itself.+--+-- This is mainly useful for encoding cyclic metadata. Note that LLVM+-- represents inline and non-inline nodes identically, so+-- roundtripping the Haskell AST does not preserve whether a node was+-- inline or not.+data MDRef a+  = MDRef MetadataNodeID+  | MDInline a   deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +instance Functor MDRef where+  fmap _ (MDRef i) = MDRef i+  fmap f (MDInline a) = MDInline (f a)++data DWOpFragment = DW_OP_LLVM_Fragment+  { offset :: Word64+  , size :: Word64+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#diexpression>+data DWOp+  = DwOpFragment DWOpFragment -- ^ Must appear at the end+  | DW_OP_StackValue -- ^ Must be the last one or followed by a DW_OP_LLVM_Fragment+  | DW_OP_Swap+  | DW_OP_ConstU Word64+  | DW_OP_PlusUConst Word64+  | DW_OP_Plus+  | DW_OP_Minus+  | DW_OP_Mul+  | DW_OP_Deref+  | DW_OP_XDeref+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+ -- | <http://llvm.org/docs/LangRef.html#metadata>-data Metadata-  = MDString ShortByteString -- ^ <http://llvm.org/docs/doxygen/html/classllvm_1_1MDNode.html>-  | MDNode MetadataNode -- ^ <http://llvm.org/docs/doxygen/html/classllvm_1_1MDNode.html>-  | MDValue Operand -- ^ <http://llvm.org/docs/doxygen/html/classllvm_1_1ValueAsMetadata.html>+data MDNode+  = MDTuple [Maybe Metadata] -- ^ Nothing represents 'null'+  | DIExpression DIExpression+  | DIGlobalVariableExpression DIGlobalVariableExpression+  | DILocation DILocation+  | DIMacroNode DIMacroNode+  | DINode DINode   deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- | An 'Operand' is roughly that which is an argument to an 'LLVM.AST.Instruction.Instruction'-data Operand -  -- | %foo-  = LocalReference Type Name-  -- | 'Constant's include 'LLVM.AST.Constant.GlobalReference', for \@foo-  | ConstantOperand Constant-  | MetadataOperand Metadata+data DILocation = Location+  { line :: Word32+  , column :: Word16+  , scope :: MDRef DILocalScope+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#diexpression>+data DIExpression = Expression+  { operands :: [DWOp]+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | A pair of a `DIGlobalVariable` and a `DIExpression`.+--+-- This is used in the `cuGlobals` fields of `DICompileUnit`.+data DIGlobalVariableExpression = GlobalVariableExpression+  { var :: MDRef DIGlobalVariable+  , expr :: MDRef DIExpression+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | Accessiblity flag+data DIAccessibility+  = Private+  | Protected+  | Public   deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- | The 'LLVM.AST.Instruction.Call' instruction is special: the callee can be inline assembly-type CallableOperand  = Either InlineAssembly Operand+-- | Inheritance flag+data DIInheritance+  = SingleInheritance+  | MultipleInheritance+  | VirtualInheritance+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data DIFlag+  = Accessibility DIAccessibility+  | FwdDecl+  | AppleBlock+  | BlockByrefStruct+  | VirtualFlag+  | Artificial+  | Explicit+  | Prototyped+  | ObjcClassComplete+  | ObjectPointer+  | Vector+  | StaticMember+  | LValueReference+  | RValueReference+  | InheritanceFlag DIInheritance+  | IntroducedVirtual+  | BitField+  | NoReturn+  | MainSubprogram+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data DIMacroInfo = Define | Undef+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DIMacroNode.html>+data DIMacroNode+  -- | <https://llvm.org/docs/LangRef.html#dimacro>+  = DIMacro+    { info :: DIMacroInfo+    , line :: Word32+    , name :: ShortByteString+    , value :: ShortByteString+    }+  -- | <https://llvm.org/docs/LangRef.html#dimacrofile>+  | DIMacroFile+    { line :: Word32+    , file :: MDRef DIFile+    , elements :: [MDRef DIMacroNode]+    }+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DINode.html>+data DINode+  = DIEnumerator DIEnumerator+  | DIImportedEntity DIImportedEntity+  | DIObjCProperty DIObjCProperty+  | DIScope DIScope+  | DISubrange DISubrange+  | DITemplateParameter DITemplateParameter+  | DIVariable DIVariable+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DIObjCProperty.html>+data DIObjCProperty = ObjCProperty+  { name :: ShortByteString+  , file :: Maybe (MDRef DIFile)+  , line :: Word32+  , getterName :: ShortByteString+  , setterName :: ShortByteString+  , attributes :: Word32+  , type' :: Maybe (MDRef DIType)+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data ImportedEntityTag = ImportedModule | ImportedDeclaration+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DIImportedEntity.html>+data DIImportedEntity = ImportedEntity+  { tag :: ImportedEntityTag+  , name :: ShortByteString+  , scope :: MDRef DIScope+  , entity :: Maybe (MDRef DINode)+  , file :: Maybe (MDRef DIFile)+  , line :: Word32+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#dienumerator>+data DIEnumerator =+  Enumerator { value :: Int64, name :: ShortByteString }+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#disubrange>+data DISubrange =+  Subrange { count :: Int64, lowerBound :: Int64 }+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DIScope.html>+data DIScope+  = DICompileUnit DICompileUnit+  | DIFile DIFile+  | DILocalScope DILocalScope+  | DIModule DIModule+  | DINamespace DINamespace+  | DIType DIType+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data DIModule = Module+  { scope :: MDRef DIScope+  , name :: ShortByteString+  , configurationMacros :: ShortByteString+  , includePath :: ShortByteString+  , isysRoot :: ShortByteString+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data DINamespace = Namespace+  { name :: ShortByteString+  , scope :: MDRef DIScope+  , exportSymbols :: Bool+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data DebugEmissionKind = NoDebug | FullDebug | LineTablesOnly+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#dicompileunit>+data DICompileUnit = CompileUnit+  { language :: Word32+  , file :: MDRef DIFile+  , producer :: ShortByteString+  , optimized :: Bool+  , flags :: ShortByteString+  , runtimeVersion :: Word32+  , splitDebugFileName :: ShortByteString+  , emissionKind :: DebugEmissionKind+  , enums :: [MDRef DICompositeType] -- ^ Only enum types are allowed here+  , retainedTypes :: [MDRef (Either DIType DISubprogram)]+  , globals :: [MDRef DIGlobalVariableExpression]+  , imports :: [MDRef DIImportedEntity]+  , macros :: [MDRef DIMacroNode]+  , dWOId :: Word64+  , splitDebugInlining :: Bool+  , debugInfoForProfiling :: Bool+  , gnuPubnames :: Bool+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#difile>+data DIFile = File+  { filename :: ShortByteString+  , directory :: ShortByteString+  , checksum :: ShortByteString+  , checksumKind :: ChecksumKind+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data ChecksumKind = None | MD5 | SHA1+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DILocalScope.html>+data DILocalScope+  = DILexicalBlockBase DILexicalBlockBase+  | DISubprogram DISubprogram+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#disubprogram>+data DISubprogram = Subprogram+  { scope :: Maybe (MDRef DIScope)+  , name :: ShortByteString+  , linkageName :: ShortByteString+  , file :: Maybe (MDRef DIFile)+  , line :: Word32+  , type' :: Maybe (MDRef DISubroutineType)+  , localToUnit :: Bool+  , definition :: Bool+  , scopeLine :: Word32+  , containingType :: Maybe (MDRef DIType)+  , virtuality :: Virtuality+  , virtualityIndex :: Word32+  , thisAdjustment :: Int32+  , flags :: [DIFlag]+  , optimized :: Bool+  , unit :: Maybe (MDRef DICompileUnit)+  , templateParams :: [MDRef DITemplateParameter]+  , declaration :: Maybe (MDRef DISubprogram)+  , variables :: [MDRef DILocalVariable]+  , thrownTypes :: [MDRef DIType]+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Virtuality = NoVirtuality | Virtual | PureVirtual+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data BasicTypeTag = BaseType | UnspecifiedType+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- <https://llvm.org/doxygen/classllvm_1_1DIType.html>+data DIType+  = DIBasicType DIBasicType+  | DICompositeType DICompositeType+  | DIDerivedType DIDerivedType+  | DISubroutineType DISubroutineType+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#dibasictype>+data DIBasicType = BasicType+  { typeName :: ShortByteString+  , sizeInBits :: Word64+  , alignInBits :: Word32+  , typeEncoding :: Maybe Encoding+  , typeTag :: BasicTypeTag+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#disubroutinetype>+data DISubroutineType = SubroutineType+  { typeFlags :: [DIFlag]+  , typeCC :: Word8+  , typeTypeArray :: [Maybe (MDRef DIType)]+  -- ^ The first element is the return type, the following are the+  -- operand types. `Nothing` corresponds to @void@.+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data DerivedTypeTag+  = Typedef+  | PointerType+  | PtrToMemberType+  | ReferenceType+  | RValueReferenceType+  | ConstType+  | VolatileType+  | RestrictType+  | AtomicType+  | Member+  | Inheritance+  | Friend+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#diderivedtype>+data DIDerivedType =+  DerivedType+    { derivedTag :: DerivedTypeTag+    , derivedName :: ShortByteString+    , derivedFile :: Maybe (MDRef DIFile)+    , derivedLine :: Word32+    , derivedScope :: Maybe (MDRef DIScope)+    , derivedBaseType :: MDRef DIType+    , sizeInBits :: Word64+    , alignInBits :: Word32+    , derivedOffsetInBits :: Word64+    , derivedAddressSpace :: Maybe Word32+    , derivedFlags :: [DIFlag]+    } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#dicompositetype>+data DICompositeType+  = DIArrayType+    { subscripts :: [DISubrange]+    , elementTy :: Maybe (MDRef DIType)+    , sizeInBits :: Word64+    , alignInBits :: Word32+    , flags :: [DIFlag]+    }+  | DIClassType+    { scope :: Maybe (MDRef DIScope)+    , name :: ShortByteString+    , file :: Maybe (MDRef DIFile)+    , line :: Word32+    , flags :: [DIFlag]+    , derivedFrom :: Maybe (MDRef DIType)+    , elements :: [MDRef (Either DIDerivedType DISubprogram)]+    -- ^ `DIDerivedType` with tag set to one of `Member`, `Inheritance`, `Friend`+    -- or `DISubprogram` with `definition` set to `True`.+    , vtableHolder :: Maybe (MDRef DIType)+    , templateParams :: [DITemplateParameter]+    , identifier :: ShortByteString+    , sizeInBits :: Word64+    , alignInBits :: Word32+    }+  | DIEnumerationType+    { scope :: Maybe (MDRef DIScope)+    , name :: ShortByteString+    , file :: Maybe (MDRef DIFile)+    , line :: Word32+    , values :: [DIEnumerator]+    , baseType :: Maybe (MDRef DIType)+    , identifier :: ShortByteString+    , sizeInBits :: Word64+    , alignInBits :: Word32+    }+  | DIStructureType+    { scope :: Maybe (MDRef DIScope)+    , name :: ShortByteString+    , file :: Maybe (MDRef DIFile)+    , line :: Word32+    , flags :: [DIFlag]+    , derivedFrom :: Maybe (MDRef DIType)+    , elements :: [MDRef (Either DIDerivedType DISubprogram)]+    -- ^ `DIDerivedType` with tag set to one of `Member`, `Inheritance`, `Friend`+    -- or `DISubprogram` with `definition` set to `True`.+    , runtimeLang :: Word16+    , vtableHolder :: Maybe (MDRef DIType)+    , identifier :: ShortByteString+    , sizeInBits :: Word64+    , alignInBits :: Word32+    }+  | DIUnionType+    { scope :: Maybe (MDRef DIScope)+    , name :: ShortByteString+    , file :: Maybe (MDRef DIFile)+    , line :: Word32+    , flags :: [DIFlag]+    , elements :: [MDRef (Either DIDerivedType DISubprogram)]+    -- ^ `DIDerivedType` with tag set to one of `Member`, `Inheritance`, `Friend`+    -- or `DISubprogram` with `definition` set to `True`.+    , runtimeLang :: Word16+    , identifier :: ShortByteString+    , sizeInBits :: Word64+    , alignInBits :: Word32+    }+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data Encoding+  = AddressEncoding+  | BooleanEncoding+  | FloatEncoding+  | SignedEncoding+  | SignedCharEncoding+  | UnsignedEncoding+  | UnsignedCharEncoding+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++data TemplateValueParameterTag+  = TemplateValueParameter+  | GNUTemplateTemplateParam+  | GNUTemplateParameterPack+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DITemplateParameter.html>+data DITemplateParameter+  = DITemplateTypeParameter+    { name :: ShortByteString+    , type' :: MDRef DIType+    }+  -- ^ <https://llvm.org/docs/LangRef.html#ditemplatetypeparameter>+  | DITemplateValueParameter+    { name :: ShortByteString+    , type' :: MDRef DIType+    , value :: Metadata+    , tag :: TemplateValueParameterTag+    }+  -- ^ <https://llvm.org/docs/LangRef.html#ditemplatevalueparameter>+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DILexicalBlockBase.html>+data DILexicalBlockBase+  = DILexicalBlock+    { scope :: MDRef DILocalScope+    , file :: Maybe (MDRef DIFile)+    , line :: Word32+    , column :: Word16+    }+  -- ^ <https://llvm.org/docs/LangRef.html#dilexicalblock>+  | DILexicalBlockFile+    { scope :: MDRef DILocalScope+    , file :: Maybe (MDRef DIFile)+    , discriminator :: Word32+    }+  -- ^ <https://llvm.org/docs/LangRef.html#dilexicalblockfile>+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/doxygen/classllvm_1_1DIVariable.html>+data DIVariable+  = DIGlobalVariable DIGlobalVariable+  | DILocalVariable DILocalVariable+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#diglobalvariable>+data DIGlobalVariable = GlobalVariable+  { name :: ShortByteString+  , scope :: Maybe (MDRef DIScope)+  , file :: Maybe (MDRef DIFile)+  , line :: Word32+  , type' :: Maybe (MDRef DIType)+  , linkageName :: ShortByteString+  , local :: Bool+  , definition :: Bool+  , staticDataMemberDeclaration :: Maybe (MDRef DIDerivedType)+  , alignInBits :: Word32+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)++-- | <https://llvm.org/docs/LangRef.html#dilocalvariable>+data DILocalVariable = LocalVariable+  { name :: ShortByteString+  , scope :: MDRef DIScope+  , file :: Maybe (MDRef DIFile)+  , line :: Word32+  , type' :: Maybe (MDRef DIType)+  , flags :: [DIFlag]+  , arg :: Word16+  , alignInBits :: Word32+  } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)

@@ -133,7 +133,11 @@ bitcast a to = emitInstr to $ BitCast a to []  extractElement :: MonadIRBuilder m => Operand -> Operand -> m Operand-extractElement v i = emitInstr (typeOf v) $ ExtractElement v i []+extractElement v i = emitInstr elemTyp $ ExtractElement v i []+  where elemTyp =+          case typeOf v of+            VectorType _ typ -> typ+            _ -> error "extractElement: Expected a vector type (malformed AST)."  insertElement :: MonadIRBuilder m => Operand -> Operand -> Operand -> m Operand insertElement v e i = emitInstr (typeOf v) $ InsertElement v e i []@@ -142,7 +146,7 @@ shuffleVector a b m = emitInstr (typeOf a) $ ShuffleVector a b m []  extractValue :: MonadIRBuilder m => Operand -> [Word32] -> m Operand-extractValue a i = emitInstr (typeOf a) $ ExtractValue a i []+extractValue a i = emitInstr (extractValueType i (typeOf a)) $ ExtractValue a i []  insertValue :: MonadIRBuilder m => Operand -> Operand -> [Word32] -> m Operand insertValue a e i = emitInstr (typeOf a) $ InsertValue a e i []

@@ -1,12 +1,7 @@ {-# LANGUAGE CPP #-} module LLVM.IRBuilder.Internal.SnocList where -#if MIN_VERSION_base(4,11,0) import LLVM.Prelude-#else-import Data.Semigroup (Semigroup(..))-import LLVM.Prelude hiding ((<>))-#endif  newtype SnocList a = SnocList { unSnocList :: [a] }   deriving (Eq, Show)

@@ -7,6 +7,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -- For MonadState s (IRBuilderT m) instance+{-# LANGUAGE CPP #-}  module LLVM.IRBuilder.Module where @@ -27,7 +28,9 @@ import Control.Monad.State.Lazy import Control.Monad.List import Control.Monad.Trans.Maybe+#if !(MIN_VERSION_mtl(2,2,2)) import Control.Monad.Trans.Identity+#endif  import Data.Bifunctor import Data.ByteString.Short as BS

@@ -5,6 +5,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -- For MonadState s (ModuleBuilderT m) instance+{-# LANGUAGE CPP #-}  module LLVM.IRBuilder.Monad where @@ -15,16 +16,19 @@ import Control.Monad.Fail import qualified Control.Monad.Fail as Fail import Control.Monad.Identity-import Control.Monad.Writer.Lazy as Lazy-import Control.Monad.Writer.Strict as Strict+import qualified Control.Monad.Writer.Lazy as Lazy+import qualified Control.Monad.Writer.Strict as Strict+import Control.Monad.Writer (MonadWriter) import Control.Monad.Reader-import Control.Monad.RWS.Lazy as Lazy-import Control.Monad.RWS.Strict as Strict+import qualified Control.Monad.RWS.Lazy as Lazy+import qualified Control.Monad.RWS.Strict as Strict import qualified Control.Monad.State.Lazy as Lazy import Control.Monad.State.Strict import Control.Monad.List import Control.Monad.Trans.Maybe+#if !(MIN_VERSION_mtl(2,2,2)) import Control.Monad.Trans.Identity+#endif  import Data.Bifunctor import Data.String@@ -111,6 +115,20 @@ -- * Low-level functionality ------------------------------------------------------------------------------- +-- | If no partial block exists, create a new block with a fresh label.+--+-- This is useful if you want to ensure that the label for the block+-- is assigned before another label which is not possible with+-- `modifyBlock`.+ensureBlock :: MonadIRBuilder m => m ()+ensureBlock = do+  mbb <- liftIRState $ gets builderBlock+  case mbb of+    Nothing -> do+      nm <- freshUnName+      liftIRState $ modify $ \s -> s { builderBlock = Just $! emptyPartialBlock nm }+    Just _ -> pure ()+ modifyBlock   :: MonadIRBuilder m   => (PartialBlock -> PartialBlock)@@ -155,6 +173,8 @@   -> Instruction   -> m Operand emitInstr retty instr = do+  -- Ensure that the fresh identifier for the block is assigned before the identifier for the instruction.+  ensureBlock   nm <- fresh   modifyBlock $ \bb -> bb     { partialBlockInstrs = partialBlockInstrs bb `snoc` (nm := instr)@@ -229,6 +249,18 @@   result <- ir   liftIRState $ modify $ \s -> s { builderNameSuggestion = before }   return result++-- | Get the name of the currently active block.+--+-- This function will throw an error if there is no active block. The+-- only situation in which this can occur is if it is called before+-- any call to `block` and before emitting any instructions.+currentBlock :: MonadIRBuilder m => m Name+currentBlock = liftIRState $ do+  name <- gets (fmap partialBlockName . builderBlock)+  case name of+    Just n -> pure n+    Nothing -> error "Called currentBlock when no block was active"  ------------------------------------------------------------------------------- -- mtl instances

@@ -1,5 +1,6 @@ -- | This module is presents a prelude mostly like the post-Applicative-Monad world of--- base >= 4.8 / ghc >= 7.10, even on earlier versions. It's intended as an internal library+-- base >= 4.8 / ghc >= 7.10, as well as the post-Semigroup-Monoid world of+-- base >= 4.11 / ghc >= 8.4, even on earlier versions. It's intended as an internal library -- for llvm-hs-pure and llvm-hs; it's exposed only to be shared between the two. module LLVM.Prelude (     module Prelude,@@ -9,6 +10,7 @@     module Data.Word,     module Data.Functor,     module Data.Foldable,+    module Data.Semigroup,     module Data.Traversable,     module Control.Applicative,     module Control.Monad,@@ -17,8 +19,7 @@     fromMaybe,     leftBiasedZip,     findM,-    ifM,-    (<>)+    ifM     ) where  import Prelude hiding (@@ -34,10 +35,10 @@ import GHC.Generics (Generic) import Data.Int import Data.Maybe (fromMaybe)-import Data.Monoid ((<>)) import Data.Word import Data.Functor import Data.Foldable+import Data.Semigroup (Semigroup((<>))) import Data.Traversable import Control.Applicative import Control.Monad hiding (

@@ -1,329 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecursiveDo #-}-module Main-  ( main-  ) where--import           Data.Monoid-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.IO as T-import           LLVM.AST hiding (function)-import qualified LLVM.AST.Constant as C-import qualified LLVM.AST.Float as F-import           LLVM.AST.Global (basicBlocks, name, parameters, returnType)-import qualified LLVM.AST.Type as AST-import qualified LLVM.AST.CallingConvention as CC-import           Test.Hspec hiding (example)-import qualified LLVM.AST.Instruction as I (function)-import           LLVM.IRBuilder--main :: IO ()-main =-  hspec $ do-    describe "module builder" $ do-      it "builds the simple module" $-        simple `shouldBe`-        defaultModule {-          moduleName = "exampleModule",-          moduleDefinitions =-            [ GlobalDefinition functionDefaults {-                name = "add",-                parameters =-                  ( [ Parameter AST.i32 "a" []-                    , Parameter AST.i32 "b" []-                    ]-                  , False-                  ),-                returnType = AST.i32,-                basicBlocks =-                  [ BasicBlock-                      "entry"-                      [ UnName 0 := Add {-                          operand0 = LocalReference AST.i32 "a",-                          operand1 = LocalReference AST.i32 "b",-                          nsw = False,-                          nuw = False,-                          metadata = []-                        }-                      ]-                      (Do (Ret (Just (LocalReference AST.i32 (UnName 0))) []))-                  ]-              }-            ]-        }-      it "calls constant globals" $ do-        callWorksWithConstantGlobals-      it "supports recursive function calls" $ do-        recursiveFunctionCalls-      it "builds the example" $ do-        let f10 = ConstantOperand (C.Float (F.Double 10))-            fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = noFastMathFlags, metadata = [] }-            add a b = Add { operand0 = a, operand1 = b, nsw = False, nuw = False, metadata = [] }-        example `shouldBe`-          defaultModule {-            moduleName = "exampleModule",-            moduleDefinitions =-              [ GlobalDefinition functionDefaults {-                  name = "foo",-                  returnType = AST.double,-                  basicBlocks =-                    [ BasicBlock (UnName 0) [ "xxx" := fadd f10 f10]-                        (Do (Ret Nothing []))-                    , BasicBlock-                        "blk"-                        [ UnName 1 := fadd f10 f10-                        , UnName 2 := fadd (LocalReference AST.double (UnName 1)) (LocalReference AST.double (UnName 1))-                        , UnName 3 := add (ConstantOperand (C.Int 32 10)) (ConstantOperand (C.Int 32 10))-                        ]-                        (Do (Br "blk1" []))-                    , BasicBlock-                        "blk1"-                        [ "c" := fadd f10 f10-                        , UnName 4 := fadd (LocalReference AST.double "c") (LocalReference AST.double "c")-                        ]-                        (Do (Br "blk2" []))-                    , BasicBlock-                        "blk2"-                        [ "phi" :=-                            Phi-                              AST.double-                              [ ( f10, "blk" )-                              , ( f10, "blk1" )-                              , ( f10, "blk2" )-                              ]-                              []-                        , UnName 5 := fadd f10 f10-                        , UnName 6 := fadd (LocalReference AST.double (UnName 5)) (LocalReference AST.double (UnName 5))-                        ]-                        (Do (Ret Nothing []))-                    ]-                }-              , GlobalDefinition functionDefaults {-                  name = "bar",-                  returnType = AST.double,-                  basicBlocks =-                    [ BasicBlock-                       (UnName 0)-                       [ UnName 1 := fadd f10 f10-                       , UnName 2 := fadd (LocalReference AST.double (UnName 1)) (LocalReference AST.double (UnName 1))-                       ]-                       (Do (Ret Nothing []))-                    ]-                }-              , GlobalDefinition functionDefaults {-                  name = "baz",-                  parameters =-                    ( [ Parameter AST.i32 (UnName 0) []-                      , Parameter AST.double "arg" []-                      , Parameter AST.i32 (UnName 1) []-                      , Parameter AST.double "arg1" []]-                    , False),-                  returnType = AST.double,-                  basicBlocks =-                    [ BasicBlock-                        (UnName 2)-                        []-                        (Do-                           (Switch-                             (LocalReference AST.i32 (UnName 1))-                             (UnName 3)-                             [ ( C.Int 32 0, UnName 4), ( C.Int 32 1, UnName 7) ] []))-                    , BasicBlock-                        (UnName 3)-                        []-                        (Do (Br (UnName 4) []))-                    , BasicBlock-                        (UnName 4)-                        [ "arg2" := fadd (LocalReference AST.double "arg") f10-                        , UnName 5 := fadd (LocalReference AST.double "arg2") (LocalReference AST.double "arg2")-                        , UnName 6 := Select {-                            condition' = ConstantOperand (C.Int 1 0),-                            trueValue = LocalReference AST.double "arg2",-                            falseValue = LocalReference AST.double (UnName 5),-                            metadata = []-                          }-                        ]-                        (Do (Ret Nothing []))-                    , BasicBlock-                        (UnName 7)-                        [ UnName 8 := GetElementPtr {-                            inBounds = False,-                            address = ConstantOperand (C.Null (AST.ptr (AST.ptr (AST.ptr AST.i32)))),-                            indices =-                              [ ConstantOperand (C.Int 32 10)-                              , ConstantOperand (C.Int 32 20)-                              , ConstantOperand (C.Int 32 30)-                              ],-                            metadata = []-                          }-                        , UnName 9 := GetElementPtr {-                            inBounds = False,-                            address = LocalReference (AST.ptr AST.i32) (UnName 8),-                            indices = [ ConstantOperand (C.Int 32 40) ],-                            metadata = []-                          }-                        ]-                        (Do (Ret Nothing []))-                    ]-                }-              ]-          }--recursiveFunctionCalls :: Expectation-recursiveFunctionCalls = do-  m `shouldBe` defaultModule-    { moduleName = "exampleModule"-    , moduleDefinitions =-      [ GlobalDefinition functionDefaults-          { returnType = AST.i32-          , name = Name "f"-          , parameters = ([Parameter AST.i32 "a" []], False)-          , basicBlocks =-              [ BasicBlock (Name "entry")-                 [ UnName 0 := Call-                    { tailCallKind = Nothing-                    , callingConvention = CC.C-                    , returnAttributes = []-                    , I.function =-                        Right (ConstantOperand (C.GlobalReference (AST.ptr (FunctionType AST.i32 [AST.i32] False)) (Name "f")))-                    , arguments = [(LocalReference (IntegerType {typeBits = 32}) (Name "a"),[])]-                    , functionAttributes = []-                    , metadata = []-                    }-                 ]-                 (Do (Ret (Just (LocalReference AST.i32 (UnName 0))) []))-              ]-          }-      ]-    }-  where-    m = buildModule "exampleModule" $ mdo-      f <- function "f" [(AST.i32, "a")] AST.i32 $ \[a] -> mdo-        entry <- block `named` "entry"; do-          c <- call f [(a, [])]-          ret c-      pure ()--callWorksWithConstantGlobals = do-  funcCall `shouldBe` defaultModule-    { moduleName = "exampleModule"-    , moduleDefinitions =-      [ GlobalDefinition functionDefaults {-          returnType = AST.ptr AST.i8,-          name = Name "malloc",-          parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False),-          basicBlocks = []-        }-      , GlobalDefinition functionDefaults {-          returnType = VoidType,-          name = Name "omg",-          parameters = ([],False),-          basicBlocks = [-            BasicBlock (UnName 1) [-              UnName 0 := Call { tailCallKind = Nothing-                , I.function = Right (-                  ConstantOperand (-                    C.GlobalReference-                      (AST.ptr $ FunctionType {resultType = AST.ptr $ IntegerType {typeBits = 8}, argumentTypes = [IntegerType {typeBits = 64}], isVarArg = False})-                      (Name "malloc")-                    )-                  )-                , callingConvention = CC.C-                , returnAttributes = []-                , arguments = [(ConstantOperand (C.Int {C.integerBits = 64, C.integerValue = 10}),[])]-                , functionAttributes = []-                , metadata = []-                }-              ]-              (Do (Unreachable {metadata' = []}))-          ]-        }-      ]-    }--simple :: Module-simple = buildModule "exampleModule" $ mdo--  function "add" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo--    entry <- block `named` "entry"; do-      c <- add a b-      ret c--example :: Module-example = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo--  foo <- function "foo" [] AST.double $ \_ -> mdo-    xxx <- fadd c1 c1 `named` "xxx"--    blk1 <- block `named` "blk"; do-      a <- fadd c1 c1-      b <- fadd a a-      c <- add c2 c2-      br blk2--    blk2 <- block `named` "blk"; do-      a <- fadd c1 c1 `named` "c"-      b <- fadd a a-      br blk3--    blk3 <- block `named` "blk"; do-      l <- phi [(c1, blk1), (c1, blk2), (c1, blk3)] `named` "phi"-      a <- fadd c1 c1-      b <- fadd a a-      retVoid--    pure ()---  function "bar" [] AST.double $ \_ -> mdo--    blk3 <- block; do-      a <- fadd c1 c1-      b <- fadd a a-      retVoid--    pure ()--  function "baz" [(AST.i32, NoParameterName), (AST.double, "arg"), (AST.i32, NoParameterName), (AST.double, "arg")] AST.double $ \[rrr, arg, arg2, arg3] -> mdo--    switch arg2 blk1 [(C.Int 32 0, blk2), (C.Int 32 1, blk3)]--    blk1 <- block; do-      br blk2--    blk2 <- block; do-      a <- fadd arg c1 `named` "arg"-      b <- fadd a a-      select (cons $ C.Int 1 0) a b-      retVoid--    blk3 <- block; do-      let nul = cons $ C.Null $ AST.ptr $ AST.ptr $ AST.ptr $ IntegerType 32-      addr <- gep nul [cons $ C.Int 32 10, cons $ C.Int 32 20, cons $ C.Int 32 30]-      addr' <- gep addr [cons $ C.Int 32 40]-      retVoid--    pure ()-  where-    mkModule ds = defaultModule { moduleName = "exampleModule", moduleDefinitions = ds }-    cons = ConstantOperand--funcCall :: Module-funcCall = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo-  extern "malloc" [AST.i64] (AST.ptr AST.i8)--  let mallocTy = AST.ptr $ AST.FunctionType (AST.ptr AST.i8) [AST.i64] False--  function "omg" [] (AST.void) $ \_ -> do-    size <- int64 10-    call (ConstantOperand $ C.GlobalReference mallocTy "malloc") [(size, [])]-    unreachable-  where-  mkModule ds = defaultModule { moduleName = "exampleModule", moduleDefinitions = ds }--c1 :: Operand-c1 = ConstantOperand $ C.Float (F.Double 10)--c2 :: Operand-c2 = ConstantOperand $ C.Int 32 10

@@ -0,0 +1,329 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+module LLVM.Test.IRBuilder+  ( tests+  ) where++import           Test.Tasty+import           Test.Tasty.HUnit++import           LLVM.AST hiding (function)+import qualified LLVM.AST.Constant as C+import qualified LLVM.AST.Float as F+import           LLVM.AST.Global (basicBlocks, name, parameters, returnType)+import qualified LLVM.AST.Type as AST+import qualified LLVM.AST.CallingConvention as CC+import qualified LLVM.AST.Instruction as I (function)+import           LLVM.IRBuilder++tests :: TestTree+tests =+  testGroup "IRBuilder" [+    testGroup "module builder"+      [ testCase "builds the simple module" $+        simple @?=+        defaultModule {+          moduleName = "exampleModule",+          moduleDefinitions =+            [ GlobalDefinition functionDefaults {+                name = "add",+                parameters =+                  ( [ Parameter AST.i32 "a" []+                    , Parameter AST.i32 "b" []+                    ]+                  , False+                  ),+                returnType = AST.i32,+                basicBlocks =+                  [ BasicBlock+                      "entry"+                      [ UnName 0 := Add {+                          operand0 = LocalReference AST.i32 "a",+                          operand1 = LocalReference AST.i32 "b",+                          nsw = False,+                          nuw = False,+                          metadata = []+                        }+                      ]+                      (Do (Ret (Just (LocalReference AST.i32 (UnName 0))) []))+                  ]+              }+            ]+        }+      , testCase "calls constant globals" callWorksWithConstantGlobals+      , testCase "supports recursive function calls" recursiveFunctionCalls+      , testCase "builds the example" $ do+        let f10 = ConstantOperand (C.Float (F.Double 10))+            fadd a b = FAdd { operand0 = a, operand1 = b, fastMathFlags = noFastMathFlags, metadata = [] }+            add a b = Add { operand0 = a, operand1 = b, nsw = False, nuw = False, metadata = [] }+        example @?=+          defaultModule {+            moduleName = "exampleModule",+            moduleDefinitions =+              [ GlobalDefinition functionDefaults {+                  name = "foo",+                  returnType = AST.double,+                  basicBlocks =+                    [ BasicBlock (UnName 0) [ "xxx" := fadd f10 f10]+                        (Do (Ret Nothing []))+                    , BasicBlock+                        "blk"+                        [ UnName 1 := fadd f10 f10+                        , UnName 2 := fadd (LocalReference AST.double (UnName 1)) (LocalReference AST.double (UnName 1))+                        , UnName 3 := add (ConstantOperand (C.Int 32 10)) (ConstantOperand (C.Int 32 10))+                        ]+                        (Do (Br "blk1" []))+                    , BasicBlock+                        "blk1"+                        [ "c" := fadd f10 f10+                        , UnName 4 := fadd (LocalReference AST.double "c") (LocalReference AST.double "c")+                        ]+                        (Do (Br "blk2" []))+                    , BasicBlock+                        "blk2"+                        [ "phi" :=+                            Phi+                              AST.double+                              [ ( f10, "blk" )+                              , ( f10, "blk1" )+                              , ( f10, "blk2" )+                              ]+                              []+                        , UnName 5 := fadd f10 f10+                        , UnName 6 := fadd (LocalReference AST.double (UnName 5)) (LocalReference AST.double (UnName 5))+                        ]+                        (Do (Ret Nothing []))+                    ]+                }+              , GlobalDefinition functionDefaults {+                  name = "bar",+                  returnType = AST.double,+                  basicBlocks =+                    [ BasicBlock+                       (UnName 0)+                       [ UnName 1 := fadd f10 f10+                       , UnName 2 := fadd (LocalReference AST.double (UnName 1)) (LocalReference AST.double (UnName 1))+                       ]+                       (Do (Ret Nothing []))+                    ]+                }+              , GlobalDefinition functionDefaults {+                  name = "baz",+                  parameters =+                    ( [ Parameter AST.i32 (UnName 0) []+                      , Parameter AST.double "arg" []+                      , Parameter AST.i32 (UnName 1) []+                      , Parameter AST.double "arg1" []]+                    , False),+                  returnType = AST.double,+                  basicBlocks =+                    [ BasicBlock+                        (UnName 2)+                        []+                        (Do+                           (Switch+                             (LocalReference AST.i32 (UnName 1))+                             (UnName 3)+                             [ ( C.Int 32 0, UnName 4), ( C.Int 32 1, UnName 7) ] []))+                    , BasicBlock+                        (UnName 3)+                        []+                        (Do (Br (UnName 4) []))+                    , BasicBlock+                        (UnName 4)+                        [ "arg2" := fadd (LocalReference AST.double "arg") f10+                        , UnName 5 := fadd (LocalReference AST.double "arg2") (LocalReference AST.double "arg2")+                        , UnName 6 := Select {+                            condition' = ConstantOperand (C.Int 1 0),+                            trueValue = LocalReference AST.double "arg2",+                            falseValue = LocalReference AST.double (UnName 5),+                            metadata = []+                          }+                        ]+                        (Do (Ret Nothing []))+                    , BasicBlock+                        (UnName 7)+                        [ UnName 8 := GetElementPtr {+                            inBounds = False,+                            address = ConstantOperand (C.Null (AST.ptr (AST.ptr (AST.ptr AST.i32)))),+                            indices =+                              [ ConstantOperand (C.Int 32 10)+                              , ConstantOperand (C.Int 32 20)+                              , ConstantOperand (C.Int 32 30)+                              ],+                            metadata = []+                          }+                        , UnName 9 := GetElementPtr {+                            inBounds = False,+                            address = LocalReference (AST.ptr AST.i32) (UnName 8),+                            indices = [ ConstantOperand (C.Int 32 40) ],+                            metadata = []+                          }+                        ]+                        (Do (Ret Nothing []))+                    ]+                }+              ]+          }+      ]+  ]++recursiveFunctionCalls :: Assertion+recursiveFunctionCalls = do+  m @?= defaultModule+    { moduleName = "exampleModule"+    , moduleDefinitions =+      [ GlobalDefinition functionDefaults+          { returnType = AST.i32+          , name = Name "f"+          , parameters = ([Parameter AST.i32 "a" []], False)+          , basicBlocks =+              [ BasicBlock (Name "entry")+                 [ UnName 0 := Call+                    { tailCallKind = Nothing+                    , callingConvention = CC.C+                    , returnAttributes = []+                    , I.function =+                        Right (ConstantOperand (C.GlobalReference (AST.ptr (FunctionType AST.i32 [AST.i32] False)) (Name "f")))+                    , arguments = [(LocalReference (IntegerType {typeBits = 32}) (Name "a"),[])]+                    , functionAttributes = []+                    , metadata = []+                    }+                 ]+                 (Do (Ret (Just (LocalReference AST.i32 (UnName 0))) []))+              ]+          }+      ]+    }+  where+    m = buildModule "exampleModule" $ mdo+      f <- function "f" [(AST.i32, "a")] AST.i32 $ \[a] -> mdo+        entry <- block `named` "entry"; do+          c <- call f [(a, [])]+          ret c+      pure ()++callWorksWithConstantGlobals :: Assertion+callWorksWithConstantGlobals = do+  funcCall @?= defaultModule+    { moduleName = "exampleModule"+    , moduleDefinitions =+      [ GlobalDefinition functionDefaults {+          returnType = AST.ptr AST.i8,+          name = Name "malloc",+          parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False),+          basicBlocks = []+        }+      , GlobalDefinition functionDefaults {+          returnType = VoidType,+          name = Name "omg",+          parameters = ([],False),+          basicBlocks = [+            BasicBlock (UnName 0) [+              UnName 1 := Call { tailCallKind = Nothing+                , I.function = Right (+                  ConstantOperand (+                    C.GlobalReference+                      (AST.ptr $ FunctionType {resultType = AST.ptr $ IntegerType {typeBits = 8}, argumentTypes = [IntegerType {typeBits = 64}], isVarArg = False})+                      (Name "malloc")+                    )+                  )+                , callingConvention = CC.C+                , returnAttributes = []+                , arguments = [(ConstantOperand (C.Int {C.integerBits = 64, C.integerValue = 10}),[])]+                , functionAttributes = []+                , metadata = []+                }+              ]+              (Do (Unreachable {metadata' = []}))+          ]+        }+      ]+    }++simple :: Module+simple = buildModule "exampleModule" $ mdo++  function "add" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo++    entry <- block `named` "entry"; do+      c <- add a b+      ret c++example :: Module+example = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo++  foo <- function "foo" [] AST.double $ \_ -> mdo+    xxx <- fadd c1 c1 `named` "xxx"++    blk1 <- block `named` "blk"; do+      a <- fadd c1 c1+      b <- fadd a a+      c <- add c2 c2+      br blk2++    blk2 <- block `named` "blk"; do+      a <- fadd c1 c1 `named` "c"+      b <- fadd a a+      br blk3++    blk3 <- block `named` "blk"; do+      l <- phi [(c1, blk1), (c1, blk2), (c1, blk3)] `named` "phi"+      a <- fadd c1 c1+      b <- fadd a a+      retVoid++    pure ()+++  function "bar" [] AST.double $ \_ -> mdo++    blk3 <- block; do+      a <- fadd c1 c1+      b <- fadd a a+      retVoid++    pure ()++  function "baz" [(AST.i32, NoParameterName), (AST.double, "arg"), (AST.i32, NoParameterName), (AST.double, "arg")] AST.double $ \[rrr, arg, arg2, arg3] -> mdo++    switch arg2 blk1 [(C.Int 32 0, blk2), (C.Int 32 1, blk3)]++    blk1 <- block; do+      br blk2++    blk2 <- block; do+      a <- fadd arg c1 `named` "arg"+      b <- fadd a a+      select (cons $ C.Int 1 0) a b+      retVoid++    blk3 <- block; do+      let nul = cons $ C.Null $ AST.ptr $ AST.ptr $ AST.ptr $ IntegerType 32+      addr <- gep nul [cons $ C.Int 32 10, cons $ C.Int 32 20, cons $ C.Int 32 30]+      addr' <- gep addr [cons $ C.Int 32 40]+      retVoid++    pure ()+  where+    mkModule ds = defaultModule { moduleName = "exampleModule", moduleDefinitions = ds }+    cons = ConstantOperand++funcCall :: Module+funcCall = mkModule $ execModuleBuilder emptyModuleBuilder $ mdo+  extern "malloc" [AST.i64] (AST.ptr AST.i8)++  let mallocTy = AST.ptr $ AST.FunctionType (AST.ptr AST.i8) [AST.i64] False++  function "omg" [] (AST.void) $ \_ -> do+    size <- int64 10+    call (ConstantOperand $ C.GlobalReference mallocTy "malloc") [(size, [])]+    unreachable+  where+  mkModule ds = defaultModule { moduleName = "exampleModule", moduleDefinitions = ds }++c1 :: Operand+c1 = ConstantOperand $ C.Float (F.Double 10)++c2 :: Operand+c2 = ConstantOperand $ C.Int 32 10

@@ -3,7 +3,9 @@ import Test.Tasty  import qualified LLVM.Test.DataLayout as DataLayout+import qualified LLVM.Test.IRBuilder as IRBuilder -tests = testGroup "llvm-hs" [-    DataLayout.tests+tests = testGroup "llvm-hs"+  [ DataLayout.tests+  , IRBuilder.tests   ]