From 57e73f3e7a6b1b299ec629db86d204c2b5649f8a Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Mon, 23 Oct 2023 23:02:48 +0100 Subject: [PATCH 1/3] Use llvm-15 and update llvm-hs-pretty --- cabal.project | 12 + cabal.project.freeze | 7 +- vendored/llvm-hs-pretty/src/LLVM/Pretty.hs | 38 +- .../llvm-hs-pretty/src/LLVM/Pretty/Typed.hs | 14 +- vendored/llvm-hs-pure/CHANGELOG.md | 158 ----- vendored/llvm-hs-pure/LICENSE | 30 - vendored/llvm-hs-pure/Setup.hs | 2 - vendored/llvm-hs-pure/default.nix | 20 - vendored/llvm-hs-pure/llvm-hs-pure.cabal | 107 --- vendored/llvm-hs-pure/src/LLVM/AST.hs | 89 --- .../llvm-hs-pure/src/LLVM/AST/AddrSpace.hs | 8 - .../llvm-hs-pure/src/LLVM/AST/Attribute.hs | 19 - vendored/llvm-hs-pure/src/LLVM/AST/COMDAT.hs | 13 - .../src/LLVM/AST/CallingConvention.hs | 50 -- .../llvm-hs-pure/src/LLVM/AST/Constant.hs | 247 ------- vendored/llvm-hs-pure/src/LLVM/AST/DLL.hs | 10 - .../llvm-hs-pure/src/LLVM/AST/DataLayout.hs | 76 --- vendored/llvm-hs-pure/src/LLVM/AST/Float.hs | 18 - .../src/LLVM/AST/FloatingPointPredicate.hs | 27 - .../src/LLVM/AST/FunctionAttribute.hs | 59 -- vendored/llvm-hs-pure/src/LLVM/AST/Global.hs | 141 ---- .../src/LLVM/AST/InlineAssembly.hs | 27 - .../llvm-hs-pure/src/LLVM/AST/Instruction.hs | 468 ------------- .../src/LLVM/AST/IntegerPredicate.hs | 21 - vendored/llvm-hs-pure/src/LLVM/AST/Linkage.hs | 19 - vendored/llvm-hs-pure/src/LLVM/AST/Name.hs | 45 -- vendored/llvm-hs-pure/src/LLVM/AST/Operand.hs | 554 --------------- .../src/LLVM/AST/ParameterAttribute.hs | 33 - .../llvm-hs-pure/src/LLVM/AST/RMWOperation.hs | 22 - .../src/LLVM/AST/ThreadLocalStorage.hs | 12 - vendored/llvm-hs-pure/src/LLVM/AST/Type.hs | 102 --- vendored/llvm-hs-pure/src/LLVM/AST/Typed.hs | 208 ------ .../llvm-hs-pure/src/LLVM/AST/Visibility.hs | 8 - vendored/llvm-hs-pure/src/LLVM/DataLayout.hs | 127 ---- vendored/llvm-hs-pure/src/LLVM/IRBuilder.hs | 8 - .../src/LLVM/IRBuilder/Constant.hs | 41 -- .../src/LLVM/IRBuilder/Instruction.hs | 432 ------------ .../src/LLVM/IRBuilder/Internal/SnocList.hs | 22 - .../llvm-hs-pure/src/LLVM/IRBuilder/Module.hs | 250 ------- .../llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs | 299 --------- vendored/llvm-hs-pure/src/LLVM/Prelude.hs | 68 -- vendored/llvm-hs-pure/src/LLVM/Triple.hs | 380 ----------- .../llvm-hs-pure/test/LLVM/Test/DataLayout.hs | 120 ---- .../llvm-hs-pure/test/LLVM/Test/IRBuilder.hs | 635 ------------------ vendored/llvm-hs-pure/test/LLVM/Test/Tests.hs | 11 - vendored/llvm-hs-pure/test/Test.hs | 4 - 46 files changed, 45 insertions(+), 5016 deletions(-) delete mode 100644 vendored/llvm-hs-pure/CHANGELOG.md delete mode 100644 vendored/llvm-hs-pure/LICENSE delete mode 100644 vendored/llvm-hs-pure/Setup.hs delete mode 100644 vendored/llvm-hs-pure/default.nix delete mode 100644 vendored/llvm-hs-pure/llvm-hs-pure.cabal delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/AddrSpace.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Attribute.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/COMDAT.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/CallingConvention.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Constant.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/DLL.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/DataLayout.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Float.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/FloatingPointPredicate.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Global.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/InlineAssembly.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Instruction.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/IntegerPredicate.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Linkage.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Name.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Operand.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/RMWOperation.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/ThreadLocalStorage.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Type.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Typed.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/AST/Visibility.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/DataLayout.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/IRBuilder.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/IRBuilder/Internal/SnocList.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/Prelude.hs delete mode 100644 vendored/llvm-hs-pure/src/LLVM/Triple.hs delete mode 100644 vendored/llvm-hs-pure/test/LLVM/Test/DataLayout.hs delete mode 100644 vendored/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs delete mode 100644 vendored/llvm-hs-pure/test/LLVM/Test/Tests.hs delete mode 100644 vendored/llvm-hs-pure/test/Test.hs diff --git a/cabal.project b/cabal.project index c179e8f50..502cb6444 100644 --- a/cabal.project +++ b/cabal.project @@ -7,6 +7,18 @@ packages: with-compiler: ghc-9.6.3 +source-repository-package + type: git + location: https://github.com/llvm-hs/llvm-hs.git + tag: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76 + subdir: llvm-hs + +source-repository-package + type: git + location: https://github.com/llvm-hs/llvm-hs.git + tag: 5bca2c1a2a3aa98ecfb19181e7a5ebbf3e212b76 + subdir: llvm-hs-pure + package diagnose flags: +megaparsec-compat diff --git a/cabal.project.freeze b/cabal.project.freeze index c15a036f5..31ece677a 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -73,8 +73,9 @@ constraints: any.Cabal ==3.10.1.0, integer-logarithms -check-bounds +integer-gmp, any.invariant ==0.6.2, any.ki ==1.0.1.1, - any.llvm-hs ==9.0.1, - llvm-hs -debug +shared-llvm, + any.llvm-hs ==15.0.0, + llvm-hs -debug -llvm-with-rtti, + any.llvm-hs-pure ==15.0.0, any.logict ==0.8.1.0, any.megaparsec ==9.6.0, megaparsec -dev, @@ -153,4 +154,4 @@ constraints: any.Cabal ==3.10.1.0, any.wcwidth ==0.0.2, wcwidth -cli +split-base, any.witherable ==0.4.2 -index-state: hackage.haskell.org 2023-10-25T21:01:40Z +index-state: hackage.haskell.org 2023-10-26T12:16:12Z diff --git a/vendored/llvm-hs-pretty/src/LLVM/Pretty.hs b/vendored/llvm-hs-pretty/src/LLVM/Pretty.hs index c3bf92d46..5cb936a48 100644 --- a/vendored/llvm-hs-pretty/src/LLVM/Pretty.hs +++ b/vendored/llvm-hs-pretty/src/LLVM/Pretty.hs @@ -217,9 +217,9 @@ instance Pretty Type where pretty (FloatingPointType PPC_FP128FP) = "ppc_fp128" pretty VoidType = "void" - pretty (PointerType ref (AS.AddrSpace addr)) - | addr == 0 = pretty ref <> "*" - | otherwise = pretty ref <+> "addrspace" <> parens (pretty addr) <> "*" + pretty (PointerType (AS.AddrSpace addr)) + | addr == 0 = "ptr" + | otherwise = "ptr" <+> "addrspace" <> parens (pretty addr) pretty ft@(FunctionType {..}) = pretty resultType <+> ppFunctionArgumentTypes argumentTypes isVarArg pretty (VectorType {..}) = "<" <> pretty nVectorElements <+> "x" <+> pretty elementType <> ">" pretty (StructureType {..}) = if isPacked @@ -307,6 +307,17 @@ ppAttrInGroup = \case instance Pretty FunctionAttribute where pretty = \case + Hot -> "hot" + NoCallback -> "nocallback" + NoCfCheck -> "nocf_check" + NoMerge -> "nomerge" + NoProfile -> "noprofile" + NullPointerIsValid -> "null_pointer_is_valid" + OptForFuzzing -> "optforfuzzing" + SanitizeMemTag -> "sanitize_memtag" + ShadowCallStack -> "shadowcallstack" + SpeculativeLoadHardening -> "speculative_load_hardening" + VScaleRange vMin vMax -> "vscale_range" <+> pretty vMin <+> "," <+> pretty vMax NoReturn -> "noreturn" NoUnwind -> "nounwind" FA.ReadNone -> "readnone" @@ -358,18 +369,19 @@ instance Pretty ParameterAttribute where pretty = \case ZeroExt -> "zeroext" SignExt -> "signext" + NoUndef -> "noundef" InReg -> "inreg" - SRet -> "sret" + SRet ty -> "sret" <+> parens (pretty ty) Alignment word -> "align" <+> pretty word NoAlias -> "noalias" - ByVal -> "byval" + ByVal ty -> "byval" <+> parens (pretty ty) NoCapture -> "nocapture" Nest -> "nest" PA.ReadNone -> "readnone" PA.ReadOnly -> "readonly" PA.WriteOnly -> "writeonly" PA.NoFree -> "nofree" - InAlloca -> "inalloca" + InAlloca ty -> "inalloca" <+> parens (pretty ty) NonNull -> "nonnull" Dereferenceable word -> "dereferenceable" <> parens (pretty word) DereferenceableOrNull word -> "dereferenceable_or_null" <> parens (pretty word) @@ -535,7 +547,7 @@ instance Pretty Instruction where Load {..} -> "load" <+> ppMAtomicity maybeAtomicity <+> ppVolatile volatile <+> pretty argTy `cma` ppTyped address <+> ppMOrdering maybeAtomicity <> ppAlign alignment <+> ppInstrMeta metadata where argTy = case typeOf address of - PointerType argTy_ _ -> argTy_ + PointerType _ -> ptr _ -> error "invalid load of non-pointer type. (Malformed AST)" Phi {..} -> "phi" <+> pretty type' <+> commas (fmap phiIncoming incomingValues) <+> ppInstrMeta metadata @@ -1078,7 +1090,7 @@ instance Pretty C.Constant where pretty (C.Float (F.X86_FP80 val _)) = pretty $ pack $ printf "%6.6e" val pretty (C.Float (F.PPC_FP128 val _)) = pretty $ pack $ printf "%6.6e" val - pretty (C.GlobalReference ty nm) = "@" <> pretty nm + pretty (C.GlobalReference nm) = "@" <> pretty nm pretty (C.Vector args) = "<" <+> commas (fmap ppTyped args) <+> ">" pretty (C.Add {..}) = "add" <+> ppTyped operand0 `cma` pretty operand1 @@ -1090,8 +1102,6 @@ instance Pretty C.Constant where pretty (C.And {..}) = "and" <+> ppTyped operand0 `cma` pretty operand1 pretty (C.Or {..}) = "or" <+> ppTyped operand0 `cma` pretty operand1 pretty (C.Xor {..}) = "xor" <+> ppTyped operand0 `cma` pretty operand1 - pretty (C.SDiv {..}) = "sdiv" <+> ppTyped operand0 `cma` pretty operand1 - pretty (C.UDiv {..}) = "udiv" <+> ppTyped operand0 `cma` pretty operand1 pretty (C.SRem {..}) = "srem" <+> ppTyped operand0 `cma` pretty operand1 pretty (C.URem {..}) = "urem" <+> ppTyped operand0 `cma` pretty operand1 @@ -1138,7 +1148,7 @@ instance Pretty C.Constant where pretty C.GetElementPtr {..} = "getelementptr" <+> bounds inBounds <+> parens (commas (pretty argTy : fmap ppTyped (address:indices))) where argTy = case typeOf address of - PointerType argTy_ _ -> argTy_ + PointerType _ -> ptr _ -> error "invalid load of non-pointer type. (Malformed AST)" bounds True = "inbounds" bounds False = mempty @@ -1326,7 +1336,7 @@ ppCall Call { function = Right f,..} ftype = if fnIsVarArg then ppFunctionArgumentTypes fnArgumentTypes fnIsVarArg else mempty - referencedType (PointerType t _) = referencedType t + referencedType (PointerType _) = ptr referencedType t = t tail = case tailCallKind of @@ -1334,7 +1344,7 @@ ppCall Call { function = Right f,..} Just MustTail -> "musttail" Just NoTail -> "notail" Nothing -> mempty -ppCall Call { function = Left (IA.InlineAssembly {..}), ..} +ppCall Call { function = Left (IA.InlineAssembly {type'=_iaType, ..}), ..} = tail <+> "call" <+> pretty callingConvention <+> ppReturnAttributes returnAttributes <+> pretty type' <+> "asm" <+> sideeffect' <+> align' <+> dialect' <+> dquotes (pretty (pack (BL.unpack assembly))) <> "," <+> dquotes (pretty constraints) <> parens (commas $ fmap ppArguments arguments) <+> ppFunctionAttributes functionAttributes @@ -1369,7 +1379,7 @@ ppInvoke Invoke { function' = Right f,..} ftype = if fnIsVarArg then ppFunctionArgumentTypes fnArgumentTypes fnIsVarArg else mempty - referencedType (PointerType t _) = referencedType t + referencedType (PointerType _) = ptr referencedType t = t ppInvoke x = error "Non-callable argument. (Malformed AST)" diff --git a/vendored/llvm-hs-pretty/src/LLVM/Pretty/Typed.hs b/vendored/llvm-hs-pretty/src/LLVM/Pretty/Typed.hs index 2b6e96a43..b0b92c01c 100644 --- a/vendored/llvm-hs-pretty/src/LLVM/Pretty/Typed.hs +++ b/vendored/llvm-hs-pretty/src/LLVM/Pretty/Typed.hs @@ -45,8 +45,8 @@ instance Typed C.Constant where [] -> error "Vectors of size zero are not allowed. (Malformed AST)" (x:_) -> typeOf x typeOf (C.Undef t) = t - typeOf (C.BlockAddress {..}) = ptr i8 - typeOf (C.GlobalReference t _) = t + typeOf (C.BlockAddress {..}) = ptr + typeOf (C.GlobalReference t ) = ptr typeOf (C.Add {..}) = typeOf operand0 typeOf (C.FAdd {..}) = typeOf operand0 typeOf (C.FDiv {..}) = typeOf operand0 @@ -55,8 +55,6 @@ instance Typed C.Constant where typeOf (C.FSub {..}) = typeOf operand0 typeOf (C.Mul {..}) = typeOf operand0 typeOf (C.FMul {..}) = typeOf operand0 - typeOf (C.UDiv {..}) = typeOf operand0 - typeOf (C.SDiv {..}) = typeOf operand0 typeOf (C.URem {..}) = typeOf operand0 typeOf (C.SRem {..}) = typeOf operand0 typeOf (C.Shl {..}) = typeOf operand0 @@ -92,14 +90,12 @@ instance Typed C.Constant where typeOf (C.ShuffleVector {..}) = case (typeOf operand0, typeOf mask) of (VectorType _ t, VectorType m _) -> VectorType m t _ -> error "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)" - typeOf (C.ExtractValue {..}) = extractValueType indices' (typeOf aggregate) - typeOf (C.InsertValue {..}) = typeOf aggregate typeOf (C.TokenNone) = TokenType typeOf (C.AddrSpaceCast {..}) = type' getElementPtrType :: Type -> [C.Constant] -> Type -getElementPtrType ty [] = ptr ty -getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is +getElementPtrType ty [] = ptr +getElementPtrType (PointerType ty ) (_:is) = ptr getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) = getElementPtrType (elTys !! fromIntegral val) is getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is @@ -107,7 +103,7 @@ getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is getElementPtrType _ _ = error "Expecting aggregate type. (Malformed AST)" getElementType :: Type -> Type -getElementType (PointerType t _) = t +getElementType (PointerType t ) = ptr getElementType _ = error $ "Expecting pointer type. (Malformed AST)" extractValueType :: [Word32] -> Type -> Type diff --git a/vendored/llvm-hs-pure/CHANGELOG.md b/vendored/llvm-hs-pure/CHANGELOG.md deleted file mode 100644 index 5342670e8..000000000 --- a/vendored/llvm-hs-pure/CHANGELOG.md +++ /dev/null @@ -1,158 +0,0 @@ - -## 12.0.0 (2021-03-19) - -* Update to LLVM 12.0 -* Eliminate hard-coded assumption of 32-bit `size_t` -* Add a runtime variant of the `LLVM.AST.Constant.sizeof` utility in `LLVM.IRBuilder.Instruction.sizeof`. The size of opaque structure types is unknown until link-time and therefore cannot be computed as a constant. -* Handle type resolution through `NamedTypeReference` correctly: type resolution in LLVM depends on module state by design -* Support the LLVM `NoFree` attribute -* Add support for some more DWARF operators: `DW_OP_bregx` and `DW_OP_push_object_address` - -## 9.1.0 (UNRELEASED) - -* IRBuilder: first emitted terminator (`br`, `condBr`, `ret`, ...) is only - generated in final IR. This allows for greater composition of IR (and matches - with LLVM semantics, since later instructions are unreachable). - -## 9.0.0 (2019-09-06) - -* The functions in `LLVM.IRBuilder.Constant` no longer return a - monadic context. To recover the previous behavior use `pure`. (Thanks to @jfaure) -* `LLVM.IRBuilder.Instruction.globalStringPtr` returns a `Constant` - instead of an `Operand`. (Thanks to @jfaure) -* Fresh name generation in the IRBuilder should be significantly faster (Thanks to @luc-tielen) -* Update to LLVM 9.0 - * The `MainSubprogram` constructor from `DIFlag` has been removed - and a few new flags have been added. - -## 8.0.0 (2019-03-10) - -* Upgrade to LLVM 8 -* Change type of `value` field in `DITemplateValueParameter` to - `Maybe Metadata` to reflect that it can be null. - -## 7.0.0 (2018-09-28) - -* Track type definitions in `MonadModuleBuilder`. This allows us to - automatically resolve `NamedTypeReference`s in `gep` instructions. - Note that type definitions must be defined before they are used - (i.e. `MonadFix` will not behave correctly here). -* Change the type of `gep` in the `IRBuilder` API to require a - `MonadModuleBuilder` constraint. -* Change the type of `typedef` in the `IRBuilder` API to return a - `NamedTypeReference` to the newly defined type. -* Update for LLVM 7.0: - * Add `isUnsigned` field to `DIEnumerator`. - * Change `DISubrange` to use the new `DICount` type instead of an `Int64`. - * Merge `checksum` and `checksumKind` fields of `DIFile` into a - `checksum` field of type `Maybe ChecksumInfo`. - * Rename the `variables` field of `DISubprogram` to `retainedNodes`. - -## 6.2.1 (2018-06-12) - -* Fix type of `shuffleVector` in the IRBuilder API. - -## 6.2.0 (2018-05-08) - -* Remove field prefixes from `DIDerivedType`, `DIBasicType` and - `DISubroutineType` to make the API consistent with the other debug - metadata types. -* Change the type of the scope fields in `DIModule` and `DINamespace` - to `Maybe (MDRef DIScope)` to reflect that they can be optional. - -## 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 - * Add `StrictFP` and `SanitizeHWAddress` function attributes. - * Remove `UnsafeAlgebra` constructor from `FastMathFlags`. - * Add `allowReassoc`, `allowContract` and `approxFunc` fields to `FastMathFlags`. - * Remove `NoFastMathFlags` constructor since it is equivalent to - setting all fields in the `FastMathFlags` record to - `False`. Existing uses of `NoFastMathFlags` can be replaced by the - `noFastMathFlags` value. -* Add `AggregateZero` for zero-initializing structs, arrays and vectors. Previously `Null` - was used for null pointers as well as zero-inializing aggregates. The new behavior reflects - LLVM’s internal representation and the C++-API. Existing uses of `Null` on non-pointer types - must be changed to `AggregateZero`. -* Fix recursive function calls in the `IRBuilder` API. - -## 5.1.2 (2018-01-06) - -* Fixes and enhancements to the IRBuilder - * `sdiv` and `udiv` no longer default to exact. - * Fix type of global references. - * Add more instructions. - - -## 5.1.1 (2017-12-16) - -* Add a completely new API for building modules in a monadic style similar to the IRBuilder provided by LLVM’s C++ API. The modules can be found in `LLVM.IRBuilder`. An example can be found in the readme and in the test suite. -* Add an API for getting the type of LLVM values in - `LLVM.AST.Typed`. This is primarily intended to be used in other - libraries that build upon `llvm-hs-pure` such as `llvm-hs-pretty`. - -## 5.1.0 (2017-10-12) - -### Enhancements - -* Suport string attributes as parameter attributes -* Support more calling conventions -* Support `NoTail` `TailCallKind` - -## 5.0.0 (2017-09-07) - -* Support for LLVM 5.0 - - We only give a summary of the changes affecting the public API of `llvm-hs-pure` here. - Please refer to the official - [release notes for LLVM 5.0](http://releases.llvm.org/5.0.0/docs/ReleaseNotes.html) - for an overview of all changes in LLVM 5.0. - - * The `X86_64_Win64` calling convention is now called `Win64`. - * There is a new `Speculatable` function attribute. - * The `CrossThread` synchronization scope has been removed. There is - now a new `System` synchronization scope. - -## 4.1.0 (2017-05-17) - -* Switch AST to `ByteString`/`ShortByteString` reflecting LLVM’s use - of C-style strings. -* `preferredAlignment` is now a `Word32` instead of `Maybe Word32`. To - recover the old behavior set it to the same value as abiAlignment. -* `GlobalAlias` now expects the element type of a pointer type instead - of the pointer type itself. The address space is passed separately - via the `addrSpace` field. This makes `GlobalAlias` consistent with - `GlobalVariable`. -* The `FloatingPointType` constructor now takes a `FloatingPointType` argument - instead of a width and a `FloatingPointFormat` to more closely match the - LLVM IR language reference. -* The `IsString` instance of `Name` now throws an error on non-ASCII - strings instead of silently discarding the upper bytes. There is - also a new `mkName` function with the same behavior for easier - discoverability. Non-ASCII names need to be encoded using an arbitrary encoding to - to a `ShortByteString` which can then be used as a `Name`. - -## 4.0.0 (initial release, changes in comparison to llvm-general) - -* Move modules from `LLVM.General*` to `LLVM.*` -* Support for LLVM 4.0 -* Improved support for LLVM’s exception handling instructions -* `-fshared-llvm` is now supported on windows (thanks to @RyanGLScott) -* Default to `-fshared-llvm` -* Expose `LLVM.Internal.*` modules. diff --git a/vendored/llvm-hs-pure/LICENSE b/vendored/llvm-hs-pure/LICENSE deleted file mode 100644 index f28ceeb46..000000000 --- a/vendored/llvm-hs-pure/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2013, Benjamin S. Scarlet and Google Inc. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Benjamin S. Scarlet nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/vendored/llvm-hs-pure/Setup.hs b/vendored/llvm-hs-pure/Setup.hs deleted file mode 100644 index 9a994af67..000000000 --- a/vendored/llvm-hs-pure/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/vendored/llvm-hs-pure/default.nix b/vendored/llvm-hs-pure/default.nix deleted file mode 100644 index e7a92bbbf..000000000 --- a/vendored/llvm-hs-pure/default.nix +++ /dev/null @@ -1,20 +0,0 @@ -{ mkDerivation, attoparsec, base, bytestring, containers, mtl -, stdenv, tasty, tasty-hunit, tasty-quickcheck, template-haskell -, transformers, transformers-compat -}: -mkDerivation { - pname = "llvm-hs-pure"; - version = "4.1.0.0"; - src = ./.; - libraryHaskellDepends = [ - attoparsec base bytestring containers mtl template-haskell - transformers transformers-compat - ]; - testHaskellDepends = [ - base containers mtl tasty tasty-hunit tasty-quickcheck transformers - transformers-compat - ]; - homepage = "http://github.com/llvm-hs/llvm-hs/"; - description = "Pure Haskell LLVM functionality (no FFI)"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/vendored/llvm-hs-pure/llvm-hs-pure.cabal b/vendored/llvm-hs-pure/llvm-hs-pure.cabal deleted file mode 100644 index 6781497ec..000000000 --- a/vendored/llvm-hs-pure/llvm-hs-pure.cabal +++ /dev/null @@ -1,107 +0,0 @@ -name: llvm-hs-pure -version: 12.0.0 -license: BSD3 -license-file: LICENSE -author: Anthony Cowley, Stephen Diehl, Moritz Kiefer , Benjamin S. Scarlet -maintainer: Anthony Cowley, Stephen Diehl, Moritz Kiefer -copyright: (c) 2013 Benjamin S. Scarlet and Google Inc. -homepage: http://github.com/llvm-hs/llvm-hs/ -bug-reports: http://github.com/llvm-hs/llvm-hs/issues -build-type: Simple -stability: experimental -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 == 8.8.1 -extra-source-files: CHANGELOG.md - -source-repository head - type: git - location: git://github.com/llvm-hs/llvm-hs.git - branch: llvm-12 - -library - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >= 4.9 && < 5, - attoparsec >= 0.13, - bytestring >= 0.10 && < 0.11, - fail, - transformers >= 0.3 && < 0.6, - mtl >= 2.3.0, - template-haskell >= 2.5.0.0, - containers >= 0.4.2.1, - unordered-containers >= 0.2 - hs-source-dirs: src - default-extensions: - NoImplicitPrelude - TupleSections - DeriveDataTypeable - DeriveGeneric - EmptyDataDecls - FlexibleContexts - FlexibleInstances - StandaloneDeriving - ConstraintKinds - exposed-modules: - LLVM.AST - LLVM.AST.AddrSpace - LLVM.AST.InlineAssembly - LLVM.AST.Attribute - LLVM.AST.ParameterAttribute - LLVM.AST.FunctionAttribute - LLVM.AST.CallingConvention - LLVM.AST.Constant - LLVM.AST.DataLayout - LLVM.AST.Float - LLVM.AST.FloatingPointPredicate - LLVM.AST.Global - LLVM.AST.Instruction - LLVM.AST.IntegerPredicate - LLVM.AST.Linkage - LLVM.AST.Name - LLVM.AST.Operand - LLVM.AST.RMWOperation - LLVM.AST.ThreadLocalStorage - LLVM.AST.Type - LLVM.AST.Typed - LLVM.AST.Visibility - LLVM.AST.DLL - LLVM.AST.COMDAT - LLVM.DataLayout - LLVM.IRBuilder - LLVM.IRBuilder.Constant - LLVM.IRBuilder.Instruction - LLVM.IRBuilder.Internal.SnocList - LLVM.IRBuilder.Module - LLVM.IRBuilder.Monad - LLVM.Prelude - LLVM.Triple - -test-suite test - default-language: Haskell2010 - type: exitcode-stdio-1.0 - build-depends: - base >= 4.9 && < 5, - tasty >= 0.11, - tasty-hunit >= 0.9, - tasty-quickcheck >= 0.8, - llvm-hs-pure, - transformers >= 0.3, - containers >= 0.4.2.1, - mtl >= 2.1 - hs-source-dirs: test - default-extensions: - TupleSections - FlexibleInstances - FlexibleContexts - main-is: Test.hs - other-modules: - LLVM.Test.DataLayout - LLVM.Test.IRBuilder - LLVM.Test.Tests diff --git a/vendored/llvm-hs-pure/src/LLVM/AST.hs b/vendored/llvm-hs-pure/src/LLVM/AST.hs deleted file mode 100644 index d1784cd17..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | This module and descendants define AST data types to represent LLVM code. --- Note that these types are designed for fidelity rather than convenience - if the truth --- of what LLVM supports is less than pretty, so be it. -module LLVM.AST ( - Module(..), defaultModule, - Definition(..), - Global(GlobalVariable, GlobalAlias, Function), - globalVariableDefaults, - globalAliasDefaults, - functionDefaults, - UnnamedAddr(..), - Parameter(..), - BasicBlock(..), - Operand(..), - CallableOperand, - Metadata(..), - MetadataNodeID(..), - MDRef(..), - MDNode(..), - module LLVM.AST.Instruction, - module LLVM.AST.Name, - module LLVM.AST.Type - -- * Overview - -- $overview - - -- * Constructing the AST for an LLVM module - -- $moduleconstruction - ) where - -import LLVM.Prelude - -import LLVM.AST.Name -import LLVM.AST.Type (Type(..), FloatingPointType(..)) -import LLVM.AST.Global -import LLVM.AST.Operand hiding (Module) -import LLVM.AST.Instruction -import LLVM.AST.DataLayout -import qualified LLVM.AST.Attribute as A -import qualified LLVM.AST.COMDAT as COMDAT - -{- $overview - -@llvm-hs-pure@ defines the Haskell AST for representing an LLVM -`Module`. For interacting with the LLVM C/C++ libraries and an -overview of the various libraries in the @llvm-hs@ ecosystem, take a -look at the docs in the @LLVM@ module in @llvm-hs@. - -In addition to constructing the LLVM AST manually, there is also a -monadic IRBuilder interface in `LLVM.IRBuilder`. The IRBuilder will -take care of generating fresh names automatically and generally -reduces the verbosity of using the AST directly. Using -@RecursiveDo/mdo@, it is also capable of handling forward references -automatically. --} - --- | Any thing which can be at the top level of a 'Module' -data Definition - = GlobalDefinition Global - | TypeDefinition Name (Maybe Type) - | MetadataNodeDefinition MetadataNodeID MDNode - | NamedMetadataDefinition ShortByteString [MetadataNodeID] - | ModuleInlineAssembly ByteString - | FunctionAttributes A.GroupID [A.FunctionAttribute] - | COMDAT ShortByteString COMDAT.SelectionKind - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | -data Module = - Module { - moduleName :: ShortByteString, - moduleSourceFileName :: ShortByteString, - -- | a 'DataLayout', if specified, must match that of the eventual code generator - moduleDataLayout :: Maybe DataLayout, - moduleTargetTriple :: Maybe ShortByteString, - moduleDefinitions :: [Definition] - } - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | helper for making 'Module's -defaultModule :: Module -defaultModule = - Module { - moduleName = "", - moduleSourceFileName = "", - moduleDataLayout = Nothing, - moduleTargetTriple = Nothing, - moduleDefinitions = [] - } diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/AddrSpace.hs b/vendored/llvm-hs-pure/src/LLVM/AST/AddrSpace.hs deleted file mode 100644 index d66d97f54..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/AddrSpace.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | Pointers exist in Address Spaces -module LLVM.AST.AddrSpace where - -import LLVM.Prelude - --- | See -data AddrSpace = AddrSpace Word32 - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Attribute.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Attribute.hs deleted file mode 100644 index 464e451f0..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Attribute.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | Module to allow importing 'Attribute' distinctly qualified. --- Before LLVM 3.5, the attributes which could be used on functions --- and those which could be used on parameters were disjoint. In --- LLVM 3.5, two attributes (readonly and readnone) can be used --- in both contexts. Because their interpretation is different in --- the two contexts and only those two attributes can be used in --- both contexts, I've opted to keep the Haskell types for parameter --- and function attributes distinct, but move the two types into --- separate modules so they can have contructors with the same names. -module LLVM.AST.Attribute ( - ParameterAttribute(..), - FunctionAttribute(..), - GroupID(..) - ) where - -import LLVM.AST.ParameterAttribute - hiding (NoFree, ReadNone, ReadOnly, StringAttribute, WriteOnly, - stringAttributeKind, stringAttributeValue) -import LLVM.AST.FunctionAttribute diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/COMDAT.hs b/vendored/llvm-hs-pure/src/LLVM/AST/COMDAT.hs deleted file mode 100644 index d5746665e..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/COMDAT.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | Module to allow importing 'COMDAT.SelectionKind' distinctly qualified. -module LLVM.AST.COMDAT where - -import LLVM.Prelude - --- | -data SelectionKind - = Any - | ExactMatch - | Largest - | NoDuplicates - | SameSize - deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/CallingConvention.hs b/vendored/llvm-hs-pure/src/LLVM/AST/CallingConvention.hs deleted file mode 100644 index 06b25a0c1..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/CallingConvention.hs +++ /dev/null @@ -1,50 +0,0 @@ --- | Module to allow importing 'CallingConvention' distinctly qualified. -module LLVM.AST.CallingConvention where - -import LLVM.Prelude - --- | -data CallingConvention - = C - | Fast - | Cold - | GHC - | HiPE - | WebKit_JS - | AnyReg - | PreserveMost - | PreserveAll - | Swift - | CXX_FastTLS - | X86_StdCall - | X86_FastCall - | ARM_APCS - | ARM_AAPCS - | ARM_AAPCS_VFP - | MSP430_INTR - | X86_ThisCall - | PTX_Kernel - | PTX_Device - | SPIR_FUNC - | SPIR_KERNEL - | Intel_OCL_BI - | X86_64_SysV - | Win64 - | X86_VectorCall - | HHVM - | HHVM_C - | X86_Intr - | AVR_Intr - | AVR_Signal - | AVR_Builtin - | AMDGPU_VS - | AMDGPU_HS - | AMDGPU_GS - | AMDGPU_PS - | AMDGPU_CS - | AMDGPU_Kernel - | X86_RegCall - | MSP430_Builtin - | Numbered Word32 - deriving (Eq, Read, Show, Typeable, Data, Generic) - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Constant.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Constant.hs deleted file mode 100644 index dfab7934e..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Constant.hs +++ /dev/null @@ -1,247 +0,0 @@ --- | A representation of LLVM constants -module LLVM.AST.Constant where - -import LLVM.Prelude - -import Data.Bits ((.|.), (.&.), complement, testBit, shiftL) - -import LLVM.AST.Type -import LLVM.AST.Name -import LLVM.AST.FloatingPointPredicate (FloatingPointPredicate) -import LLVM.AST.IntegerPredicate (IntegerPredicate) -import LLVM.AST.AddrSpace ( AddrSpace(..) ) -import qualified LLVM.AST.Float as F - -{- | - - -N.B. - - -Although constant expressions and instructions have many similarites, there are important -differences - so they're represented using different types in this AST. At the cost of making it -harder to move an code back and forth between being constant and not, this approach embeds more of -the rules of what IR is legal into the Haskell types. --} -data Constant - = Int { integerBits :: Word32, integerValue :: Integer } - | Float { floatValue :: F.SomeFloat } - | Null { constantType :: Type } - | AggregateZero { constantType :: Type } - | Struct { structName :: Maybe Name, isPacked :: Bool, memberValues :: [ Constant ] } - | Array { memberType :: Type, memberValues :: [ Constant ] } - | Vector { memberValues :: [ Constant ] } - | Undef { constantType :: Type } - | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name } - | GlobalReference Type Name - | TokenNone - | Add { - nsw :: Bool, - nuw :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | FAdd { - operand0 :: Constant, - operand1 :: Constant - } - | Sub { - nsw :: Bool, - nuw :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | FSub { - operand0 :: Constant, - operand1 :: Constant - } - | Mul { - nsw :: Bool, - nuw :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | FMul { - operand0 :: Constant, - operand1 :: Constant - } - | UDiv { - exact :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | SDiv { - exact :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | FDiv { - operand0 :: Constant, - operand1 :: Constant - } - | URem { - operand0 :: Constant, - operand1 :: Constant - } - | SRem { - operand0 :: Constant, - operand1 :: Constant - } - | FRem { - operand0 :: Constant, - operand1 :: Constant - } - | Shl { - nsw :: Bool, - nuw :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | LShr { - exact :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | AShr { - exact :: Bool, - operand0 :: Constant, - operand1 :: Constant - } - | And { - operand0 :: Constant, - operand1 :: Constant - } - | Or { - operand0 :: Constant, - operand1 :: Constant - } - | Xor { - operand0 :: Constant, - operand1 :: Constant - } - | GetElementPtr { - inBounds :: Bool, - address :: Constant, - indices :: [Constant] - } - | Trunc { - operand0 :: Constant, - type' :: Type - } - | ZExt { - operand0 :: Constant, - type' :: Type - } - | SExt { - operand0 :: Constant, - type' :: Type - } - | FPToUI { - operand0 :: Constant, - type' :: Type - } - | FPToSI { - operand0 :: Constant, - type' :: Type - } - | UIToFP { - operand0 :: Constant, - type' :: Type - } - | SIToFP { - operand0 :: Constant, - type' :: Type - } - | FPTrunc { - operand0 :: Constant, - type' :: Type - } - | FPExt { - operand0 :: Constant, - type' :: Type - } - | PtrToInt { - operand0 :: Constant, - type' :: Type - } - | IntToPtr { - operand0 :: Constant, - type' :: Type - } - | BitCast { - operand0 :: Constant, - type' :: Type - } - | AddrSpaceCast { - operand0 :: Constant, - type' :: Type - } - | ICmp { - iPredicate :: IntegerPredicate, - operand0 :: Constant, - operand1 :: Constant - } - | FCmp { - fpPredicate :: FloatingPointPredicate, - operand0 :: Constant, - operand1 :: Constant - } - | Select { - condition' :: Constant, - trueValue :: Constant, - falseValue :: Constant - } - | ExtractElement { - vector :: Constant, - index :: Constant - } - | InsertElement { - vector :: Constant, - element :: Constant, - index :: Constant - } - | ShuffleVector { - operand0 :: Constant, - operand1 :: Constant, - mask :: Constant - } - | ExtractValue { - aggregate :: Constant, - indices' :: [Word32] - } - | InsertValue { - aggregate :: Constant, - element :: Constant, - indices' :: [Word32] - } - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - - --- | Since LLVM types don't include signedness, there's ambiguity in interpreting --- an constant as an Integer. The LLVM assembly printer prints integers as signed, but --- cheats for 1-bit integers and prints them as 'true' or 'false'. That way it circuments the --- otherwise awkward fact that a twos complement 1-bit number only has the values -1 and 0. -signedIntegerValue :: Constant -> Integer -signedIntegerValue (Int nBits' bits) = - let nBits = fromIntegral nBits' - in - if bits `testBit` (nBits - 1) then bits .|. (-1 `shiftL` nBits) else bits -signedIntegerValue _ = error "signedIntegerValue is only defined for Int" - --- | This library's conversion from LLVM C++ objects will always produce integer constants --- as unsigned, so this function in many cases is not necessary. However, nothing's to keep --- stop direct construction of an 'Int' with a negative 'integerValue'. There's nothing in principle --- wrong with such a value - it has perfectly good low order bits like any integer, and will be used --- as such, likely producing the intended result if lowered to C++. If, however one wishes to interpret --- an 'Int' of unknown provenance as unsigned, then this function will serve. -unsignedIntegerValue :: Constant -> Integer -unsignedIntegerValue (Int nBits bits) = - bits .&. (complement (-1 `shiftL` (fromIntegral nBits))) -unsignedIntegerValue _ = error "unsignedIntegerValue is only defined for Int" - --- platform independant sizeof: a gep to the end of a nullptr and some bitcasting. -sizeof :: Word32 -> Type -> Constant -sizeof szBits t = PtrToInt szPtr (IntegerType szBits) - where - ptrType = PointerType t (AddrSpace 0) - nullPtr = IntToPtr (Int szBits 0) ptrType - szPtr = GetElementPtr True nullPtr [Int szBits 1] diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/DLL.hs b/vendored/llvm-hs-pure/src/LLVM/AST/DLL.hs deleted file mode 100644 index 926550930..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/DLL.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | Module to allow importing 'DLL.StorageClass' distinctly qualified. -module LLVM.AST.DLL where - -import LLVM.Prelude - --- | -data StorageClass - = Import - | Export - deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/DataLayout.hs b/vendored/llvm-hs-pure/src/LLVM/AST/DataLayout.hs deleted file mode 100644 index 50605b571..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/DataLayout.hs +++ /dev/null @@ -1,76 +0,0 @@ --- | -module LLVM.AST.DataLayout where - -import LLVM.Prelude - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) - -import LLVM.AST.AddrSpace - --- | Little Endian is the one true way :-). Sadly, we must support the infidels. -data Endianness = LittleEndian | BigEndian - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | An AlignmentInfo describes how a given type must and would best be aligned -data AlignmentInfo = AlignmentInfo { - abiAlignment :: Word32, - preferredAlignment :: Word32 - } - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | A type of type for which 'AlignmentInfo' may be specified -data AlignType - = IntegerAlign - | VectorAlign - | FloatAlign - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | A style of name mangling -data Mangling - = ELFMangling - | MIPSMangling - | MachOMangling - | WindowsCOFFMangling - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | a description of the various data layout properties which may be used during --- optimization -data DataLayout = DataLayout { - endianness :: Endianness, - mangling :: Maybe Mangling, - stackAlignment :: Maybe Word32, - pointerLayouts :: Map AddrSpace (Word32, AlignmentInfo), - typeLayouts :: Map (AlignType, Word32) AlignmentInfo, - aggregateLayout :: AlignmentInfo, - nativeSizes :: Maybe (Set Word32) - } - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | a default 'DataLayout' -defaultDataLayout :: Endianness -> DataLayout -defaultDataLayout defaultEndianness = DataLayout { - endianness = defaultEndianness, - mangling = Nothing, - stackAlignment = Nothing, - pointerLayouts = Map.fromList [ - (AddrSpace 0, (64, AlignmentInfo 64 64)) - ], - typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo 8 8), - ((IntegerAlign, 8), AlignmentInfo 8 8), - ((IntegerAlign, 16), AlignmentInfo 16 16), - ((IntegerAlign, 32), AlignmentInfo 32 32), - ((IntegerAlign, 64), AlignmentInfo 32 64), - ((FloatAlign, 16), AlignmentInfo 16 16), - ((FloatAlign, 32), AlignmentInfo 32 32), - ((FloatAlign, 64), AlignmentInfo 64 64), - ((FloatAlign, 128), AlignmentInfo 128 128), - ((VectorAlign, 64), AlignmentInfo 64 64), - ((VectorAlign, 128), AlignmentInfo 128 128) - ], - aggregateLayout = AlignmentInfo 0 64, - nativeSizes = Nothing - } - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Float.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Float.hs deleted file mode 100644 index e050bebc7..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Float.hs +++ /dev/null @@ -1,18 +0,0 @@ --- | This module provides a sub-namespace for a type to support the various sizes of floating point --- numbers LLVM supports. It is most definitely intended to be imported qualified. -module LLVM.AST.Float where - -import LLVM.Prelude - --- | A type summing up the various float types. --- N.B. Note that in the constructors with multiple fields, the lower significance bits are on the right --- - e.g. Quadruple highbits lowbits -data SomeFloat - = Half Word16 - | Single Float - | Double Double - | Quadruple Word64 Word64 - | X86_FP80 Word16 Word64 - | PPC_FP128 Word64 Word64 - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/FloatingPointPredicate.hs b/vendored/llvm-hs-pure/src/LLVM/AST/FloatingPointPredicate.hs deleted file mode 100644 index 6c52d6544..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/FloatingPointPredicate.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Predicates for the 'LLVM.AST.Instruction.FCmp' instruction -module LLVM.AST.FloatingPointPredicate where - -import LLVM.Prelude - --- | -data FloatingPointPredicate - = False - | OEQ - | OGT - | OGE - | OLT - | OLE - | ONE - | ORD - | UNO - | UEQ - | UGT - | UGE - | ULT - | ULE - | UNE - | True - deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) - - - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs b/vendored/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs deleted file mode 100644 index 38974c464..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/FunctionAttribute.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | Module to allow importing 'FunctionAttribute' distinctly qualified. -module LLVM.AST.FunctionAttribute where - -import LLVM.Prelude - --- | -data FunctionAttribute - = AllocSize Word32 (Maybe Word32) -- ^ AllocSize 0 (Just 0) is invalid - | AlwaysInline - | ArgMemOnly - | Builtin - | Cold - | Convergent - | InaccessibleMemOnly - | InaccessibleMemOrArgMemOnly - | InlineHint - | JumpTable - | MinimizeSize - | MustProgress - | Naked - | NoBuiltin - | NoDuplicate - | NoFree - | NoImplicitFloat - | NoInline - | NonLazyBind - | NoRecurse - | NoRedZone - | NoReturn - | NoSync - | NoUnwind - | OptimizeForSize - | OptimizeNone - | ReadNone - | ReadOnly - | ReturnsTwice - | SafeStack - | SanitizeAddress - | SanitizeHWAddress - | SanitizeMemory - | SanitizeThread - | Speculatable - | StackAlignment Word64 - | StackProtect - | StackProtectReq - | StackProtectStrong - | StrictFP - | StringAttribute { - stringAttributeKind :: ShortByteString, - stringAttributeValue :: ShortByteString -- ^ Use "" for no value -- the two are conflated - } - | UWTable - | WillReturn - | WriteOnly - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | -newtype GroupID = GroupID Word - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Global.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Global.hs deleted file mode 100644 index cbf2a4f5c..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Global.hs +++ /dev/null @@ -1,141 +0,0 @@ --- | 'Global's - top-level values in 'Module's - and supporting structures. -module LLVM.AST.Global where - -import LLVM.Prelude - -import LLVM.AST.Name -import LLVM.AST.Type -import LLVM.AST.Constant (Constant) -import LLVM.AST.AddrSpace -import LLVM.AST.Instruction (Named, Instruction, Terminator) -import qualified LLVM.AST.Linkage as L -import qualified LLVM.AST.Visibility as V -import qualified LLVM.AST.DLL as DLL -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 - -- | - = GlobalVariable { - name :: Name, - linkage :: L.Linkage, - visibility :: V.Visibility, - dllStorageClass :: Maybe DLL.StorageClass, - threadLocalMode :: Maybe TLS.Model, - unnamedAddr :: Maybe UnnamedAddr, - isConstant :: Bool, - type' :: Type, - addrSpace :: AddrSpace, - initializer :: Maybe Constant, - section :: Maybe ShortByteString, - comdat :: Maybe ShortByteString, - alignment :: Word32, - metadata :: [(ShortByteString, MDRef MDNode)] - } - -- | - | GlobalAlias { - name :: Name, - linkage :: L.Linkage, - visibility :: V.Visibility, - dllStorageClass :: Maybe DLL.StorageClass, - threadLocalMode :: Maybe TLS.Model, - unnamedAddr :: Maybe UnnamedAddr, - type' :: Type, - addrSpace :: AddrSpace, - aliasee :: Constant - } - -- | - | Function { - linkage :: L.Linkage, - visibility :: V.Visibility, - dllStorageClass :: Maybe DLL.StorageClass, - callingConvention :: CC.CallingConvention, - returnAttributes :: [A.ParameterAttribute], - returnType :: Type, - name :: Name, - parameters :: ([Parameter],Bool), -- ^ snd indicates varargs - functionAttributes :: [Either A.GroupID A.FunctionAttribute], - section :: Maybe ShortByteString, - comdat :: Maybe ShortByteString, - alignment :: Word32, - garbageCollectorName :: Maybe ShortByteString, - prefix :: Maybe Constant, - basicBlocks :: [BasicBlock], - personalityFunction :: Maybe Constant, - metadata :: [(ShortByteString, MDRef MDNode)] - } - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | 'Parameter's for 'Function's -data Parameter = Parameter Type Name [A.ParameterAttribute] - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | --- LLVM code in a function is a sequence of 'BasicBlock's each with a label, --- some instructions, and a terminator. -data BasicBlock = BasicBlock Name [Named Instruction] (Named Terminator) - deriving (Eq, Read, Show, Typeable, Data, Generic) - -data UnnamedAddr = LocalAddr | GlobalAddr - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | helper for making 'GlobalVariable's -globalVariableDefaults :: Global -globalVariableDefaults = - GlobalVariable { - name = error "global variable name not defined", - linkage = L.External, - visibility = V.Default, - dllStorageClass = Nothing, - threadLocalMode = Nothing, - addrSpace = AddrSpace 0, - unnamedAddr = Nothing, - isConstant = False, - type' = error "global variable type not defined", - initializer = Nothing, - section = Nothing, - comdat = Nothing, - alignment = 0, - metadata = [] - } - --- | helper for making 'GlobalAlias's -globalAliasDefaults :: Global -globalAliasDefaults = - GlobalAlias { - name = error "global alias name not defined", - linkage = L.External, - visibility = V.Default, - dllStorageClass = Nothing, - threadLocalMode = Nothing, - unnamedAddr = Nothing, - type' = error "global alias type not defined", - addrSpace = AddrSpace 0, - aliasee = error "global alias aliasee not defined" - } - --- | helper for making 'Function's -functionDefaults :: Global -functionDefaults = - Function { - linkage = L.External, - visibility = V.Default, - dllStorageClass = Nothing, - callingConvention = CC.C, - returnAttributes = [], - returnType = error "function return type not defined", - name = error "function name not defined", - parameters = ([], False), - functionAttributes = [], - section = Nothing, - comdat = Nothing, - alignment = 0, - garbageCollectorName = Nothing, - prefix = Nothing, - basicBlocks = [], - personalityFunction = Nothing, - metadata = [] - } diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/InlineAssembly.hs b/vendored/llvm-hs-pure/src/LLVM/AST/InlineAssembly.hs deleted file mode 100644 index 061f659e6..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/InlineAssembly.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | A representation of an LLVM inline assembly -module LLVM.AST.InlineAssembly where - -import LLVM.Prelude - -import LLVM.AST.Type - --- | the dialect of assembly used in an inline assembly string --- -data Dialect - = ATTDialect - | IntelDialect - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | --- to be used through 'LLVM.AST.Operand.CallableOperand' with a --- 'LLVM.AST.Instruction.Call' instruction -data InlineAssembly - = InlineAssembly { - type' :: Type, - assembly :: ByteString, - constraints :: ShortByteString, - hasSideEffects :: Bool, - alignStack :: Bool, - dialect :: Dialect - } - deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Instruction.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Instruction.hs deleted file mode 100644 index 1b48d8575..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Instruction.hs +++ /dev/null @@ -1,468 +0,0 @@ --- | LLVM instructions --- -module LLVM.AST.Instruction where - -import LLVM.Prelude - -import LLVM.AST.Type -import LLVM.AST.Name -import LLVM.AST.Constant -import LLVM.AST.Operand -import LLVM.AST.IntegerPredicate (IntegerPredicate) -import LLVM.AST.FloatingPointPredicate (FloatingPointPredicate) -import LLVM.AST.RMWOperation (RMWOperation) -import LLVM.AST.CallingConvention (CallingConvention) -import qualified LLVM.AST.ParameterAttribute as PA (ParameterAttribute) -import qualified LLVM.AST.FunctionAttribute as FA (FunctionAttribute, GroupID) - -import Data.List.NonEmpty - --- | --- Metadata can be attached to an instruction -type InstructionMetadata = [(ShortByteString, MDRef MDNode)] - --- | -data Terminator - = Ret { - returnOperand :: Maybe Operand, - metadata' :: InstructionMetadata - } - | CondBr { - condition :: Operand, - trueDest :: Name, - falseDest :: Name, - metadata' :: InstructionMetadata - } - | Br { - dest :: Name, - metadata' :: InstructionMetadata - } - | Switch { - operand0' :: Operand, - defaultDest :: Name, - dests :: [(Constant, Name)], - metadata' :: InstructionMetadata - } - | IndirectBr { - operand0' :: Operand, - possibleDests :: [Name], - metadata' :: InstructionMetadata - } - | Invoke { - callingConvention' :: CallingConvention, - returnAttributes' :: [PA.ParameterAttribute], - function' :: CallableOperand, - arguments' :: [(Operand, [PA.ParameterAttribute])], - functionAttributes' :: [Either FA.GroupID FA.FunctionAttribute], - returnDest :: Name, - exceptionDest :: Name, - metadata' :: InstructionMetadata - } - | Resume { - operand0' :: Operand, - metadata' :: InstructionMetadata - } - | Unreachable { - metadata' :: InstructionMetadata - } - | CleanupRet { - cleanupPad :: Operand, - unwindDest :: Maybe Name, - metadata' :: InstructionMetadata - } - | CatchRet { - catchPad :: Operand, - successor :: Name, - metadata' :: InstructionMetadata - } - | CatchSwitch { - parentPad' :: Operand, - catchHandlers :: NonEmpty Name, - defaultUnwindDest :: Maybe Name, - metadata' :: InstructionMetadata - } - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | -data FastMathFlags - = FastMathFlags { - allowReassoc :: Bool, - noNaNs :: Bool, - noInfs :: Bool, - noSignedZeros :: Bool, - allowReciprocal :: Bool, - allowContract :: Bool, - approxFunc :: Bool - } - deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) - -noFastMathFlags :: FastMathFlags -noFastMathFlags = - FastMathFlags { - allowReassoc = False, - noNaNs = False, - noInfs = False, - noSignedZeros = False, - allowReciprocal = False, - allowContract = False, - approxFunc = False - } - --- | --- -data MemoryOrdering - = Unordered - | Monotonic - | Acquire - | Release - | AcquireRelease - | SequentiallyConsistent - deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) - --- | -data SynchronizationScope - = SingleThread - | System - deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) - --- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction -type Atomicity = (SynchronizationScope, MemoryOrdering) - --- | For the redoubtably complex 'LandingPad' instruction -data LandingPadClause - = Catch Constant - | Filter Constant - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | For the call instruction --- -data TailCallKind = Tail | MustTail | NoTail - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | non-terminator instructions: --- --- --- --- --- -data Instruction - = FNeg { - fastMathFlags :: FastMathFlags, - operand0 :: Operand, - metadata :: InstructionMetadata - } - | Add { - nsw :: Bool, - nuw :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | FAdd { - fastMathFlags :: FastMathFlags, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Sub { - nsw :: Bool, - nuw :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | FSub { - fastMathFlags :: FastMathFlags, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Mul { - nsw :: Bool, - nuw :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | FMul { - fastMathFlags :: FastMathFlags, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | UDiv { - exact :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | SDiv { - exact :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | FDiv { - fastMathFlags :: FastMathFlags, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | URem { - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | SRem { - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | FRem { - fastMathFlags :: FastMathFlags, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Shl { - nsw :: Bool, - nuw :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | LShr { - exact :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | AShr { - exact :: Bool, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | And { - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Or { - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Xor { - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Alloca { - allocatedType :: Type, - numElements :: Maybe Operand, - alignment :: Word32, - metadata :: InstructionMetadata - } - | Load { - volatile :: Bool, - address :: Operand, - maybeAtomicity :: Maybe Atomicity, - alignment :: Word32, - metadata :: InstructionMetadata - } - | Store { - volatile :: Bool, - address :: Operand, - value :: Operand, - maybeAtomicity :: Maybe Atomicity, - alignment :: Word32, - metadata :: InstructionMetadata - } - | GetElementPtr { - inBounds :: Bool, - address :: Operand, - indices :: [Operand], - metadata :: InstructionMetadata - } - | Fence { - atomicity :: Atomicity, - metadata :: InstructionMetadata - } - | CmpXchg { - volatile :: Bool, - address :: Operand, - expected :: Operand, - replacement :: Operand, - atomicity :: Atomicity, - failureMemoryOrdering :: MemoryOrdering, - metadata :: InstructionMetadata - } - | AtomicRMW { - volatile :: Bool, - rmwOperation :: RMWOperation, - address :: Operand, - value :: Operand, - atomicity :: Atomicity, - metadata :: InstructionMetadata - } - | Trunc { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | ZExt { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | SExt { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | FPToUI { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | FPToSI { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | UIToFP { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | SIToFP { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | FPTrunc { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | FPExt { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | PtrToInt { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | IntToPtr { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | BitCast { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | AddrSpaceCast { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | ICmp { - iPredicate :: IntegerPredicate, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | FCmp { - fpPredicate :: FloatingPointPredicate, - operand0 :: Operand, - operand1 :: Operand, - metadata :: InstructionMetadata - } - | Phi { - type' :: Type, - incomingValues :: [ (Operand, Name) ], - metadata :: InstructionMetadata - } - | Freeze { - operand0 :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | Select { - condition' :: Operand, - trueValue :: Operand, - falseValue :: Operand, - metadata :: InstructionMetadata - } - | Call { - tailCallKind :: Maybe TailCallKind, - callingConvention :: CallingConvention, - returnAttributes :: [PA.ParameterAttribute], - function :: CallableOperand, - arguments :: [(Operand, [PA.ParameterAttribute])], - functionAttributes :: [Either FA.GroupID FA.FunctionAttribute], - metadata :: InstructionMetadata - } - | VAArg { - argList :: Operand, - type' :: Type, - metadata :: InstructionMetadata - } - | ExtractElement { - vector :: Operand, - index :: Operand, - metadata :: InstructionMetadata - } - | InsertElement { - vector :: Operand, - element :: Operand, - index :: Operand, - metadata :: InstructionMetadata - } - | ShuffleVector { - operand0 :: Operand, - operand1 :: Operand, - mask :: [Int32], - metadata :: InstructionMetadata - } - | ExtractValue { - aggregate :: Operand, - indices' :: [Word32], - metadata :: InstructionMetadata - } - | InsertValue { - aggregate :: Operand, - element :: Operand, - indices' :: [Word32], - metadata :: InstructionMetadata - } - | LandingPad { - type' :: Type, - cleanup :: Bool, - clauses :: [LandingPadClause], - metadata :: InstructionMetadata - } - | CatchPad { - catchSwitch :: Operand, - args :: [Operand], - metadata :: InstructionMetadata - } - | CleanupPad { - parentPad :: Operand, - args :: [Operand], - metadata :: InstructionMetadata - } - - deriving (Eq, Read, Show, Typeable, Data, Generic) - --- | Instances of instructions may be given a name, allowing their results to be referenced as 'Operand's. --- Sometimes instructions - e.g. a call to a function returning void - don't need names. -data Named a - = Name := a - | Do a - deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/IntegerPredicate.hs b/vendored/llvm-hs-pure/src/LLVM/AST/IntegerPredicate.hs deleted file mode 100644 index 6a127458e..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/IntegerPredicate.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Predicates for the 'LLVM.AST.Instruction.ICmp' instruction -module LLVM.AST.IntegerPredicate where - -import LLVM.Prelude - --- | -data IntegerPredicate - = EQ - | NE - | UGT - | UGE - | ULT - | ULE - | SGT - | SGE - | SLT - | SLE - deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) - - - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Linkage.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Linkage.hs deleted file mode 100644 index dd0f63f59..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Linkage.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | Module to allow importing 'Linkage' distinctly qualified. -module LLVM.AST.Linkage where - -import LLVM.Prelude - --- | -data Linkage - = Private - | Internal - | AvailableExternally - | LinkOnce - | Weak - | Common - | Appending - | ExternWeak - | LinkOnceODR - | WeakODR - | External - deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Name.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Name.hs deleted file mode 100644 index e1ad2f733..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Name.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | Names as used in LLVM IR -module LLVM.AST.Name where - -import LLVM.Prelude -import Data.Char -import Data.String - -{- | -Objects of various sorts in LLVM IR are identified by address in the LLVM C++ API, and -may be given a string name. When printed to (resp. read from) human-readable LLVM assembly, objects without -string names are numbered sequentially (resp. must be numbered sequentially). String names may be quoted, and -are quoted when printed if they would otherwise be misread - e.g. when containing special characters. - -> 7 - -means the seventh unnamed object, while - -> "7" - -means the object named with the string "7". - -This libraries handling of 'UnName's during translation of the AST down into C++ IR is somewhat more -forgiving than the LLVM assembly parser: it does not require that unnamed values be numbered sequentially; -however, the numbers of 'UnName's passed into C++ cannot be preserved in the C++ objects. If the C++ IR is -printed as assembly or translated into a Haskell AST, unnamed nodes will be renumbered sequentially. Thus -unnamed node numbers should be thought of as having any scope limited to the 'LLVM.AST.Module' in -which they are used. --} -data Name - = Name ShortByteString -- ^ a string name - | UnName Word -- ^ a number for a nameless thing - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | Using 'fromString` on non-ASCII strings will throw an error. -instance IsString Name where - fromString s - | all isAscii s = Name (fromString s) - | otherwise = - error ("Only ASCII strings are automatically converted to LLVM names. " - <> "Other strings need to be encoded to a `ShortByteString` using an arbitrary encoding.") - --- | Create a 'Name' based on an ASCII 'String'. --- Non-ASCII strings will throw an error. -mkName :: String -> Name -mkName = fromString diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Operand.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Operand.hs deleted file mode 100644 index 51efed4a8..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Operand.hs +++ /dev/null @@ -1,554 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} --- | A type to represent operands to LLVM 'LLVM.AST.Instruction.Instruction's -module LLVM.AST.Operand -( module LLVM.AST.Operand -) -where - -import LLVM.Prelude - -import LLVM.AST.Name -import LLVM.AST.Constant -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) - --- | `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 - = DW_OP_And - | DW_OP_Bregx - | DW_OP_ConstU Word64 - | DW_OP_Deref - | DW_OP_Div - | DW_OP_Dup - | DwOpFragment DWOpFragment -- ^ Must appear at the end - | DW_OP_Lit0 - | DW_OP_Minus - | DW_OP_Mod - | DW_OP_Mul - | DW_OP_Not - | DW_OP_Or - | DW_OP_Plus - | DW_OP_PlusUConst Word64 - | DW_OP_PushObjectAddress - | DW_OP_Shl - | DW_OP_Shr - | DW_OP_Shra - | DW_OP_StackValue -- ^ Must be the last one or followed by a DW_OP_LLVM_Fragment - | DW_OP_Swap - | DW_OP_XDeref - | DW_OP_Xor - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | -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) - -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) - --- | Inheritance flag -data DIInheritance - = SingleInheritance - | MultipleInheritance - | VirtualInheritance - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -data DIFlag - = Accessibility DIAccessibility - | FwdDecl - | AppleBlock - | ReservedBit4 -- Used to be BlockByRef, can be reused for anything except DICompositeType. - | VirtualFlag - | Artificial - | Explicit - | Prototyped - | ObjcClassComplete - | ObjectPointer - | Vector - | StaticMember - | LValueReference - | RValueReference - | InheritanceFlag DIInheritance - | IntroducedVirtual - | BitField - | NoReturn - | TypePassByValue - | TypePassByReference - | EnumClass - | Thunk - | NonTrivial - | BigEndian - | LittleEndian - | AllCallsDescribed - 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, isUnsigned :: Bool, name :: ShortByteString } - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | -data DISubrange = Subrange - { count :: DICount - , lowerBound :: Maybe DIBound - , upperBound :: Maybe DIBound - , stride :: Maybe DIBound - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -data DICount - = DICountConstant Int64 - | DICountVariable (MDRef DIVariable) - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -data DIBound - = DIBoundConstant Int64 - | DIBoundVariable (MDRef DIVariable) - | DIBoundExpression (MDRef DIExpression) - 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 :: Maybe (MDRef DIScope) - , name :: ShortByteString - , configurationMacros :: ShortByteString - , includePath :: ShortByteString - , apiNotesFile :: ShortByteString - , lineNo :: Word32 - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -data DINamespace = Namespace - { name :: ShortByteString - , scope :: Maybe (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 DebugNameTableKind = NameTableKindDefault | NameTableKindGNU | NameTableKindNone - 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 - , nameTableKind :: DebugNameTableKind - , rangesBaseAddress :: Bool - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | -data DIFile = File - { filename :: ShortByteString - , directory :: ShortByteString - , checksum :: Maybe ChecksumInfo - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -data ChecksumInfo = ChecksumInfo - { checksumKind :: ChecksumKind - , checksumValue :: ShortByteString - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - -data ChecksumKind = 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) - , retainedNodes :: [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 - { name :: ShortByteString - , sizeInBits :: Word64 - , alignInBits :: Word32 - , encoding :: Maybe Encoding - , tag :: BasicTypeTag - , flags :: [DIFlag] - } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | -data DISubroutineType = SubroutineType - { flags :: [DIFlag] - , cc :: Word8 - , typeArray :: [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 - { tag :: DerivedTypeTag - , name :: ShortByteString - , file :: Maybe (MDRef DIFile) - , line :: Word32 - , scope :: Maybe (MDRef DIScope) - , baseType :: Maybe (MDRef DIType) - -- ^ This can be `Nothing` to represent @void *@ - , sizeInBits :: Word64 - , alignInBits :: Word32 - , offsetInBits :: Word64 - , addressSpace :: Maybe Word32 - , flags :: [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 - | UTFEncoding - 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' :: Maybe (MDRef DIType) - -- ^ For DITemplateTypeParameter this field is required, - -- for DITemplateValueParameter it is optional. - } - -- ^ - | DITemplateValueParameter - { name :: ShortByteString - , type' :: Maybe (MDRef DIType) - , value :: Maybe 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) - , templateParams :: [MDRef DITemplateParameter] - , 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/vendored/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs b/vendored/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs deleted file mode 100644 index a05873ce4..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/ParameterAttribute.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | Module to allow importing 'ParameterAttribute' distinctly qualified. -module LLVM.AST.ParameterAttribute where - -import LLVM.Prelude - --- | -data ParameterAttribute - = Alignment Word64 - | ByVal - | Dereferenceable Word64 - | DereferenceableOrNull Word64 - | ImmArg - | InAlloca - | InReg - | Nest - | NoAlias - | NoCapture - | NoFree - | NonNull - | ReadNone - | ReadOnly - | Returned - | SignExt - | SRet - | SwiftError - | SwiftSelf - | WriteOnly - | StringAttribute { - stringAttributeKind :: ShortByteString, - stringAttributeValue :: ShortByteString -- ^ Use "" for no value -- the two are conflated - } - | ZeroExt - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/RMWOperation.hs b/vendored/llvm-hs-pure/src/LLVM/AST/RMWOperation.hs deleted file mode 100644 index 72d8b08c1..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/RMWOperation.hs +++ /dev/null @@ -1,22 +0,0 @@ --- | Operations for the 'LLVM.AST.Instruction.AtomicRMW' instruction -module LLVM.AST.RMWOperation where - -import LLVM.Prelude - --- | -data RMWOperation - = Xchg - | Add - | Sub - | And - | Nand - | Or - | Xor - | Max - | Min - | UMax - | UMin - | FAdd - | FSub - deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/ThreadLocalStorage.hs b/vendored/llvm-hs-pure/src/LLVM/AST/ThreadLocalStorage.hs deleted file mode 100644 index 1ad9e08b2..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/ThreadLocalStorage.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | Module to allow importing 'ThreadLocalStorage.Model' distinctly qualified. -module LLVM.AST.ThreadLocalStorage where - -import LLVM.Prelude - --- | -data Model - = GeneralDynamic - | LocalDynamic - | InitialExec - | LocalExec - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Type.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Type.hs deleted file mode 100644 index 686ce5870..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Type.hs +++ /dev/null @@ -1,102 +0,0 @@ --- | A representation of an LLVM type -module LLVM.AST.Type where - -import LLVM.Prelude - -import LLVM.AST.AddrSpace -import LLVM.AST.Name - --- | LLVM supports some special formats floating point format. This type is to distinguish those format. Also see -data FloatingPointType - = HalfFP -- ^ 16-bit floating point value - | FloatFP -- ^ 32-bit floating point value - | DoubleFP -- ^ 64-bit floating point value - | FP128FP -- ^ 128-bit floating point value (112-bit mantissa) - | X86_FP80FP -- ^ 80-bit floating point value (X87) - | PPC_FP128FP -- ^ 128-bit floating point value (two 64-bits) - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | -data Type - -- | - = VoidType - -- | - | IntegerType { typeBits :: Word32 } - -- | - | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace } - -- | - | FloatingPointType { floatingPointType :: FloatingPointType } - -- | - | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool } - -- | - | VectorType { nVectorElements :: Word32, elementType :: Type } - -- | - | StructureType { isPacked :: Bool, elementTypes :: [Type] } - -- | - | ArrayType { nArrayElements :: Word64, elementType :: Type } - -- | - | NamedTypeReference Name - -- | - | MetadataType -- only to be used as a parameter type for a few intrinsics - -- | - | LabelType -- only to be used as the type of block names - -- | - | TokenType - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | An abbreviation for 'VoidType' -void :: Type -void = VoidType - --- | An abbreviation for 'IntegerType' 1 -i1 :: Type -i1 = IntegerType 1 - --- | An abbreviation for 'IntegerType' 8 -i8 :: Type -i8 = IntegerType 8 - --- | An abbreviation for 'IntegerType' 16 -i16 :: Type -i16 = IntegerType 16 - --- | An abbreviation for 'IntegerType' 32 -i32 :: Type -i32 = IntegerType 32 - --- | An abbreviation for 'IntegerType' 64 -i64 :: Type -i64 = IntegerType 64 - --- | An abbreviation for 'IntegerType' 128 -i128 :: Type -i128 = IntegerType 128 - --- | An abbreviation for 'PointerType' t ('AddrSpace' 0) -ptr :: Type -> Type -ptr t = PointerType t (AddrSpace 0) - --- | An abbreviation for 'FloatingPointType' 'HalfFP' -half :: Type -half = FloatingPointType HalfFP - --- | An abbreviation for 'FloatingPointType' 'FloatFP' -float :: Type -float = FloatingPointType FloatFP - --- | An abbreviation for 'FloatingPointType' 'DoubleFP' -double :: Type -double = FloatingPointType DoubleFP - --- | An abbreviation for 'FloatingPointType' 'FP128FP' -fp128 :: Type -fp128 = FloatingPointType FP128FP - --- | An abbreviation for 'FloatingPointType' 'X86_FP80FP' -x86_fp80 :: Type -x86_fp80 = FloatingPointType X86_FP80FP - --- | An abbreviation for 'FloatingPointType' 'PPC_FP128FP' -ppc_fp128 :: Type -ppc_fp128 = FloatingPointType PPC_FP128FP - diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Typed.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Typed.hs deleted file mode 100644 index 00c64aebb..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Typed.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Querying the type of LLVM expressions -module LLVM.AST.Typed ( - Typed(..), - getElementType, - indexTypeByConstants, - indexTypeByOperands, - extractValueType, -) where - -import LLVM.Prelude - -import Control.Monad.State (gets) -import qualified Data.Map.Lazy as Map -import qualified Data.Either as Either -import GHC.Stack - -import LLVM.AST -import LLVM.AST.Global -import LLVM.AST.Type - -import LLVM.IRBuilder.Module - -import qualified LLVM.AST.Constant as C -import qualified LLVM.AST.Float as F - -class Typed a where - typeOf :: (HasCallStack, MonadModuleBuilder m) => a -> m (Either String Type) - -instance Typed Operand where - typeOf (LocalReference t _) = return $ Right t - typeOf (ConstantOperand c) = typeOf c - typeOf _ = return $ Right MetadataType - -instance Typed CallableOperand where - typeOf (Right op) = typeOf op - typeOf (Left _) = return $ Left "typeOf inline assembler is not defined. (Malformed AST)" - -instance Typed C.Constant where - typeOf (C.Int bits _) = return $ Right $ IntegerType bits - typeOf (C.Float t) = typeOf t - typeOf (C.Null t) = return $ Right t - typeOf (C.AggregateZero t) = return $ Right t - typeOf (C.Struct {..}) = case structName of - Nothing -> do - mvtys <- mapM typeOf memberValues - case (all Either.isRight mvtys) of - True -> return $ Right $ StructureType isPacked $ Either.rights mvtys - False -> do - let (Left s) = head $ filter Either.isLeft mvtys - return $ Left $ "Could not deduce type for struct field: " ++ s - Just sn -> return $ Right $ NamedTypeReference sn - typeOf (C.Array {..}) = return $ Right $ ArrayType (fromIntegral $ length memberValues) memberType - typeOf (C.Vector {..}) = case memberValues of - [] -> return $ Left "Vectors of size zero are not allowed. (Malformed AST)" - (x:_) -> do - t <- typeOf x - case t of - (Left _) -> return t - (Right t') -> return $ Right $ VectorType (fromIntegral $ length memberValues) t' - - typeOf (C.Undef t) = return $ Right t - typeOf (C.BlockAddress {}) = return $ Right $ ptr i8 - typeOf (C.GlobalReference t _) = return $ Right t - typeOf (C.Add {..}) = typeOf operand0 - typeOf (C.FAdd {..}) = typeOf operand0 - typeOf (C.FDiv {..}) = typeOf operand0 - typeOf (C.FRem {..}) = typeOf operand0 - typeOf (C.Sub {..}) = typeOf operand0 - typeOf (C.FSub {..}) = typeOf operand0 - typeOf (C.Mul {..}) = typeOf operand0 - typeOf (C.FMul {..}) = typeOf operand0 - typeOf (C.UDiv {..}) = typeOf operand0 - typeOf (C.SDiv {..}) = typeOf operand0 - typeOf (C.URem {..}) = typeOf operand0 - typeOf (C.SRem {..}) = typeOf operand0 - typeOf (C.Shl {..}) = typeOf operand0 - typeOf (C.LShr {..}) = typeOf operand0 - typeOf (C.AShr {..}) = typeOf operand0 - typeOf (C.And {..}) = typeOf operand0 - typeOf (C.Or {..}) = typeOf operand0 - typeOf (C.Xor {..}) = typeOf operand0 - typeOf (C.GetElementPtr {..}) = do - aty <- typeOf address - case aty of - (Left _) -> return aty - (Right aty') -> indexTypeByConstants aty' indices - typeOf (C.Trunc {..}) = return $ Right type' - typeOf (C.ZExt {..}) = return $ Right type' - typeOf (C.SExt {..}) = return $ Right type' - typeOf (C.FPToUI {..}) = return $ Right type' - typeOf (C.FPToSI {..}) = return $ Right type' - typeOf (C.UIToFP {..}) = return $ Right type' - typeOf (C.SIToFP {..}) = return $ Right type' - typeOf (C.FPTrunc {..}) = return $ Right type' - typeOf (C.FPExt {..}) = return $ Right type' - typeOf (C.PtrToInt {..}) = return $ Right type' - typeOf (C.IntToPtr {..}) = return $ Right type' - typeOf (C.BitCast {..}) = return $ Right type' - typeOf (C.ICmp {..}) = do - t <- typeOf operand0 - case t of - (Left _) -> return t - (Right (VectorType n _)) -> return $ Right $ VectorType n i1 - (Right _) -> return $ Right i1 - typeOf (C.FCmp {..}) = do - t <- typeOf operand0 - case t of - (Left _) -> return t - (Right (VectorType n _)) -> return $ Right $ VectorType n i1 - (Right _) -> return $ Right i1 - typeOf (C.Select {..}) = typeOf trueValue - typeOf (C.ExtractElement {..}) = do - t <- typeOf vector - case t of - (Left _) -> return t - (Right (VectorType _ t')) -> return $ Right t' - (Right _) -> return $ Left "The first operand of an extractelement instruction is a value of vector type. (Malformed AST)" - typeOf (C.InsertElement {..}) = typeOf vector - typeOf (C.ShuffleVector {..}) = do - t0 <- typeOf operand0 - tm <- typeOf mask - case (t0, tm) of - (Right (VectorType _ t), Right (VectorType m _)) -> return $ Right $ VectorType m t - _ -> return $ Left "The first operand of an shufflevector instruction is a value of vector type. (Malformed AST)" - typeOf (C.ExtractValue {..}) = do - t <- typeOf aggregate - case t of - (Left _) -> return t - (Right t') -> extractValueType indices' t' - typeOf (C.InsertValue {..}) = typeOf aggregate - typeOf (C.TokenNone) = return $ Right TokenType - typeOf (C.AddrSpaceCast {..}) = return $ Right type' - --- | Index into a type using a list of 'Constant' values. Returns a pointer type whose referent is the indexed type, or an error message if indexing was not possible. -indexTypeByConstants :: (HasCallStack, MonadModuleBuilder m) => Type -> [C.Constant] -> m (Either String Type) -indexTypeByConstants ty [] = return $ Right $ ptr ty -indexTypeByConstants (PointerType ty _) (_:is) = indexTypeByConstants ty is -indexTypeByConstants (StructureType _ elTys) (C.Int 32 val:is) = - indexTypeByConstants (elTys !! fromIntegral val) is -indexTypeByConstants (StructureType _ _) (i:_) = - return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i -indexTypeByConstants (VectorType _ elTy) (_:is) = indexTypeByConstants elTy is -indexTypeByConstants (ArrayType _ elTy) (_:is) = indexTypeByConstants elTy is -indexTypeByConstants (NamedTypeReference n) is = do - mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs)) - case mayTy of - Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n - Just ty -> indexTypeByConstants ty is -indexTypeByConstants ty _ = return $ Left $ "Expecting aggregate type. (Malformed AST): " ++ show ty - --- | Index into a type using a list of 'Operand' values. Returns a pointer type whose referent is the indexed type, or an error message if indexing was not possible. -indexTypeByOperands :: (HasCallStack, MonadModuleBuilder m) => Type -> [Operand] -> m (Either String Type) -indexTypeByOperands ty [] = return $ Right $ ptr ty -indexTypeByOperands (PointerType ty _) (_:is) = indexTypeByOperands ty is -indexTypeByOperands (StructureType _ elTys) (ConstantOperand (C.Int 32 val):is) = - indexTypeByOperands (elTys !! fromIntegral val) is -indexTypeByOperands (StructureType _ _) (i:_) = - return $ Left $ "Indices into structures should be 32-bit integer constants. (Malformed AST): " ++ show i -indexTypeByOperands (VectorType _ elTy) (_:is) = indexTypeByOperands elTy is -indexTypeByOperands (ArrayType _ elTy) (_:is) = indexTypeByOperands elTy is -indexTypeByOperands (NamedTypeReference n) is = do - mayTy <- liftModuleState (gets (Map.lookup n . builderTypeDefs)) - case mayTy of - Nothing -> return $ Left $ "Couldn’t resolve typedef for: " ++ show n - Just ty -> indexTypeByOperands ty is -indexTypeByOperands ty _ = return $ Left $ "Expecting aggregate type. (Malformed AST): " ++ show ty - -getElementType :: Type -> Either String Type -getElementType (PointerType t _) = Right t -getElementType t = Left $ "Expecting pointer type. (Malformed AST): " ++ show t - -extractValueType :: (HasCallStack, MonadModuleBuilder m) => [Word32] -> Type -> m (Either String Type) -extractValueType [] ty = return $ Right ty -extractValueType (i : is) (ArrayType numEls elTy) - | fromIntegral i < numEls = extractValueType is elTy - | fromIntegral i >= numEls = return $ Left $ "Expecting valid index into array type. (Malformed AST): " ++ show i -extractValueType (i : is) (StructureType _ elTys) - | fromIntegral i < length elTys = extractValueType is (elTys !! fromIntegral i) - | otherwise = return $ Left $ "Expecting valid index into structure type. (Malformed AST): " ++ show i -extractValueType _ ty = return $ Left $ "Expecting vector type. (Malformed AST): " ++ show ty - -instance Typed F.SomeFloat where - typeOf (F.Half _) = return $ Right $ FloatingPointType HalfFP - typeOf (F.Single _) = return $ Right $ FloatingPointType FloatFP - typeOf (F.Double _) = return $ Right $ FloatingPointType DoubleFP - typeOf (F.Quadruple _ _) = return $ Right $ FloatingPointType FP128FP - typeOf (F.X86_FP80 _ _) = return $ Right $ FloatingPointType X86_FP80FP - typeOf (F.PPC_FP128 _ _) = return $ Right $ FloatingPointType PPC_FP128FP - -instance Typed Global where - typeOf (GlobalVariable {..}) = return $ Right $ type' - typeOf (GlobalAlias {..}) = return $ Right $ type' - typeOf (Function {..}) = do - let (params, isVarArg) = parameters - ptys <- mapM typeOf params - case (all Either.isRight ptys) of - True -> return $ Right $ FunctionType returnType (Either.rights ptys) isVarArg - False -> do - let (Left s) = head $ filter Either.isLeft ptys - return $ Left $ "Could not deduce type for function parameter: " ++ s - -instance Typed Parameter where - typeOf (Parameter t _ _) = return $ Right t - -instance Typed [Int32] where - typeOf mask = return $ Right $ VectorType (fromIntegral $ length mask) i32 diff --git a/vendored/llvm-hs-pure/src/LLVM/AST/Visibility.hs b/vendored/llvm-hs-pure/src/LLVM/AST/Visibility.hs deleted file mode 100644 index 563c9aa48..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/AST/Visibility.hs +++ /dev/null @@ -1,8 +0,0 @@ --- | Module to allow importing 'Visibility' distinctly qualified. -module LLVM.AST.Visibility where - -import LLVM.Prelude - --- | -data Visibility = Default | Hidden | Protected - deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/vendored/llvm-hs-pure/src/LLVM/DataLayout.hs b/vendored/llvm-hs-pure/src/LLVM/DataLayout.hs deleted file mode 100644 index 6c487bab9..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/DataLayout.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module LLVM.DataLayout ( - dataLayoutToString, - parseDataLayout - ) where - -import LLVM.Prelude - -import Control.Monad.Trans.Except - -import Data.Attoparsec.ByteString -import Data.Attoparsec.ByteString.Char8 -import Data.ByteString.Char8 as ByteString hiding (map, foldr) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set - -import LLVM.AST.DataLayout -import LLVM.AST.AddrSpace - -dataLayoutToString :: DataLayout -> ByteString -dataLayoutToString dl = - let sAlignmentInfo :: AlignmentInfo -> ByteString - sAlignmentInfo (AlignmentInfo abi pref) = - pack (show abi) <> - if pref /= abi - then ":" <> pack (show pref) - else "" - sTriple :: (Word32, AlignmentInfo) -> ByteString - sTriple (s, ai) = pack (show s) <> ":" <> sAlignmentInfo ai - atChar at = case at of - IntegerAlign -> "i" - VectorAlign -> "v" - FloatAlign -> "f" - manglingChar m = case m of - ELFMangling -> "e" - MIPSMangling -> "m" - MachOMangling -> "o" - WindowsCOFFMangling -> "w" - oneOpt f accessor = maybe [] ((:[]) . f) (accessor dl) - defDl = defaultDataLayout BigEndian - nonDef :: Eq a => (DataLayout -> [a]) -> [a] - nonDef f = (f dl) List.\\ (f defDl) - in - ByteString.intercalate "-" ( - [case endianness dl of BigEndian -> "E"; LittleEndian -> "e"] - ++ - (oneOpt (("m:" <>) . manglingChar) mangling) - ++ - [ - "p" <> (if a == 0 then "" else pack (show a)) <> ":" <> sTriple t - | (AddrSpace a, t) <- nonDef (Map.toList . pointerLayouts) - ] ++ [ - atChar at <> sTriple (s, ai) - | ((at, s), ai) <- nonDef (Map.toList . typeLayouts) - ] ++ [ - "a:" <> sAlignmentInfo ai | ai <- nonDef (pure . aggregateLayout) - ] ++ - (oneOpt (("n"<>) . (ByteString.intercalate ":") . map (pack . show) . Set.toList) nativeSizes) - ++ - (oneOpt (("S"<>) . pack . show) stackAlignment) - ) - --- | Parse a 'DataLayout', given a default Endianness should one not be specified in the --- string to be parsed. LLVM itself uses BigEndian as the default: thus pass BigEndian to --- be conformant or LittleEndian to be righteously defiant. -parseDataLayout :: Endianness -> ByteString -> Except String (Maybe DataLayout) -parseDataLayout _ "" = pure Nothing -parseDataLayout defaultEndianness str = - let - num :: Parser Word32 - num = read <$> many1 digit - alignmentInfo :: Parser AlignmentInfo - alignmentInfo = do - abi <- num - pref <- optional $ char ':' *> num - let pref' = fromMaybe abi pref - pure $ AlignmentInfo abi pref' - triple :: Parser (Word32, AlignmentInfo) - triple = do - s <- num - ai <- char ':' *> alignmentInfo - pure (s, ai) - parseSpec :: Parser (DataLayout -> DataLayout) - parseSpec = choice [ - char 'e' *> pure (\dl -> dl { endianness = LittleEndian }), - char 'E' *> pure (\dl -> dl { endianness = BigEndian }), - do - m <- char 'm' *> char ':' *> choice [ - char 'e' *> pure ELFMangling, - char 'm' *> pure MIPSMangling, - char 'o' *> pure MachOMangling, - char 'w' *> pure WindowsCOFFMangling - ] - pure $ \dl -> dl { mangling = Just m }, - do - n <- char 'S' *> num - pure $ \dl -> dl { stackAlignment = Just n }, - do - a <- char 'p' *> (AddrSpace <$> option 0 (read <$> many1 digit)) - t <- char ':' *> triple - pure $ \dl -> dl { pointerLayouts = Map.insert a t (pointerLayouts dl) }, - do - -- Ignore this obsolete approach to stack alignment. After the 3.4 release, - -- this is never generated, still parsed but ignored. Comments suggest - -- it will no longer be parsed after 4.0. - void $ char 's' *> triple - pure id, - do - at <- choice [ - char 'i' *> pure IntegerAlign, - char 'v' *> pure VectorAlign, - char 'f' *> pure FloatAlign - ] - (sz, ai) <- triple - pure $ \dl -> dl { typeLayouts = Map.insert (at, sz) ai (typeLayouts dl) }, - do - ai <- char 'a' *> char ':' *> alignmentInfo - pure $ \dl -> dl { aggregateLayout = ai }, - do - ns <- char 'n' *> num `sepBy` (char ':') - pure $ \dl -> dl { nativeSizes = Just (Set.fromList ns) } - ] - in - case parseOnly (parseSpec `sepBy` (char '-')) str of - Left _ -> throwE $ "ill-formed data layout: " ++ show str - Right fs -> pure . Just $ foldr ($) (defaultDataLayout defaultEndianness) fs diff --git a/vendored/llvm-hs-pure/src/LLVM/IRBuilder.hs b/vendored/llvm-hs-pure/src/LLVM/IRBuilder.hs deleted file mode 100644 index 4ce6b84fe..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/IRBuilder.hs +++ /dev/null @@ -1,8 +0,0 @@ -module LLVM.IRBuilder - (module X) - where - -import LLVM.IRBuilder.Monad as X -import LLVM.IRBuilder.Instruction as X -import LLVM.IRBuilder.Module as X -import LLVM.IRBuilder.Constant as X diff --git a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs b/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs deleted file mode 100644 index 881e8b920..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Constant.hs +++ /dev/null @@ -1,41 +0,0 @@ -module LLVM.IRBuilder.Constant where -import Data.Word -import LLVM.Prelude -import LLVM.AST hiding (args, dests) -import LLVM.AST.Typed - -import LLVM.AST.Constant -import LLVM.AST.Float -import LLVM.IRBuilder.Module - -import GHC.Stack - -int64 :: Integer -> Operand -int64 = ConstantOperand . Int 64 -int32 :: Integer -> Operand -int32 = ConstantOperand . Int 32 -int16 :: Integer -> Operand -int16 = ConstantOperand . Int 16 -int8 :: Integer -> Operand -int8 = ConstantOperand . Int 8 -bit :: Integer -> Operand -bit = ConstantOperand . Int 1 - -double :: Double -> Operand -double = ConstantOperand . Float . Double - -single :: Float -> Operand -single = ConstantOperand . Float . Single - -half :: Word16 -> Operand -half = ConstantOperand . Float . Half - -struct :: Maybe Name -> Bool -> [Constant] -> Operand -struct nm packing members = ConstantOperand $ Struct nm packing members - -array :: (HasCallStack, MonadModuleBuilder m) => [Constant] -> m Operand -array members = do - thm <- typeOf $ head members - case thm of - (Left s) -> error s - (Right thm') -> return $ ConstantOperand $ Array thm' members diff --git a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs b/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs deleted file mode 100644 index 1716395b4..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Instruction.hs +++ /dev/null @@ -1,432 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module LLVM.IRBuilder.Instruction where - -import Prelude hiding (and, or, pred) - -import Data.Word -import Data.Char (ord) -import GHC.Int -import GHC.Stack - -import LLVM.AST hiding (args, dests) -import LLVM.AST.Type as AST -import LLVM.AST.Typed -import LLVM.AST.ParameterAttribute -import qualified LLVM.AST as AST -import qualified LLVM.AST.CallingConvention as CC -import qualified LLVM.AST.Constant as C -import qualified LLVM.AST.IntegerPredicate as IP -import qualified LLVM.AST.FloatingPointPredicate as FP - -import LLVM.AST.Global -import LLVM.AST.Linkage - -import LLVM.IRBuilder.Monad -import LLVM.IRBuilder.Module - --- | See . -fneg :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> m Operand -fneg a = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ FNeg noFastMathFlags a [] - --- | See . -fadd :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -fadd a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ FAdd noFastMathFlags a b [] - --- | See . -fmul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -fmul a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ FMul noFastMathFlags a b [] - --- | See . -fsub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -fsub a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ FSub noFastMathFlags a b [] - --- | See . -fdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -fdiv a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ FDiv noFastMathFlags a b [] - --- | See . -frem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -frem a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ FRem noFastMathFlags a b [] - --- | See . -add :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -add a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ Add False False a b [] - --- | See . -mul :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -mul a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ Mul False False a b [] - --- | See . -sub :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -sub a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ Sub False False a b [] - --- | See . -udiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -udiv a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ UDiv False a b [] - --- | See . -sdiv :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -sdiv a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ SDiv False a b [] - --- | See . -urem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -urem a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ URem a b [] - --- | See . -srem :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -srem a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ SRem a b [] - --- | See . -shl :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -shl a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ Shl False False a b [] - --- | See . -lshr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -lshr a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ LShr True a b [] - --- | See . -ashr :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -ashr a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ AShr True a b [] - --- | See . -and :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -and a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ And a b [] - --- | See . -or :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -or a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ Or a b [] - --- | See . -xor :: (MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -xor a b = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ Xor a b [] - --- | See . -alloca :: MonadIRBuilder m => Type -> Maybe Operand -> Word32 -> m Operand -alloca ty count align = emitInstr (ptr ty) $ Alloca ty count align [] - --- | See . -load :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Word32 -> m Operand -load a align = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> do - let retty = case ta' of - PointerType ty _ -> ty - _ -> error "Cannot load non-pointer (Malformed AST)." - emitInstr retty $ Load False a Nothing align [] - --- | See . -store :: MonadIRBuilder m => Operand -> Word32 -> Operand -> m () -store addr align val = emitInstrVoid $ Store False addr val Nothing align [] - --- | Emit the @getelementptr@ instruction. --- See . -gep :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Operand] -> m Operand -gep addr is = do - ta <- typeOf addr - case ta of - (Left s) -> error s - (Right ta') -> do - ty <- indexTypeByOperands ta' is - case ty of - (Left s) -> error s - (Right ty') -> emitInstr ty' (GetElementPtr False addr is []) - --- | Emit the @trunc ... to@ instruction. --- See . -trunc :: MonadIRBuilder m => Operand -> Type -> m Operand -trunc a to = emitInstr to $ Trunc a to [] - --- | Emit the @fptrunc ... to@ instruction. --- See . -fptrunc :: MonadIRBuilder m => Operand -> Type -> m Operand -fptrunc a to = emitInstr to $ FPTrunc a to [] - --- | Emit the @zext ... to@ instruction. --- See . -zext :: MonadIRBuilder m => Operand -> Type -> m Operand -zext a to = emitInstr to $ ZExt a to [] - --- | Emit the @sext ... to@ instruction. --- See . -sext :: MonadIRBuilder m => Operand -> Type -> m Operand -sext a to = emitInstr to $ SExt a to [] - --- | Emit the @fptoui ... to@ instruction. --- See . -fptoui :: MonadIRBuilder m => Operand -> Type -> m Operand -fptoui a to = emitInstr to $ FPToUI a to [] - --- | Emit the @fptosi ... to@ instruction. --- See . -fptosi :: MonadIRBuilder m => Operand -> Type -> m Operand -fptosi a to = emitInstr to $ FPToSI a to [] - --- | Emit the @fpext ... to@ instruction. --- See . -fpext :: MonadIRBuilder m => Operand -> Type -> m Operand -fpext a to = emitInstr to $ FPExt a to [] - --- | Emit the @uitofp ... to@ instruction. --- See . -uitofp :: MonadIRBuilder m => Operand -> Type -> m Operand -uitofp a to = emitInstr to $ UIToFP a to [] - --- | Emit the @sitofp ... to@ instruction. --- See . -sitofp :: MonadIRBuilder m => Operand -> Type -> m Operand -sitofp a to = emitInstr to $ SIToFP a to [] - --- | Emit the @ptrtoint ... to@ instruction. --- See . -ptrtoint :: MonadIRBuilder m => Operand -> Type -> m Operand -ptrtoint a to = emitInstr to $ PtrToInt a to [] - --- | Emit the @inttoptr ... to@ instruction. --- See . -inttoptr :: MonadIRBuilder m => Operand -> Type -> m Operand -inttoptr a to = emitInstr to $ IntToPtr a to [] - --- | Emit the @bitcast ... to@ instruction. --- See . -bitcast :: MonadIRBuilder m => Operand -> Type -> m Operand -bitcast a to = emitInstr to $ BitCast a to [] - --- | See . -extractElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> m Operand -extractElement v i = do - tv <- typeOf v - let elemTyp = case tv of - (Left s) -> error s - (Right (VectorType _ typ)) -> typ - (Right typ) -> error $ "extractElement: Expected a vector type but got " ++ show typ ++ " (Malformed AST)." - emitInstr elemTyp $ ExtractElement v i [] - --- | See . -insertElement :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand -insertElement v e i = do - tv <- typeOf v - case tv of - (Left s) -> error s - (Right tv') -> emitInstr tv' $ InsertElement v e i [] - --- | See . -shuffleVector :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> [Int32] -> m Operand -shuffleVector a b m = do - ta <- typeOf a - tm <- typeOf m - let retType = case (ta, tm) of - (Right (VectorType _ elemTyp), Right (VectorType maskLength _)) -> VectorType maskLength elemTyp - _ -> error "shuffleVector: Expected two vectors and a vector mask" - emitInstr retType $ ShuffleVector a b m [] - --- | See . -extractValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [Word32] -> m Operand -extractValue a i = do - ta <- typeOf a - let aggType = case ta of - (Left s) -> error s - (Right typ@ArrayType{}) -> typ - (Right typ@NamedTypeReference{}) -> typ - (Right typ@StructureType{}) -> typ - (Right typ) -> error $ "extractValue: Expecting structure or array type but got " ++ show typ ++ " (Malformed AST)." - retType <- indexTypeByOperands aggType (map (ConstantOperand . C.Int 32 . fromIntegral) i) - case retType of - (Left s) -> error s - (Right retType') -> emitInstr (pointerReferent retType') $ ExtractValue a i [] - --- | See . -insertValue :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> [Word32] -> m Operand -insertValue a e i = do - ta <- typeOf a - case ta of - (Left s) -> error s - (Right ta') -> emitInstr ta' $ InsertValue a e i [] - --- | See . -icmp :: MonadIRBuilder m => IP.IntegerPredicate -> Operand -> Operand -> m Operand -icmp pred a b = emitInstr i1 $ ICmp pred a b [] - --- | See . -fcmp :: MonadIRBuilder m => FP.FloatingPointPredicate -> Operand -> Operand -> m Operand -fcmp pred a b = emitInstr i1 $ FCmp pred a b [] - --- | Unconditional branch. --- Emit a @br label @ instruction --- See . -br :: MonadIRBuilder m => Name -> m () -br val = emitTerm (Br val []) - --- | See . -phi :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => [(Operand, Name)] -> m Operand -phi [] = emitInstr AST.void $ Phi AST.void [] [] -phi incoming@(i:_) = do - ty <- typeOf (fst i) - case ty of - (Left s) -> error s - (Right ty') -> emitInstr ty' $ Phi ty' incoming [] - --- | Emit a @ret void@ instruction. --- See . -retVoid :: MonadIRBuilder m => m () -retVoid = emitTerm (Ret Nothing []) - --- | See . -call :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> [(Operand, [ParameterAttribute])] -> m Operand -call fun args = do - let instr = Call { - AST.tailCallKind = Nothing - , AST.callingConvention = CC.C - , AST.returnAttributes = [] - , AST.function = Right fun - , AST.arguments = args - , AST.functionAttributes = [] - , AST.metadata = [] - } - tf <- typeOf fun - case tf of - (Left s) -> error s - (Right (FunctionType r _ _)) -> case r of - VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) - _ -> emitInstr r instr - (Right (PointerType (FunctionType r _ _) _)) -> case r of - VoidType -> emitInstrVoid instr >> (pure (ConstantOperand (C.Undef void))) - _ -> emitInstr r instr - (Right _) -> error "Cannot call non-function (Malformed AST)." - --- | See . -ret :: MonadIRBuilder m => Operand -> m () -ret val = emitTerm (Ret (Just val) []) - --- | See . -switch :: MonadIRBuilder m => Operand -> Name -> [(C.Constant, Name)] -> m () -switch val def dests = emitTerm $ Switch val def dests [] - --- | See . -select :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Operand -> Operand -> Operand -> m Operand -select cond t f = do - tt <- typeOf t - case tt of - (Left s) -> error s - (Right tt') -> emitInstr tt' $ Select cond t f [] - --- | Conditional branch (see 'br' for unconditional instructions). --- See . -condBr :: MonadIRBuilder m => Operand -> Name -> Name -> m () -condBr cond tdest fdest = emitTerm $ CondBr cond tdest fdest [] - --- | See . -unreachable :: MonadIRBuilder m => m () -unreachable = emitTerm $ Unreachable [] - --- | Creates a series of instructions to generate a pointer to a string --- constant. Useful for making format strings to pass to @printf@, for example -globalStringPtr - :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) - => String -- ^ The string to generate - -> Name -- ^ Variable name of the pointer - -> m C.Constant -globalStringPtr str nm = do - let asciiVals = map (fromIntegral . ord) str - llvmVals = map (C.Int 8) (asciiVals ++ [0]) -- append null terminator - char = IntegerType 8 - charArray = C.Array char llvmVals - ty <- LLVM.AST.Typed.typeOf charArray - case ty of - (Left s) -> error s - (Right ty') -> do - emitDefn $ GlobalDefinition globalVariableDefaults - { name = nm - , LLVM.AST.Global.type' = ty' - , linkage = External - , isConstant = True - , initializer = Just charArray - , unnamedAddr = Just GlobalAddr - } - return $ C.GetElementPtr True - (C.GlobalReference (ptr ty') nm) - [(C.Int 32 0), (C.Int 32 0)] - -sizeof :: (HasCallStack, MonadIRBuilder m, MonadModuleBuilder m) => Word32 -> Type -> m Operand -sizeof szBits ty = do - tyNullPtr <- inttoptr (ConstantOperand $ C.Int szBits 0) (ptr ty) - tySzPtr <- gep tyNullPtr [ConstantOperand $ C.Int szBits 1] - ptrtoint tySzPtr $ IntegerType szBits diff --git a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Internal/SnocList.hs b/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Internal/SnocList.hs deleted file mode 100644 index 865dbb0e1..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Internal/SnocList.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} -module LLVM.IRBuilder.Internal.SnocList where - -import LLVM.Prelude - -newtype SnocList a = SnocList { unSnocList :: [a] } - deriving (Eq, Show) - -instance Semigroup (SnocList a) where - SnocList xs <> SnocList ys = SnocList $ ys ++ xs - -instance Monoid (SnocList a) where -#if !(MIN_VERSION_base(4,11,0)) - mappend = (<>) -#endif - mempty = SnocList [] - -snoc :: SnocList a -> a -> SnocList a -snoc (SnocList xs) x = SnocList $ x : xs - -getSnocList :: SnocList a -> [a] -getSnocList = reverse . unSnocList diff --git a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs b/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs deleted file mode 100644 index dd7f1fdab..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Module.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- For MonadState s (IRBuilderT m) instance - {-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module LLVM.IRBuilder.Module where - -import Prelude hiding (and, or) - -import Control.Monad (MonadPlus, forM) -import Control.Monad.Fix -import Control.Applicative -import Control.Monad.Cont (MonadCont, ContT) -import Control.Monad.Except -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 Control.Monad.Reader -import Control.Monad.RWS.Lazy as Lazy -import Control.Monad.RWS.Strict as Strict -import qualified Control.Monad.State.Strict as Strict -import Control.Monad.State.Lazy -import Control.Monad.Trans.Maybe -#if !(MIN_VERSION_mtl(2,2,2)) -import Control.Monad.Trans.Identity -#endif -#if __GLASGOW_HASKELL__ < 808 -import Control.Monad.Fail (MonadFail) -#endif - -import Data.Bifunctor -import qualified Data.ByteString.Short as BS -import Data.Char -import Data.Data -import Data.Foldable -import Data.Map.Lazy (Map) -import qualified Data.Map.Lazy as Map -import Data.String - -import GHC.Generics(Generic) - -import LLVM.AST hiding (function) -import LLVM.AST.Global -import LLVM.AST.Linkage -import LLVM.AST.Type (ptr) -import qualified LLVM.AST.Constant as C - -import LLVM.IRBuilder.Internal.SnocList -import LLVM.IRBuilder.Monad - -newtype ModuleBuilderT m a = ModuleBuilderT { unModuleBuilderT :: StateT ModuleBuilderState m a } - deriving - ( Functor, Alternative, Applicative, Monad, MonadCont, MonadError e - , MonadFix, MonadIO, MonadPlus, MonadReader r, MonadTrans, MonadWriter w - ) - -instance MonadFail m => MonadFail (ModuleBuilderT m) where - fail str = ModuleBuilderT (StateT $ \_ -> Fail.fail str) - -data ModuleBuilderState = ModuleBuilderState - { builderDefs :: SnocList Definition - , builderTypeDefs :: Map Name Type - } - -emptyModuleBuilder :: ModuleBuilderState -emptyModuleBuilder = ModuleBuilderState - { builderDefs = mempty - , builderTypeDefs = mempty - } - -type ModuleBuilder = ModuleBuilderT Identity - -class Monad m => MonadModuleBuilder m where - liftModuleState :: State ModuleBuilderState a -> m a - - default liftModuleState - :: (MonadTrans t, MonadModuleBuilder m1, m ~ t m1) - => State ModuleBuilderState a - -> m a - liftModuleState = lift . liftModuleState - -instance Monad m => MonadModuleBuilder (ModuleBuilderT m) where - liftModuleState (StateT s) = ModuleBuilderT $ StateT $ pure . runIdentity . s - - - --- | Evaluate 'ModuleBuilder' to a result and a list of definitions -runModuleBuilder :: ModuleBuilderState -> ModuleBuilder a -> (a, [Definition]) -runModuleBuilder s m = runIdentity $ runModuleBuilderT s m - --- | Evaluate 'ModuleBuilderT' to a result and a list of definitions -runModuleBuilderT :: Monad m => ModuleBuilderState -> ModuleBuilderT m a -> m (a, [Definition]) -runModuleBuilderT s (ModuleBuilderT m) - = second (getSnocList . builderDefs) - <$> runStateT m s - --- | Evaluate 'ModuleBuilder' to a list of definitions -execModuleBuilder :: ModuleBuilderState -> ModuleBuilder a -> [Definition] -execModuleBuilder s m = snd $ runModuleBuilder s m - --- | Evaluate 'ModuleBuilderT' to a list of definitions -execModuleBuilderT :: Monad m => ModuleBuilderState -> ModuleBuilderT m a -> m [Definition] -execModuleBuilderT s m = snd <$> runModuleBuilderT s m - -emitDefn :: MonadModuleBuilder m => Definition -> m () -emitDefn def = liftModuleState $ modify $ \s -> s { builderDefs = builderDefs s `snoc` def } - --- | A parameter name suggestion -data ParameterName - = NoParameterName - | ParameterName BS.ShortByteString - deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) - --- | Using 'fromString` on non-ASCII strings will throw an error. -instance IsString ParameterName where - fromString s - | all isAscii s = ParameterName (fromString s) - | otherwise = - error ("Only ASCII strings are automatically converted to LLVM parameter names. " - <> "Other strings need to be encoded to a `ShortByteString` using an arbitrary encoding.") - --- | Define and emit a (non-variadic) function definition -function - :: MonadModuleBuilder m - => Name -- ^ Function name - -> [(Type, ParameterName)] -- ^ Parameter types and name suggestions - -> Type -- ^ Return type - -> ([Operand] -> IRBuilderT m ()) -- ^ Function body builder - -> m Operand -function label argtys retty body = do - let tys = fst <$> argtys - (paramNames, blocks) <- runIRBuilderT emptyIRBuilder $ do - paramNames <- forM argtys $ \(_, paramName) -> case paramName of - NoParameterName -> fresh - ParameterName p -> fresh `named` p - body $ zipWith LocalReference tys paramNames - return paramNames - let - def = GlobalDefinition functionDefaults - { name = label - , parameters = (zipWith (\ty nm -> Parameter ty nm []) tys paramNames, False) - , returnType = retty - , basicBlocks = blocks - } - funty = ptr $ FunctionType retty (fst <$> argtys) False - emitDefn def - pure $ ConstantOperand $ C.GlobalReference funty label - --- | An external function definition -extern - :: MonadModuleBuilder m - => Name -- ^ Definition name - -> [Type] -- ^ Parameter types - -> Type -- ^ Type - -> m Operand -extern nm argtys retty = do - emitDefn $ GlobalDefinition functionDefaults - { name = nm - , linkage = External - , parameters = ([Parameter ty (mkName "") [] | ty <- argtys], False) - , returnType = retty - } - let funty = ptr $ FunctionType retty argtys False - pure $ ConstantOperand $ C.GlobalReference funty nm - --- | An external variadic argument function definition -externVarArgs - :: MonadModuleBuilder m - => Name -- ^ Definition name - -> [Type] -- ^ Parameter types - -> Type -- ^ Type - -> m Operand -externVarArgs nm argtys retty = do - emitDefn $ GlobalDefinition functionDefaults - { name = nm - , linkage = External - , parameters = ([Parameter ty (mkName "") [] | ty <- argtys], True) - , returnType = retty - } - let funty = ptr $ FunctionType retty argtys True - pure $ ConstantOperand $ C.GlobalReference funty nm - --- | A global variable definition -global - :: MonadModuleBuilder m - => Name -- ^ Variable name - -> Type -- ^ Type - -> C.Constant -- ^ Initializer - -> m Operand -global nm ty initVal = do - emitDefn $ GlobalDefinition globalVariableDefaults - { name = nm - , LLVM.AST.Global.type' = ty - , linkage = External - , initializer = Just initVal - } - pure $ ConstantOperand $ C.GlobalReference (ptr ty) nm - --- | A named type definition -typedef - :: MonadModuleBuilder m - => Name - -> Maybe Type - -> m Type -typedef nm ty = do - emitDefn $ TypeDefinition nm ty - for_ ty $ \ty' -> - liftModuleState (modify (\s -> s { builderTypeDefs = Map.insert nm ty' (builderTypeDefs s) })) - pure (NamedTypeReference nm) - --- | Convenience function for module construction -buildModule :: BS.ShortByteString -> ModuleBuilder a -> Module -buildModule nm = mkModule . execModuleBuilder emptyModuleBuilder - where - mkModule ds = defaultModule { moduleName = nm, moduleDefinitions = ds } - --- | Convenience function for module construction (transformer version) -buildModuleT :: Monad m => BS.ShortByteString -> ModuleBuilderT m a -> m Module -buildModuleT nm = fmap mkModule . execModuleBuilderT emptyModuleBuilder - where - mkModule ds = defaultModule { moduleName = nm, moduleDefinitions = ds } - -------------------------------------------------------------------------------- --- mtl instances -------------------------------------------------------------------------------- - -instance MonadState s m => MonadState s (ModuleBuilderT m) where - state = lift . state - -instance MonadModuleBuilder m => MonadModuleBuilder (ContT r m) -instance MonadModuleBuilder m => MonadModuleBuilder (ExceptT e m) -instance MonadModuleBuilder m => MonadModuleBuilder (IdentityT m) -instance MonadModuleBuilder m => MonadModuleBuilder (MaybeT m) -instance MonadModuleBuilder m => MonadModuleBuilder (ReaderT r m) -instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (Strict.RWST r w s m) -instance (MonadModuleBuilder m, Monoid w) => MonadModuleBuilder (Lazy.RWST r w s m) -instance MonadModuleBuilder m => MonadModuleBuilder (StateT s m) -instance MonadModuleBuilder m => MonadModuleBuilder (Strict.StateT s m) -instance (Monoid w, MonadModuleBuilder m) => MonadModuleBuilder (Strict.WriterT w m) - --- Not an mtl instance, but necessary in order for @globalStringPtr@ to compile -instance MonadModuleBuilder m => MonadModuleBuilder (IRBuilderT m) diff --git a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs b/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs deleted file mode 100644 index 3f2b6af6a..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/IRBuilder/Monad.hs +++ /dev/null @@ -1,299 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- For MonadState s (ModuleBuilderT m) instance - {-# LANGUAGE TypeOperators #-} -module LLVM.IRBuilder.Monad where - -import LLVM.Prelude - -import Control.Monad.Cont -import Control.Monad.Except -import qualified Control.Monad.Fail as Fail -import Control.Monad.Identity -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 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.Trans.Maybe -#if !(MIN_VERSION_mtl(2,2,2)) -import Control.Monad.Trans.Identity -#endif -#if __GLASGOW_HASKELL__ < 808 -import Control.Monad.Fail (MonadFail) -#endif - -import Control.Monad.Fix -import Data.Bifunctor -import Data.Monoid (First(..)) -import Data.String -import Data.Map.Strict(Map) -import qualified Data.Map.Strict as M -import GHC.Stack - -import LLVM.AST - -import LLVM.IRBuilder.Internal.SnocList - --- | This provides a uniform API for creating instructions and inserting them --- into a basic block: either at the end of a BasicBlock, or at a specific --- location in a block. -newtype IRBuilderT m a = IRBuilderT { unIRBuilderT :: StateT IRBuilderState m a } - deriving - ( Functor, Alternative, Applicative, Monad, MonadCont, MonadError e - , MonadFix, MonadIO, MonadPlus, MonadReader r, MonadTrans, MonadWriter w - ) - -instance MonadFail m => MonadFail (IRBuilderT m) where - fail str = IRBuilderT (StateT $ \ _ -> Fail.fail str) - -type IRBuilder = IRBuilderT Identity - -class Monad m => MonadIRBuilder m where - liftIRState :: State IRBuilderState a -> m a - - default liftIRState - :: (MonadTrans t, MonadIRBuilder m1, m ~ t m1) - => State IRBuilderState a - -> m a - liftIRState = lift . liftIRState - -instance Monad m => MonadIRBuilder (IRBuilderT m) where - liftIRState (StateT s) = IRBuilderT $ StateT $ pure . runIdentity . s - --- | A partially constructed block as a sequence of instructions -data PartialBlock = PartialBlock - { partialBlockName :: !Name - , partialBlockInstrs :: SnocList (Named Instruction) - , partialBlockTerm :: First (Named Terminator) - } - -emptyPartialBlock :: Name -> PartialBlock -emptyPartialBlock nm = PartialBlock nm mempty (First Nothing) - --- | Builder monad state -data IRBuilderState = IRBuilderState - { builderSupply :: !Word - , builderUsedNames :: !(Map ShortByteString Word) - , builderNameSuggestion :: !(Maybe ShortByteString) - , builderBlocks :: SnocList BasicBlock - , builderBlock :: !(Maybe PartialBlock) - } - -emptyIRBuilder :: IRBuilderState -emptyIRBuilder = IRBuilderState - { builderSupply = 0 - , builderUsedNames = mempty - , builderNameSuggestion = Nothing - , builderBlocks = mempty - , builderBlock = Nothing - } - --- | Evaluate IRBuilder to a result and a list of basic blocks -runIRBuilder :: IRBuilderState -> IRBuilder a -> (a, [BasicBlock]) -runIRBuilder s m = runIdentity $ runIRBuilderT s m - --- | Evaluate IRBuilderT to a result and a list of basic blocks -runIRBuilderT :: Monad m => IRBuilderState -> IRBuilderT m a -> m (a, [BasicBlock]) -runIRBuilderT s m - = second (getSnocList . builderBlocks) - <$> runStateT (unIRBuilderT $ m <* block) s - --- | Evaluate IRBuilder to a list of basic blocks -execIRBuilder :: IRBuilderState -> IRBuilder a -> [BasicBlock] -execIRBuilder s m = snd $ runIRBuilder s m - --- | Evaluate IRBuilderT to a list of basic blocks -execIRBuilderT :: Monad m => IRBuilderState -> IRBuilderT m a -> m [BasicBlock] -execIRBuilderT s m = snd <$> runIRBuilderT s m - -------------------------------------------------------------------------------- --- * 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) - -> m () -modifyBlock f = do - mbb <- liftIRState $ gets builderBlock - case mbb of - Nothing -> do - nm <- freshUnName - liftIRState $ modify $ \s -> s { builderBlock = Just $! f $ emptyPartialBlock nm } - Just bb -> - liftIRState $ modify $ \s -> s { builderBlock = Just $! f bb } - --- | Generate a fresh name. The resulting name is numbered or --- based on the name suggested with 'named' if that's used. -fresh :: MonadIRBuilder m => m Name -fresh = do - msuggestion <- liftIRState $ gets builderNameSuggestion - maybe freshUnName freshName msuggestion - --- | Generate a fresh name from a name suggestion -freshName :: MonadIRBuilder m => ShortByteString -> m Name -freshName suggestion = do - usedNames <- liftIRState $ gets builderUsedNames - let - nameCount = fromMaybe 0 $ M.lookup suggestion usedNames - unusedName = suggestion <> fromString ("_" <> show nameCount) - updatedUsedNames = M.insert suggestion (nameCount + 1) usedNames - liftIRState $ modify $ \s -> s { builderUsedNames = updatedUsedNames } - return $ Name unusedName - --- | Generate a fresh numbered name -freshUnName :: MonadIRBuilder m => m Name -freshUnName = liftIRState $ do - n <- gets builderSupply - modify $ \s -> s { builderSupply = 1 + n } - pure $ UnName n - --- | Emit instruction -emitInstr - :: MonadIRBuilder m - => Type -- ^ Return type - -> 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) - } - pure (LocalReference retty nm) - --- | Emit instruction that returns void -emitInstrVoid - :: MonadIRBuilder m - => Instruction - -> m () -emitInstrVoid instr = do - modifyBlock $ \bb -> bb - { partialBlockInstrs = partialBlockInstrs bb `snoc` (Do instr) - } - pure () - --- | Emit terminator -emitTerm - :: MonadIRBuilder m - => Terminator - -> m () -emitTerm term = modifyBlock $ \bb -> bb - { partialBlockTerm = partialBlockTerm bb <> First (Just (Do term)) - } - --- | Starts a new block labelled using the given name and ends the previous --- one. The name is assumed to be fresh. -emitBlockStart - :: MonadIRBuilder m - => Name - -> m () -emitBlockStart nm = do - mbb <- liftIRState $ gets builderBlock - case mbb of - Nothing -> return () - Just bb -> do - let - instrs = getSnocList $ partialBlockInstrs bb - newBb = case getFirst (partialBlockTerm bb) of - Nothing -> BasicBlock (partialBlockName bb) instrs (Do (Ret Nothing [])) - Just term -> BasicBlock (partialBlockName bb) instrs term - liftIRState $ modify $ \s -> s - { builderBlocks = builderBlocks s `snoc` newBb - } - liftIRState $ modify $ \s -> s { builderBlock = Just $ emptyPartialBlock nm } - -------------------------------------------------------------------------------- --- * High-level functionality -------------------------------------------------------------------------------- - --- | Starts a new block and ends the previous one -block - :: MonadIRBuilder m - => m Name -block = do - nm <- fresh - emitBlockStart nm - return nm - --- | @ir `named` name@ executes the 'IRBuilder' @ir@ using @name@ as the base --- name whenever a fresh local name is generated. Collisions are avoided by --- appending numbers (first @"name"@, then @"name1"@, @"name2"@, and so on). -named - :: MonadIRBuilder m - => m r - -> ShortByteString - -> m r -named ir name = do - before <- liftIRState $ gets builderNameSuggestion - liftIRState $ modify $ \s -> s { builderNameSuggestion = Just name } - 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 :: HasCallStack => 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" - --- | Find out if the currently active block has a terminator. --- --- This function will fail under the same condition as @currentBlock@ -hasTerminator :: HasCallStack => MonadIRBuilder m => m Bool -hasTerminator = do - current <- liftIRState $ gets builderBlock - case current of - Nothing -> error "Called hasTerminator when no block was active" - Just blk -> case getFirst (partialBlockTerm blk) of - Nothing -> return False - Just _ -> return True - -------------------------------------------------------------------------------- --- mtl instances -------------------------------------------------------------------------------- - -instance MonadState s m => MonadState s (IRBuilderT m) where - state = lift . state - -instance MonadIRBuilder m => MonadIRBuilder (ContT r m) -instance MonadIRBuilder m => MonadIRBuilder (ExceptT e m) -instance MonadIRBuilder m => MonadIRBuilder (IdentityT m) -instance MonadIRBuilder m => MonadIRBuilder (MaybeT m) -instance MonadIRBuilder m => MonadIRBuilder (ReaderT r m) -instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (Strict.RWST r w s m) -instance (MonadIRBuilder m, Monoid w) => MonadIRBuilder (Lazy.RWST r w s m) -instance MonadIRBuilder m => MonadIRBuilder (StateT s m) -instance MonadIRBuilder m => MonadIRBuilder (Lazy.StateT s m) -instance (Monoid w, MonadIRBuilder m) => MonadIRBuilder (Strict.WriterT w m) -instance (Monoid w, MonadIRBuilder m) => MonadIRBuilder (Lazy.WriterT w m) diff --git a/vendored/llvm-hs-pure/src/LLVM/Prelude.hs b/vendored/llvm-hs-pure/src/LLVM/Prelude.hs deleted file mode 100644 index 1fe0e0889..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/Prelude.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | This module is presents a prelude mostly like the post-Applicative-Monad world of --- 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, - module Data.Data, - module GHC.Generics, - module Data.Int, - module Data.Word, - module Data.Functor, - module Data.Foldable, - module Data.Semigroup, - module Data.Traversable, - module Control.Applicative, - module Control.Monad, - ByteString, - ShortByteString, - fromMaybe, - leftBiasedZip, - findM, - ifM - ) where - -import Prelude hiding ( - mapM, mapM_, - sequence, sequence_, - concat, - foldr, foldr1, foldl, foldl1, - minimum, maximum, sum, product, all, any, and, or, - concatMap, - elem, notElem, - ) -import Data.Data (Data, Typeable) -import GHC.Generics (Generic) -import Data.Int -import Data.Maybe (fromMaybe) -import Data.Word -import Data.Functor -import Data.Foldable -import Data.Semigroup (Semigroup((<>))) -import Data.Traversable -import Control.Applicative -import Control.Monad hiding ( - forM, forM_, - mapM, mapM_, - sequence, sequence_, - msum - ) - -import Data.ByteString (ByteString) -import Data.ByteString.Short (ShortByteString) - -leftBiasedZip :: [a] -> [b] -> [(a, Maybe b)] -leftBiasedZip [] _ = [] -leftBiasedZip xs [] = map (, Nothing) xs -leftBiasedZip (x:xs) (y:ys) = (x, Just y) : leftBiasedZip xs ys - -ifM :: Monad m => m Bool -> m a -> m a -> m a -ifM cond ifTrue ifFalse = do - cond' <- cond - if cond' - then ifTrue - else ifFalse - -findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) -findM _ [] = return Nothing -findM p (x:xs) = ifM (p x) (return $ Just x) (findM p xs) diff --git a/vendored/llvm-hs-pure/src/LLVM/Triple.hs b/vendored/llvm-hs-pure/src/LLVM/Triple.hs deleted file mode 100644 index 35c2b44d4..000000000 --- a/vendored/llvm-hs-pure/src/LLVM/Triple.hs +++ /dev/null @@ -1,380 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- | A 'Triple' represents a target triple, which is a target host description. --- | Target triples consistent of a few components: architecture, vendor, --- | operating system, and environment. --- | - -module LLVM.Triple ( - Triple (..), Architecture (..), Vendor (..), OS (..), unknownTriple, parseTriple, tripleToString - ) where - -import LLVM.Prelude -import Control.Monad.Trans.Except -import Data.Attoparsec.ByteString -import Data.Attoparsec.ByteString.Char8 -import Data.ByteString.Char8 as ByteString hiding (map, foldr) -import qualified Data.ByteString.Short as BS hiding (pack) - -import Data.Map (Map, (!)) -import qualified Data.Map as Map - -data Architecture - = UnknownArch - | Arm -- ARM (little endian): arm armv.* xscale - | Armeb -- ARM (big endian): armeb - | Aarch64 -- AArch64 (little endian): aarch64 - | Aarch64_be -- AArch64 (big endian): aarch64_be - | Aarch64_32 -- AArch64 (little endian) ILP32: aarch64_32 - | Arc -- ARC: Synopsys ARC - | Avr -- AVR: Atmel AVR microcontroller - | Bpfel -- eBPF or extended BPF or 64-bit BPF (little endian) - | Bpfeb -- eBPF or extended BPF or 64-bit BPF (big endian) - | Csky -- CSKY: csky - | Hexagon -- Hexagon: hexagon - | Mips -- MIPS: mips mipsallegrex mipsr6 - | Mipsel -- MIPSEL: mipsel mipsallegrexe mipsr6el - | Mips64 -- MIPS64: mips64 mips64r6 mipsn32 mipsn32r6 - | Mips64el -- MIPS64EL: mips64el mips64r6el mipsn32el mipsn32r6el - | Msp430 -- MSP430: msp430 - | Ppc -- PPC: powerpc - | Ppcle -- PPCLE: powerpc (little endian) - | Ppc64 -- PPC64: powerpc64 ppu - | Ppc64le -- PPC64LE: powerpc64le - | R600 -- R600: AMD GPUs HD2XXX - HD6XXX - | Amdgcn -- AMDGCN: AMD GCN GPUs - | Riscv32 -- RISC-V (32-bit): riscv32 - | Riscv64 -- RISC-V (64-bit): riscv64 - | Sparc -- Sparc: sparc - | Sparcv9 -- Sparcv9: Sparcv9 - | Sparcel -- Sparc: (endianness = little). NB: 'Sparcle' is a CPU variant - | Systemz -- SystemZ: s390x - | Tce -- TCE (http://tce.cs.tut.fi/): tce - | Tcele -- TCE little endian (http://tce.cs.tut.fi/): tcele - | Thumb -- Thumb (little endian): thumb thumbv.* - | Thumbeb -- Thumb (big endian): thumbeb - | X86 -- X86: i[3-9]86 - | X86_64 -- X86-64: amd64 x86_64 - | Xcore -- XCore: xcore - | Nvptx -- NVPTX: 32-bit - | Nvptx64 -- NVPTX: 64-bit - | Le32 -- le32: generic little-endian 32-bit CPU (PNaCl) - | Le64 -- le64: generic little-endian 64-bit CPU (PNaCl) - | Amdil -- AMDIL - | Amdil64 -- AMDIL with 64-bit pointers - | Hsail -- AMD HSAIL - | Hsail64 -- AMD HSAIL with 64-bit pointers - | Spir -- SPIR: standard portable IR for OpenCL 32-bit version - | Spir64 -- SPIR: standard portable IR for OpenCL 64-bit version - | Kalimba -- Kalimba: generic kalimba - | Shave -- SHAVE: Movidius vector VLIW processors - | Lanai -- Lanai: Lanai 32-bit - | Wasm32 -- WebAssembly with 32-bit pointers - | Wasm64 -- WebAssembly with 64-bit pointers - | Renderscript32 -- 32-bit RenderScript - | Renderscript64 -- 64-bit RenderScript - | Ve -- NEC SX-Aurora Vector Engine - deriving (Eq, Ord, Show) - --- NOTE: SubArchitecture is not currently used. -data SubArchitecture - = NoSubArch - | ARMSubArch_v8_7a - | ARMSubArch_v8_6a - | ARMSubArch_v8_5a - | ARMSubArch_v8_4a - | ARMSubArch_v8_3a - | ARMSubArch_v8_2a - | ARMSubArch_v8_1a - | ARMSubArch_v8 - | ARMSubArch_v8r - | ARMSubArch_v8m_baseline - | ARMSubArch_v8m_mainline - | ARMSubArch_v8_1m_mainline - | ARMSubArch_v7 - | ARMSubArch_v7em - | ARMSubArch_v7m - | ARMSubArch_v7s - | ARMSubArch_v7k - | ARMSubArch_v7ve - | ARMSubArch_v6 - | ARMSubArch_v6m - | ARMSubArch_v6k - | ARMSubArch_v6t2 - | ARMSubArch_v5 - | ARMSubArch_v5te - | ARMSubArch_v4t - | AArch64SubArch_arm64e - | KalimbaSubArch_v3 - | KalimbaSubArch_v4 - | KalimbaSubArch_v5 - | MipsSubArch_r6 - | PPCSubArch_spe - deriving (Eq, Ord, Show) - -data Vendor - = UnknownVendor - | Apple - | PC - | SCEI - | Freescale - | IBM - | ImaginationTechnologies - | MipsTechnologies - | NVIDIA - | CSR - | Myriad - | AMD - | Mesa - | SUSE - | OpenEmbedded - deriving (Eq, Ord, Show) - -data OS - = UnknownOS - | Ananas - | CloudABI - | Darwin - | DragonFly - | FreeBSD - | Fuchsia - | IOS - | KFreeBSD - | Linux - | Lv2 -- PS3 - | MacOSX - | NetBSD - | OpenBSD - | Solaris - | Win32 - | ZOS - | Haiku - | Minix - | RTEMS - | NaCl -- Native Client - | AIX - | CUDA -- NVIDIA CUDA - | NVCL -- NVIDIA OpenCL - | AMDHSA -- AMD HSA Runtime - | PS4 - | ELFIAMCU - | TvOS -- Apple tvOS - | WatchOS -- Apple watchOS - | Mesa3D - | Contiki - | AMDPAL -- AMD PAL Runtime - | HermitCore -- HermitCore Unikernel/Multikernel - | Hurd -- GNU/Hurd - | WASI -- Experimental WebAssembly OS - | Emscripten - deriving (Eq, Ord, Show) - -data Environment - = UnknownEnvironment - | GNU - | GNUABIN32 - | GNUABI64 - | GNUEABI - | GNUEABIHF - | GNUX32 - | GNUILP32 - | CODE16 - | EABI - | EABIHF - | Android - | Musl - | MuslEABI - | MuslEABIHF - | MSVC - | Itanium - | Cygnus - | CoreCLR - | Simulator -- Simulator variants of other systems e.g. Apple's iOS - | MacABI -- Mac Catalyst variant of Apple's iOS deployment target. - deriving (Eq, Ord, Show) - -data ObjectFormat - = UnknownObjectFormat - | COFF - | ELF - | GOFF - | MachO - | Wasm - | XCOFF - deriving (Eq, Ord, Show) - -data Triple = Triple { - architecture :: Architecture, - subarchitecture :: SubArchitecture, - os :: OS, - vendor :: Vendor, - environment :: Environment, - objectFormat :: ObjectFormat - } deriving (Eq, Ord, Show) - -unknownTriple :: Triple -unknownTriple = Triple { - architecture = UnknownArch, - subarchitecture = NoSubArch, - vendor = UnknownVendor, - os = UnknownOS, - environment = UnknownEnvironment, - objectFormat = UnknownObjectFormat - } - -invertBijection :: (Ord k, Ord v) => Map k v -> Map v k -invertBijection = Map.foldrWithKey (flip Map.insert) Map.empty - -architectureFromStringMap :: Map String Architecture -architectureFromStringMap = Map.fromList [ - ("unknown", UnknownArch), - ("arm", Arm), - ("armeb", Armeb), - ("aarch64", Aarch64), - ("aarch64_be", Aarch64_be), - ("aarch64_32", Aarch64_32), - ("arc", Arc), - ("avr", Avr), - ("bpfel", Bpfel), - ("bpfeb", Bpfeb), - ("csky", Csky), - ("hexagon", Hexagon), - ("mips", Mips), - ("mipsel", Mipsel), - ("mips64", Mips64), - ("mips64el", Mips64el), - ("msp430", Msp430), - ("ppc", Ppc), - ("ppcle", Ppcle), - ("ppc64", Ppc64), - ("ppc64le", Ppc64le), - ("r600", R600), - ("amdgcn", Amdgcn), - ("riscv32", Riscv32), - ("riscv64", Riscv64), - ("sparc", Sparc), - ("sparcv9", Sparcv9), - ("sparcel", Sparcel), - ("systemz", Systemz), - ("tce", Tce), - ("tcele", Tcele), - ("thumb", Thumb), - ("thumbeb", Thumbeb), - ("x86", X86), - ("x86_64", X86_64), - ("xcore", Xcore), - ("nvptx", Nvptx), - ("nvptx64", Nvptx64), - ("le32", Le32), - ("le64", Le64), - ("amdil", Amdil), - ("amdil64", Amdil64), - ("hsail", Hsail), - ("hsail64", Hsail64), - ("spir", Spir), - ("spir64", Spir64), - ("kalimba", Kalimba), - ("shave", Shave), - ("lanai", Lanai), - ("wasm32", Wasm32), - ("wasm64", Wasm64), - ("renderscript32", Renderscript32), - ("renderscript64", Renderscript64), - ("ve", Ve) - ] - -architectureToStringMap :: Map Architecture String -architectureToStringMap = invertBijection architectureFromStringMap - -vendorFromStringMap :: Map String Vendor -vendorFromStringMap = Map.fromList [ - ("apple" , Apple ), - ("pc" , PC ), - ("scei" , SCEI ), - ("freescale" , Freescale ), - ("ibm" , IBM ), - ("imaginationtechnologies", ImaginationTechnologies), - ("mipstechnologies" , MipsTechnologies ), - ("nvidia" , NVIDIA ), - ("csr" , CSR ), - ("myriad" , Myriad ), - ("amd" , AMD ), - ("mesa" , Mesa ), - ("suse" , SUSE ), - ("openembedded" , OpenEmbedded ) - ] - -vendorToStringMap :: Map Vendor String -vendorToStringMap = invertBijection vendorFromStringMap - -osFromStringMap :: Map String OS -osFromStringMap = Map.fromList [ - ("ananas" , Ananas ), - ("cloudabi" , CloudABI ), - ("darwin" , Darwin ), - ("dragonfly" , DragonFly ), - ("freebsd" , FreeBSD ), - ("fuchsia" , Fuchsia ), - ("ios" , IOS ), - ("kfreebsd" , KFreeBSD ), - ("linux" , Linux ), - ("lv2" , Lv2 ), - ("macosx" , MacOSX ), - ("netbsd" , NetBSD ), - ("openbsd" , OpenBSD ), - ("solaris" , Solaris ), - ("win32" , Win32 ), - ("zos" , ZOS ), - ("haiku" , Haiku ), - ("minix" , Minix ), - ("rtems" , RTEMS ), - ("nacl" , NaCl ), - ("aix" , AIX ), - ("cuda" , CUDA ), - ("nvcl" , NVCL ), - ("amdhsa" , AMDHSA ), - ("ps4" , PS4 ), - ("elfiamcu" , ELFIAMCU ), - ("tvos" , TvOS ), - ("watchos" , WatchOS ), - ("mesa3d" , Mesa3D ), - ("contiki" , Contiki ), - ("amdpal" , AMDPAL ), - ("hermitcore", HermitCore), - ("hurd" , Hurd ), - ("wasi" , WASI ), - ("emscripten", Emscripten) - ] - -osToStringMap :: Map OS String -osToStringMap = invertBijection osFromStringMap - -tripleToString :: Triple -> ShortByteString -tripleToString Triple {..} = - BS.toShort $ ByteString.intercalate (pack "-") [ - pack (architectureToStringMap ! architecture), - pack (vendorToStringMap ! vendor), - pack (osToStringMap ! os) - ] - -parseTriple :: ShortByteString -> Except String Triple -parseTriple triple = do - let - tripleStr = BS.fromShort triple - parseSpec :: Parser (Triple -> Triple) - parseSpec = choice [ - do - arch <- choice [string (pack s) $> a | (s, a) <- Map.toList architectureFromStringMap] - pure $ \t -> t { architecture = arch }, - do - vendor <- choice [string (pack s) $> v | (s, v) <- Map.toList vendorFromStringMap] - pure $ \t -> t { vendor = vendor }, - do - os <- choice [string (pack s) $> o | (s, o) <- Map.toList osFromStringMap] - pure $ \t -> t { os = os } - ] - in - case parseOnly (parseSpec `sepBy` char '-') tripleStr of - Left _ -> throwE $ "ill-formed triple: " ++ show tripleStr - Right fs -> pure $ foldr ($) unknownTriple fs - diff --git a/vendored/llvm-hs-pure/test/LLVM/Test/DataLayout.hs b/vendored/llvm-hs-pure/test/LLVM/Test/DataLayout.hs deleted file mode 100644 index 1bef42362..000000000 --- a/vendored/llvm-hs-pure/test/LLVM/Test/DataLayout.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module LLVM.Test.DataLayout where - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -import Control.Monad.Trans.Except - -import Control.Applicative -import Control.Monad -import Data.Maybe -import Data.Monoid -import qualified Data.Set as Set -import qualified Data.Map as Map - -import LLVM.AST -import LLVM.AST.DataLayout -import LLVM.AST.AddrSpace -import LLVM.DataLayout - -ddl = defaultDataLayout LittleEndian - -mergeWithDefaultDL :: DataLayout -> DataLayout -mergeWithDefaultDL dl = - dl - { pointerLayouts = pointerLayouts dl <> pointerLayouts (defaultDataLayout LittleEndian) - , typeLayouts = typeLayouts dl <> typeLayouts (defaultDataLayout LittleEndian) - } - -instance Arbitrary Endianness where - arbitrary = elements [LittleEndian, BigEndian] - -instance Arbitrary AddrSpace where - arbitrary = AddrSpace <$> arbitrary - -instance Arbitrary Mangling where - arbitrary = - elements [ELFMangling, MIPSMangling, MachOMangling, WindowsCOFFMangling] - -instance Arbitrary AlignmentInfo where - arbitrary = AlignmentInfo <$> arbitrary <*> arbitrary - -instance Arbitrary AlignType where - arbitrary = elements [IntegerAlign, VectorAlign, FloatAlign] - -instance Arbitrary DataLayout where - arbitrary = - DataLayout - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - -tests = testGroup "DataLayout" $ - testProperty "roundtrip" - (\dl -> pure (Just (mergeWithDefaultDL dl)) == parseDataLayout LittleEndian (dataLayoutToString dl)) - : - [ - testCase name $ do - let Right parsed = runExcept $ parseDataLayout LittleEndian strDl - (dataLayoutToString astDl, parsed) @?= (strDl, Just astDl) - | (name, astDl, strDl) <- [ - ("little-endian", ddl, "e"), - ("big-endian", defaultDataLayout BigEndian, "E"), - ("native", ddl { nativeSizes = Just (Set.fromList [8,32]) }, "e-n8:32"), - ( - "no pref", - ddl { - pointerLayouts = - Map.singleton - (AddrSpace 0) - ( - 8, - AlignmentInfo 64 64 - ) - }, - "e-p:8:64" - ), ( - "pref", - ddl { - pointerLayouts = - Map.insert (AddrSpace 1) (8, AlignmentInfo 32 64) (pointerLayouts ddl) - }, - "e-p1:8:32:64" - ), ( - "def", - ddl { pointerLayouts = Map.singleton (AddrSpace 0) (64, AlignmentInfo 64 64) }, - "e" - ), ( - "big", - ddl { - endianness = LittleEndian, - mangling = Just ELFMangling, - stackAlignment = Just 128, - pointerLayouts = Map.fromList [ - (AddrSpace 0, (8, AlignmentInfo 8 16)) - ], - typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo 8 256), - ((IntegerAlign, 8), AlignmentInfo 8 256), - ((IntegerAlign, 16), AlignmentInfo 16 256), - ((IntegerAlign, 32), AlignmentInfo 32 256), - ((IntegerAlign, 64), AlignmentInfo 64 256), - ((VectorAlign, 64), AlignmentInfo 64 256), - ((VectorAlign, 128), AlignmentInfo 128 256), - ((FloatAlign, 32), AlignmentInfo 32 256), - ((FloatAlign, 64), AlignmentInfo 64 256), - ((FloatAlign, 80), AlignmentInfo 128 256) - ] `Map.union` typeLayouts ddl, - aggregateLayout = AlignmentInfo 0 256, - nativeSizes = Just (Set.fromList [8,16,32,64]) - }, - "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-v64:64:256-v128:128:256-f32:32:256-f64:64:256-f80:128:256-a:0:256-n8:16:32:64-S128" - ) - ] - ] diff --git a/vendored/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs b/vendored/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs deleted file mode 100644 index 52cb7fe44..000000000 --- a/vendored/llvm-hs-pure/test/LLVM/Test/IRBuilder.hs +++ /dev/null @@ -1,635 +0,0 @@ -{-# 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 qualified LLVM.AST.Global -import LLVM.AST.Linkage (Linkage(..)) -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 { - LLVM.AST.Global.name = "add", - LLVM.AST.Global.parameters = - ( [ Parameter AST.i32 "a_0" [] - , Parameter AST.i32 "b_0" [] - ] - , False - ), - LLVM.AST.Global.returnType = AST.i32, - LLVM.AST.Global.basicBlocks = - [ BasicBlock - "entry_0" - [ UnName 0 := Add { - operand0 = LocalReference AST.i32 "a_0", - operand1 = LocalReference AST.i32 "b_0", - 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 "resolves typedefs" resolvesTypeDefs - , testCase "resolves constant typedefs" resolvesConstantTypeDefs - , testCase "handling of terminator" terminatorHandling - , 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 { - LLVM.AST.Global.name = "foo", - LLVM.AST.Global.returnType = AST.double, - LLVM.AST.Global.basicBlocks = - [ BasicBlock (UnName 0) [ "xxx_0" := fadd f10 f10] - (Do (Ret Nothing [])) - , BasicBlock - "blk_0" - [ 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 "blk_1" [])) - , BasicBlock - "blk_1" - [ "c_0" := fadd f10 f10 - , UnName 4 := fadd (LocalReference AST.double "c_0") (LocalReference AST.double "c_0") - ] - (Do (Br "blk_2" [])) - , BasicBlock - "blk_2" - [ "phi_0" := - Phi - AST.double - [ ( f10, "blk_0" ) - , ( f10, "blk_1" ) - , ( f10, "blk_2" ) - ] - [] - , UnName 5 := fadd f10 f10 - , UnName 6 := fadd (LocalReference AST.double (UnName 5)) (LocalReference AST.double (UnName 5)) - ] - (Do (Ret Nothing [])) - ] - } - , GlobalDefinition functionDefaults { - LLVM.AST.Global.name = "bar", - LLVM.AST.Global.returnType = AST.double, - LLVM.AST.Global.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 { - LLVM.AST.Global.name = "baz", - LLVM.AST.Global.parameters = - ( [ Parameter AST.i32 (UnName 0) [] - , Parameter AST.double "arg_0" [] - , Parameter AST.i32 (UnName 1) [] - , Parameter AST.double "arg_1" []] - , False), - LLVM.AST.Global.returnType = AST.double, - LLVM.AST.Global.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) - [ "arg_2" := fadd (LocalReference AST.double "arg_0") f10 - , UnName 5 := fadd (LocalReference AST.double "arg_2") (LocalReference AST.double "arg_2") - , UnName 6 := Select { - condition' = ConstantOperand (C.Int 1 0), - trueValue = LocalReference AST.double "arg_2", - 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 - { LLVM.AST.Global.returnType = AST.i32 - , LLVM.AST.Global.name = Name "f" - , LLVM.AST.Global.parameters = ([Parameter AST.i32 "a_0" []], False) - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (Name "entry_0") - [ 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_0"),[])] - , 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 { - LLVM.AST.Global.returnType = AST.ptr AST.i8, - LLVM.AST.Global.name = Name "malloc", - LLVM.AST.Global.parameters = ([Parameter (IntegerType {typeBits = 64}) (Name "") []],False), - LLVM.AST.Global.basicBlocks = [] - } - , GlobalDefinition functionDefaults { - LLVM.AST.Global.returnType = VoidType, - LLVM.AST.Global.name = Name "omg", - LLVM.AST.Global.parameters = ([],False), - LLVM.AST.Global.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' = []})) - ] - } - ] - } - -resolvesTypeDefs :: Assertion -resolvesTypeDefs = do - buildModule "" builder @?= ast - where builder = mdo - pairTy <- typedef "pair" (Just (StructureType False [AST.i32, AST.i32])) - function "f" [(AST.ptr pairTy, "ptr"), (AST.i32, "x"), (AST.i32, "y")] AST.void $ \[ptr, x, y] -> do - xPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] - yPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] - store xPtr 0 x - store yPtr 0 y - function "g" [(pairTy, "pair")] AST.i32 $ \[pair] -> do - x <- extractValue pair [0] - y <- extractValue pair [1] - z <- add x y - ret z - pure () - ast = defaultModule - { moduleName = "" - , moduleDefinitions = - [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32])) - , GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "f" - , LLVM.AST.Global.parameters = ( [ Parameter (AST.ptr (NamedTypeReference "pair")) "ptr_0" [] - , Parameter AST.i32 "x_0" [] - , Parameter AST.i32 "y_0" []] - , False) - , LLVM.AST.Global.returnType = AST.void - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (UnName 0) - [ UnName 1 := GetElementPtr - { inBounds = False - , address = LocalReference (AST.ptr (NamedTypeReference "pair")) "ptr_0" - , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] - , metadata = [] - } - , UnName 2 := GetElementPtr - { inBounds = False - , address = LocalReference (AST.ptr (NamedTypeReference "pair")) "ptr_0" - , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] - , metadata = [] - } - , Do $ Store - { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 1) - , value = LocalReference AST.i32 "x_0" - , maybeAtomicity = Nothing - , alignment = 0 - , metadata = [] - } - , Do $ Store - { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 2) - , value = LocalReference AST.i32 "y_0" - , maybeAtomicity = Nothing - , alignment = 0 - , metadata = [] - } - ] - (Do (Ret Nothing [])) - ] - } - , GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "g" - , LLVM.AST.Global.parameters = ( [Parameter (NamedTypeReference "pair") "pair_0" []] - , False) - , LLVM.AST.Global.returnType = AST.i32 - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (UnName 0) - [ UnName 1 := ExtractValue - { aggregate = LocalReference (NamedTypeReference "pair") "pair_0" - , indices' = [0] - , metadata = [] - } - , UnName 2 := ExtractValue - { aggregate = LocalReference (NamedTypeReference "pair") "pair_0" - , indices' = [1] - , metadata = [] - } - , UnName 3 := Add - { nsw = False - , nuw = False - , operand0 = LocalReference AST.i32 (UnName 1) - , operand1 = LocalReference AST.i32 (UnName 2) - , metadata = [] - } - ] - (Do (Ret (Just (LocalReference AST.i32 (UnName 3))) [])) - ] - } - ]} - -resolvesConstantTypeDefs :: Assertion -resolvesConstantTypeDefs = do - buildModule "" builder @?= ast - where builder = mdo - pairTy <- typedef "pair" (Just (StructureType False [AST.i32, AST.i32])) - globalPair <- global "gpair" pairTy (C.AggregateZero pairTy) - function "f" [(AST.i32, "x"), (AST.i32, "y")] AST.void $ \[x, y] -> do - let ptr = ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair" - xPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] - yPtr <- gep ptr [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] - store xPtr 0 x - store yPtr 0 y - function "g" [] AST.i32 $ \[] -> do - pair <- load (ConstantOperand $ C.GlobalReference (AST.ptr pairTy) "gpair") 0 - x <- extractValue pair [0] - y <- extractValue pair [1] - z <- add x y - ret z - pure () - ast = defaultModule - { moduleName = "" - , moduleDefinitions = - [ TypeDefinition "pair" (Just (StructureType False [AST.i32, AST.i32])) - , GlobalDefinition globalVariableDefaults - { LLVM.AST.Global.name = "gpair" - , LLVM.AST.Global.type' = NamedTypeReference "pair" - , LLVM.AST.Global.linkage = External - , LLVM.AST.Global.initializer = Just (C.AggregateZero (NamedTypeReference "pair")) - } - , GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "f" - , LLVM.AST.Global.parameters = ( [ Parameter AST.i32 "x_0" [] - , Parameter AST.i32 "y_0" []] - , False) - , LLVM.AST.Global.returnType = AST.void - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (UnName 0) - [ UnName 1 := GetElementPtr - { inBounds = False - , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair") - , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 0)] - , metadata = [] - } - , UnName 2 := GetElementPtr - { inBounds = False - , address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair") - , indices = [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 1)] - , metadata = [] - } - , Do $ Store - { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 1) - , value = LocalReference AST.i32 "x_0" - , maybeAtomicity = Nothing - , alignment = 0 - , metadata = [] - } - , Do $ Store - { volatile = False - , address = LocalReference (AST.ptr AST.i32) (UnName 2) - , value = LocalReference AST.i32 "y_0" - , maybeAtomicity = Nothing - , alignment = 0 - , metadata = [] - } - ] - (Do (Ret Nothing [])) - ] - } - , GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "g" - , LLVM.AST.Global.parameters = ([], False) - , LLVM.AST.Global.returnType = AST.i32 - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (UnName 0) - [ UnName 1 := Load - { volatile = False, - address = ConstantOperand (C.GlobalReference (AST.ptr (NamedTypeReference "pair")) "gpair"), - maybeAtomicity = Nothing, - alignment = 0, - metadata = [] - } - , UnName 2 := ExtractValue - { aggregate = LocalReference (NamedTypeReference "pair") (UnName 1) - , indices' = [0] - , metadata = [] - } - , UnName 3 := ExtractValue - { aggregate = LocalReference (NamedTypeReference "pair") (UnName 1) - , indices' = [1] - , metadata = [] - } - , UnName 4 := Add - { nsw = False - , nuw = False - , operand0 = LocalReference AST.i32 (UnName 2) - , operand1 = LocalReference AST.i32 (UnName 3) - , metadata = [] - } - ] - (Do (Ret (Just (LocalReference AST.i32 (UnName 4))) [])) - ] - } - ]} - -terminatorHandling :: Assertion -terminatorHandling = do - firstTerminatorWins @?= firstWinsAst - terminatorsCompose @?= terminatorsComposeAst - nestedControlFlowWorks @?= nestedControlFlowAst - where - firstTerminatorWins = buildModule "firstTerminatorWinsModule" $ mdo - function "f" [(AST.i32, "a"), (AST.i32, "b")] AST.i32 $ \[a, b] -> mdo - - entry <- block `named` "entry"; do - c <- add a b - d <- add a c - ret c - ret d - terminatorsCompose = buildModule "terminatorsComposeModule" $ mdo - function "f" [(AST.i1, "a")] AST.i1 $ \[a] -> mdo - - entry <- block `named` "entry"; do - if' a $ do - ret (bit 0) - - ret (bit 1) - nestedControlFlowWorks = buildModule "nestedControlFlowWorksModule" $ mdo - function "f" [(AST.i1, "a"), (AST.i1, "b")] AST.i1 $ \[a, b] -> mdo - - entry <- block `named` "entry"; do - if' a $ do - if' b $ do - ret (bit 0) - - ret (bit 1) - if' cond asm = mdo - condBr cond ifBlock end - ifBlock <- block `named` "if.begin" - asm - br end - end <- block `named` "if.end" - return () - - firstWinsAst = defaultModule - { moduleName = "firstTerminatorWinsModule" - , moduleDefinitions = - [ GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "f" - , LLVM.AST.Global.parameters = ([ Parameter AST.i32 "a_0" [], Parameter AST.i32 "b_0" []], False) - , LLVM.AST.Global.returnType = AST.i32 - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (Name "entry_0") - [ UnName 0 := Add { nsw = False, nuw = False, metadata = [] - , operand0 = LocalReference (IntegerType {typeBits = 32}) (Name "a_0") - , operand1 = LocalReference (IntegerType {typeBits = 32}) (Name "b_0") - } - , UnName 1 := Add { nsw = False, nuw = False, metadata = [] - , operand0 = LocalReference (IntegerType {typeBits = 32}) (Name "a_0") - , operand1 = LocalReference (IntegerType {typeBits = 32}) (UnName 0) - } - ] - (Do (Ret {returnOperand = Just (LocalReference (IntegerType {typeBits = 32}) (UnName 0)), metadata' = []}))] - } - ]} - terminatorsComposeAst = defaultModule - { moduleName = "terminatorsComposeModule" - , moduleDefinitions = - [ GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "f" - , LLVM.AST.Global.parameters = ([ Parameter AST.i1 "a_0" []], False) - , LLVM.AST.Global.returnType = AST.i1 - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (Name "entry_0") - [] - (Do (CondBr {condition = LocalReference (IntegerType {typeBits = 1}) (Name "a_0") - , trueDest = Name "if.begin_0" - , falseDest = Name "if.end_0", metadata' = []})) - , BasicBlock (Name "if.begin_0") - [] - (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 0})), metadata' = []})) - , BasicBlock (Name "if.end_0") - [] - (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), metadata' = []}))] - } - ]} - nestedControlFlowAst = defaultModule - { moduleName = "nestedControlFlowWorksModule" - , moduleDefinitions = - [ GlobalDefinition functionDefaults - { LLVM.AST.Global.name = "f" - , LLVM.AST.Global.parameters = ([ Parameter AST.i1 "a_0" [], Parameter AST.i1 "b_0" []], False) - , LLVM.AST.Global.returnType = AST.i1 - , LLVM.AST.Global.basicBlocks = - [ BasicBlock (Name "entry_0") - [] - (Do (CondBr { condition = LocalReference (IntegerType {typeBits = 1}) (Name "a_0") - , trueDest = Name "if.begin_0" - , falseDest = Name "if.end_1" - , metadata' = []})) - , BasicBlock (Name "if.begin_0") [] (Do (CondBr { condition = LocalReference (IntegerType {typeBits = 1}) (Name "b_0") - , trueDest = Name "if.begin_1" - , falseDest = Name "if.end_0" - , metadata' = []})) - , BasicBlock (Name "if.begin_1") [] (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 0})), metadata' = []})) - , BasicBlock (Name "if.end_0") [] (Do (Br {dest = Name "if.end_1", metadata' = []})) - , BasicBlock (Name "if.end_1") [] (Do (Ret {returnOperand = Just (ConstantOperand (C.Int {C.integerBits = 1, C.integerValue = 1})), 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 - let 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/vendored/llvm-hs-pure/test/LLVM/Test/Tests.hs b/vendored/llvm-hs-pure/test/LLVM/Test/Tests.hs deleted file mode 100644 index e32554504..000000000 --- a/vendored/llvm-hs-pure/test/LLVM/Test/Tests.hs +++ /dev/null @@ -1,11 +0,0 @@ -module LLVM.Test.Tests where - -import Test.Tasty - -import qualified LLVM.Test.DataLayout as DataLayout -import qualified LLVM.Test.IRBuilder as IRBuilder - -tests = testGroup "llvm-hs" - [ DataLayout.tests - , IRBuilder.tests - ] diff --git a/vendored/llvm-hs-pure/test/Test.hs b/vendored/llvm-hs-pure/test/Test.hs deleted file mode 100644 index 75b88570b..000000000 --- a/vendored/llvm-hs-pure/test/Test.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Test.Tasty as X -import qualified LLVM.Test.Tests as LLVM - -main = defaultMain LLVM.tests From 1e0b5020e4b00e2dc74421858a8176ed51e2e35d Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Mon, 23 Oct 2023 23:15:24 +0100 Subject: [PATCH 2/3] Start fixing things somewhat --- .../src/Smol/Backend/IR/ToLLVM/Helpers.hs | 32 +++++++++++-------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs b/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs index 180468107..6e9471b6f 100644 --- a/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs +++ b/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs @@ -134,24 +134,26 @@ getPrintInt = extern "printint" [AST.i32] AST.i32 -- | given a pointer to a struct, get the value at `index` loadFromStruct :: (L.MonadIRBuilder m, L.MonadModuleBuilder m) => + LLVM.Type -> Op.Operand -> [Integer] -> m Op.Operand -loadFromStruct struct' indexes = do +loadFromStruct ty struct' indexes = do -- get pointer to slot `i` - slot1 <- LLVM.gep struct' $ C.int32 <$> ([0] <> indexes) + slot1 <- LLVM.gep ty struct' $ C.int32 <$> ([0] <> indexes) -- load value - LLVM.load slot1 0 + LLVM.load ty slot1 0 storePrimInStruct :: (L.MonadIRBuilder m, L.MonadModuleBuilder m) => + LLVM.Type -> Op.Operand -> [Integer] -> Op.Operand -> m () -storePrimInStruct struct' indexes a = do +storePrimInStruct ty struct' indexes a = do -- get pointer to element - slot1 <- LLVM.gep struct' $ C.int32 <$> ([0] <> indexes) + slot1 <- LLVM.gep ty struct' $ C.int32 <$> ([0] <> indexes) -- store a in slot1 LLVM.store slot1 0 a @@ -160,26 +162,28 @@ moveToStruct :: ( L.MonadModuleBuilder m, L.MonadIRBuilder m ) => + LLVM.Type -> Op.Operand -> Op.Operand -> m () -moveToStruct fromStruct toStruct = do - input <- LLVM.load fromStruct 0 +moveToStruct ty fromStruct toStruct = do + input <- LLVM.load ty fromStruct 0 LLVM.store toStruct 0 input callClosure :: ( L.MonadModuleBuilder m, L.MonadIRBuilder m ) => + LLVM.Type -> Op.Operand -> Op.Operand -> m Op.Operand -callClosure opFunc opArg = do +callClosure ty opFunc opArg = do -- get fn pt and env (fn, env) <- fromClosure opFunc -- call fn with env + arg - LLVM.call + LLVM.call ty fn [ (opArg, []), (env, []) @@ -194,11 +198,13 @@ callWithReturnStruct :: [Op.Operand] -> m Op.Operand callWithReturnStruct fn structType fnArgs = do + let ty = LLVM.void + retStruct <- allocLocal "struct-return" structType let allArgs = (,[]) <$> (fnArgs <> [retStruct]) - _ <- LLVM.call fn allArgs + _ <- LLVM.call ty fn allArgs pure retStruct @@ -206,9 +212,9 @@ struct :: [AST.Type] -> AST.Type struct = AST.StructureType False -pointerType :: AST.Type -> AST.Type -pointerType ty = - AST.PointerType ty (AST.AddrSpace 0) +pointerType :: AST.Type +pointerType = + AST.PointerType (AST.AddrSpace 0) allocLocal :: (L.MonadIRBuilder m) => From 143677a689dea05c4e9f4a757c9f70deb234996e Mon Sep 17 00:00:00 2001 From: Daniel Harvey Date: Tue, 7 Nov 2023 22:24:50 +0000 Subject: [PATCH 3/3] Slightly more --- .../src/Smol/Backend/IR/ToLLVM/Helpers.hs | 32 +++++++++++-------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs b/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs index 6e9471b6f..c06e86acd 100644 --- a/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs +++ b/smol-backend/src/Smol/Backend/IR/ToLLVM/Helpers.hs @@ -174,16 +174,17 @@ callClosure :: ( L.MonadModuleBuilder m, L.MonadIRBuilder m ) => + (LLVM.Type, LLVM.Type) -> LLVM.Type -> Op.Operand -> Op.Operand -> m Op.Operand -callClosure ty opFunc opArg = do +callClosure (fnTy, closureTy) returnTy opFunc opArg = do -- get fn pt and env - (fn, env) <- fromClosure opFunc + (fn, env) <- fromClosure (fnTy, closureTy) opFunc -- call fn with env + arg - LLVM.call ty + LLVM.call returnTy fn [ (opArg, []), (env, []) @@ -227,14 +228,15 @@ allocLocal label ty = -- | get fn and environment from closure for calling fromClosure :: (L.MonadIRBuilder m, L.MonadModuleBuilder m) => + (LLVM.Type ,LLVM.Type)-> Op.Operand -> m (Op.Operand, Op.Operand) -fromClosure closure = do +fromClosure (fnTy,closureTy) closure = do -- get fn pt - fn <- loadFromStruct closure [0] + fn <- loadFromStruct fnTy closure [0] -- get pointer to env - envAddress <- LLVM.gep closure [C.int32 0, C.int32 1] + envAddress <- LLVM.gep closureTy closure [C.int32 0, C.int32 1] pure (fn, envAddress) @@ -319,8 +321,8 @@ irTypeToLLVM IRInt2 = LLVM.i1 irTypeToLLVM (IRArray size inner) = LLVM.ArrayType size (irTypeToLLVM inner) irTypeToLLVM (IRStruct bits) = LLVM.StructureType False (irTypeToLLVM <$> bits) -irTypeToLLVM (IRPointer target) = - LLVM.PointerType (irTypeToLLVM target) (LLVM.AddrSpace 0) +irTypeToLLVM (IRPointer _target) = + LLVM.PointerType (LLVM.AddrSpace 0) irTypeToLLVM (IRFunctionType tyArgs tyRet) = LLVM.FunctionType (functionReturnType tyRet) (functionArgsType tyRet tyArgs) False @@ -353,10 +355,10 @@ irStoreInStruct :: irStoreInStruct fromTy toStruct indexes from = do input <- if irTypeNeedsPointer fromTy - then LLVM.load from 0 + then LLVM.load (irTypeToLLVM fromTy) from 0 else pure from -- get pointer to element - slot1 <- LLVM.gep toStruct $ LLVM.int32 <$> ([0] <> indexes) + slot1 <- LLVM.gep (irTypeToLLVM fromTy) toStruct $ LLVM.int32 <$> ([0] <> indexes) -- store a in slot1 LLVM.store slot1 0 input @@ -373,14 +375,16 @@ irVarFromPath :: LLVM.MonadModuleBuilder m, LLVM.MonadIRBuilder m ) => + LLVM.Type -> LLVM.Operand -> IRIdentifier -> GetPath -> m () -irVarFromPath llExpr ident (GetPath as GetValue) = do - val <- if null as then pure llExpr else loadFromStruct llExpr as +irVarFromPath ty llExpr ident (GetPath as GetValue) = do + val <- if null as then pure llExpr else + loadFromStruct ty llExpr as addVar ident val -irVarFromPath _llExpr _ident (GetPath _ (GetArrayTail _)) = do +irVarFromPath _llExpr _ _ident (GetPath _ (GetArrayTail _)) = do error "spread on arrays not implemented as we'll need some sort of malloc" irFuncPointerToLLVM :: (MonadState IRState m) => IRFunctionName -> m LLVM.Operand @@ -388,4 +392,4 @@ irFuncPointerToLLVM fnName = do fnType <- lookupFunctionType fnName pure $ LLVM.ConstantOperand - (LLVM.GlobalReference (pointerType fnType) (irFunctionNameToLLVM fnName)) + (LLVM.GlobalReference (irFunctionNameToLLVM fnName))