diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/llvm-hs-pure.cabal b/llvm-hs-pure.cabal --- a/llvm-hs-pure.cabal +++ b/llvm-hs-pure.cabal @@ -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 , 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 . It includes an ADT to represent LLVM IR (). 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 diff --git a/src/LLVM/AST.hs b/src/LLVM/AST.hs --- a/src/LLVM/AST.hs +++ b/src/LLVM/AST.hs @@ -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] diff --git a/src/LLVM/AST/Global.hs b/src/LLVM/AST/Global.hs --- a/src/LLVM/AST/Global.hs +++ b/src/LLVM/AST/Global.hs @@ -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) -- | data Global @@ -31,7 +32,8 @@ initializer :: Maybe Constant, section :: Maybe ShortByteString, comdat :: Maybe ShortByteString, - alignment :: Word32 + alignment :: Word32, + metadata :: [(ShortByteString, MDRef MDNode)] } -- | | 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 = [] } diff --git a/src/LLVM/AST/Instruction.hs b/src/LLVM/AST/Instruction.hs --- a/src/LLVM/AST/Instruction.hs +++ b/src/LLVM/AST/Instruction.hs @@ -19,7 +19,7 @@ -- | -- Metadata can be attached to an instruction -type InstructionMetadata = [(ShortByteString, MetadataNode)] +type InstructionMetadata = [(ShortByteString, MDRef MDNode)] -- | data Terminator diff --git a/src/LLVM/AST/Operand.hs b/src/LLVM/AST/Operand.hs --- a/src/LLVM/AST/Operand.hs +++ b/src/LLVM/AST/Operand.hs @@ -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 + +-- | +data Metadata + = MDString ShortByteString -- ^ + | MDNode (MDRef MDNode) -- ^ + | MDValue Operand -- ^ + 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) --- | -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) + +-- | +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) + -- | -data Metadata - = MDString ShortByteString -- ^ - | MDNode MetadataNode -- ^ - | MDValue Operand -- ^ +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) + +-- | +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) + +-- | +data DIMacroNode + -- | + = DIMacro + { info :: DIMacroInfo + , line :: Word32 + , name :: ShortByteString + , value :: ShortByteString + } + -- | + | DIMacroFile + { line :: Word32 + , file :: MDRef DIFile + , elements :: [MDRef DIMacroNode] + } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +data DINode + = DIEnumerator DIEnumerator + | DIImportedEntity DIImportedEntity + | DIObjCProperty DIObjCProperty + | DIScope DIScope + | DISubrange DISubrange + | DITemplateParameter DITemplateParameter + | DIVariable DIVariable + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +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) + +-- | +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) + +-- | +data DIEnumerator = + Enumerator { value :: Int64, name :: ShortByteString } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +data DISubrange = + Subrange { count :: Int64, lowerBound :: Int64 } + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +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) + +-- | +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) + +-- | +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) + +-- | +data DILocalScope + = DILexicalBlockBase DILexicalBlockBase + | DISubprogram DISubprogram + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +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) + +-- +data DIType + = DIBasicType DIBasicType + | DICompositeType DICompositeType + | DIDerivedType DIDerivedType + | DISubroutineType DISubroutineType + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +data DIBasicType = BasicType + { typeName :: ShortByteString + , sizeInBits :: Word64 + , alignInBits :: Word32 + , typeEncoding :: Maybe Encoding + , typeTag :: BasicTypeTag + } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +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) + +-- | +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) + +-- | +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) + +-- | +data DITemplateParameter + = DITemplateTypeParameter + { name :: ShortByteString + , type' :: MDRef DIType + } + -- ^ + | DITemplateValueParameter + { name :: ShortByteString + , type' :: MDRef DIType + , value :: Metadata + , tag :: TemplateValueParameterTag + } + -- ^ + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +data DILexicalBlockBase + = DILexicalBlock + { scope :: MDRef DILocalScope + , file :: Maybe (MDRef DIFile) + , line :: Word32 + , column :: Word16 + } + -- ^ + | DILexicalBlockFile + { scope :: MDRef DILocalScope + , file :: Maybe (MDRef DIFile) + , discriminator :: Word32 + } + -- ^ + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +data DIVariable + = DIGlobalVariable DIGlobalVariable + | DILocalVariable DILocalVariable + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | +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) + +-- | +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) diff --git a/src/LLVM/IRBuilder/Instruction.hs b/src/LLVM/IRBuilder/Instruction.hs --- a/src/LLVM/IRBuilder/Instruction.hs +++ b/src/LLVM/IRBuilder/Instruction.hs @@ -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 [] diff --git a/src/LLVM/IRBuilder/Internal/SnocList.hs b/src/LLVM/IRBuilder/Internal/SnocList.hs --- a/src/LLVM/IRBuilder/Internal/SnocList.hs +++ b/src/LLVM/IRBuilder/Internal/SnocList.hs @@ -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) diff --git a/src/LLVM/IRBuilder/Module.hs b/src/LLVM/IRBuilder/Module.hs --- a/src/LLVM/IRBuilder/Module.hs +++ b/src/LLVM/IRBuilder/Module.hs @@ -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 diff --git a/src/LLVM/IRBuilder/Monad.hs b/src/LLVM/IRBuilder/Monad.hs --- a/src/LLVM/IRBuilder/Monad.hs +++ b/src/LLVM/IRBuilder/Monad.hs @@ -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 diff --git a/src/LLVM/Prelude.hs b/src/LLVM/Prelude.hs --- a/src/LLVM/Prelude.hs +++ b/src/LLVM/Prelude.hs @@ -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 ( diff --git a/test/IRBuilder.hs b/test/IRBuilder.hs deleted file mode 100644 --- a/test/IRBuilder.hs +++ /dev/null @@ -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 diff --git a/test/LLVM/Test/IRBuilder.hs b/test/LLVM/Test/IRBuilder.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/IRBuilder.hs @@ -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 diff --git a/test/LLVM/Test/Tests.hs b/test/LLVM/Test/Tests.hs --- a/test/LLVM/Test/Tests.hs +++ b/test/LLVM/Test/Tests.hs @@ -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 ]