diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,369 @@ +## 12.1.0 (2023.06.26) + ++ Merge llvm-hs and llvm-hs-pure. ++ Fix the build ++ Add upper bounds to everything + +# llvm-hs changelog + +## 12.0.0 (2021-03-19) + +* Update to LLVM 12.0 +* Remove OrcJIT V1 bindings and replace them with OrcJIT V2. + +## 9.0.1 (2019-09-28) + +* Fix build with Clang on MacOS. +* Expose `LLVMOffsetOfElement` as `getOffsetOfElement`. + +## 9.0.0 (2019-09-06) + +* Support GHC 8.8 +* Update to LLVM 9.0 + * Note that this is the last LLVM release that supports the current + OrcJIT APIs and `llvm-hs` does not yet have bindings for OrcJIT + V2. If you are interested in working on that please get in + touch. See https://github.com/llvm-hs/llvm-hs/issues/276 for more + details. + * The `sanitizeAddresses` field from `MachineCodeOptions` has been + removed following a change in LLVM. + * The `MemorySanitizer` now has two new options `kernel` and + `recover` matching the options in LLVM. + + +## 8.1.0 + +* Change `withHostTargetMachine` to accept the code model, relocation model, + and optimization level as arguments. The old behaviour is available + under the name `withHostTargetMachineDefault`. + +## 8.0.0 (2019-03-10) + +* Upgrade to LLVM 8 +* It is now possible to define multiple variables with an empty name + without causing a name collision. Variables with an empty name + cannot be referenced. This fixes an issue caused by using + IRBuilder’s `extern` helper. + +## 7.0.1 (2018-09-29) + +* Support llvm-config executables named `llvm-config-7` in addition to + `llvm-config-7.0` and `llvm-config`. + +## 7.0.0 (2018-09-28) + +* Throw an `EncodeException` if a local variable is defined multiple + times. This is consistent with `llc` which also forbids reusing + variable names. +* Update for LLVM 7.0: + * The ORC JIT API has been changed to reflect the changes in LLVM + itself. The test suite should give you a good idea of how to adapt + your code but here is a summary: + * There is now a separate `ExecutionSession` that tracks module handles. + * `SymbolResolver` only has a single resolver function. + * Creating an `ObjectLinkingLayer` requires a way to get the + symbol resolver for a module. + * Creating a `CompileOnDemandLayer` requires a way to set and get + the symbol resolver for a module. + +## 6.3.0 (2018-06-12) + +* `findSymbol` and `findSymbolIn` now return `Either JITSymbolError + JITSymbol` if the JIT symbol has the error flag set or the address + is 0. (This is consistent with how LLVM treats JIT symbols). +* The return type of `SymbolResolverFn` has been changed to `Either + JITSymbolError JITSymbol`. It is fine to return a 0 address in + `Right` so existing resolvers can be adapted by wrapping the result + in `Right`. +* Fixed a bug where instructions were constant-folded during + encoding. This caused problems since the API available on a Constant + is not the same as the one on an Instruction (e.g., we cannot set + metadata on a Constant). +* Fix use-after-free in `createObjectFile`. +* Add `withObjectFile` wrapper for `createObjectFile` and + `disposeObjectFile`. +* Add API for looking up symbols in the `LinkingLayer`. +* Add `LLVM.OrcJIT.CompileLayer` and `LLVM.OrcJIT.LinkingLayer` + modules that reexport the internal modules. The + `findSymbol/findSymbolIn` methods that have previously been exported + from `LLVM.OrcJIT` can now be found in `LLVM.OrcJIT.CompileLayer`. + +## 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.1 (2018-05-06) + +* Fix the source distribution by adding missing files to extra-source-files. + +## 6.1.0 (2018-05-05) + +* Remove the `MetadataNodeReference` constructor. References to + metadata nodes are now encoded using the polymorphic `MDRef` type. +* Add support for encoding and decoding debug metadata. Thanks to + @xldenis who started that effort! +* Drop support for GHC 7.10. +* Support decoding/encoding of metadata in `GlobalVariable` and `Function`. +* Fix check that the type of `GlobalReference` is correct in the + presence of automatic renamings due to name collisions. +* Extract LinkingLayer into a separate module. + +## 6.0.0 (2018-03-06) + +* Support for LLVM 6.0, take a look at the changelog of llvm-hs-pure for details. +* 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. +* Enforce that `Null` is only used on pointer types. Existing uses of `Null` on arrays, structs and + vector must be changed to the newly introduced `AggregateZero`. + +## 5.1.3 (2018-01-06) + +* Add bindings to `loadLibraryPermamently` and `getSymbolAddressInProcess`. + +## 5.1.2 (2017-12-19) + +* Reupload of 5.1.1 since [Hackage broke](https://github.com/haskell/hackage-server/issues/643) during the original upload. + +## 5.1.1 (2017-12-16) + +* Fix argument order in `LLVM_Hs_CreateTargetMachine`. This affects `withTargetMachine` and `withHostTargetMachine`. +* Add support for `MCTargetOptions`. + +## 5.1.0 (2017-10-12) + +### Bugfixes + +* Set target options in `withTargetMachine`. Previously the options + passed there were simply ignored. +* Fix decoding of constant vectors. +* Fix decoding of function attributes in calls. + +### Enhancements + +* Support for more target options. +* 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` 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. + * The `OrcJIT`-API now operates on individual modules instead of + sets of modules. + * The `lessPreciseFloatingPointMultiplyAddOption` field has been + removed from the target options. + * The `compressDebugSections` option field is now of type + `DebugCompressionType` instead of `Bool`. + * The `BasicBlockVectorize` pass has been removed. You should use + `SuperwordLevelParallelismVectorize` instead. + +* Throw 'EncodeException' when the type supplied in a + 'GlobalReference' does not match the type of the expression. +* Throw 'EncodeException' when the result of instructions returning + void is named using ':='. + +## 4.2.0 (2017-06-20) + +* Revamp OrcJIT API + * The user facing API is now exposed using `LLVM.OrcJIT`. + * All user facing functions have been documented. + * In addition the bracket-style API, there are now `new*` and + `dispose*` functions making it easier to ingegrate OrcJIT in + custom monad transformer stacks. + * There is a new `CompileLayer` typeclass which abstracts over the + various compile layers in `OrcJIT`. +* Support QuickCheck 2.10 + +## 4.1.0 (2017-05-17) + +* Switch most of the API from `String` to `ByteString`. +* Switch from ExceptT to using exceptions. + See `LLVM.Exception` for an overview of the exceptions potentially thrown. + +## 4.0.1 + +* Fix linking of system libraries + +## 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. + +# llvm-hs-pure changelog + +## 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,88 @@ +# llvm-party - Haskell bindings for LLVM + +[![Build Status](https://travis-ci.org/llvm-hs/llvm-hs.svg?branch=llvm-6)](https://travis-ci.org/llvm-hs/llvm-hs) [![Hackage](https://img.shields.io/hackage/v/llvm-hs.svg)](https://hackage.haskell.org/package/llvm-hs) + +This project aims to provide a relatively complete set of bindings for +the LLVM API. If you find that anything is missing please open an +issue! We generally try to stay close to the LLVM C++-API so you can +consult the LLVM documentation and reuse existing resources. + +This is yet [another](https://hackage.haskell.org/package/llvm-tf) [fork](https://hackage.haskell.org/package/llvm) [of](https://hackage.haskell.org/package/llvm-hs) [llvm](https://hackage.haskell.org/package/llvm-general). +Specifically [llvm-hs](https://hackage.haskell.org/package/llvm-hs)/[llvm-hs-pure](https://hackage.haskell.org/package/llvm-hs-pure) +was forked, and smashed together into a single package. + +## Getting started + +If you’ve worked with LLVM before, take a look at the examples in the +[llvm-hs-examples repo](https://github.com/llvm-hs/llvm-hs-examples). +If not, you can find a translation of the [official LLVM +tutorial](http://llvm.org/docs/tutorial/#kaleidoscope-implementing-a-language-with-llvm) +at https://github.com/llvm-hs/llvm-hs-kaleidoscope. There is also a +[blog series](https://blog.josephmorag.com/tags/llvm/) on writing a C +compiler with the library. In general, we try to stay very close to +the API and AST provided by LLVM itself, so the [LLVM language +reference](http://llvm.org/docs/LangRef.html) is also very useful. + +## LLVM API Interface + +`llvm-hs` provides an LLVM binding at (roughly) the same level of abstraction +as the official LLVM C API. Because of this, anything you might do with the +LLVM C API, you should expect to be able to do with `llvm-hs`. In addition, +some things which are not handled in the LLVM C API are supported. For example, +the LLVM C API [does not provide any +support](https://llvm.org/doxygen/group__LLVMCSupportTypes.html) for working +with `AttributeSet` and `AttributeList` types, but `llvm-hs` does. + +However, the binding to LLVM is only half the story: a lot of advanced +pure-Haskell functionality is built on top of this basic interface in the +`llvm-hs-pure` module, most notably the monadic +[IRBuilder](https://hackage.haskell.org/package/llvm-hs-pure) and +[ModuleBuilder](https://hackage.haskell.org/package/llvm-hs-pure) interfaces +which greatly simplify the task of generating LLVM code from a higher level +abstract syntax. The +[llvm-hs-examples](https://github.com/llvm-hs/llvm-hs-examples/blob/master/irbuilder/Main.hs) +project contains example usage. These high level interfaces are ideal for +implementing the LLVM backend for your code generation project. A good example +is Google's [Dex](https://github.com/google-research/dex-lang) research +language. + +## LLVM API Coverage and Philosophy + +The `llvm-hs` FFI layer in `LLVM/Internal/FFI` extends the upstream LLVM C API +*adding missing functionality* which upstream has not yet exposed from the C++ +API. We also provide some *improved implementations* of buggy or otherwise +problematic functions in the LLVM C API. As the LLVM C API becomes more +complete, we retire our extensions and directly wrap the newly added C API +functions, ensuring our FFI layer is as small as possible. + +If you find you need to use some LLVM functionality which is available via the +C++ API but not via the C API or in `llvm-hs`, please open an issue and +include links to the relevant entities in the LLVM doxygen-generated +documentation. + +In general, if it is possible to implement something in Haskell using the LLVM +C API primitives, that is preferable to implementing things in the FFI layer +and merely exposing them to Haskell as wrapped C or C++ functions. + +## Contributing + +We love all kinds of contributions so please feel free to open issues for +missing LLVM features, report & fix bugs or report API inconveniences. + +## Versioning + +Trying to represent the version of LLVM in the version number but also +allowing for version bumps in the bindings themselves while respecting +the [PVP](http://pvp.haskell.org/) can be tricky. Luckily LLVM switched to a +[new versioning scheme](http://blog.llvm.org/2016/12/llvms-new-versioning-scheme.html) +of `major.0.patch` starting from version `4.0`. This means that we can +use the last two components for these bindings while the first +component indicates the version of LLVM. A special case are the +versions `3.major.minor` that represent bindings to LLVM 3.9. Bindings +to earlier versions are not provided. + +## How is this related to llvm-general? + +This project is a fork of the venerable `llvm-general` that aims to improve the +public release story, and better provide the interfaces needed for any Haskell +project looking to leverage LLVM. Contributions are encouraged. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE CPP, FlexibleInstances #-} +import Control.Exception (SomeException, try) +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import Data.Monoid +import Distribution.PackageDescription hiding (buildInfo, includeDirs) +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Setup hiding (Flag) +import Distribution.System +import System.Environment + +#ifdef MIN_VERSION_Cabal +#if MIN_VERSION_Cabal(2,0,0) +#define MIN_VERSION_Cabal_2_0_0 +#endif +#endif + +-- define these selectively in C files (we are _not_ using HsFFI.h), +-- rather than universally in the ccOptions, because HsFFI.h currently defines them +-- without checking they're already defined and so causes warnings. +uncheckedHsFFIDefines :: [String] +uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] + +#ifndef MIN_VERSION_Cabal_2_0_0 +mkVersion :: [Int] -> Version +mkVersion ver = Version ver [] +versionNumbers :: Version -> [Int] +versionNumbers = versionBranch +mkFlagName :: String -> FlagName +mkFlagName = FlagName +#endif + +#if !(MIN_VERSION_Cabal(2,1,0)) +lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool +lookupFlagAssignment = lookup +#endif + +llvmVersion :: Version +llvmVersion = mkVersion [12,0] + +-- Ordered by decreasing specificty so we will prefer llvm-config-9.0 +-- over llvm-config-9 over llvm-config. +llvmConfigNames :: [String] +llvmConfigNames = reverse versionedConfigs ++ ["llvm-config"] + where + versionedConfigs = + map + (\vs -> "llvm-config-" ++ intercalate "." (map show vs)) + (tail (inits (versionNumbers llvmVersion))) + +findJustBy :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b) +findJustBy f (x:xs) = do + x' <- f x + case x' of + Nothing -> findJustBy f xs + j -> return j +findJustBy _ [] = return Nothing + +llvmProgram :: Program +llvmProgram = (simpleProgram "llvm-config") { + programFindLocation = \v p -> findJustBy (\n -> programFindLocation (simpleProgram n) v p) llvmConfigNames, + programFindVersion = \verbosity path -> + let + stripVcsSuffix = takeWhile (\c -> isDigit c || c == '.') + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + in findProgramVersion "--version" (stripVcsSuffix . trim) verbosity path + } + +getLLVMConfig :: ConfigFlags -> IO ([String] -> IO String) +getLLVMConfig confFlags = do + let verbosity = fromFlag $ configVerbosity confFlags + (program, _, _) <- requireProgramVersion verbosity llvmProgram + (withinVersion llvmVersion) + (configPrograms confFlags) + return $ getProgramOutput verbosity program + +addToLdLibraryPath :: String -> IO () +addToLdLibraryPath path = do + let (ldLibraryPathVar, ldLibraryPathSep) = + case buildOS of + OSX -> ("DYLD_LIBRARY_PATH",":") + _ -> ("LD_LIBRARY_PATH",":") + v <- try $ getEnv ldLibraryPathVar :: IO (Either SomeException String) + setEnv ldLibraryPathVar (path ++ either (const "") (ldLibraryPathSep ++) v) + +addLLVMToLdLibraryPath :: ConfigFlags -> IO () +addLLVMToLdLibraryPath confFlags = do + llvmConfig <- getLLVMConfig confFlags + [libDir] <- liftM lines $ llvmConfig ["--libdir"] + addToLdLibraryPath libDir + +-- | These flags are not relevant for us and dropping them allows +-- linking against LLVM build with Clang using GCC +ignoredCxxFlags :: [String] +ignoredCxxFlags = ["-fcolor-diagnostics"] ++ map ("-D" ++) uncheckedHsFFIDefines + +ignoredCFlags :: [String] +ignoredCFlags = ["-fcolor-diagnostics"] + +-- | Header directories are added separately to configExtraIncludeDirs +isIncludeFlag :: String -> Bool +isIncludeFlag flag = "-I" `isPrefixOf` flag + +isWarningFlag :: String -> Bool +isWarningFlag flag = "-W" `isPrefixOf` flag + +isIgnoredCFlag :: String -> Bool +isIgnoredCFlag flag = flag `elem` ignoredCFlags || isIncludeFlag flag || isWarningFlag flag + +isIgnoredCxxFlag :: String -> Bool +isIgnoredCxxFlag flag = flag `elem` ignoredCxxFlags || isIncludeFlag flag || isWarningFlag flag + +main :: IO () +main = do + let origUserHooks = simpleUserHooks + + defaultMainWithHooks origUserHooks { + hookedPrograms = [ llvmProgram ], + + confHook = \(genericPackageDescription, hookedBuildInfo) confFlags -> do + llvmConfig <- getLLVMConfig confFlags + llvmCxxFlags <- do + rawLlvmCxxFlags <- llvmConfig ["--cxxflags"] + return . filter (not . isIgnoredCxxFlag) $ words rawLlvmCxxFlags + let stdLib = maybe "stdc++" + (drop (length stdlibPrefix)) + (find (isPrefixOf stdlibPrefix) llvmCxxFlags) + where stdlibPrefix = "-stdlib=lib" + includeDirs <- liftM lines $ llvmConfig ["--includedir"] + libDirs <- liftM lines $ llvmConfig ["--libdir"] + [llvmVersion] <- liftM lines $ llvmConfig ["--version"] + let getLibs = liftM (map (fromJust . stripPrefix "-l") . words) . llvmConfig + flags = configConfigurationsFlags confFlags + linkFlag = case lookupFlagAssignment (mkFlagName "shared-llvm") flags of + Nothing -> "--link-shared" + Just shared -> if shared then "--link-shared" else "--link-static" + libs <- getLibs ["--libs", linkFlag] + systemLibs <- getLibs ["--system-libs", linkFlag] + + let genericPackageDescription' = genericPackageDescription { + condLibrary = do + libraryCondTree <- condLibrary genericPackageDescription + return libraryCondTree { + condTreeData = condTreeData libraryCondTree <> mempty { + libBuildInfo = + mempty { + ccOptions = llvmCxxFlags, + extraLibs = libs ++ stdLib : systemLibs + } + } + } + } + configFlags' = confFlags { + configExtraLibDirs = libDirs ++ configExtraLibDirs confFlags, + configExtraIncludeDirs = includeDirs ++ configExtraIncludeDirs confFlags + } + addLLVMToLdLibraryPath configFlags' + confHook simpleUserHooks (genericPackageDescription', hookedBuildInfo) configFlags', + + hookedPreProcessors = + let origHookedPreprocessors = hookedPreProcessors origUserHooks +#ifdef MIN_VERSION_Cabal_2_0_0 + newHsc buildInfo localBuildInfo componentLocalBuildInfo = +#else + newHsc buildInfo localBuildInfo = +#endif + ppUnlit { + platformIndependent = platformIndependent (origHsc buildInfo), + runPreProcessor = \inFiles outFiles verbosity -> do + llvmConfig <- getLLVMConfig (configFlags localBuildInfo) + llvmCFlags <- do + rawLlvmCFlags <- llvmConfig ["--cflags"] + return . filter (not . isIgnoredCFlag) $ words rawLlvmCFlags + let buildInfo' = buildInfo { ccOptions = "-Wno-variadic-macros" : llvmCFlags } + runPreProcessor (origHsc buildInfo') inFiles outFiles verbosity + } + where origHsc buildInfo' = + fromMaybe + ppHsc2hs + (lookup "hsc" origHookedPreprocessors) + buildInfo' + localBuildInfo +#ifdef MIN_VERSION_Cabal_2_0_0 + componentLocalBuildInfo +#endif + in [("hsc", newHsc)] ++ origHookedPreprocessors, + + buildHook = \packageDesc localBuildInfo userHooks buildFlags -> + do addLLVMToLdLibraryPath (configFlags localBuildInfo) + buildHook origUserHooks packageDesc localBuildInfo userHooks buildFlags, + + testHook = \args packageDesc localBuildInfo userHooks testFlags -> + do addLLVMToLdLibraryPath (configFlags localBuildInfo) + testHook origUserHooks args packageDesc localBuildInfo userHooks testFlags + } diff --git a/llvm-party.cabal b/llvm-party.cabal new file mode 100644 --- /dev/null +++ b/llvm-party.cabal @@ -0,0 +1,346 @@ +cabal-version: 2.2 +name: llvm-party +version: 12.1.0 +license: BSD-3-Clause +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/jappeace/llvm-party/ +bug-reports: http://github.com/jappeace/llvm-party/issues +build-type: Custom +stability: experimental +category: Compilers/Interpreters, Code Generation +synopsis: General purpose LLVM bindings +description: + llvm-party is a set of Haskell bindings for LLVM . Unlike other current Haskell bindings, + it uses an ADT to represent LLVM IR (), and so offers two advantages: it + handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not + only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell. + This is a fork of llvm-hs, with a major advantage that it's being maintained, for now. + +extra-source-files: + src/LLVM/Internal/FFI/Analysis.h + src/LLVM/Internal/FFI/Attribute.h + src/LLVM/Internal/FFI/AttributeC.hpp + src/LLVM/Internal/FFI/CallingConvention.h + src/LLVM/Internal/FFI/Constant.h + src/LLVM/Internal/FFI/ErrorHandling.hpp + src/LLVM/Internal/FFI/GlobalValue.h + src/LLVM/Internal/FFI/InlineAssembly.h + src/LLVM/Internal/FFI/Instruction.h + src/LLVM/Internal/FFI/LibFunc.h + src/LLVM/Internal/FFI/Metadata.h + src/LLVM/Internal/FFI/OrcJIT.h + src/LLVM/Internal/FFI/SMDiagnostic.h + src/LLVM/Internal/FFI/Target.h + src/LLVM/Internal/FFI/Target.hpp + src/LLVM/Internal/FFI/Type.h + src/LLVM/Internal/FFI/Value.h + test/debug_metadata_1.ll + test/debug_metadata_2.ll + test/debug_metadata_3.ll + test/debug_metadata_4.ll + test/debug_metadata_5.ll + test/main_return_38.c + README.md + LICENSE + CHANGELOG.md + +tested-with: GHC ==8.8.1 +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: git://github.com/jappeace/llvm-party.git + branch: llvm-12 + +flag shared-llvm + description: link against llvm shared rather than static library + default: True + +flag llvm-with-rtti + description: + assume llvm was built with LLVM_ENABLE_RTTI=ON (default is OFF) + + default: False + +flag debug + description: + compile C(++) shims with debug info for ease of troubleshooting + + default: False + +custom-setup + setup-depends: + , base <5 + , Cabal <3.10.1.0 + , containers + +library + default-language: Haskell2010 + hs-source-dirs: src + build-tool-depends: hsc2hs:hsc2hs + ghc-options: + -O2 -Wall -fno-warn-name-shadowing -fno-warn-orphans -optcxx=-O3 + -optcxx=-Wall -optcxx=-std=c++14 -optcxx=-lstdc++ + + cxx-options: -O3 -Wall -std=c++14 + + if flag(llvm-with-rtti) + cxx-options: -frtti + ghc-options: -optcxx=-frtti + + else + cxx-options: -fno-rtti + ghc-options: -optcxx=-fno-rtti + + if flag(debug) + cxx-options: -g + ghc-options: -optcxx=-g + + extra-libraries: stdc++ + build-depends: + , array >=0.4.0.0 && <0.6 + , attoparsec >=0.13 && <0.15 + , base >=4.9 && <5 + , bytestring >=0.10 && <0.12 + , containers >=0.4.2.1 && <0.7 + , exceptions >=0.8 && <0.11 + , fail <4.10 + , mtl >=2.1.3 && <2.3 + , template-haskell >=2.5.0.0 && <2.20 + , transformers >=0.3 && <0.6 + , unordered-containers >=0.2 && <0.3 + , utf8-string >=0.3.7 && <1.1 + + default-extensions: + NoImplicitPrelude + ConstraintKinds + DeriveDataTypeable + DeriveGeneric + EmptyDataDecls + FlexibleContexts + FlexibleInstances + StandaloneDeriving + TupleSections + + exposed-modules: + LLVM + LLVM.Analysis + LLVM.AST + LLVM.AST.AddrSpace + LLVM.AST.Attribute + LLVM.AST.CallingConvention + LLVM.AST.COMDAT + LLVM.AST.Constant + LLVM.AST.DataLayout + LLVM.AST.DLL + LLVM.AST.Float + LLVM.AST.FloatingPointPredicate + LLVM.AST.FunctionAttribute + LLVM.AST.Global + LLVM.AST.InlineAssembly + LLVM.AST.Instruction + LLVM.AST.IntegerPredicate + LLVM.AST.Linkage + LLVM.AST.Name + LLVM.AST.Operand + LLVM.AST.ParameterAttribute + LLVM.AST.RMWOperation + LLVM.AST.ThreadLocalStorage + LLVM.AST.Type + LLVM.AST.Typed + LLVM.AST.Visibility + LLVM.CodeGenOpt + LLVM.CodeModel + LLVM.CommandLine + LLVM.Context + LLVM.DataLayout + LLVM.Diagnostic + LLVM.Exception + LLVM.ExecutionEngine + LLVM.Internal.Analysis + LLVM.Internal.Atomicity + LLVM.Internal.Attribute + LLVM.Internal.BasicBlock + LLVM.Internal.CallingConvention + LLVM.Internal.Coding + LLVM.Internal.CommandLine + LLVM.Internal.Constant + LLVM.Internal.Context + LLVM.Internal.DataLayout + LLVM.Internal.DecodeAST + LLVM.Internal.Diagnostic + LLVM.Internal.EncodeAST + LLVM.Internal.ExecutionEngine + LLVM.Internal.FastMathFlags + LLVM.Internal.FFI.Analysis + LLVM.Internal.FFI.Assembly + LLVM.Internal.FFI.Attribute + LLVM.Internal.FFI.BasicBlock + LLVM.Internal.FFI.BinaryOperator + LLVM.Internal.FFI.Bitcode + LLVM.Internal.FFI.Builder + LLVM.Internal.FFI.ByteRangeCallback + LLVM.Internal.FFI.Cleanup + LLVM.Internal.FFI.CommandLine + LLVM.Internal.FFI.Constant + LLVM.Internal.FFI.Context + LLVM.Internal.FFI.DataLayout + LLVM.Internal.FFI.DynamicLibrary + LLVM.Internal.FFI.ExecutionEngine + LLVM.Internal.FFI.Function + LLVM.Internal.FFI.GlobalAlias + LLVM.Internal.FFI.GlobalValue + LLVM.Internal.FFI.GlobalVariable + LLVM.Internal.FFI.InlineAssembly + LLVM.Internal.FFI.Instruction + LLVM.Internal.FFI.InstructionDefs + LLVM.Internal.FFI.Iterate + LLVM.Internal.FFI.LLVMCTypes + LLVM.Internal.FFI.MemoryBuffer + LLVM.Internal.FFI.Metadata + LLVM.Internal.FFI.Module + LLVM.Internal.FFI.ObjectFile + LLVM.Internal.FFI.OrcJIT + LLVM.Internal.FFI.PassManager + LLVM.Internal.FFI.PtrHierarchy + LLVM.Internal.FFI.RawOStream + LLVM.Internal.FFI.RTDyldMemoryManager + LLVM.Internal.FFI.ShortByteString + LLVM.Internal.FFI.SMDiagnostic + LLVM.Internal.FFI.Target + LLVM.Internal.FFI.Threading + LLVM.Internal.FFI.Transforms + LLVM.Internal.FFI.Type + LLVM.Internal.FFI.User + LLVM.Internal.FFI.Value + LLVM.Internal.FloatingPointPredicate + LLVM.Internal.Function + LLVM.Internal.Global + LLVM.Internal.InlineAssembly + LLVM.Internal.Instruction + LLVM.Internal.InstructionDefs + LLVM.Internal.IntegerPredicate + LLVM.Internal.LibraryFunction + LLVM.Internal.Linking + LLVM.Internal.MemoryBuffer + LLVM.Internal.Metadata + LLVM.Internal.Module + LLVM.Internal.ObjectFile + LLVM.Internal.Operand + LLVM.Internal.OrcJIT + LLVM.Internal.PassManager + LLVM.Internal.RawOStream + LLVM.Internal.RMWOperation + LLVM.Internal.String + LLVM.Internal.TailCallKind + LLVM.Internal.Target + LLVM.Internal.Threading + LLVM.Internal.Type + LLVM.Internal.Value + LLVM.IRBuilder + LLVM.IRBuilder.Constant + LLVM.IRBuilder.Instruction + LLVM.IRBuilder.Internal.SnocList + LLVM.IRBuilder.Module + LLVM.IRBuilder.Monad + LLVM.Linking + LLVM.Module + LLVM.OrcJIT + LLVM.PassManager + LLVM.Prelude + LLVM.Relocation + LLVM.Target + LLVM.Target.LibraryFunction + LLVM.Target.Options + LLVM.Threading + LLVM.Transforms + LLVM.Triple + + other-modules: + Control.Monad.AnyCont + Control.Monad.AnyCont.Class + Control.Monad.Trans.AnyCont + + include-dirs: src + cxx-sources: + src/LLVM/Internal/FFI/AssemblyC.cpp + src/LLVM/Internal/FFI/AttributeC.cpp + src/LLVM/Internal/FFI/BitcodeC.cpp + src/LLVM/Internal/FFI/BuilderC.cpp + src/LLVM/Internal/FFI/CallingConventionC.cpp + src/LLVM/Internal/FFI/CommandLineC.cpp + src/LLVM/Internal/FFI/ConstantC.cpp + src/LLVM/Internal/FFI/ErrorHandling.cpp + src/LLVM/Internal/FFI/ExecutionEngineC.cpp + src/LLVM/Internal/FFI/FunctionC.cpp + src/LLVM/Internal/FFI/GlobalAliasC.cpp + src/LLVM/Internal/FFI/GlobalValueC.cpp + src/LLVM/Internal/FFI/InlineAssemblyC.cpp + src/LLVM/Internal/FFI/InstructionC.cpp + src/LLVM/Internal/FFI/MetadataC.cpp + src/LLVM/Internal/FFI/ModuleC.cpp + src/LLVM/Internal/FFI/OrcJITC.cpp + src/LLVM/Internal/FFI/PassManagerC.cpp + src/LLVM/Internal/FFI/RawOStreamC.cpp + src/LLVM/Internal/FFI/RTDyldMemoryManager.cpp + src/LLVM/Internal/FFI/SMDiagnosticC.cpp + src/LLVM/Internal/FFI/TargetC.cpp + src/LLVM/Internal/FFI/TypeC.cpp + src/LLVM/Internal/FFI/ValueC.cpp + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: + , base >=4.9 && <5 + , bytestring >=0.10 + , containers >=0.4.2.1 + , llvm-party + , mtl >=2.1 + , pretty-show >=1.6 + , process + , QuickCheck >=2.5.1.1 + , tasty >=0.11 + , tasty-hunit >=0.9 + , tasty-quickcheck >=0.8 + , temporary >=1.2 + , transformers >=0.3.0.0 + + hs-source-dirs: test + default-extensions: + FlexibleContexts + FlexibleInstances + TupleSections + + main-is: Test.hs + other-modules: + LLVM.Test.Analysis + LLVM.Test.Attribute + LLVM.Test.CallingConvention + LLVM.Test.Constants + LLVM.Test.DataLayout + LLVM.Test.ExecutionEngine + LLVM.Test.FunctionAttribute + LLVM.Test.Global + LLVM.Test.InlineAssembly + LLVM.Test.Instructions + LLVM.Test.Instrumentation + LLVM.Test.Linking + LLVM.Test.Metadata + LLVM.Test.Module + LLVM.Test.ObjectCode + LLVM.Test.Optimization + LLVM.Test.OrcJIT + LLVM.Test.ParameterAttribute + LLVM.Test.Regression + LLVM.Test.Support + LLVM.Test.Target + LLVM.Test.Tests + LLVM.Test.IRBuilder diff --git a/src/Control/Monad/AnyCont.hs b/src/Control/Monad/AnyCont.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/AnyCont.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE + MultiParamTypeClasses, + UndecidableInstances + #-} +module Control.Monad.AnyCont ( + MonadAnyCont(..), + ScopeAnyCont(..), + AnyContT(..), + MonadTransAnyCont(..), + runAnyContT, runAnyContT', + withAnyContT, + mapAnyContT + ) where + +import Prelude + +import Control.Monad.Trans.AnyCont +import Control.Monad.AnyCont.Class +import Control.Monad.Trans.Class +import Control.Monad.State.Class +import Control.Monad.Error.Class + +instance MonadState s m => MonadState s (AnyContT m) where + get = lift get + {-# INLINE get #-} + put = lift . put + {-# INLINE put #-} + state = lift . state + {-# INLINE state #-} + +instance MonadError e m => MonadError e (AnyContT m) where + throwError = lift . throwError + {-# INLINE throwError #-} + x `catchError` h = anyContT $ \f -> (runAnyContT x f) `catchError` (\e -> runAnyContT (h e) f) diff --git a/src/Control/Monad/AnyCont/Class.hs b/src/Control/Monad/AnyCont/Class.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/AnyCont/Class.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE + RankNTypes, + MultiParamTypeClasses, + UndecidableInstances + #-} +module Control.Monad.AnyCont.Class where + +import Prelude + +import Control.Monad.Trans.Class +import Control.Monad.Trans.AnyCont (AnyContT) +import qualified Control.Monad.Trans.AnyCont as AnyCont +import Control.Monad.Trans.Except as Except +import Control.Monad.Trans.State as State + +class ScopeAnyCont m where + scopeAnyCont :: m a -> m a + +class MonadAnyCont b m where + anyContToM :: (forall r . (a -> b r) -> b r) -> m a + + +instance MonadTransAnyCont b m => MonadAnyCont b (AnyContT m) where + anyContToM c = AnyCont.anyContT (liftAnyCont c) + {-# INLINE anyContToM #-} + +instance Monad m => ScopeAnyCont (AnyContT m) where + scopeAnyCont = lift . AnyCont.runAnyContT' return + {-# INLINE scopeAnyCont #-} + + +instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where + anyContToM x = lift $ anyContToM x + {-# INLINE anyContToM #-} + +instance ScopeAnyCont m => ScopeAnyCont (StateT s m) where + scopeAnyCont = StateT . (scopeAnyCont .) . runStateT + {-# INLINE scopeAnyCont #-} + + +instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (ExceptT e m) where + anyContToM x = lift $ anyContToM x + {-# INLINE anyContToM #-} + +instance ScopeAnyCont m => ScopeAnyCont (ExceptT e m) where + scopeAnyCont = mapExceptT scopeAnyCont + {-# INLINE scopeAnyCont #-} + + +class MonadTransAnyCont b m where + liftAnyCont :: (forall r . (a -> b r) -> b r) -> (forall r . (a -> m r) -> m r) + +instance MonadTransAnyCont b b where + liftAnyCont c = c + {-# INLINE liftAnyCont #-} + +instance MonadTransAnyCont b m => MonadTransAnyCont b (StateT s m) where + liftAnyCont c = (\c q -> StateT $ \s -> c $ ($ s) . runStateT . q) (liftAnyCont c) + +instance MonadTransAnyCont b m => MonadTransAnyCont b (ExceptT e m) where + liftAnyCont c = (\c q -> ExceptT . c $ runExceptT . q) (liftAnyCont c) diff --git a/src/Control/Monad/Trans/AnyCont.hs b/src/Control/Monad/Trans/AnyCont.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/AnyCont.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE + CPP, RankNTypes + #-} +module Control.Monad.Trans.AnyCont where + +import LLVM.Prelude + +import Control.Monad.Catch +import Control.Monad.Cont as Cont +import Control.Monad.Fail as Fail + +newtype AnyContT m a = AnyContT { unAnyContT :: forall r . ContT r m a } + +instance Functor (AnyContT m) where + fmap f p = AnyContT $ fmap f (unAnyContT p) + {-# INLINE fmap #-} + +instance Applicative (AnyContT m) where + pure a = AnyContT $ pure a + {-# INLINE pure #-} + f <*> v = AnyContT $ unAnyContT f <*> unAnyContT v + {-# INLINE (<*>) #-} + +instance Monad m => Monad (AnyContT m) where + AnyContT f >>= k = AnyContT $ f >>= \x -> unAnyContT (k x) + {-# INLINE (>>=) #-} + return a = AnyContT $ return a + {-# INLINE return #-} +#if !(MIN_VERSION_base(4,13,0)) + fail s = AnyContT (ContT (\_ -> Cont.fail s)) + {-# INLINE fail #-} +#endif + +instance MonadFail m => MonadFail (AnyContT m) where + fail s = AnyContT (ContT (\_ -> Fail.fail s)) + {-# INLINE fail #-} + +instance MonadIO m => MonadIO (AnyContT m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} + +instance MonadTrans AnyContT where + lift ma = AnyContT (lift ma) + {-# INLINE lift #-} + +instance MonadThrow m => MonadThrow (AnyContT m) where + throwM = lift . throwM + {-# INLINE throwM #-} + +runAnyContT :: AnyContT m a -> forall r . (a -> m r) -> m r +runAnyContT k = runContT (unAnyContT k) +{-# INLINE runAnyContT #-} + +runAnyContT' :: (a -> m r) -> AnyContT m a -> m r +runAnyContT' f k = runContT (unAnyContT k) f +{-# INLINE runAnyContT' #-} + +anyContT :: (forall r . (a -> m r) -> m r) -> AnyContT m a +anyContT f = AnyContT (ContT f) +{-# INLINE anyContT #-} + +withAnyContT :: (forall r . (b -> m r) -> (a -> m r)) -> AnyContT m a -> AnyContT m b +withAnyContT f m = anyContT $ runAnyContT m . f +{-# INLINE withAnyContT #-} + +mapAnyContT :: (forall r . m r -> m r) -> AnyContT m a -> AnyContT m a +mapAnyContT f m = anyContT $ f . runAnyContT m +{-# INLINE mapAnyContT #-} diff --git a/src/LLVM.hs b/src/LLVM.hs new file mode 100644 --- /dev/null +++ b/src/LLVM.hs @@ -0,0 +1,116 @@ +{-| +Module : LLVM +Description: An interface to use LLVM in all capacities. +Copyright: (c) Moritz Kiefer 2018 + Stephen Diehl 2018 + Benjamin Scarlett 2016 +Maintainer: moritz.kiefer@purelyfunctional.org +-} +module LLVM ( + module LLVM.Module + -- * Overview of the @llvm-hs@ library ecosystem + -- $ecosystem + + -- * Constructing the C++ representation of an LLVM module + -- $moduleconstruction + + -- * #objectcode# Generating object code + -- $objectcode + + -- * #jitcompilation# JIT compilation + -- $jitcompilation + ) where + +import LLVM.Module + +import LLVM.AST () + +{- $ecosystem + +The main two libraries in the @llvm-hs@ ecosystem are @llvm-hs-pure@ +and @llvm-hs@. + +* @llvm-hs-pure@ defines a pure Haskell representation of the LLVM +AST. It has no dependency on the LLVM C/C++ libraries so even if you +have trouble installing those or want to avoid that dependency, you +should be able to use it. The documentation +in [LLVM.AST](https://hackage.haskell.org/package/llvm-hs-pure/docs/LLVM-AST.html) +describes the different options for constructing the AST. + +* @llvm-hs@ then builds upon @llvm-hs-pure@ and provides the actual FFI +bindings to LLVM’s C++ libraries. Most importantly this includes +bidirectional conversions from the Haskell representation of an LLVM +module to the C++ representation and the other way around. + +Once you have constructed the C++ representation, there are two main options: + +1. Generate object code as described in "LLVM#objectcode" +2. or JIT compile the module as described in "LLVM#jitcompilation". + +In addition to @llvm-hs@ and @llvm-hs-pure@, there are a couple of +other libraries that you be interested in: + +* [llvm-hs-pretty](https://hackage.haskell.org/package/llvm-hs-pretty) + a pure Haskell prettyprinter for the AST in @llvm-hs-pure@. This is + useful if you just want to render your AST to LLVM’s textual IR + format either for debugging purposes (@llc@ will usually give pretty + good error messages for invalid IR) or because you prefer to call + the LLVM CLI tools over the linking against the LLVM libraries. + +* [llvm-hs-typed](https://github.com/llvm-hs/llvm-hs-typed) contains a + strongly-typed wrapper for the AST in @llvm-hs-pure@ which makes it + harder to accidentally construct invalid LLVM IR. + +* [llvm-hs-quote](https://github.com/llvm-hs/llvm-hs-quote) contains a + Haskell quasiquoter that can be used for splicing larger chunks of + existing LLVM IR into your Haskell code. + +Finally, there is a [translation](https://github.com/llvm-hs/llvm-hs-kaleidoscope) of +LLVM’s official Kaleidoscope tutorial to @llvm-hs@ and you can find +small, self-contained examples covering various parts of the API in +the [llvm-hs-examples](https://github.com/llvm-hs/llvm-hs-examples) +repository. +-} + +{- $moduleconstruction + +Interacting with the LLVM libraries requires that you first construct +the C++ representation of an LLVM `Module`. + +The most common way of doing that is to first construct the Haskell +representation of an LLVM module using @llvm-hs-pure@. You can then +use `withModuleFromAST` to convert the Haskell AST to the C++ +representation. + +Alternatively, you can also construct a module from LLVM’s textual IR +or the binary bitcode format using `withModuleFromLLVMAssembly` and +`withModuleFromBitcode`. + +-} + +{- $objectcode + +Once you have constructed the C++ representation of an LLVM `Module`, +you can generate an object file using `moduleObject` which will give +you a `Data.ByteString.ByteString` or write it to a file using +`writeObjectToFile`. To construct the `TargetMachine` for these +functions you can use `LLVM.Target.withHostTargetMachine` if you want +to generate object code for the machine you are currently running on +or use `LLVM.Target.withTargetMachine` and customize the target +machine based on your needs. +-} + +{- $jitcompilation + +In addition to generating object code, you can also JIT-compile LLVM +modules and call functions in the resulting `Module` from Haskell. + +LLVM has several JIT compilers but ORC JIT is the one that is actively +being developed and the one best supported by @llvm-hs@. + +Since ORC JIT is still in active development in LLVM, the API is likely to +change regularly. See the +[Kaleidoscope](https://github.com/llvm-hs/llvm-hs-kaleidoscope) project for the +most up-to-date example of using ORC JIT. + +-} diff --git a/src/LLVM/AST.hs b/src/LLVM/AST.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST.hs @@ -0,0 +1,91 @@ +{-# 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) + +-- | +-- You can for example put this in withModuleFromAst +-- +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/src/LLVM/AST/AddrSpace.hs b/src/LLVM/AST/AddrSpace.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/AddrSpace.hs @@ -0,0 +1,8 @@ +-- | 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/src/LLVM/AST/Attribute.hs b/src/LLVM/AST/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Attribute.hs @@ -0,0 +1,19 @@ +-- | 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/src/LLVM/AST/COMDAT.hs b/src/LLVM/AST/COMDAT.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/COMDAT.hs @@ -0,0 +1,13 @@ +-- | 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/src/LLVM/AST/CallingConvention.hs b/src/LLVM/AST/CallingConvention.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/CallingConvention.hs @@ -0,0 +1,50 @@ +-- | 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/src/LLVM/AST/Constant.hs b/src/LLVM/AST/Constant.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Constant.hs @@ -0,0 +1,247 @@ +-- | 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/src/LLVM/AST/DLL.hs b/src/LLVM/AST/DLL.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/DLL.hs @@ -0,0 +1,10 @@ +-- | 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/src/LLVM/AST/DataLayout.hs b/src/LLVM/AST/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/DataLayout.hs @@ -0,0 +1,76 @@ +-- | +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/src/LLVM/AST/Float.hs b/src/LLVM/AST/Float.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Float.hs @@ -0,0 +1,18 @@ +-- | 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/src/LLVM/AST/FloatingPointPredicate.hs b/src/LLVM/AST/FloatingPointPredicate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/FloatingPointPredicate.hs @@ -0,0 +1,27 @@ +-- | 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/src/LLVM/AST/FunctionAttribute.hs b/src/LLVM/AST/FunctionAttribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/FunctionAttribute.hs @@ -0,0 +1,59 @@ +-- | 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/src/LLVM/AST/Global.hs b/src/LLVM/AST/Global.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Global.hs @@ -0,0 +1,141 @@ +-- | '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/src/LLVM/AST/InlineAssembly.hs b/src/LLVM/AST/InlineAssembly.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/InlineAssembly.hs @@ -0,0 +1,27 @@ +-- | 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/src/LLVM/AST/Instruction.hs b/src/LLVM/AST/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Instruction.hs @@ -0,0 +1,468 @@ +-- | 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/src/LLVM/AST/IntegerPredicate.hs b/src/LLVM/AST/IntegerPredicate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/IntegerPredicate.hs @@ -0,0 +1,21 @@ +-- | 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/src/LLVM/AST/Linkage.hs b/src/LLVM/AST/Linkage.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Linkage.hs @@ -0,0 +1,19 @@ +-- | 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/src/LLVM/AST/Name.hs b/src/LLVM/AST/Name.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Name.hs @@ -0,0 +1,45 @@ +-- | 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/src/LLVM/AST/Operand.hs b/src/LLVM/AST/Operand.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Operand.hs @@ -0,0 +1,554 @@ +{-# 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/src/LLVM/AST/ParameterAttribute.hs b/src/LLVM/AST/ParameterAttribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/ParameterAttribute.hs @@ -0,0 +1,33 @@ +-- | 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/src/LLVM/AST/RMWOperation.hs b/src/LLVM/AST/RMWOperation.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/RMWOperation.hs @@ -0,0 +1,22 @@ +-- | 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/src/LLVM/AST/ThreadLocalStorage.hs b/src/LLVM/AST/ThreadLocalStorage.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/ThreadLocalStorage.hs @@ -0,0 +1,12 @@ +-- | 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/src/LLVM/AST/Type.hs b/src/LLVM/AST/Type.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Type.hs @@ -0,0 +1,102 @@ +-- | 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/src/LLVM/AST/Typed.hs b/src/LLVM/AST/Typed.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Typed.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | 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/src/LLVM/AST/Visibility.hs b/src/LLVM/AST/Visibility.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/AST/Visibility.hs @@ -0,0 +1,8 @@ +-- | 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/src/LLVM/Analysis.hs b/src/LLVM/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Analysis.hs @@ -0,0 +1,8 @@ +-- | functionality for analyzing 'LLVM.Module.Module's. Much of the analysis +-- possible with LLVM is managed internally, as needed by 'Transforms', and so is not +-- yet exposed here. +module LLVM.Analysis ( + verify + ) where + +import LLVM.Internal.Analysis diff --git a/src/LLVM/CodeGenOpt.hs b/src/LLVM/CodeGenOpt.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/CodeGenOpt.hs @@ -0,0 +1,12 @@ +-- | Code generation options, used in specifying TargetMachine +module LLVM.CodeGenOpt where + +import LLVM.Prelude + +-- | +data Level + = None + | Less + | Default + | Aggressive + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/CodeModel.hs b/src/LLVM/CodeModel.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/CodeModel.hs @@ -0,0 +1,14 @@ +-- | Code model, used in specifying TargetMachine +module LLVM.CodeModel where + +import LLVM.Prelude + +-- | +data Model + = Default + | JITDefault + | Small + | Kernel + | Medium + | Large + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/CommandLine.hs b/src/LLVM/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/CommandLine.hs @@ -0,0 +1,8 @@ +-- | Tools for processing command line arguments, for command line tools build +-- with llvm (or for other uses forced into pretending to be such to get at (ack) +-- global state). +module LLVM.CommandLine ( + parseCommandLineOptions +) where + +import LLVM.Internal.CommandLine diff --git a/src/LLVM/Context.hs b/src/LLVM/Context.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Context.hs @@ -0,0 +1,9 @@ +-- | functions for the LLVM Context object which holds thread-scope state +module LLVM.Context ( + Context, + withContext, + createContext, + disposeContext + ) where + +import LLVM.Internal.Context diff --git a/src/LLVM/DataLayout.hs b/src/LLVM/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/DataLayout.hs @@ -0,0 +1,127 @@ +{-# 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/src/LLVM/Diagnostic.hs b/src/LLVM/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Diagnostic.hs @@ -0,0 +1,33 @@ +-- | Diagnostics describe parse errors +module LLVM.Diagnostic ( + DiagnosticKind(..), + Diagnostic(..), + diagnosticDisplay + ) where + +import LLVM.Prelude + +-- | What kind of problem does a diagnostic describe? +data DiagnosticKind + = ErrorKind + | WarningKind + | NoteKind + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | A 'Diagnostic' described a problem during parsing of LLVM IR +data Diagnostic = Diagnostic { + lineNumber :: Int, + columnNumber :: Int, + diagnosticKind :: DiagnosticKind, + filename :: String, + message :: String, + lineContents :: String + } + deriving (Eq, Ord, Read, Show) + +-- | Convert a 'Diagnostic' to a printable form. +diagnosticDisplay :: Diagnostic -> String +diagnosticDisplay d = + (filename d) ++ ":" ++ show (lineNumber d) ++ ":" ++ show (columnNumber d) + ++ ":\n" ++ show (diagnosticKind d) ++ ": " ++ (message d) ++ "\n" + ++ (lineContents d) ++ "\n" diff --git a/src/LLVM/Exception.hs b/src/LLVM/Exception.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Exception.hs @@ -0,0 +1,72 @@ +{-| +This module lists all of the exceptions thrown by 'llvm-hs' itself. +Note that other exceptions can potentially be thrown +by the underlying libraries, e.g., for functions doing file IO. +-} +module LLVM.Exception where + +import LLVM.Prelude + +import Control.Monad.Catch + +-- | Indicates an error during the translation of the AST provided by +-- 'llvm-hs-pure' to LLVM’s internal representation. +data EncodeException = + EncodeException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception EncodeException + +-- | Indicates an error during the translation of LLVM’s internal representation +-- to the AST provided 'llvm-hs-pure'. +data DecodeException = + DecodeException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception DecodeException + +-- | Indicates an error during the parsing of a module. This is used +-- for errors encountered when parsing LLVM’s human readable assembly +-- format and when parsing the binary bitcode format. +data ParseFailureException = + ParseFailureException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception ParseFailureException + +-- | Indicates an error during the linking of two modules. +data LinkException = + LinkException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception LinkException + +-- | Indicates an error during the creation of a +-- . +-- This could be caused by a nonexisting file path. +data FdStreamException = + FdStreamException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception FdStreamException + +-- | Indicates an error during a call to 'LLVM.Internal.Module.targetMachineEmit'. +data TargetMachineEmitException = + TargetMachineEmitException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception TargetMachineEmitException + +-- | Indicates a failure to find the target. +data LookupTargetException = + LookupTargetException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception LookupTargetException + +-- | Indicates an error during the verification of a module. +data VerifyException = + VerifyException !String + deriving (Show, Eq, Ord, Typeable) + +instance Exception VerifyException diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/ExecutionEngine.hs @@ -0,0 +1,8 @@ +-- | Tools for JIT execution +module LLVM.ExecutionEngine ( + ExecutionEngine(..), + ExecutableModule, + MCJIT, withMCJIT + ) where + +import LLVM.Internal.ExecutionEngine diff --git a/src/LLVM/IRBuilder.hs b/src/LLVM/IRBuilder.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/IRBuilder.hs @@ -0,0 +1,8 @@ +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/src/LLVM/IRBuilder/Constant.hs b/src/LLVM/IRBuilder/Constant.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/IRBuilder/Constant.hs @@ -0,0 +1,41 @@ +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/src/LLVM/IRBuilder/Instruction.hs b/src/LLVM/IRBuilder/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/IRBuilder/Instruction.hs @@ -0,0 +1,432 @@ +{-# LANGUAGE FlexibleContexts #-} + +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/src/LLVM/IRBuilder/Internal/SnocList.hs b/src/LLVM/IRBuilder/Internal/SnocList.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/IRBuilder/Internal/SnocList.hs @@ -0,0 +1,22 @@ +{-# 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/src/LLVM/IRBuilder/Module.hs b/src/LLVM/IRBuilder/Module.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/IRBuilder/Module.hs @@ -0,0 +1,248 @@ +{-# 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 + +module LLVM.IRBuilder.Module where + +import Prelude hiding (and, or) + +import Control.Applicative +import Control.Monad.Cont +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.ByteString.Short(ShortByteString) +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 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 :: 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 => 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/src/LLVM/IRBuilder/Monad.hs b/src/LLVM/IRBuilder/Monad.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/IRBuilder/Monad.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- For MonadState s (ModuleBuilderT m) instance + +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 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/src/LLVM/Internal/Analysis.hs b/src/LLVM/Internal/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Analysis.hs @@ -0,0 +1,24 @@ +module LLVM.Internal.Analysis where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.IO.Class + +import qualified LLVM.Internal.FFI.Analysis as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Module +import LLVM.Internal.Coding + +import LLVM.Exception + +-- | Run basic sanity checks on a 'Module'. Note that the same checks will trigger assertions +-- within LLVM if LLVM was built with them turned on, before this function can be is called. +verify :: Module -> IO () +verify m = runAnyContT' return $ do + errorPtr <- alloca + m' <- readModule m + result <- decodeM =<< (liftIO $ FFI.verifyModule m' FFI.verifierFailureActionReturnStatus errorPtr) + when result $ throwM . VerifyException =<< decodeM errorPtr diff --git a/src/LLVM/Internal/Atomicity.hs b/src/LLVM/Internal/Atomicity.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Atomicity.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses + #-} +module LLVM.Internal.Atomicity where + +import LLVM.Prelude + +import Data.Maybe + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Coding +import qualified LLVM.AST as A + +genCodingInstance [t| Maybe A.MemoryOrdering |] ''FFI.MemoryOrdering [ + (FFI.memoryOrderingNotAtomic, Nothing), + (FFI.memoryOrderingUnordered, Just A.Unordered), + (FFI.memoryOrderingMonotonic, Just A.Monotonic), + (FFI.memoryOrderingAcquire, Just A.Acquire), + (FFI.memoryOrderingRelease, Just A.Release), + (FFI.memoryOrderingAcquireRelease, Just A.AcquireRelease), + (FFI.memoryOrderingSequentiallyConsistent, Just A.SequentiallyConsistent) + ] + +genCodingInstance [t| A.SynchronizationScope |] ''FFI.SynchronizationScope [ + (FFI.synchronizationScopeSingleThread, A.SingleThread), + (FFI.synchronizationScopeSystem, A.System) + ] + +instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.SynchronizationScope, FFI.MemoryOrdering) where + encodeM a = + return (,) `ap` encodeM (maybe A.SingleThread fst a) `ap` encodeM (liftM snd a) + +instance Monad m => DecodeM m (Maybe A.Atomicity) (FFI.SynchronizationScope, FFI.MemoryOrdering) where + decodeM (ss, ao) = return (liftM . (,)) `ap` decodeM ss `ap` decodeM ao + +instance Monad m => EncodeM m A.Atomicity (FFI.SynchronizationScope, FFI.MemoryOrdering) where + encodeM = encodeM . Just + +instance Monad m => DecodeM m A.Atomicity (FFI.SynchronizationScope, FFI.MemoryOrdering) where + decodeM = liftM fromJust . decodeM + +instance Monad m => EncodeM m A.MemoryOrdering FFI.MemoryOrdering where + encodeM = encodeM . Just + +instance Monad m => DecodeM m A.MemoryOrdering FFI.MemoryOrdering where + decodeM = liftM fromJust . decodeM + diff --git a/src/LLVM/Internal/Attribute.hs b/src/LLVM/Internal/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Attribute.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module LLVM.Internal.Attribute where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.IO.Class +import Control.Monad.State (gets) + +import Control.Exception +import Foreign.C (CUInt) +import Foreign.Ptr +import Data.Maybe + +import qualified LLVM.Internal.FFI.Attribute as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import LLVM.Internal.FFI.LLVMCTypes (parameterAttributeKindP, functionAttributeKindP) + +import qualified LLVM.AST.ParameterAttribute as A.PA +import qualified LLVM.AST.FunctionAttribute as A.FA + +import LLVM.Internal.Coding +import LLVM.Internal.Context +import LLVM.Internal.EncodeAST +import LLVM.Internal.DecodeAST + +inconsistentCases :: Show a => String -> a -> b +inconsistentCases name attr = + error $ "llvm-hs internal error: cases inconstistent in " ++ name ++ " encoding for " ++ show attr + +instance Monad m => EncodeM m A.PA.ParameterAttribute (Ptr FFI.ParameterAttrBuilder -> EncodeAST ()) where + encodeM (A.PA.StringAttribute kind value) = return $ \b -> do + (kindP, kindLen) <- encodeM kind + (valueP, valueLen) <- encodeM value + liftIO $ FFI.attrBuilderAddStringAttribute b kindP kindLen valueP valueLen + encodeM a = return $ \b -> liftIO $ case a of + A.PA.Alignment v -> FFI.attrBuilderAddAlignment b v + A.PA.Dereferenceable v -> FFI.attrBuilderAddDereferenceable b v + A.PA.DereferenceableOrNull v -> FFI.attrBuilderAddDereferenceableOrNull b v + _ -> FFI.attrBuilderAddParameterAttributeKind b $ case a of + A.PA.ByVal -> FFI.parameterAttributeKindByVal + A.PA.ImmArg -> FFI.parameterAttributeKindImmArg + A.PA.InAlloca -> FFI.parameterAttributeKindInAlloca + A.PA.InReg -> FFI.parameterAttributeKindInReg + A.PA.Nest -> FFI.parameterAttributeKindNest + A.PA.NoAlias -> FFI.parameterAttributeKindNoAlias + A.PA.NoCapture -> FFI.parameterAttributeKindNoCapture + A.PA.NoFree -> FFI.parameterAttributeKindNoFree + A.PA.NonNull -> FFI.parameterAttributeKindNonNull + A.PA.ReadNone -> FFI.parameterAttributeKindReadNone + A.PA.ReadOnly -> FFI.parameterAttributeKindReadOnly + A.PA.Returned -> FFI.parameterAttributeKindReturned + A.PA.SignExt -> FFI.parameterAttributeKindSExt + A.PA.SRet -> FFI.parameterAttributeKindStructRet + A.PA.SwiftError -> FFI.parameterAttributeKindSwiftError + A.PA.SwiftSelf -> FFI.parameterAttributeKindSwiftSelf + A.PA.WriteOnly -> FFI.parameterAttributeKindWriteOnly + A.PA.ZeroExt -> FFI.parameterAttributeKindZExt +#if __GLASGOW_HASKELL__ < 900 + A.PA.Alignment _ -> inconsistentCases "ParameterAttribute" a + A.PA.Dereferenceable _ -> inconsistentCases "ParameterAttribute" a + A.PA.DereferenceableOrNull _ -> inconsistentCases "ParameterAttribute" a + A.PA.StringAttribute _ _ -> inconsistentCases "ParameterAttribute" a +#endif + +instance Monad m => EncodeM m A.FA.FunctionAttribute (Ptr FFI.FunctionAttrBuilder -> EncodeAST ()) where + encodeM (A.FA.StringAttribute kind value) = return $ \b -> do + (kindP, kindLen) <- encodeM kind + (valueP, valueLen) <- encodeM value + liftIO $ FFI.attrBuilderAddStringAttribute b kindP kindLen valueP valueLen + encodeM a = return $ \b -> case a of + A.FA.AllocSize x y -> do + x' <- encodeM x + y' <- encodeM y + liftIO $ FFI.attrBuilderAddAllocSize b x' y' + A.FA.StackAlignment v -> liftIO $ FFI.attrBuilderAddStackAlignment b v + _ -> liftIO $ FFI.attrBuilderAddFunctionAttributeKind b $ case a of + A.FA.AlwaysInline -> FFI.functionAttributeKindAlwaysInline + A.FA.ArgMemOnly -> FFI.functionAttributeKindArgMemOnly + A.FA.Builtin -> FFI.functionAttributeKindBuiltin + A.FA.Cold -> FFI.functionAttributeKindCold + A.FA.Convergent -> FFI.functionAttributeKindConvergent + A.FA.InaccessibleMemOnly -> FFI.functionAttributeKindInaccessibleMemOnly + A.FA.InaccessibleMemOrArgMemOnly -> FFI.functionAttributeKindInaccessibleMemOrArgMemOnly + A.FA.InlineHint -> FFI.functionAttributeKindInlineHint + A.FA.JumpTable -> FFI.functionAttributeKindJumpTable + A.FA.MinimizeSize -> FFI.functionAttributeKindMinSize + A.FA.MustProgress -> FFI.functionAttributeKindMustProgress + A.FA.Naked -> FFI.functionAttributeKindNaked + A.FA.NoBuiltin -> FFI.functionAttributeKindNoBuiltin + A.FA.NoDuplicate -> FFI.functionAttributeKindNoDuplicate + A.FA.NoFree -> FFI.functionAttributeKindNoFree + A.FA.NoImplicitFloat -> FFI.functionAttributeKindNoImplicitFloat + A.FA.NoInline -> FFI.functionAttributeKindNoInline + A.FA.NonLazyBind -> FFI.functionAttributeKindNonLazyBind + A.FA.NoRecurse -> FFI.functionAttributeKindNoRecurse + A.FA.NoRedZone -> FFI.functionAttributeKindNoRedZone + A.FA.NoReturn -> FFI.functionAttributeKindNoReturn + A.FA.NoSync -> FFI.functionAttributeKindNoSync + A.FA.NoUnwind -> FFI.functionAttributeKindNoUnwind + A.FA.OptimizeForSize -> FFI.functionAttributeKindOptimizeForSize + A.FA.OptimizeNone -> FFI.functionAttributeKindOptimizeNone + A.FA.ReadNone -> FFI.functionAttributeKindReadNone + A.FA.ReadOnly -> FFI.functionAttributeKindReadOnly + A.FA.ReturnsTwice -> FFI.functionAttributeKindReturnsTwice + A.FA.SafeStack -> FFI.functionAttributeKindSafeStack + A.FA.SanitizeAddress -> FFI.functionAttributeKindSanitizeAddress + A.FA.SanitizeHWAddress -> FFI.functionAttributeKindSanitizeHWAddress + A.FA.SanitizeMemory -> FFI.functionAttributeKindSanitizeMemory + A.FA.SanitizeThread -> FFI.functionAttributeKindSanitizeThread + A.FA.Speculatable -> FFI.functionAttributeKindSpeculatable + A.FA.StackProtect -> FFI.functionAttributeKindStackProtect + A.FA.StackProtectReq -> FFI.functionAttributeKindStackProtectReq + A.FA.StackProtectStrong -> FFI.functionAttributeKindStackProtectStrong + A.FA.StrictFP -> FFI.functionAttributeKindStrictFP + A.FA.UWTable -> FFI.functionAttributeKindUWTable + A.FA.WillReturn -> FFI.functionAttributeKindWillReturn + A.FA.WriteOnly -> FFI.functionAttributeKindWriteOnly +#if __GLASGOW_HASKELL__ < 900 + A.FA.AllocSize _ _ -> inconsistentCases "FunctionAttribute" a + A.FA.StackAlignment _ -> inconsistentCases "FunctionAttribute" a + A.FA.StringAttribute _ _ -> inconsistentCases "FunctionAttribute" a +#endif + +instance DecodeM DecodeAST A.PA.ParameterAttribute FFI.ParameterAttribute where + decodeM a = do + isString <- decodeM =<< liftIO (FFI.isStringAttribute a) + if isString + then + A.PA.StringAttribute + <$> decodeM (FFI.attributeKindAsString a) + <*> decodeM (FFI.attributeValueAsString a) + else do + enum <- liftIO $ FFI.parameterAttributeKindAsEnum a + case enum of + [parameterAttributeKindP|Alignment|] -> return A.PA.Alignment `ap` (liftIO $ FFI.attributeValueAsInt a) + [parameterAttributeKindP|ByVal|] -> return A.PA.ByVal + [parameterAttributeKindP|DereferenceableOrNull|] -> return A.PA.DereferenceableOrNull `ap` (liftIO $ FFI.attributeValueAsInt a) + [parameterAttributeKindP|Dereferenceable|] -> return A.PA.Dereferenceable `ap` (liftIO $ FFI.attributeValueAsInt a) + [parameterAttributeKindP|ImmArg|] -> return A.PA.ImmArg + [parameterAttributeKindP|InAlloca|] -> return A.PA.InAlloca + [parameterAttributeKindP|InReg|] -> return A.PA.InReg + [parameterAttributeKindP|Nest|] -> return A.PA.Nest + [parameterAttributeKindP|NoAlias|] -> return A.PA.NoAlias + [parameterAttributeKindP|NoCapture|] -> return A.PA.NoCapture + [parameterAttributeKindP|NoFree|] -> return A.PA.NoFree + [parameterAttributeKindP|NonNull|] -> return A.PA.NonNull + [parameterAttributeKindP|ReadNone|] -> return A.PA.ReadNone + [parameterAttributeKindP|ReadOnly|] -> return A.PA.ReadOnly + [parameterAttributeKindP|Returned|] -> return A.PA.Returned + [parameterAttributeKindP|SExt|] -> return A.PA.SignExt + [parameterAttributeKindP|StructRet|] -> return A.PA.SRet + [parameterAttributeKindP|SwiftError|] -> return A.PA.SwiftError + [parameterAttributeKindP|SwiftSelf|] -> return A.PA.SwiftSelf + [parameterAttributeKindP|WriteOnly|] -> return A.PA.WriteOnly + [parameterAttributeKindP|ZExt|] -> return A.PA.ZeroExt + _ -> error $ "unhandled parameter attribute enum value: " ++ show enum + +instance DecodeM DecodeAST A.FA.FunctionAttribute FFI.FunctionAttribute where + decodeM a = do + isString <- decodeM =<< (liftIO $ FFI.isStringAttribute a) + if isString + then + return A.FA.StringAttribute + `ap` (decodeM $ FFI.attributeKindAsString a) + `ap` (decodeM $ FFI.attributeValueAsString a) + else do + enum <- liftIO $ FFI.functionAttributeKindAsEnum a + case enum of + [functionAttributeKindP|AllocSize|] -> do + x <- alloca + y <- decodeOptional (FFI.attributeGetAllocSizeArgs a x) + x' <- decodeM =<< peek x + return (A.FA.AllocSize x' y) + [functionAttributeKindP|AlwaysInline|] -> return A.FA.AlwaysInline + [functionAttributeKindP|ArgMemOnly|] -> return A.FA.ArgMemOnly + [functionAttributeKindP|Builtin|] -> return A.FA.Builtin + [functionAttributeKindP|Cold|] -> return A.FA.Cold + [functionAttributeKindP|Convergent|] -> return A.FA.Convergent + [functionAttributeKindP|InaccessibleMemOnly|] -> return A.FA.InaccessibleMemOnly + [functionAttributeKindP|InaccessibleMemOrArgMemOnly|] -> return A.FA.InaccessibleMemOrArgMemOnly + [functionAttributeKindP|InlineHint|] -> return A.FA.InlineHint + [functionAttributeKindP|JumpTable|] -> return A.FA.JumpTable + [functionAttributeKindP|MinSize|] -> return A.FA.MinimizeSize + [functionAttributeKindP|MustProgress|] -> return A.FA.MustProgress + [functionAttributeKindP|Naked|] -> return A.FA.Naked + [functionAttributeKindP|NoBuiltin|] -> return A.FA.NoBuiltin + [functionAttributeKindP|NoDuplicate|] -> return A.FA.NoDuplicate + [functionAttributeKindP|NoFree|] -> return A.FA.NoFree + [functionAttributeKindP|NoImplicitFloat|] -> return A.FA.NoImplicitFloat + [functionAttributeKindP|NoInline|] -> return A.FA.NoInline + [functionAttributeKindP|NoRecurse|] -> return A.FA.NoRecurse + [functionAttributeKindP|NoRedZone|] -> return A.FA.NoRedZone + [functionAttributeKindP|NoReturn|] -> return A.FA.NoReturn + [functionAttributeKindP|NoSync|] -> return A.FA.NoSync + [functionAttributeKindP|NoUnwind|] -> return A.FA.NoUnwind + [functionAttributeKindP|NonLazyBind|] -> return A.FA.NonLazyBind + [functionAttributeKindP|OptimizeForSize|] -> return A.FA.OptimizeForSize + [functionAttributeKindP|OptimizeNone|] -> return A.FA.OptimizeNone + [functionAttributeKindP|ReadNone|] -> return A.FA.ReadNone + [functionAttributeKindP|ReadOnly|] -> return A.FA.ReadOnly + [functionAttributeKindP|ReturnsTwice|] -> return A.FA.ReturnsTwice + [functionAttributeKindP|SafeStack|] -> return A.FA.SafeStack + [functionAttributeKindP|SanitizeAddress|] -> return A.FA.SanitizeAddress + [functionAttributeKindP|SanitizeHWAddress|] -> return A.FA.SanitizeHWAddress + [functionAttributeKindP|SanitizeMemory|] -> return A.FA.SanitizeMemory + [functionAttributeKindP|SanitizeThread|] -> return A.FA.SanitizeThread + [functionAttributeKindP|Speculatable|] -> return A.FA.Speculatable + [functionAttributeKindP|StackAlignment|] -> return A.FA.StackAlignment `ap` (liftIO $ FFI.attributeValueAsInt a) + [functionAttributeKindP|StackProtectReq|] -> return A.FA.StackProtectReq + [functionAttributeKindP|StackProtectStrong|] -> return A.FA.StackProtectStrong + [functionAttributeKindP|StackProtect|] -> return A.FA.StackProtect + [functionAttributeKindP|StrictFP|] -> return A.FA.StrictFP + [functionAttributeKindP|UWTable|] -> return A.FA.UWTable + [functionAttributeKindP|WillReturn|] -> return A.FA.WillReturn + [functionAttributeKindP|WriteOnly|] -> return A.FA.WriteOnly + _ -> error $ "unhandled function attribute enum value: " ++ show enum + +allocaAttrBuilder :: (Monad m, MonadAnyCont IO m) => m (Ptr (FFI.AttrBuilder a)) +allocaAttrBuilder = do + p <- allocaArray FFI.getAttrBuilderSize + anyContToM $ \f -> do + ab <- FFI.constructAttrBuilder p + r <- f ab + FFI.destroyAttrBuilder ab + return r + +instance forall a b. EncodeM EncodeAST a (Ptr (FFI.AttrBuilder b) -> EncodeAST ()) => + EncodeM EncodeAST [a] (FFI.AttributeSet b) where + encodeM as = do + ab <- allocaAttrBuilder + builds <- mapM encodeM as + void (forM builds ($ ab) :: EncodeAST [()]) + Context context <- gets encodeStateContext + anyContToM + (bracket (FFI.getAttributeSet context ab) FFI.disposeAttributeSet) + +instance forall a b. DecodeM DecodeAST a (FFI.Attribute b) => DecodeM DecodeAST [a] (FFI.AttributeSet b) where + decodeM as = do + numAttributes <- liftIO (FFI.getNumAttributes as) + attrs <- allocaArray numAttributes + liftIO (FFI.getAttributes as attrs) + decodeM (numAttributes, attrs :: Ptr (FFI.Attribute b)) + +data AttributeList = AttributeList { + functionAttributes :: [Either A.FA.GroupID A.FA.FunctionAttribute], + returnAttributes :: [A.PA.ParameterAttribute], + parameterAttributes :: [[A.PA.ParameterAttribute]] + } + deriving (Eq, Show) + +data PreSlot + = IndirectFunctionAttributes A.FA.GroupID + | DirectFunctionAttributes [A.FA.FunctionAttribute] + | ReturnAttributes [A.PA.ParameterAttribute] + | ParameterAttributes CUInt [A.PA.ParameterAttribute] + +instance {-# OVERLAPPING #-} EncodeM EncodeAST [Either A.FA.GroupID A.FA.FunctionAttribute] FFI.FunctionAttributeSet where + encodeM attrs = do + ab <- allocaAttrBuilder + forM_ attrs $ \attr -> + case attr of + Left groupId -> do + attrSet <- referAttributeGroup groupId + ab' <- anyContToM (bracket (FFI.attrBuilderFromSet attrSet) FFI.disposeAttrBuilder) + liftIO (FFI.mergeAttrBuilder ab ab') + Right attr -> do + addAttr <- encodeM attr + addAttr ab :: EncodeAST () + Context context <- gets encodeStateContext + anyContToM + (bracket (FFI.getAttributeSet context ab) FFI.disposeAttributeSet) + +instance EncodeM EncodeAST AttributeList FFI.AttributeList where + encodeM (AttributeList fAttrs rAttrs pAttrs) = do + fAttrSet <- encodeM fAttrs + rAttrSet <- encodeM rAttrs :: EncodeAST FFI.ParameterAttributeSet + (numPAttrs, pAttrSets) <- encodeM pAttrs + Context context <- gets encodeStateContext + anyContToM + (bracket + (FFI.buildAttributeList context fAttrSet rAttrSet pAttrSets numPAttrs) + FFI.disposeAttributeList) + +instance DecodeM DecodeAST AttributeList (FFI.AttrSetDecoder a, a) where + decodeM (FFI.AttrSetDecoder attrsAtIndex countParams, a) = do + functionAttrSet <- + do mAttrSet <- + -- function attributes are grouped and decoded later. Since + -- we are sometimes decoding inside of scopeAnyConT, we + -- cannot use withAttrsAtIndex to allocate the attribute + -- set since it will be freed before we decode it. + liftIO . mask_ $ do + attrSet <- + attrsAtIndex a FFI.functionIndex :: IO FFI.FunctionAttributeSet + hasAttributes <- decodeM =<< FFI.attributeSetHasAttributes attrSet + if hasAttributes + then pure (Just attrSet) + else FFI.disposeAttributeSet attrSet >> pure Nothing + case mAttrSet of + Nothing -> pure Nothing + Just attrSet -> Just . Left <$> getAttributeGroupID attrSet + returnAttrs <- + do attrSet <- + withAttrsAtIndex FFI.returnIndex :: DecodeAST FFI.ParameterAttributeSet + decodeM attrSet + numParams <- liftIO (countParams a) + paramAttrs <- + forM [1 .. numParams] $ \i -> + decodeM =<< + (withAttrsAtIndex (FFI.AttributeIndex i) :: DecodeAST FFI.ParameterAttributeSet) + return + (AttributeList + { functionAttributes = maybeToList functionAttrSet + , returnAttributes = returnAttrs + , parameterAttributes = paramAttrs + }) + where + withAttrsAtIndex :: FFI.AttributeIndex -> DecodeAST (FFI.AttributeSet b) + withAttrsAtIndex index = + anyContToM (bracket (attrsAtIndex a index) (FFI.disposeAttributeSet)) diff --git a/src/LLVM/Internal/BasicBlock.hs b/src/LLVM/Internal/BasicBlock.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/BasicBlock.hs @@ -0,0 +1,27 @@ +module LLVM.Internal.BasicBlock where + +import LLVM.Prelude + +import Control.Monad.Trans +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.BasicBlock as FFI +import qualified LLVM.Internal.FFI.Iterate as FFI + +import LLVM.Internal.DecodeAST +import LLVM.Internal.Coding +import LLVM.Internal.Instruction () + +import qualified LLVM.AST.Instruction as A + +getBasicBlockTerminator :: Ptr FFI.BasicBlock -> DecodeAST (DecodeAST (A.Named A.Terminator)) +getBasicBlockTerminator = decodeM <=< (liftIO . FFI.getBasicBlockTerminator) + +getNamedInstructions :: Ptr FFI.BasicBlock -> DecodeAST (DecodeAST [A.Named A.Instruction]) +getNamedInstructions b = do + ffiInstructions <- liftIO $ FFI.getXs (FFI.getFirstInstruction b) FFI.getNextInstruction + let n = length ffiInstructions + liftM sequence . forM (take (n-1) ffiInstructions) $ decodeM + + diff --git a/src/LLVM/Internal/CallingConvention.hs b/src/LLVM/Internal/CallingConvention.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/CallingConvention.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE + MultiParamTypeClasses, + TemplateHaskell, + QuasiQuotes + #-} +module LLVM.Internal.CallingConvention where + +import LLVM.Prelude + +import LLVM.Internal.Coding +import Foreign.C.Types (CUInt(..)) + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import LLVM.Internal.FFI.LLVMCTypes (callingConventionP) + +import qualified LLVM.AST.CallingConvention as A.CC + +instance Monad m => EncodeM m A.CC.CallingConvention FFI.CallingConvention where + encodeM cc = return $ + case cc of + A.CC.C -> FFI.callingConventionC + A.CC.Fast -> FFI.callingConventionFast + A.CC.Cold -> FFI.callingConventionCold + A.CC.GHC -> FFI.callingConventionGHC + A.CC.HiPE -> FFI.callingConventionHiPE + A.CC.WebKit_JS -> FFI.callingConventionWebKit_JS + A.CC.AnyReg -> FFI.callingConventionAnyReg + A.CC.PreserveMost -> FFI.callingConventionPreserveMost + A.CC.PreserveAll -> FFI.callingConventionPreserveAll + A.CC.Swift -> FFI.callingConventionSwift + A.CC.CXX_FastTLS -> FFI.callingConventionCXX_FAST_TLS + A.CC.X86_StdCall -> FFI.callingConventionX86_StdCall + A.CC.X86_FastCall -> FFI.callingConventionX86_FastCall + A.CC.ARM_APCS -> FFI.callingConventionARM_APCS + A.CC.ARM_AAPCS -> FFI.callingConventionARM_AAPCS + A.CC.ARM_AAPCS_VFP -> FFI.callingConventionARM_AAPCS_VFP + A.CC.MSP430_INTR -> FFI.callingConventionMSP430_INTR + A.CC.X86_ThisCall -> FFI.callingConventionX86_ThisCall + A.CC.PTX_Kernel -> FFI.callingConventionPTX_Kernel + A.CC.PTX_Device -> FFI.callingConventionPTX_Device + A.CC.SPIR_FUNC -> FFI.callingConventionSPIR_FUNC + A.CC.SPIR_KERNEL -> FFI.callingConventionSPIR_KERNEL + A.CC.Intel_OCL_BI -> FFI.callingConventionIntel_OCL_BI + A.CC.X86_64_SysV -> FFI.callingConventionX86_64_SysV + A.CC.Win64 -> FFI.callingConventionWin64 + A.CC.X86_VectorCall -> FFI.callingConventionX86_VectorCall + A.CC.HHVM -> FFI.callingConventionHHVM + A.CC.HHVM_C -> FFI.callingConventionHHVM_C + A.CC.X86_Intr -> FFI.callingConventionX86_INTR + A.CC.AVR_Intr -> FFI.callingConventionAVR_INTR + A.CC.AVR_Signal -> FFI.callingConventionAVR_SIGNAL + A.CC.AVR_Builtin -> FFI.callingConventionAVR_BUILTIN + A.CC.AMDGPU_VS -> FFI.callingConventionAMDGPU_VS + A.CC.AMDGPU_HS -> FFI.callingConventionAMDGPU_HS + A.CC.AMDGPU_GS -> FFI.callingConventionAMDGPU_GS + A.CC.AMDGPU_PS -> FFI.callingConventionAMDGPU_PS + A.CC.AMDGPU_CS -> FFI.callingConventionAMDGPU_CS + A.CC.AMDGPU_Kernel -> FFI.callingConventionAMDGPU_KERNEL + A.CC.X86_RegCall -> FFI.callingConventionX86_RegCall + A.CC.MSP430_Builtin -> FFI.callingConventionMSP430_BUILTIN + A.CC.Numbered cc' -> FFI.CallingConvention (fromIntegral cc') + +instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallingConvention where + decodeM cc = return $ case cc of + [callingConventionP|C|] -> A.CC.C + [callingConventionP|Fast|] -> A.CC.Fast + [callingConventionP|Cold|] -> A.CC.Cold + [callingConventionP|GHC|] -> A.CC.GHC + [callingConventionP|HiPE|] -> A.CC.HiPE + [callingConventionP|WebKit_JS|] -> A.CC.WebKit_JS + [callingConventionP|AnyReg|] -> A.CC.AnyReg + [callingConventionP|PreserveMost|] -> A.CC.PreserveMost + [callingConventionP|PreserveAll|] -> A.CC.PreserveAll + [callingConventionP|Swift|] -> A.CC.Swift + [callingConventionP|CXX_FAST_TLS|] -> A.CC.CXX_FastTLS + [callingConventionP|X86_StdCall|] -> A.CC.X86_StdCall + [callingConventionP|X86_FastCall|] -> A.CC.X86_FastCall + [callingConventionP|ARM_APCS|] -> A.CC.ARM_APCS + [callingConventionP|ARM_AAPCS|] -> A.CC.ARM_AAPCS + [callingConventionP|ARM_AAPCS_VFP|] -> A.CC.ARM_AAPCS_VFP + [callingConventionP|MSP430_INTR|] -> A.CC.MSP430_INTR + [callingConventionP|X86_ThisCall|] -> A.CC.X86_ThisCall + [callingConventionP|PTX_Kernel|] -> A.CC.PTX_Kernel + [callingConventionP|PTX_Device|] -> A.CC.PTX_Device + [callingConventionP|SPIR_FUNC|] -> A.CC.SPIR_FUNC + [callingConventionP|SPIR_KERNEL|] -> A.CC.SPIR_KERNEL + [callingConventionP|Intel_OCL_BI|] -> A.CC.Intel_OCL_BI + [callingConventionP|X86_64_SysV|] -> A.CC.X86_64_SysV + [callingConventionP|Win64|] -> A.CC.Win64 + [callingConventionP|X86_VectorCall|] -> A.CC.X86_VectorCall + [callingConventionP|HHVM|] -> A.CC.HHVM + [callingConventionP|HHVM_C|] -> A.CC.HHVM_C + [callingConventionP|X86_INTR|] -> A.CC.X86_Intr + [callingConventionP|AVR_INTR|] -> A.CC.AVR_Intr + [callingConventionP|AVR_SIGNAL|] -> A.CC.AVR_Signal + [callingConventionP|AVR_BUILTIN|] -> A.CC.AVR_Builtin + [callingConventionP|AMDGPU_VS|] -> A.CC.AMDGPU_VS + [callingConventionP|AMDGPU_HS|] -> A.CC.AMDGPU_HS + [callingConventionP|AMDGPU_GS|] -> A.CC.AMDGPU_GS + [callingConventionP|AMDGPU_PS|] -> A.CC.AMDGPU_PS + [callingConventionP|AMDGPU_CS|] -> A.CC.AMDGPU_CS + [callingConventionP|AMDGPU_KERNEL|] -> A.CC.AMDGPU_Kernel + [callingConventionP|X86_RegCall|] -> A.CC.X86_RegCall + [callingConventionP|MSP430_BUILTIN|] -> A.CC.MSP430_Builtin + FFI.CallingConvention (CUInt ci) + | ci >= 64 -> A.CC.Numbered (fromIntegral ci) + | otherwise -> error ("Unknown calling convention: " <> show ci) diff --git a/src/LLVM/Internal/Coding.hs b/src/LLVM/Internal/Coding.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Coding.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses, + FunctionalDependencies, + UndecidableInstances + #-} +module LLVM.Internal.Coding where + +import LLVM.Prelude + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Control.Monad.AnyCont +import Control.Monad.IO.Class + +import Foreign.C +import Foreign.Ptr +import Foreign.Storable (Storable) +import qualified Foreign.Storable +import qualified Foreign.Marshal.Alloc +import qualified Foreign.Marshal.Array +import GHC.Stack + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +class EncodeM e h c where + encodeM :: HasCallStack => h -> e c + +class DecodeM d h c where + decodeM :: HasCallStack => c -> d h + +genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec] +genCodingInstance ht ctn chs = do + let n = const Nothing + [d| + instance Monad m => EncodeM m $(ht) $(conT ctn) where + encodeM h = return $( + caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] + ) + + instance Monad m => DecodeM m $(ht) $(conT ctn) where + decodeM c = return $( + caseE [| c |] ([ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs] ++ + [ match wildP (normalB [e| error ("Decoding failed: Unknown " <> show c) |]) []])) + |] + +allocaArray :: (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a) +allocaArray p = anyContToM $ Foreign.Marshal.Array.allocaArray (fromIntegral p) + +alloca :: (Storable a, MonadAnyCont IO m) => m (Ptr a) +alloca = anyContToM Foreign.Marshal.Alloc.alloca + +peek :: (Storable a, MonadIO m) => Ptr a -> m a +peek p = liftIO $ Foreign.Storable.peek p + +peekByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> m a +peekByteOff p i = liftIO $ Foreign.Storable.peekByteOff p i + +poke :: (Storable a, MonadIO m) => Ptr a -> a -> m () +poke p a = liftIO $ Foreign.Storable.poke p a + +pokeByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> a -> m () +pokeByteOff p i a = liftIO $ Foreign.Storable.pokeByteOff p i a + +peekArray :: (Integral i, Storable a, MonadIO m) => i -> Ptr a -> m [a] +peekArray n p = liftIO $ Foreign.Marshal.Array.peekArray (fromIntegral n) p + +instance (Monad m, EncodeM m h c, Storable c, MonadAnyCont IO m) => EncodeM m [h] (CUInt, Ptr c) where + encodeM hs = do + hs <- mapM encodeM hs + (anyContToM $ \x -> Foreign.Marshal.Array.withArrayLen hs $ \n hs -> x (fromIntegral n, hs)) + +instance (Monad m, DecodeM m h c, Storable c, MonadIO m) => DecodeM m [h] (CUInt, Ptr c) where + decodeM (n, ca) = do + cs <- liftIO $ Foreign.Marshal.Array.peekArray (fromIntegral n) ca + mapM decodeM cs + +instance Monad m => EncodeM m Bool FFI.LLVMBool where + encodeM False = return $ FFI.LLVMBool 0 + encodeM True = return $ FFI.LLVMBool 1 + +instance Monad m => DecodeM m Bool FFI.LLVMBool where + decodeM (FFI.LLVMBool 0) = return $ False + decodeM (FFI.LLVMBool _) = return $ True + +instance (Monad m, EncodeM m h (Ptr c)) => EncodeM m (Maybe h) (Ptr c) where + encodeM = maybe (return nullPtr) encodeM + +instance (Monad m, DecodeM m h (Ptr c)) => DecodeM m (Maybe h) (Ptr c) where + decodeM p | p == nullPtr = return Nothing + | otherwise = liftM Just $ decodeM p + +instance Monad m => EncodeM m (Maybe Bool) (FFI.NothingAsMinusOne Bool) where + encodeM = return . FFI.NothingAsMinusOne . maybe (-1) (fromIntegral . fromEnum) + +instance Monad m => EncodeM m (Maybe Word) (FFI.NothingAsMinusOne Word) where + encodeM = return . FFI.NothingAsMinusOne . maybe (-1) fromIntegral + +instance Monad m => EncodeM m (Maybe Word32) (CUInt, FFI.LLVMBool) where + encodeM (Just a) = liftM2 (,) (encodeM a) (encodeM True) + encodeM Nothing = (0,) <$> encodeM False + +instance Monad m => EncodeM m (Maybe Word32) (Word32, FFI.LLVMBool) where + encodeM (Just a) = (a,) <$> encodeM True + encodeM Nothing = (0,) <$> encodeM False + +instance Monad m => EncodeM m Word CUInt where + encodeM = return . fromIntegral + +instance Monad m => EncodeM m Word32 CUInt where + encodeM = return . fromIntegral + +instance Monad m => EncodeM m Word64 CULong where + encodeM = return . fromIntegral + +instance Monad m => DecodeM m Word CUInt where + decodeM = return . fromIntegral + +instance Monad m => DecodeM m Word32 CUInt where + decodeM = return . fromIntegral + +instance Monad m => DecodeM m Word64 CULong where + decodeM = return . fromIntegral + +instance Monad m => EncodeM m Int32 CInt where + encodeM = return . fromIntegral + +instance Monad m => DecodeM m Int32 CInt where + decodeM = return . fromIntegral + +instance Monad m => DecodeM m Int CInt where + decodeM = return . fromIntegral + +instance Monad m => EncodeM m Word64 Word64 where + encodeM = return + +instance Monad m => DecodeM m Word64 Word64 where + decodeM = return + +decodeOptional :: (DecodeM m b a, Storable a, MonadAnyCont IO m, MonadIO m) => (Ptr a -> IO FFI.LLVMBool) -> m (Maybe b) +decodeOptional f = do + ptr <- alloca + isJust <- decodeM =<< liftIO (f ptr) + if isJust + then Just <$> (decodeM =<< peek ptr) + else pure Nothing + +decodeArray :: (DecodeM m b' b, MonadIO m) => (a -> IO CUInt) -> (a -> CUInt -> IO b) -> a -> m [b'] +decodeArray numElems getElem a = do + n <- liftIO (numElems a) + if n == 0 + then pure [] + else traverse (decodeM <=< liftIO . getElem a) [0 .. n - 1] diff --git a/src/LLVM/Internal/CommandLine.hs b/src/LLVM/Internal/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/CommandLine.hs @@ -0,0 +1,23 @@ +module LLVM.Internal.CommandLine where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.IO.Class + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.CommandLine as FFI + +import LLVM.Internal.Coding +import LLVM.Internal.String () + +-- | +-- Sadly, there is occasionally some configuration one would like to control +-- in LLVM which are accessible only as command line flags setting global state, +-- as if the command line tools were the only use of LLVM. Very sad. +parseCommandLineOptions :: [ShortByteString] -> Maybe ShortByteString -> IO () +parseCommandLineOptions args overview = runAnyContT' return $ do + args <- encodeM args + overview <- maybe (return nullPtr) encodeM overview + liftIO $ FFI.parseCommandLineOptions args overview diff --git a/src/LLVM/Internal/Constant.hs b/src/LLVM/Internal/Constant.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Constant.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE + TemplateHaskell, + QuasiQuotes, + MultiParamTypeClasses, + ScopedTypeVariables + #-} +module LLVM.Internal.Constant where + +import LLVM.Prelude + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TH +import qualified LLVM.Internal.InstructionDefs as ID + +import Data.Bits +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.State (get, gets, modify, evalState) + +import qualified Data.Map as Map +import Foreign.Ptr +import Foreign.Storable (Storable, sizeOf) + +import qualified LLVM.Internal.FFI.Constant as FFI +import qualified LLVM.Internal.FFI.GlobalValue as FFI +import qualified LLVM.Internal.FFI.Instruction as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import LLVM.Internal.FFI.LLVMCTypes (valueSubclassIdP) +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Type as FFI +import qualified LLVM.Internal.FFI.User as FFI +import qualified LLVM.Internal.FFI.Value as FFI +import qualified LLVM.Internal.FFI.BinaryOperator as FFI + +import qualified LLVM.AST.Constant as A (Constant) +import qualified LLVM.AST.Constant as A.C hiding (Constant) +import qualified LLVM.AST.Type as A +import qualified LLVM.AST.IntegerPredicate as A (IntegerPredicate) +import qualified LLVM.AST.FloatingPointPredicate as A (FloatingPointPredicate) +import qualified LLVM.AST.Float as A.F + +import LLVM.Exception +import LLVM.Internal.Coding +import LLVM.Internal.Context +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import LLVM.Internal.FloatingPointPredicate () +import LLVM.Internal.IntegerPredicate () +import LLVM.Internal.Type (renameType) +import LLVM.Internal.Value + +allocaWords :: forall a m . (Storable a, MonadAnyCont IO m, Monad m, MonadIO m) => Word32 -> m (Ptr a) +allocaWords nBits = do + allocaArray (((nBits-1) `div` (8*(fromIntegral (sizeOf (undefined :: a))))) + 1) + +inconsistentCases :: Show a => String -> a -> b +inconsistentCases name attr = + error $ "llvm-hs internal error: cases inconstistent in " ++ name ++ " encoding for " ++ show attr + +instance EncodeM EncodeAST A.Constant (Ptr FFI.Constant) where + encodeM c = scopeAnyCont $ case c of + A.C.Int { A.C.integerBits = bits, A.C.integerValue = v } -> do + t <- encodeM (A.IntegerType bits) + words <- encodeM [ + fromIntegral ((v `shiftR` (w*64)) .&. 0xffffffffffffffff) :: Word64 + | w <- [0 .. ((fromIntegral bits-1) `div` 64)] + ] + liftIO $ FFI.constantIntOfArbitraryPrecision t words + A.C.Float { A.C.floatValue = v } -> do + Context context <- gets encodeStateContext + let poke1 f = do + let nBits = fromIntegral $ 8*(sizeOf f) + words <- allocaWords nBits + poke (castPtr words) f + return (nBits, words) + poke2 fh fl = do + let nBits = fromIntegral $ 8*(sizeOf fh) + 8*(sizeOf fl) + words <- allocaWords nBits + pokeByteOff (castPtr words) 0 fl + pokeByteOff (castPtr words) (sizeOf fl) fh + return (nBits, words) + (nBits, words) <- case v of + A.F.Half f -> poke1 f + A.F.Single f -> poke1 f + A.F.Double f -> poke1 f + A.F.X86_FP80 high low -> poke2 high low + A.F.Quadruple high low -> poke2 high low + A.F.PPC_FP128 high low -> poke2 high low + let fpSem = case v of + A.F.Half _ -> FFI.floatSemanticsIEEEhalf + A.F.Single _ -> FFI.floatSemanticsIEEEsingle + A.F.Double _ -> FFI.floatSemanticsIEEEdouble + A.F.Quadruple _ _ -> FFI.floatSemanticsIEEEquad + A.F.X86_FP80 _ _ -> FFI.floatSemanticsx87DoubleExtended + A.F.PPC_FP128 _ _ -> FFI.floatSemanticsPPCDoubleDouble + nBits <- encodeM nBits + liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words fpSem + A.C.GlobalReference ty n -> do + ref <- FFI.upCast <$> referGlobal n + ty' <- (liftIO . runDecodeAST . typeOf) ref + renamedTy <- renameType ty + if renamedTy /= ty' + then throwM + (EncodeException + ("The serialized GlobalReference " ++ show n ++ " has type " ++ show ty ++ " but should have type " ++ show ty')) + else return ref + A.C.BlockAddress f b -> do + f' <- referGlobal f + b' <- getBlockForAddress f b + liftIO $ FFI.blockAddress (FFI.upCast f') b' + A.C.Struct nm p ms -> do + p <- encodeM p + ms <- encodeM ms + case nm of + Nothing -> do + Context context <- gets encodeStateContext + liftIO $ FFI.constStructInContext context ms p + Just nm -> do + t <- lookupNamedType nm + liftIO $ FFI.constNamedStruct t ms + A.C.TokenNone -> do + Context context <- gets encodeStateContext + liftIO $ FFI.getConstTokenNone context + o -> $(do + let -- This is a mapping from constructor names to the constructor of the constant + -- and the constructor and the definition of the instruction. + constExprInfo :: Map.Map String (Maybe TH.Con, Maybe (TH.Con, ID.InstructionDef)) + constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) + TH.caseE [| o |] $ + map (\p -> TH.match p (TH.normalB [|inconsistentCases "Constant" o|]) []) + [[p|A.C.Int{}|], + [p|A.C.Float{}|], + [p|A.C.Struct{}|], + [p|A.C.BlockAddress{}|], + [p|A.C.GlobalReference{}|], + [p|A.C.TokenNone{}|]] ++ + (do (name, (Just (TH.RecC n fields), instrInfo)) <- Map.toList constExprInfo + let fieldNames = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fields ] + coreCall n = TH.dyn $ "FFI.constant" ++ n + -- Addition validations that are run during encoding. A common usage of + -- this is to check if certain types are allowed. The record fields are in scope + -- when the validations are run. + validations = case name of + "Null" -> + [ TH.noBindS + [| case $(TH.dyn "constantType") of + A.PointerType {} -> pure () + _ -> + throwM + (EncodeException + ("Null pointer constant must have pointer type but has type " <> + show $(TH.dyn "constantType") <> ".")) + |] + ] + "AggregateZero" -> + [ TH.noBindS $ + [| case $(TH.dyn "constantType") of + A.ArrayType {} -> pure () + A.StructureType {} -> pure () + A.VectorType {} -> pure () + A.NamedTypeReference {} -> pure () + _ -> + throwM + (EncodeException + ("Aggregate zero constant must have struct, array or vector type but has type " <> + show $(TH.dyn "constantType") <> ".")) + |] + ] + _ -> [] + buildBody c = + validations ++ + [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fieldNames ] ++ + [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fieldNames)) |] ] + hasFlags = ''Bool `elem` [ h | (_, _, TH.ConT h) <- fields ] + core <- case instrInfo of + Just (_, iDef) -> do + let opcode = TH.dataToExpQ (const Nothing) (ID.cppOpcode iDef) + case ID.instructionKind iDef of + ID.Binary + | hasFlags -> return $ coreCall name + | otherwise -> return [| $(coreCall "BinaryOperator") $(opcode) |] + ID.Cast -> return [| $(coreCall "Cast") $(opcode) |] + _ -> return $ coreCall name + Nothing -> + case name of + "Array" -> pure (TH.varE 'FFI.constantArray) + "AggregateZero" -> pure (TH.varE 'FFI.constantNull) + "Null" -> pure (TH.varE 'FFI.constantNull) + "Undef" -> pure (TH.varE 'FFI.constantUndef) + "Vector" -> pure (TH.varE 'FFI.constantVector) + _ -> [] -- We have already handled these values + return $ TH.match + (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fields]) + (TH.normalB (TH.doE (buildBody core))) + []) + ) + +instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where + decodeM c = scopeAnyCont $ do + let v = FFI.upCast c :: Ptr FFI.Value + u = FFI.upCast c :: Ptr FFI.User + ft <- liftIO (FFI.typeOf v) + t <- decodeM ft + valueSubclassId <- liftIO $ FFI.getValueSubclassId v + nOps <- liftIO $ FFI.getNumOperands u + let globalRef = return A.C.GlobalReference + `ap` (return t) + `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v)) + op = decodeM <=< liftIO . FFI.getConstantOperand c + getConstantOperands = mapM op [0..nOps-1] + getConstantData = do + let nElements = + case t of + A.VectorType n _ -> n + A.ArrayType n _ | n <= (fromIntegral (maxBound :: Word32)) -> fromIntegral n + _ -> error "getConstantData can only be applied to vectors and arrays" + forM [0..nElements-1] $ do + decodeM <=< liftIO . FFI.getConstantDataSequentialElementAsConstant c . fromIntegral + + case valueSubclassId of + [valueSubclassIdP|Function|] -> globalRef + [valueSubclassIdP|GlobalAlias|] -> globalRef + [valueSubclassIdP|GlobalVariable|] -> globalRef + [valueSubclassIdP|ConstantInt|] -> do + np <- alloca + wsp <- liftIO $ FFI.getConstantIntWords c np + n <- peek np + words <- decodeM (n, wsp) + return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral b) 0 (words :: [Word64])) + [valueSubclassIdP|ConstantFP|] -> do + let A.FloatingPointType fpt = t + let nBits = case fpt of + A.HalfFP -> 16 + A.FloatFP -> 32 + A.DoubleFP -> 64 + A.FP128FP -> 128 + A.X86_FP80FP -> 80 + A.PPC_FP128FP -> 128 + ws <- allocaWords nBits + liftIO $ FFI.getConstantFloatWords c ws + A.C.Float <$> ( + case fpt of + A.HalfFP -> A.F.Half <$> peek (castPtr ws) + A.FloatFP -> A.F.Single <$> peek (castPtr ws) + A.DoubleFP -> A.F.Double <$> peek (castPtr ws) + A.FP128FP -> A.F.Quadruple <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0 + A.X86_FP80FP -> A.F.X86_FP80 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0 + A.PPC_FP128FP -> A.F.PPC_FP128 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0 + ) + [valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t + [valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.AggregateZero t + [valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t + [valueSubclassIdP|BlockAddress|] -> + return A.C.BlockAddress + `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c) + `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c) + [valueSubclassIdP|ConstantStruct|] -> do + return A.C.Struct + `ap` (return $ case t of A.NamedTypeReference n -> Just n; _ -> Nothing) + `ap` (decodeM =<< liftIO (FFI.isPackedStruct ft)) + `ap` getConstantOperands + [valueSubclassIdP|ConstantDataArray|] -> + return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData + [valueSubclassIdP|ConstantArray|] -> + return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantOperands + [valueSubclassIdP|ConstantDataVector|] -> + return A.C.Vector `ap` getConstantData + [valueSubclassIdP|ConstantVector|] -> + A.C.Vector <$> getConstantOperands + [valueSubclassIdP|ConstantExpr|] -> do + cppOpcode <- liftIO $ FFI.getConstantCPPOpcode c + $( + TH.caseE [| cppOpcode |] $ + (do (_, ((TH.RecC n fs, _), iDef)) <- Map.toList $ + ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs + let apWrapper o (fn, _, ct) = do + a <- case ct of + TH.ConT h + | h == ''A.Constant -> do + operandNumber <- get + modify (+1) + return [| op $(TH.litE . TH.integerL $ operandNumber) |] + | h == ''A.Type -> return [| pure t |] + | h == ''A.IntegerPredicate -> + return [| liftIO $ decodeM =<< FFI.getConstantICmpPredicate c |] + | h == ''A.FloatingPointPredicate -> + return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |] + | h == ''Bool -> case TH.nameBase fn of + "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |] + "exact" -> return [| liftIO $ decodeM =<< FFI.isExact v |] + "nsw" -> return [| liftIO $ decodeM =<< FFI.hasNoSignedWrap v |] + "nuw" -> return [| liftIO $ decodeM =<< FFI.hasNoUnsignedWrap v |] + x -> error $ "constant bool field " ++ show x ++ " not handled yet" + TH.AppT TH.ListT (TH.ConT h) + | h == ''Word32 -> + return [| + do + np <- alloca + isp <- liftIO $ FFI.getConstantIndices c np + n <- peek np + decodeM (n, isp) + |] + | h == ''A.Constant && + TH.nameBase fn == "indices" -> do + operandNumber <- get + return [| mapM op [$(TH.litE . TH.integerL $ operandNumber)..nOps-1] |] + + _ -> error $ "unhandled constant expr field type: " ++ show fn ++ " - " ++ show ct + return [| $(o) `ap` $(a) |] + return $ TH.match + (TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef)) + (TH.normalB (evalState (foldM apWrapper [| return $(TH.conE n) |] fs) 0)) + []) + ++ [TH.match TH.wildP (TH.normalB [|error ("Unknown constant opcode: " <> show cppOpcode)|]) []] + ) + [valueSubclassIdP|ConstantTokenNone|] -> return A.C.TokenNone + _ -> error $ "unhandled constant valueSubclassId: " ++ show valueSubclassId + + + + diff --git a/src/LLVM/Internal/Context.hs b/src/LLVM/Internal/Context.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Context.hs @@ -0,0 +1,28 @@ +module LLVM.Internal.Context where + +import LLVM.Prelude + +import Control.Exception +import Control.Concurrent + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.Context as FFI + +-- | a Context object holds the state the of LLVM system needs for one thread of +-- | LLVM compilation. Once upon a time, in early versions of LLVM, this state was global. +-- | Then it got packed up in this object to allow multiple threads to compile at once. +data Context = Context (Ptr FFI.Context) + +-- | Create a Context, run an action (to which it is provided), then destroy the Context. +withContext :: (Context -> IO a) -> IO a +withContext = runBound . bracket FFI.contextCreate FFI.contextDispose . (. Context) + where runBound = if rtsSupportsBoundThreads then runInBoundThread else id + +-- | Create a Context. +createContext :: IO Context +createContext = Context <$> FFI.contextCreate + +-- | Destroy a context created by 'createContext'. +disposeContext :: Context -> IO () +disposeContext (Context ptr) = FFI.contextDispose ptr diff --git a/src/LLVM/Internal/DataLayout.hs b/src/LLVM/Internal/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/DataLayout.hs @@ -0,0 +1,23 @@ +module LLVM.Internal.DataLayout where + +import LLVM.Prelude + +import Control.Exception +import Control.Monad.AnyCont +import Control.Monad.IO.Class + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.DataLayout as FFI + +import LLVM.AST.DataLayout +import LLVM.DataLayout + +import LLVM.Internal.Coding +import LLVM.Internal.String () + +withFFIDataLayout :: DataLayout -> (Ptr FFI.DataLayout -> IO a) -> IO a +withFFIDataLayout dl f = runAnyContT' return $ do + dls <- encodeM (dataLayoutToString dl) + liftIO $ bracket (FFI.createDataLayout dls) FFI.disposeDataLayout f + diff --git a/src/LLVM/Internal/DecodeAST.hs b/src/LLVM/Internal/DecodeAST.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/DecodeAST.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module LLVM.Internal.DecodeAST where + +import LLVM.Prelude + +import Control.Monad.Catch +import Control.Monad.State +import Control.Monad.AnyCont + +import Foreign.Ptr +import Foreign.C + +import Data.Array (Array) +import Data.Map (Map) +import Data.Sequence (Seq) +import qualified Data.Array as Array +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +#if __GLASGOW_HASKELL__ < 808 +import Control.Monad.Fail (MonadFail) +#endif + +import qualified LLVM.Internal.FFI.Attribute as FFI +import qualified LLVM.Internal.FFI.GlobalValue as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Value as FFI +import qualified LLVM.Internal.FFI.Type as FFI + +import qualified LLVM.AST.Name as A +import qualified LLVM.AST.Operand as A (MetadataNodeID(..)) +import qualified LLVM.AST.Attribute as A.A +import qualified LLVM.AST.COMDAT as A.COMDAT + +import LLVM.Internal.Coding +import LLVM.Internal.String () + +type NameMap a = Map (Ptr a) Word + +data DecodeState = DecodeState { + globalVarNum :: NameMap FFI.GlobalValue, + localVarNum :: NameMap FFI.Value, + localNameCounter :: Maybe Word, + namedTypeNum :: NameMap FFI.Type, + typesToDefine :: Seq (Ptr FFI.Type), + metadataNodesToDefine :: Seq (A.MetadataNodeID, Ptr FFI.MDNode), + metadataNodes :: Map (Ptr FFI.MDNode) A.MetadataNodeID, + metadataKinds :: Array Word ShortByteString, + parameterAttributeLists :: Map FFI.ParameterAttributeSet [A.A.ParameterAttribute], + functionAttributeListIDs :: [(FFI.FunctionAttributeSet, A.A.GroupID)], + comdats :: Map (Ptr FFI.COMDAT) (ShortByteString, A.COMDAT.SelectionKind) + } + +initialDecode :: DecodeState +initialDecode = DecodeState { + globalVarNum = Map.empty, + localVarNum = Map.empty, + localNameCounter = Nothing, + namedTypeNum = Map.empty, + typesToDefine = Seq.empty, + metadataNodesToDefine = Seq.empty, + metadataNodes = Map.empty, + metadataKinds = Array.listArray (1,0) [], + parameterAttributeLists = Map.empty, + functionAttributeListIDs = [], + comdats = Map.empty + } +newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a } + deriving ( + Applicative, + Functor, + Monad, + MonadIO, + MonadFail, + MonadState DecodeState, + MonadThrow, + MonadAnyCont IO, + ScopeAnyCont + ) + +runDecodeAST :: DecodeAST a -> IO a +runDecodeAST d = flip evalStateT initialDecode . runAnyContT' return . unDecodeAST $ d + +localScope :: DecodeAST a -> DecodeAST a +localScope (DecodeAST x) = DecodeAST (tweak x) + where tweak x = do + modify (\s@DecodeState { localNameCounter = Nothing } -> s { localNameCounter = Just 0 }) + r <- x + modify (\s@DecodeState { localNameCounter = Just _ } -> s { localNameCounter = Nothing }) + return r + +getName :: (Ptr a -> IO CString) + -> Ptr a + -> (DecodeState -> NameMap a) + -> DecodeAST Word + -> DecodeAST A.Name +getName getCString v getNameMap generate = do + name <- liftIO $ do + n <- getCString v + if n == nullPtr then return "" else decodeM n + if name /= "" + then + return $ A.Name name + else + A.UnName <$> do + nm <- gets getNameMap + maybe generate return $ Map.lookup v nm + +getValueName :: FFI.DescendentOf FFI.Value v => Ptr v -> (DecodeState -> NameMap v) -> DecodeAST Word -> DecodeAST A.Name +getValueName = getName (FFI.getValueName . FFI.upCast) + +getLocalName :: FFI.DescendentOf FFI.Value v => Ptr v -> DecodeAST A.Name +getLocalName v' = do + let v = FFI.upCast v' + getValueName v localVarNum $ do + nm <- gets localVarNum + Just n <- gets localNameCounter + modify $ \s -> s { localNameCounter = Just (1 + n), localVarNum = Map.insert v n nm } + return n + +getGlobalName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.Name +getGlobalName v' = do + let v = FFI.upCast v' + getValueName v globalVarNum $ do + nm <- gets globalVarNum + let n = fromIntegral $ Map.size nm + modify $ \s -> s { globalVarNum = Map.insert v n nm } + return n + + +getTypeName :: Ptr FFI.Type -> DecodeAST A.Name +getTypeName t = do + getName FFI.getStructName t namedTypeNum $ do + nm <- gets namedTypeNum + let n = fromIntegral $ Map.size nm + modify $ \s -> s { namedTypeNum = Map.insert t n nm } + return n + +saveNamedType :: Ptr FFI.Type -> DecodeAST () +saveNamedType t = do + modify $ \s -> s { typesToDefine = t Seq.<| typesToDefine s } + +getMetadataNodeID :: Ptr FFI.MDNode -> DecodeAST A.MetadataNodeID +getMetadataNodeID p = do + mdns <- gets metadataNodes + case Map.lookup p mdns of + Just r -> return r + Nothing -> do + let r = A.MetadataNodeID (fromIntegral (Map.size mdns)) + modify $ \s -> s { + metadataNodesToDefine = (r, p) Seq.<| metadataNodesToDefine s, + metadataNodes = Map.insert p r (metadataNodes s) + } + return r + +takeTypeToDefine :: DecodeAST (Maybe (Ptr FFI.Type)) +takeTypeToDefine = state $ \s -> case Seq.viewr (typesToDefine s) of + remaining Seq.:> t -> (Just t, s { typesToDefine = remaining }) + _ -> (Nothing, s) + +takeMetadataNodeToDefine :: DecodeAST (Maybe (A.MetadataNodeID, Ptr FFI.MDNode)) +takeMetadataNodeToDefine = state $ \s -> case Seq.viewr (metadataNodesToDefine s) of + remaining Seq.:> md -> (Just md, s { metadataNodesToDefine = remaining }) + _ -> (Nothing, s) + +instance DecodeM DecodeAST A.Name (Ptr FFI.BasicBlock) where + decodeM = getLocalName + +getAttributeGroupID :: FFI.FunctionAttributeSet -> DecodeAST A.A.GroupID +getAttributeGroupID p = do + ids <- gets functionAttributeListIDs + -- What we are interested in is the AttributeSetNode inside the + -- AttributeSet but LLVM does not expose this. We thus have to + -- resort to doing a linear scan and using the operator== which is + -- implemented as a comparison on those AttributeSetNodes. + id <- liftIO (findM (\(as, _) -> decodeM =<< FFI.attributeSetsEqual as p) ids) + case id of + Nothing -> do + let r = A.A.GroupID (fromIntegral (length ids)) + modify $ \s -> s { functionAttributeListIDs = (p,r) : functionAttributeListIDs s } + return r + Just (_, id') -> do + liftIO (FFI.disposeAttributeSet p) + return id' diff --git a/src/LLVM/Internal/Diagnostic.hs b/src/LLVM/Internal/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Diagnostic.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses + #-} +module LLVM.Internal.Diagnostic where + +import LLVM.Prelude + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.SMDiagnostic as FFI + +import Control.Exception + +import Foreign.Ptr + +import LLVM.Diagnostic +import LLVM.Internal.Coding +import LLVM.Internal.String () + +genCodingInstance [t| DiagnosticKind |] ''FFI.DiagnosticKind [ + (FFI.diagnosticKindError, ErrorKind), + (FFI.diagnosticKindWarning, WarningKind), + (FFI.diagnosticKindNote, NoteKind) + ] + +withSMDiagnostic :: (Ptr FFI.SMDiagnostic -> IO a) -> IO a +withSMDiagnostic = bracket FFI.createSMDiagnostic FFI.disposeSMDiagnostic + +getDiagnostic :: Ptr FFI.SMDiagnostic -> IO Diagnostic +getDiagnostic p = do + l <- decodeM =<< FFI.getSMDiagnosticLineNo p + c <- decodeM =<< FFI.getSMDiagnosticColumnNo p + k <- decodeM =<< FFI.getSMDiagnosticKind p + f <- decodeM $ FFI.getSMDiagnosticFilename p + m <- decodeM $ FFI.getSMDiagnosticMessage p + lc <- decodeM $ FFI.getSMDiagnosticLineContents p + return $ Diagnostic { + lineNumber = l, columnNumber = c, diagnosticKind = k, filename = f, message = m, lineContents = lc + } + diff --git a/src/LLVM/Internal/EncodeAST.hs b/src/LLVM/Internal/EncodeAST.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/EncodeAST.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + UndecidableInstances, + OverloadedStrings + #-} +module LLVM.Internal.EncodeAST where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.State + +import Foreign.Ptr +import Foreign.C + +import qualified LLVM.Internal.FFI.ShortByteString as ShortByteString +import qualified Data.ByteString.Short as ShortByteString + +import Data.Map (Map) +import qualified Data.Map as Map + +import qualified LLVM.Internal.FFI.Attribute as FFI +import qualified LLVM.Internal.FFI.Builder as FFI +import qualified LLVM.Internal.FFI.GlobalValue as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Value as FFI + +import qualified LLVM.AST as A +import qualified LLVM.AST.Attribute as A.A +import LLVM.Exception + +import LLVM.Internal.Context +import LLVM.Internal.Coding +import LLVM.Internal.String () + +data LocalValue + = ForwardValue (Ptr FFI.Value) + | DefinedValue (Ptr FFI.Value) + +data EncodeState = EncodeState { + encodeStateBuilder :: Ptr FFI.Builder, + encodeStateContext :: Context, + encodeStateLocals :: Map A.Name LocalValue, + encodeStateGlobals :: Map A.Name (Ptr FFI.GlobalValue), + encodeStateAllBlocks :: Map (A.Name, A.Name) (Ptr FFI.BasicBlock), + encodeStateBlocks :: Map A.Name (Ptr FFI.BasicBlock), + encodeStateMDNodes :: Map A.MetadataNodeID (Ptr FFI.MDNode), + encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type), + encodeStateRenamedTypes :: Map A.Name ShortByteString, + encodeStateAttributeGroups :: Map A.A.GroupID FFI.FunctionAttributeSet, + encodeStateCOMDATs :: Map ShortByteString (Ptr FFI.COMDAT) + } + +newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (StateT EncodeState IO) a } + deriving ( + Functor, + Applicative, + Monad, + MonadIO, + MonadState EncodeState, + MonadThrow, + MonadAnyCont IO, + ScopeAnyCont + ) + +lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) +lookupNamedType n = do + t <- gets $ Map.lookup n . encodeStateNamedTypes + maybe (throwM . EncodeException $ "reference to undefined type: " ++ show n) return t + +defineType :: A.Name -> Maybe ShortByteString -> Ptr FFI.Type -> EncodeAST () +defineType n n' t = do + modify $ \s -> s { encodeStateNamedTypes = Map.insert n t (encodeStateNamedTypes s) } + for_ n' $ \renamedName -> + modify $ \s -> s { encodeStateRenamedTypes = Map.insert n renamedName (encodeStateRenamedTypes s) } + +runEncodeAST :: Context -> EncodeAST a -> IO a +runEncodeAST context@(Context ctx) (EncodeAST a) = + bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do + let initEncodeState = EncodeState { + encodeStateBuilder = builder, + encodeStateContext = context, + encodeStateLocals = Map.empty, + encodeStateGlobals = Map.empty, + encodeStateAllBlocks = Map.empty, + encodeStateBlocks = Map.empty, + encodeStateMDNodes = Map.empty, + encodeStateNamedTypes = Map.empty, + encodeStateRenamedTypes = Map.empty, + encodeStateAttributeGroups = Map.empty, + encodeStateCOMDATs = Map.empty + } + flip evalStateT initEncodeState . runAnyContT' return $ a + +withName :: A.Name -> (CString -> IO a) -> IO a +withName (A.Name n) = ShortByteString.useAsCString n +withName (A.UnName _) = withCString "" + +instance MonadAnyCont IO m => EncodeM m A.Name CString where + encodeM (A.Name n) = encodeM n + encodeM _ = encodeM ShortByteString.empty + +phase :: EncodeAST a -> EncodeAST (EncodeAST a) +phase p = do + let s0 `withLocalsFrom` s1 = s0 { + encodeStateLocals = encodeStateLocals s1, + encodeStateBlocks = encodeStateBlocks s1 + } + s <- get + return $ do + s' <- get + put $ s' `withLocalsFrom` s + r <- p + modify (`withLocalsFrom` s') + return r + +defineLocal :: FFI.DescendentOf FFI.Value v => A.Name -> Ptr v -> EncodeAST () +defineLocal n v' = do + let v = FFI.upCast v' + case n of + A.Name s + | ShortByteString.null s -> pure () + _ -> do + def <- gets $ Map.lookup n . encodeStateLocals + case def of + Just (ForwardValue dummy) -> liftIO $ FFI.replaceAllUsesWith dummy v + Just _ -> throwM (EncodeException ("Duplicate definition of local variable: " <> show n <> ".")) + _ -> return () + modify $ \b -> b { encodeStateLocals = Map.insert n (DefinedValue v) (encodeStateLocals b) } + +defineGlobal :: FFI.DescendentOf FFI.GlobalValue v => A.Name -> Ptr v -> EncodeAST () +defineGlobal n v = modify $ \b -> b { encodeStateGlobals = Map.insert n (FFI.upCast v) (encodeStateGlobals b) } + +defineMDNode :: A.MetadataNodeID -> Ptr FFI.MDNode -> EncodeAST () +defineMDNode n v = modify $ \b -> b { encodeStateMDNodes = Map.insert n (FFI.upCast v) (encodeStateMDNodes b) } + +defineAttributeGroup :: A.A.GroupID -> FFI.FunctionAttributeSet -> EncodeAST () +defineAttributeGroup gid attrs = modify $ \b -> b { encodeStateAttributeGroups = Map.insert gid attrs (encodeStateAttributeGroups b) } + +defineCOMDAT :: ShortByteString -> Ptr FFI.COMDAT -> EncodeAST () +defineCOMDAT name cd = modify $ \b -> b { encodeStateCOMDATs = Map.insert name cd (encodeStateCOMDATs b) } + +refer :: (Show n, Ord n) => (EncodeState -> Map n v) -> n -> EncodeAST v -> EncodeAST v +refer r n f = do + mop <- gets $ Map.lookup n . r + maybe f return mop + +undefinedReference :: Show n => String -> n -> EncodeAST a +undefinedReference m n = throwM . EncodeException $ "reference to undefined " ++ m ++ ": " ++ show n + +referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n v) -> String -> n -> EncodeAST v +referOrThrow r m n = refer r n $ undefinedReference m n + +referGlobal :: A.Name -> EncodeAST (Ptr FFI.GlobalValue) +referGlobal = referOrThrow encodeStateGlobals "global" +referMDNode :: A.MetadataNodeID -> EncodeAST (Ptr FFI.MDNode) +referMDNode = referOrThrow encodeStateMDNodes "metadata node" +referAttributeGroup :: A.A.GroupID -> EncodeAST FFI.FunctionAttributeSet +referAttributeGroup = referOrThrow encodeStateAttributeGroups "attribute group" +referCOMDAT :: ShortByteString -> EncodeAST (Ptr FFI.COMDAT) +referCOMDAT = referOrThrow encodeStateCOMDATs "COMDAT" + +defineBasicBlock :: A.Name -> A.Name -> Ptr FFI.BasicBlock -> EncodeAST () +defineBasicBlock fn n b = modify $ \s -> s { + encodeStateBlocks = Map.insert n b (encodeStateBlocks s), + encodeStateAllBlocks = Map.insert (fn, n) b (encodeStateAllBlocks s) +} + +instance EncodeM EncodeAST A.Name (Ptr FFI.BasicBlock) where + encodeM = referOrThrow encodeStateBlocks "block" + +getBlockForAddress :: A.Name -> A.Name -> EncodeAST (Ptr FFI.BasicBlock) +getBlockForAddress fn n = referOrThrow encodeStateAllBlocks "blockaddress" (fn, n) + diff --git a/src/LLVM/Internal/ExecutionEngine.hs b/src/LLVM/Internal/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/ExecutionEngine.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE + MultiParamTypeClasses, + FunctionalDependencies, + OverloadedStrings, + RankNTypes + #-} +module LLVM.Internal.ExecutionEngine where + +import LLVM.Prelude + +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.AnyCont + +import Data.IORef +import Foreign.Ptr +import Foreign.C (CUInt, CString) +import Foreign.Marshal.Alloc (allocaBytes) + +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.ExecutionEngine as FFI +import qualified LLVM.Internal.FFI.Module as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Module +import LLVM.Internal.Context +import LLVM.Internal.Coding +import qualified LLVM.CodeModel as CodeModel +import LLVM.Internal.Target +import qualified LLVM.AST as A +import GHC.Stack + +removeModule :: Ptr FFI.ExecutionEngine -> Ptr FFI.Module -> IO () +removeModule e m = runAnyContT' return $ do + d0 <- alloca + d1 <- alloca + r <- liftIO $ FFI.removeModule e m d0 d1 + when (r /= 0) $ fail "FFI.removeModule failure" + +-- | a 'ExecutableModule' e represents a 'Module' which is currently "in" an +-- 'ExecutionEngine', and so the functions of which may be executed. +data ExecutableModule e = ExecutableModule e (Ptr FFI.Module) + +-- | +class ExecutionEngine e f | e -> f where + withModuleInEngine :: e -> Module -> (ExecutableModule e -> IO a) -> IO a + getFunction :: HasCallStack => ExecutableModule e -> A.Name -> IO (Maybe f) + +instance ExecutionEngine (Ptr FFI.ExecutionEngine) (FunPtr ()) where + withModuleInEngine e m f = do + m' <- readModule m + bracket_ (FFI.addModule e m') (removeModule e m') (f (ExecutableModule e m')) + getFunction (ExecutableModule e m) (A.Name name) = runAnyContT' return $ do + name <- encodeM name + f <- liftIO $ FFI.getNamedFunction m name + if f == nullPtr + then + return Nothing + else + do + p <- liftIO $ FFI.getPointerToGlobal e (FFI.upCast f) + return $ if p == nullPtr then Nothing else Just (castPtrToFunPtr p) + getFunction _ _ = error "Only named functions can be looked up" + +withExecutionEngine :: + Context -> + Maybe (Ptr FFI.Module) -> + (Ptr (Ptr FFI.ExecutionEngine) -> Ptr FFI.Module -> Ptr (FFI.OwnerTransfered CString) -> IO CUInt) -> + (Ptr FFI.ExecutionEngine -> IO a) -> + IO a +withExecutionEngine c m createEngine f = runAnyContT' return $ do + liftIO initializeNativeTarget + outExecutionEngine <- alloca + outErrorCStringPtr <- alloca + dummyModule <- maybe (anyContToM $ + withModuleFromAST c (A.Module "" "" Nothing Nothing [])) + (liftIO . newModule) m + dummyModule' <- readModule dummyModule + r <- liftIO $ createEngine outExecutionEngine dummyModule' outErrorCStringPtr + when (r /= 0) $ fail =<< decodeM outErrorCStringPtr + executionEngine <- anyContToM $ bracket (peek outExecutionEngine) FFI.disposeExecutionEngine + liftIO $ removeModule executionEngine dummyModule' + liftIO $ f executionEngine + +data MCJITState + = Deferred (forall a . Module -> (Ptr FFI.ExecutionEngine -> IO a) -> IO a) + | Constructed (Ptr FFI.ExecutionEngine) + +-- | +-- +-- N.B. - the LLVM MCJIT does not current support adding multiple +-- modules to any one instance of the MCJIT. +newtype MCJIT = MCJIT (IORef MCJITState) + +-- | bracket the creation and destruction of an 'MCJIT' +withMCJIT :: + Context + -> Maybe Word -- ^ optimization level + -> Maybe CodeModel.Model + -> Maybe Bool -- ^ True to disable frame pointer elimination + -> Maybe Bool -- ^ True to enable fast instruction selection +-- -> Maybe MemoryManager -- llvm-hs doesn't support this yet + -> (MCJIT -> IO a) + -> IO a +withMCJIT c opt cm fpe fisel f = do + FFI.linkInMCJIT + let createMCJITCompilerForModule e m s = do + size <- FFI.getMCJITCompilerOptionsSize + allocaBytes (fromIntegral size) $ \p -> do + FFI.initializeMCJITCompilerOptions p size + traverse_ (FFI.setMCJITCompilerOptionsOptLevel p <=< encodeM) opt + traverse_ (FFI.setMCJITCompilerOptionsCodeModel p <=< encodeM) cm + traverse_ (FFI.setMCJITCompilerOptionsNoFramePointerElim p <=< encodeM) fpe + traverse_ (FFI.setMCJITCompilerOptionsEnableFastISel p <=< encodeM) fisel + FFI.createMCJITCompilerForModule e m p size s + t <- newIORef (Deferred $ \mod f -> do m' <- readModule mod + withExecutionEngine c (Just m') createMCJITCompilerForModule f) + f (MCJIT t) + +instance ExecutionEngine MCJIT (FunPtr ()) where + withModuleInEngine (MCJIT s) m f = do + jitState <- readIORef s + let f' (ExecutableModule _ m) = f (ExecutableModule (MCJIT s) m) + case jitState of + Deferred c -> c m $ \e -> + bracket_ + (writeIORef s (Constructed e)) + (writeIORef s jitState) + (withModuleInEngine e m f') + Constructed e -> withModuleInEngine e m f' + + getFunction (ExecutableModule (MCJIT r) m) n = do + s <- liftIO $ readIORef r + case s of + Deferred _ -> return Nothing + Constructed e -> getFunction (ExecutableModule e m) n diff --git a/src/LLVM/Internal/FFI/Analysis.h b/src/LLVM/Internal/FFI/Analysis.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Analysis.h @@ -0,0 +1,11 @@ +#ifndef __LLVM_INTERNAL_FFI__ANALYSIS__H__ +#define __LLVM_INTERNAL_FFI__ANALYSIS__H__ + +#include "llvm-c/Analysis.h" + +#define LLVM_HS_FOR_EACH_VERIFIER_FAILURE_ACTION(macro) \ + macro(AbortProcess) \ + macro(PrintMessage) \ + macro(ReturnStatus) + +#endif diff --git a/src/LLVM/Internal/FFI/Analysis.hs b/src/LLVM/Internal/FFI/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Analysis.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.Analysis where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.Module + +foreign import ccall unsafe "LLVMVerifyModule" verifyModule :: + Ptr Module -> VerifierFailureAction -> Ptr (OwnerTransfered CString) -> IO LLVMBool diff --git a/src/LLVM/Internal/FFI/Assembly.hs b/src/LLVM/Internal/FFI/Assembly.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Assembly.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} + +-- | Functions to read and write textual LLVM assembly +module LLVM.Internal.FFI.Assembly where + +import LLVM.Prelude + +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.MemoryBuffer +import LLVM.Internal.FFI.Module +import LLVM.Internal.FFI.PtrHierarchy + +import Foreign.C +import Foreign.Ptr + +-- | Use LLVM's parser to parse a string of llvm assembly in a memory buffer to get a module +foreign import ccall unsafe "LLVM_Hs_ParseLLVMAssembly" parseLLVMAssembly :: + Ptr Context -> OwnerTransfered (Ptr MemoryBuffer) -> Ptr (OwnerTransfered CString) -> IO (Ptr Module) + + +-- | LLVM's serializer to generate a string of llvm assembly from a module +foreign import ccall unsafe "LLVM_Hs_WriteLLVMAssembly" writeLLVMAssembly :: + Ptr Module -> Ptr RawOStream -> IO () diff --git a/src/LLVM/Internal/FFI/AssemblyC.cpp b/src/LLVM/Internal/FFI/AssemblyC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/AssemblyC.cpp @@ -0,0 +1,28 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/AsmParser/Parser.h" +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/Module.h" +#include "llvm/Pass.h" +#include "llvm/Support/MemoryBuffer.h" +#include "llvm/Support/SourceMgr.h" +#include "llvm/Support/raw_ostream.h" + +#include "llvm-c/Core.h" +#include "llvm-c/IRReader.h" + +using namespace llvm; + +extern "C" { + +LLVMModuleRef LLVM_Hs_ParseLLVMAssembly(LLVMContextRef context, + LLVMMemoryBufferRef memoryBuffer, + char **error) { + LLVMModuleRef M; + LLVMParseIRInContext(context, memoryBuffer, &M, error); + return M; +} + +void LLVM_Hs_WriteLLVMAssembly(LLVMModuleRef module, raw_ostream &os) { + os << *unwrap(module); +} +} diff --git a/src/LLVM/Internal/FFI/Attribute.h b/src/LLVM/Internal/FFI/Attribute.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Attribute.h @@ -0,0 +1,90 @@ +#ifndef __LLVM_INTERNAL_FFI__ATTRIBUTES__H__ +#define __LLVM_INTERNAL_FFI__ATTRIBUTES__H__ + + +// The last three arguments are flags indicating if this is a +// parameter attribute, function result attribute or function attribute. +#define LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(macro) \ + macro(None,F,F,F) \ + macro(AlwaysInline,F,F,T) \ + macro(ArgMemOnly,F,F,T) \ + macro(Builtin,F,F,T) \ + macro(Cold,F,F,T) \ + macro(Convergent,F,F,T) \ + macro(Hot,F,F,T) \ + macro(ImmArg,T,F,F) \ + macro(InAlloca,T,F,F) \ + macro(InReg,T,T,F) \ + macro(InaccessibleMemOnly,F,F,T) \ + macro(InaccessibleMemOrArgMemOnly,F,F,T) \ + macro(InlineHint,F,F,T) \ + macro(JumpTable,F,F,T) \ + macro(MinSize,F,F,T) \ + macro(Naked,F,F,T) \ + macro(Nest,T,F,F) \ + macro(NoAlias,T,T,F) \ + macro(NoBuiltin,F,F,T) \ + macro(NoCallback,F,F,T) \ + macro(NoCapture,T,F,F) \ + macro(NoCfCheck,F,F,T) \ + macro(NoDuplicate,F,F,T) \ + macro(NoFree,T,F,T) \ + macro(NoImplicitFloat,F,F,T) \ + macro(NoInline,F,F,T) \ + macro(NoMerge,F,F,T) \ + macro(NoProfile,F,F,T) \ + macro(NoRecurse,F,F,T) \ + macro(NoRedZone,F,F,T) \ + macro(NoReturn,F,F,T) \ + macro(NoSync,F,F,T) \ + macro(NoUndef,F,F,T) \ + macro(NoUnwind,F,F,T) \ + macro(NonLazyBind,F,F,T) \ + macro(NonNull,T,T,F) \ + macro(NullPointerIsValid,T,T,F) \ + macro(OptForFuzzing,F,F,T) \ + macro(OptimizeForSize,F,F,T) \ + macro(OptimizeNone,F,F,T) \ + macro(ReadNone,T,F,T) \ + macro(ReadOnly,T,F,T) \ + macro(Returned,T,F,F) \ + macro(ReturnsTwice,F,F,T) \ + macro(SExt,T,T,F) \ + macro(SafeStack,F,F,T) \ + macro(SanitizeAddress,F,F,T) \ + macro(SanitizeHWAddress,F,F,T) \ + macro(SanitizeMemTag,F,F,T) \ + macro(SanitizeMemory,F,F,T) \ + macro(SanitizeThread,F,F,T) \ + macro(ShadowCallStack,F,F,T) \ + macro(Speculatable,F,F,T) \ + macro(SpeculativeLoadHardening,F,F,T) \ + macro(StackProtect,F,F,T) \ + macro(StackProtectReq,F,F,T) \ + macro(StackProtectStrong,F,F,T) \ + macro(StrictFP,F,F,T) \ + macro(SwiftError,T,F,F) \ + macro(SwiftSelf,T,F,F) \ + macro(UWTable,F,F,T) \ + macro(WillReturn,F,F,T) \ + macro(WriteOnly,T,F,T) \ + macro(ZExt,T,T,F) \ + macro(ByRef,T,F,F) \ + macro(ByVal,T,F,F) \ + macro(MustProgress,F,F,T) \ + macro(Preallocated,F,F,T) \ + macro(StructRet,T,F,F) \ + macro(Alignment,T,T,F) \ + macro(AllocSize,F,F,T) \ + macro(Dereferenceable,T,T,F) \ + macro(DereferenceableOrNull,T,T,F) \ + macro(StackAlignment,F,F,T) \ + macro(EndAttrKinds,F,F,F) + +typedef enum { +#define ENUM_CASE(x,p,r,f) LLVM_Hs_AttributeKind_ ## x, +LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_AttributeKind; + +#endif diff --git a/src/LLVM/Internal/FFI/Attribute.hs b/src/LLVM/Internal/FFI/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Attribute.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE + ForeignFunctionInterface, + RankNTypes + #-} +module LLVM.Internal.FFI.Attribute where + +import LLVM.Prelude + +import Foreign.C +import Foreign.Ptr + +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.LLVMCTypes + +type Slot = CUInt +type IntValue = Word64 + +{- +Data model: +llvm::Attribute is one function or parameter attribute + +llvm::AttributeSet stores a set of function, return or parameter attributes + +llvm::AttributeList stores the AttributeSet for the function itself, +the return value and for the functions parameters. + +Encode path: +Use AttrBuilder on the C++ side only, to implement [Attribute] -> AttributeList +AttributeLists -> whole AttributeList +-} + +data MixedAttributeType +data FunctionAttributeType +data ParameterAttributeType +data AttributeImpl a +data AttributeSetImpl a +data AttributeListImpl + +type Attribute a = Ptr (AttributeImpl a) +type FunctionAttribute = Attribute FunctionAttributeType +type ParameterAttribute = Attribute ParameterAttributeType +newtype AttributeIndex = AttributeIndex CUInt + +type AttributeSet a = Ptr (AttributeSetImpl a) +-- type MixedAttributeSet = AttributeSet MixedAttributeType +type FunctionAttributeSet = AttributeSet FunctionAttributeType +type ParameterAttributeSet = AttributeSet ParameterAttributeType +type AttributeList = Ptr AttributeListImpl + +forgetAttributeType :: AttributeSet a -> AttributeSet MixedAttributeType +forgetAttributeType = castPtr + +functionIndex :: AttributeIndex +functionIndex = AttributeIndex (-1) +returnIndex :: AttributeIndex +returnIndex = AttributeIndex 0 + +data AttrSetDecoder a = AttrSetDecoder { + attrSetDecoderAttributesAtIndex :: forall b. a -> AttributeIndex -> IO (AttributeSet b), + attrSetDecoderCountParams :: a -> IO CUInt + } + +-- | +foreign import ccall unsafe "LLVMGetEnumAttributeKind" parameterAttributeKindAsEnum :: + ParameterAttribute -> IO ParameterAttributeKind + +-- | +foreign import ccall unsafe "LLVMGetEnumAttributeKind" functionAttributeKindAsEnum :: + FunctionAttribute -> IO FunctionAttributeKind + +-- | +foreign import ccall unsafe "LLVMIsStringAttribute" isStringAttribute :: + Attribute a -> IO LLVMBool + +-- | Unfortunately the LLVM C API function can only deal with a 32 bit (unsigned*) length, so we can't just call +-- | +foreign import ccall unsafe "LLVM_Hs_AttributeKindAsString" attributeKindAsString :: + Attribute a -> Ptr CSize -> IO (Ptr CChar) + +-- | Unfortunately the LLVM C API function can only deal with a 32 bit (unsigned*) length, so we can't just call +-- | Ptr CSize -> IO (Ptr CChar) + +-- TODO-LLVM-VERSION-INCREASE: Check C API coverage (has this functionality been added?) +-- | The LLVM C API does not expose this functionality +foreign import ccall unsafe "LLVM_Hs_AttributeValueAsInt" attributeValueAsInt :: + Attribute a -> IO Word64 + +-- | The LLVM C API does not expose this functionality +foreign import ccall unsafe "LLVM_Hs_getNumAttributes" getNumAttributes :: + AttributeSet a -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_getAttributes" getAttributes :: + AttributeSet a -> Ptr (Attribute a) -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetAttributeList" getAttributeList :: + Ptr Context -> AttributeIndex -> AttributeSet a -> IO AttributeList + +foreign import ccall unsafe "LLVM_Hs_BuildAttributeList" buildAttributeList :: + Ptr Context -> FunctionAttributeSet -> ParameterAttributeSet -> Ptr ParameterAttributeSet -> CUInt -> IO AttributeList + +foreign import ccall unsafe "LLVM_Hs_DisposeAttributeList" disposeAttributeList :: + AttributeList -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetAttributeSet" getAttributeSet :: + Ptr Context -> Ptr (AttrBuilder a) -> IO (AttributeSet a) + +foreign import ccall unsafe "LLVM_Hs_DisposeAttributeSet" disposeAttributeSet :: + AttributeSet a -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttributeSetsEqual" attributeSetsEqual :: + AttributeSet a -> AttributeSet a -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_AttributeSetHasAttributes" attributeSetHasAttributes :: + AttributeSet a -> IO LLVMBool + +data AttrBuilder a +type FunctionAttrBuilder = AttrBuilder FunctionAttributeType +type ParameterAttrBuilder = AttrBuilder ParameterAttributeType + +foreign import ccall unsafe "LLVM_Hs_GetAttrBuilderSize" getAttrBuilderSize :: + CSize + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderFromAttrSet" attrBuilderFromSet :: + AttributeSet a -> IO (Ptr (AttrBuilder a)) + +foreign import ccall unsafe "LLVM_Hs_DisposeAttrBuilder" disposeAttrBuilder :: + Ptr (AttrBuilder a) -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderMerge" mergeAttrBuilder :: + Ptr (AttrBuilder a) -> Ptr (AttrBuilder a) -> IO () + +foreign import ccall unsafe "LLVM_Hs_ConstructAttrBuilder" constructAttrBuilder :: + Ptr Word8 -> IO (Ptr (AttrBuilder a)) + +foreign import ccall unsafe "LLVM_Hs_DestroyAttrBuilder" destroyAttrBuilder :: + Ptr (AttrBuilder a) -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAttributeKind" attrBuilderAddFunctionAttributeKind :: + Ptr FunctionAttrBuilder -> FunctionAttributeKind -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAttributeKind" attrBuilderAddParameterAttributeKind :: + Ptr ParameterAttrBuilder -> ParameterAttributeKind -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddStringAttribute" attrBuilderAddStringAttribute :: + Ptr (AttrBuilder a) -> Ptr CChar -> CSize -> Ptr CChar -> CSize -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAlignment" attrBuilderAddAlignment :: + Ptr ParameterAttrBuilder -> Word64 -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddStackAlignment" attrBuilderAddStackAlignment :: + Ptr FunctionAttrBuilder -> Word64 -> IO () + +-- The CInt is 0 if the last value is null and 1 otherwise +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddAllocSize" attrBuilderAddAllocSize' :: + Ptr FunctionAttrBuilder -> CUInt -> CUInt -> LLVMBool -> IO () + +attrBuilderAddAllocSize :: Ptr FunctionAttrBuilder -> CUInt -> (CUInt, LLVMBool) -> IO () +attrBuilderAddAllocSize b i (y, isJust) = attrBuilderAddAllocSize' b i y isJust + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddDereferenceableAttr" attrBuilderAddDereferenceable :: + Ptr ParameterAttrBuilder -> Word64 -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttrBuilderAddDereferenceableOrNullAttr" attrBuilderAddDereferenceableOrNull :: + Ptr ParameterAttrBuilder -> Word64 -> IO () + +foreign import ccall unsafe "LLVM_Hs_AttributeGetAllocSizeArgs" attributeGetAllocSizeArgs :: + FunctionAttribute -> Ptr CUInt -> Ptr CUInt -> IO LLVMBool diff --git a/src/LLVM/Internal/FFI/AttributeC.cpp b/src/LLVM/Internal/FFI/AttributeC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/AttributeC.cpp @@ -0,0 +1,154 @@ +#define __STDC_LIMIT_MACROS +#include "LLVM/Internal/FFI/AttributeC.hpp" +#include "llvm/IR/LLVMContext.h" + +extern "C" { + +static_assert(sizeof(AttributeList) == sizeof(AttributeListImpl *), + "AttributeList implementation has changed"); + +static_assert(sizeof(Attribute) == sizeof(AttributeImpl *), + "Attribute implementation has changed"); + +#define CHECK(name, p, r, f) \ + static_assert(unsigned(llvm::Attribute::name) == \ + unsigned(LLVM_Hs_AttributeKind_##name), \ + "LLVM_Hs_AttributeKind enum out of sync w/ " \ + "llvm::Attribute::AttrKind for " #name); +LLVM_HS_FOR_EACH_ATTRIBUTE_KIND(CHECK) +#undef CHECK + +uint64_t LLVM_Hs_AttributeValueAsInt(LLVMAttributeRef a) { + return unwrap(a).getValueAsInt(); +} + +const char *LLVM_Hs_AttributeKindAsString(LLVMAttributeRef a, size_t &l) { + const StringRef s = unwrap(a).getKindAsString(); + l = s.size(); + return s.data(); +} + +const char *LLVM_Hs_AttributeValueAsString(LLVMAttributeRef a, size_t &l) { + const StringRef s = unwrap(a).getValueAsString(); + l = s.size(); + return s.data(); +} + +AttributeList * LLVM_Hs_GetAttributeList(LLVMContextRef context, + unsigned index, + AttributeSet *as) { + return new AttributeList(AttributeList::get(*unwrap(context), index, *as)); +} + +AttributeList * LLVM_Hs_BuildAttributeList(LLVMContextRef context, + AttributeSet *fAttrs, + AttributeSet *rAttrs, + AttributeSet **pAttrs, + unsigned numPAttrs) { + std::vector pAttrSets{numPAttrs}; + for (unsigned i = 0; i < numPAttrs; ++i) { + pAttrSets[i] = *pAttrs[i]; + } + return new AttributeList( + AttributeList::get(*unwrap(context), *fAttrs, *rAttrs, pAttrSets)); +} + +void LLVM_Hs_DisposeAttributeList(AttributeList *attributeList) { + delete attributeList; +} + +AttributeSet *LLVM_Hs_GetAttributeSet(LLVMContextRef context, + const AttrBuilder &ab) { + return new AttributeSet(AttributeSet::get(*unwrap(context), ab)); +} + +void LLVM_Hs_DisposeAttributeSet(AttributeList *attributeList) { + delete attributeList; +} + +LLVMBool LLVM_Hs_AttributeSetsEqual(AttributeSet *as1, + AttributeSet *as2) { + return *as1 == *as2; +} + +LLVMBool LLVM_Hs_AttributeSetHasAttributes(AttributeSet *as) { + return as->hasAttributes(); +} + +unsigned LLVM_Hs_getNumAttributes(AttributeSet *attributeSet) { + return attributeSet->getNumAttributes(); +} + +void LLVM_Hs_getAttributes(AttributeSet *attributeSet, + LLVMAttributeRef *attrs) { + for (auto a : *attributeSet) { + *attrs++ = wrap(a); + } +} + +size_t LLVM_Hs_GetAttrBuilderSize() { return sizeof(AttrBuilder); } + +AttrBuilder *LLVM_Hs_ConstructAttrBuilder(char *p) { + return new (p) AttrBuilder(); +} + +AttrBuilder *LLVM_Hs_AttrBuilderFromAttrSet(AttributeSet *as) { + return new AttrBuilder(*as); +} + +void LLVM_Hs_DisposeAttrBuilder(AttributeSet *as) { delete as; } + +void LLVM_Hs_AttrBuilderMerge(AttrBuilder *ab1, AttrBuilder *ab2) { + ab1->merge(*ab2); +} + +void LLVM_Hs_DestroyAttrBuilder(AttrBuilder *a) { a->~AttrBuilder(); } + +void LLVM_Hs_AttrBuilderAddAttributeKind(AttrBuilder &ab, unsigned kind) { + ab.addAttribute(Attribute::AttrKind(kind)); +} + +void LLVM_Hs_AttrBuilderAddStringAttribute(AttrBuilder &ab, const char *kind, + size_t kind_len, const char *value, + size_t value_len) { + ab.addAttribute(StringRef(kind, kind_len), StringRef(value, value_len)); +} + +void LLVM_Hs_AttrBuilderAddAlignment(AttrBuilder &ab, uint64_t v) { + ab.addAlignmentAttr(MaybeAlign(v)); +} + +void LLVM_Hs_AttrBuilderAddStackAlignment(AttrBuilder &ab, uint64_t v) { + ab.addStackAlignmentAttr(MaybeAlign(v)); +} + +void LLVM_Hs_AttrBuilderAddAllocSize(AttrBuilder &ab, unsigned x, unsigned y, + LLVMBool optionalIsThere) { + if (optionalIsThere) { + ab.addAllocSizeAttr(x, Optional(y)); + } else { + ab.addAllocSizeAttr(x, Optional()); + } +} + +void LLVM_Hs_AttrBuilderAddDereferenceableAttr(AttrBuilder &ab, uint64_t v) { + ab.addDereferenceableAttr(v); +} + +void LLVM_Hs_AttrBuilderAddDereferenceableOrNullAttr(AttrBuilder &ab, + uint64_t v) { + ab.addDereferenceableOrNullAttr(v); +} + +LLVMBool LLVM_Hs_AttributeGetAllocSizeArgs(LLVMAttributeRef a, unsigned *x, + unsigned *y) { + auto pair = unwrap(a).getAllocSizeArgs(); + *x = pair.first; + if (pair.second.hasValue()) { + *y = pair.second.getValue(); + return 1; + } else { + return 0; + } +} +} diff --git a/src/LLVM/Internal/FFI/AttributeC.hpp b/src/LLVM/Internal/FFI/AttributeC.hpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/AttributeC.hpp @@ -0,0 +1,11 @@ +#ifndef __LLVM_ATTRIBUTE_C_HPP__ +#define __LLVM_ATTRIBUTE_C_HPP__ +#define __STDC_LIMIT_MACROS +#include "LLVM/Internal/FFI/Attribute.h" +#include "llvm/IR/Attributes.h" +using namespace llvm; + +typedef AttributeSet *LLVMAttributeSetRef; +typedef AttributeList *LLVMAttributeListRef; + +#endif diff --git a/src/LLVM/Internal/FFI/BasicBlock.hs b/src/LLVM/Internal/FFI/BasicBlock.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/BasicBlock.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses + #-} + +-- | +module LLVM.Internal.FFI.BasicBlock where + +import LLVM.Prelude + +import Foreign.Ptr + +import LLVM.Internal.FFI.PtrHierarchy + +-- | +foreign import ccall unsafe "LLVMIsABasicBlock" isABasicBlock :: + Ptr Value -> IO (Ptr BasicBlock) + +-- | +foreign import ccall unsafe "LLVMGetBasicBlockTerminator" getBasicBlockTerminator :: + Ptr BasicBlock -> IO (Ptr Instruction) + +-- | +foreign import ccall unsafe "LLVMGetFirstInstruction" getFirstInstruction :: + Ptr BasicBlock -> IO (Ptr Instruction) + +-- | +foreign import ccall unsafe "LLVMGetLastInstruction" getLastInstruction :: + Ptr BasicBlock -> IO (Ptr Instruction) + +-- | +foreign import ccall unsafe "LLVMGetNextInstruction" getNextInstruction :: + Ptr Instruction -> IO (Ptr Instruction) + diff --git a/src/LLVM/Internal/FFI/BinaryOperator.hs b/src/LLVM/Internal/FFI/BinaryOperator.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/BinaryOperator.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances + #-} +-- | FFI functions for handling the LLVM BinaryOperator class +module LLVM.Internal.FFI.BinaryOperator where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.LLVMCTypes + +foreign import ccall unsafe "LLVMIsABinaryOperator" isABinaryOperator :: + Ptr Value -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_HasNoSignedWrap" hasNoSignedWrap :: + Ptr Value -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_HasNoUnsignedWrap" hasNoUnsignedWrap :: + Ptr Value -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_IsExact" isExact :: + Ptr Value -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_GetFastMathFlags" getFastMathFlags :: + Ptr Value -> IO FastMathFlags diff --git a/src/LLVM/Internal/FFI/Bitcode.hs b/src/LLVM/Internal/FFI/Bitcode.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Bitcode.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} + +-- | Functions to read and write LLVM bitcode +module LLVM.Internal.FFI.Bitcode where + +import LLVM.Prelude + +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.MemoryBuffer +import LLVM.Internal.FFI.Module +import LLVM.Internal.FFI.PtrHierarchy + +import Foreign.C +import Foreign.Ptr + +foreign import ccall unsafe "LLVM_Hs_ParseBitcode" parseBitcode :: + Ptr Context -> Ptr MemoryBuffer -> Ptr (OwnerTransfered CString) -> IO (Ptr Module) + +foreign import ccall unsafe "LLVM_Hs_WriteBitcode" writeBitcode :: + Ptr Module -> Ptr RawOStream -> IO () + + + diff --git a/src/LLVM/Internal/FFI/BitcodeC.cpp b/src/LLVM/Internal/FFI/BitcodeC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/BitcodeC.cpp @@ -0,0 +1,34 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/Module.h" +#include "llvm-c/Core.h" +#include "llvm/Support/raw_ostream.h" +#include "llvm/Support/MemoryBuffer.h" +#include "llvm/Bitcode/BitcodeReader.h" +#include "llvm/Bitcode/BitcodeWriter.h" + +using namespace llvm; + +extern "C" { + +LLVMModuleRef LLVM_Hs_ParseBitcode( + LLVMContextRef c, + LLVMMemoryBufferRef mb, + char **error +) { + Expected> moduleOrErr = parseBitcodeFile(unwrap(mb)->getMemBufferRef(), *unwrap(c)); + if (Error err = moduleOrErr.takeError()) { + handleAllErrors(std::move(err), [&](ErrorInfoBase &eib) { + *error = strdup(eib.message().c_str()); + }); + return nullptr; + } + return wrap(moduleOrErr.get().release()); +} + +void LLVM_Hs_WriteBitcode(LLVMModuleRef m, raw_ostream &os) { + WriteBitcodeToFile(*unwrap(m), os); +} + +} + diff --git a/src/LLVM/Internal/FFI/Builder.hs b/src/LLVM/Internal/FFI/Builder.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Builder.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ViewPatterns #-} + +module LLVM.Internal.FFI.Builder where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C +import GHC.Stack + +import qualified Data.List as List +import qualified Data.Map as Map + +import qualified LLVM.AST.Instruction as A +import LLVM.Internal.InstructionDefs as ID + +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy + +data Builder + +foreign import ccall unsafe "LLVMCreateBuilderInContext" createBuilderInContext :: + Ptr Context -> IO (Ptr Builder) + +foreign import ccall unsafe "LLVMDisposeBuilder" disposeBuilder :: + Ptr Builder -> IO () + +foreign import ccall unsafe "LLVMPositionBuilderAtEnd" positionBuilderAtEnd :: + Ptr Builder -> Ptr BasicBlock -> IO () + +foreign import ccall unsafe "LLVMBuildRet" buildRet :: + Ptr Builder -> Ptr Value -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildBr" buildBr :: + Ptr Builder -> Ptr BasicBlock -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildCondBr" buildCondBr :: + Ptr Builder -> Ptr Value -> Ptr BasicBlock -> Ptr BasicBlock -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildSwitch" buildSwitch :: + Ptr Builder -> Ptr Value -> Ptr BasicBlock -> CUInt -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildIndirectBr" buildIndirectBr :: + Ptr Builder -> Ptr Value -> CUInt -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildInvoke" buildInvoke :: + Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt + -> Ptr BasicBlock -> Ptr BasicBlock -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildResume" buildResume :: + Ptr Builder -> Ptr Value -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildUnreachable" buildUnreachable :: + Ptr Builder -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildCleanupRet" buildCleanupRet :: + Ptr Builder -> Ptr Value -> Ptr BasicBlock -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildCatchRet" buildCatchRet :: + Ptr Builder -> Ptr Value -> Ptr BasicBlock -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildCatchSwitch" buildCatchSwitch :: + Ptr Builder -> Ptr Value -> Ptr BasicBlock -> CUInt -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildAdd" buildAdd :: + Ptr Builder -> LLVMBool -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildMul" buildMul :: + Ptr Builder -> LLVMBool -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildShl" buildShl :: + Ptr Builder -> LLVMBool -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildSub" buildSub :: + Ptr Builder -> LLVMBool -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildUDiv" buildUDiv :: + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildSDiv" buildSDiv :: + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildLShr" buildLShr :: + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildAShr" buildAShr :: + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildAddrSpaceCast" buildAddrSpaceCast :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildBitCast" buildBitCast :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildFPExt" buildFPExt :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildFPToSI" buildFPToSI :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildFPToUI" buildFPToUI :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildFPTrunc" buildFPTrunc :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildIntToPtr" buildIntToPtr :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildPtrToInt" buildPtrToInt :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildSExt" buildSExt :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildSIToFP" buildSIToFP :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildTrunc" buildTrunc :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildUIToFP" buildUIToFP :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildZExt" buildZExt :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildAnd" buildAnd :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildOr" buildOr :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildSRem" buildSRem :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildURem" buildURem :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildXor" buildXor :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildFNeg" buildFNeg :: + Ptr Builder -> Ptr Value -> CString -> IO (Ptr UnaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildFAdd" buildFAdd :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildFDiv" buildFDiv :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildFMul" buildFMul :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildFRem" buildFRem :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVM_Hs_BuildFSub" buildFSub :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr BinaryOperator) + +foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca :: + Ptr Builder -> Ptr Type -> Ptr Value -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildLoad" buildLoad' :: + Ptr Builder -> LLVMBool -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) + +buildLoad :: Ptr Builder -> LLVMBool -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> CUInt -> CString -> IO (Ptr Instruction) +buildLoad builder vol a' (ss, mo) al s = buildLoad' builder vol a' mo ss al s + +foreign import ccall unsafe "LLVM_Hs_BuildStore" buildStore' :: + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) + +buildStore :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> CUInt -> CString -> IO (Ptr Instruction) +buildStore builder vol a' v' (ss, mo) al s = buildStore' builder vol a' v' mo ss al s + +foreign import ccall unsafe "LLVM_Hs_BuildGEP" buildGetElementPtr' :: + Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildInBoundsGEP" buildInBoundsGetElementPtr' :: + Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + +buildGetElementPtr :: HasCallStack => Ptr Builder -> LLVMBool -> Ptr Value -> (CUInt, Ptr (Ptr Value)) -> CString -> IO (Ptr Instruction) +buildGetElementPtr builder (LLVMBool 1) a (n, is) s = buildInBoundsGetElementPtr' builder a is n s +buildGetElementPtr builder (LLVMBool 0) a (n, is) s = buildGetElementPtr' builder a is n s +buildGetElementPtr _ (LLVMBool i) _ _ _ = error ("LLVMBool should be 0 or 1 but is " <> show i) + +foreign import ccall unsafe "LLVM_Hs_BuildFence" buildFence' :: + Ptr Builder -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) + +buildFence :: Ptr Builder -> (SynchronizationScope, MemoryOrdering) -> CString -> IO (Ptr Instruction) +buildFence builder (ss, mo) s = buildFence' builder mo ss s + +foreign import ccall unsafe "LLVM_Hs_BuildAtomicCmpXchg" buildCmpXchg' :: + Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> MemoryOrdering -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) + +buildCmpXchg :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> MemoryOrdering -> CString -> IO (Ptr Instruction) +buildCmpXchg builder vol a e r (ss, smo) fmo s = buildCmpXchg' builder vol a e r smo fmo ss s + +foreign import ccall unsafe "LLVM_Hs_BuildAtomicRMW" buildAtomicRMW' :: + Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) + +buildAtomicRMW :: Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> (SynchronizationScope, MemoryOrdering) -> CString -> IO (Ptr Instruction) +buildAtomicRMW builder vol rmwOp a v (ss, mo) s = buildAtomicRMW' builder vol rmwOp a v mo ss s + +foreign import ccall unsafe "LLVM_Hs_BuildICmp" buildICmp :: + Ptr Builder -> ICmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildFCmp" buildFCmp :: + Ptr Builder -> FCmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildPhi" buildPhi :: + Ptr Builder -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildCall" buildCall :: + Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildFreeze" buildFreeze :: + Ptr Builder -> Ptr Value -> Ptr Type -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildSelect" buildSelect :: + Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildVAArg" buildVAArg :: + Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildExtractElement" buildExtractElement :: + Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildInsertElement" buildInsertElement :: + Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildShuffleVector" buildShuffleVector :: + Ptr Builder -> Ptr Value -> Ptr Value -> Ptr CInt -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildExtractValue" buildExtractValue :: + Ptr Builder -> Ptr Value -> Ptr CUInt -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildInsertValue" buildInsertValue :: + Ptr Builder -> Ptr Value -> Ptr Value -> Ptr CUInt -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVMBuildLandingPad" buildLandingPad' :: + Ptr Builder -> Ptr Type -> Ptr Value -> CUInt -> CString -> IO (Ptr Instruction) + +-- | The personality should be set via the function +buildLandingPad :: Ptr Builder -> Ptr Type -> CUInt -> CString -> IO (Ptr Instruction) +buildLandingPad builder ty numClauses name = buildLandingPad' builder ty nullPtr numClauses name + +foreign import ccall unsafe "LLVM_Hs_BuildCleanupPad" buildCleanupPad :: + Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_BuildCatchPad" buildCatchPad :: + Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_SetFastMathFlags" setFastMathFlags :: + Ptr Builder -> FastMathFlags -> IO () diff --git a/src/LLVM/Internal/FFI/BuilderC.cpp b/src/LLVM/Internal/FFI/BuilderC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/BuilderC.cpp @@ -0,0 +1,476 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/IRBuilder.h" + +#include "llvm-c/Core.h" + +#include "LLVM/Internal/FFI/Instruction.h" + +using namespace llvm; + +namespace llvm { +static AtomicOrdering unwrap(LLVMAtomicOrdering l) { + switch(l) { + case LLVMAtomicOrderingNotAtomic: return AtomicOrdering::NotAtomic; + case LLVMAtomicOrderingUnordered: return AtomicOrdering::Unordered; + case LLVMAtomicOrderingMonotonic: return AtomicOrdering::Monotonic; + case LLVMAtomicOrderingAcquire: return AtomicOrdering::Acquire; + case LLVMAtomicOrderingRelease: return AtomicOrdering::Release; + case LLVMAtomicOrderingAcquireRelease: return AtomicOrdering::AcquireRelease; + case LLVMAtomicOrderingSequentiallyConsistent: return AtomicOrdering::SequentiallyConsistent; + //FIXME: this function should be total and no default should be required + default: return AtomicOrdering(0); + } +} + +static SyncScope::ID unwrap(LLVMSynchronizationScope l) { + switch(l) { + case LLVMSingleThreadSynchronizationScope: return SyncScope::SingleThread; + case LLVMSystemSynchronizationScope: return SyncScope::System; + //FIXME: this function should be total and no default should be required + default: return SyncScope::ID(0); + } +} + +static AtomicRMWInst::BinOp unwrap(LLVMAtomicRMWBinOp_ l) { + switch(l) { +#define ENUM_CASE(x) case LLVMAtomicRMWBinOp_ ## x: return AtomicRMWInst::x; +LLVM_HS_FOR_EACH_RMW_OPERATION(ENUM_CASE) +#undef ENUM_CASE + //FIXME: this function should be total and no default should be required + default: return AtomicRMWInst::BinOp(0); + } +} + +static FastMathFlags unwrap(LLVMFastMathFlags f) { + FastMathFlags r = FastMathFlags(); +#define ENUM_CASE_F(x,l) if (f & LLVM ## x) r.set ## x(); +#define ENUM_CASE_T(x,l) if (f & LLVM ## x) r.set ## x(true); +#define ENUM_CASE(x,l,takesArg) ENUM_CASE_ ## takesArg(x,l) +LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) +#undef ENUM_CASE + return r; +} + +} + +extern "C" { + +LLVMValueRef LLVM_Hs_BuildAdd( + LLVMBuilderRef b, + LLVMBool nsw, + LLVMBool nuw, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (nuw) { + return LLVMBuildNUWAdd(b, o0, o1, s); + } else if (nsw) { + return LLVMBuildNSWAdd(b, o0, o1, s); + } else { + return LLVMBuildAdd(b, o0, o1, s); + } +} + +LLVMValueRef LLVM_Hs_BuildMul( + LLVMBuilderRef b, + LLVMBool nsw, + LLVMBool nuw, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (nuw) { + return LLVMBuildNUWMul(b, o0, o1, s); + } else if (nsw) { + return LLVMBuildNSWMul(b, o0, o1, s); + } else { + return LLVMBuildMul(b, o0, o1, s); + } +} + +LLVMValueRef LLVM_Hs_BuildShl( + LLVMBuilderRef b, + LLVMBool nsw, + LLVMBool nuw, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + // TODO-LLVM-VERSION-INCREASE: Check C API coverage (has this functionality been added?) + // For some reason, the LLVM C API does not provide NUW/NSW constructors for Shl + BinaryOperator *BO = unwrap(b)->Insert(BinaryOperator::Create(Instruction::Shl, unwrap(o0), unwrap(o1)), s); + if (nuw) BO->setHasNoUnsignedWrap(); + if (nsw) BO->setHasNoSignedWrap(); + return wrap(BO); +} + +LLVMValueRef LLVM_Hs_BuildSub( + LLVMBuilderRef b, + LLVMBool nsw, + LLVMBool nuw, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (nuw) { + return LLVMBuildNUWSub(b, o0, o1, s); + } else if (nsw) { + return LLVMBuildNSWSub(b, o0, o1, s); + } else { + return LLVMBuildSub(b, o0, o1, s); + } +} + +LLVMValueRef LLVM_Hs_BuildUDiv( + LLVMBuilderRef b, + LLVMBool exact, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (!exact) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateUDiv(unwrap(o0), unwrap(o1)), s)); + } + return wrap(unwrap(b)->Insert(BinaryOperator::CreateExactUDiv(unwrap(o0), unwrap(o1)), s)); +} + +LLVMValueRef LLVM_Hs_BuildSDiv( + LLVMBuilderRef b, + LLVMBool exact, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (!exact) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateSDiv(unwrap(o0), unwrap(o1)), s)); + } + return wrap(unwrap(b)->Insert(BinaryOperator::CreateExactSDiv(unwrap(o0), unwrap(o1)), s)); +} + +LLVMValueRef LLVM_Hs_BuildLShr( + LLVMBuilderRef b, + LLVMBool exact, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (!exact) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateLShr(unwrap(o0), unwrap(o1)), s)); + } + return wrap(unwrap(b)->Insert(BinaryOperator::CreateExactLShr(unwrap(o0), unwrap(o1)), s)); +} + +LLVMValueRef LLVM_Hs_BuildAShr( + LLVMBuilderRef b, + LLVMBool exact, + LLVMValueRef o0, + LLVMValueRef o1, + const char *s +) { + if (!exact) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateAShr(unwrap(o0), unwrap(o1)), s)); + } + return wrap(unwrap(b)->Insert(BinaryOperator::CreateExactAShr(unwrap(o0), unwrap(o1)), s)); +} + +LLVMValueRef LLVM_Hs_BuildAddrSpaceCast(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::AddrSpaceCast, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildBitCast(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::BitCast, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildFPExt(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::FPExt, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildFPToSI(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::FPToSI, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildFPToUI(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::FPToUI, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildFPTrunc(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::FPTrunc, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildIntToPtr(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::IntToPtr, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildPtrToInt(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::PtrToInt, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildSExt(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::SExt, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildSIToFP(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::SIToFP, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildTrunc(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::Trunc, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildUIToFP(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::UIToFP, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildZExt(LLVMBuilderRef b, LLVMValueRef val, LLVMTypeRef destTy, const char *name) { + return wrap(unwrap(b)->Insert(CastInst::Create(Instruction::ZExt, unwrap(val), unwrap(destTy)), name)); +} + +LLVMValueRef LLVM_Hs_BuildAnd(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateAnd(unwrap(lhs), unwrap(rhs)), name)); +} + +LLVMValueRef LLVM_Hs_BuildOr(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateOr(unwrap(lhs), unwrap(rhs)), name)); +} + +LLVMValueRef LLVM_Hs_BuildSRem(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateSRem(unwrap(lhs), unwrap(rhs)), name)); +} + +LLVMValueRef LLVM_Hs_BuildURem(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateURem(unwrap(lhs), unwrap(rhs)), name)); +} + +LLVMValueRef LLVM_Hs_BuildXor(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + return wrap(unwrap(b)->Insert(BinaryOperator::CreateXor(unwrap(lhs), unwrap(rhs)), name)); +} + +LLVMValueRef LLVM_Hs_BuildFNeg(LLVMBuilderRef b, LLVMValueRef rhs, const char *name) { + return LLVMBuildFNeg(b, rhs, name); +} + +LLVMValueRef LLVM_Hs_BuildFAdd(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + BinaryOperator* bo = BinaryOperator::CreateFAdd(unwrap(lhs), unwrap(rhs)); + bo->setFastMathFlags(unwrap(b)->getFastMathFlags()); + return wrap(unwrap(b)->Insert(bo, name)); +} + +LLVMValueRef LLVM_Hs_BuildFDiv(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + BinaryOperator* bo = BinaryOperator::CreateFDiv(unwrap(lhs), unwrap(rhs)); + bo->setFastMathFlags(unwrap(b)->getFastMathFlags()); + return wrap(unwrap(b)->Insert(bo, name)); +} + +LLVMValueRef LLVM_Hs_BuildFMul(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + BinaryOperator* bo = BinaryOperator::CreateFMul(unwrap(lhs), unwrap(rhs)); + bo->setFastMathFlags(unwrap(b)->getFastMathFlags()); + return wrap(unwrap(b)->Insert(bo, name)); +} + +LLVMValueRef LLVM_Hs_BuildFRem(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + BinaryOperator* bo = BinaryOperator::CreateFRem(unwrap(lhs), unwrap(rhs)); + bo->setFastMathFlags(unwrap(b)->getFastMathFlags()); + return wrap(unwrap(b)->Insert(bo, name)); +} + +LLVMValueRef LLVM_Hs_BuildFSub(LLVMBuilderRef b, LLVMValueRef lhs, LLVMValueRef rhs, const char *name) { + BinaryOperator* bo = BinaryOperator::CreateFSub(unwrap(lhs), unwrap(rhs)); + bo->setFastMathFlags(unwrap(b)->getFastMathFlags()); + return wrap(unwrap(b)->Insert(bo, name)); +} + +void LLVM_Hs_SetFastMathFlags(LLVMBuilderRef b, LLVMFastMathFlags f) { + unwrap(b)->setFastMathFlags(unwrap(f)); +} + +LLVMValueRef LLVM_Hs_BuildICmp(LLVMBuilderRef b, LLVMIntPredicate op, LLVMValueRef lhs, LLVMValueRef rhs, const char* name) { + + return wrap(unwrap(b)->Insert(new ICmpInst(static_cast(op), + unwrap(lhs), unwrap(rhs)), name)); +} + +LLVMValueRef LLVM_Hs_BuildLoad( + LLVMBuilderRef b, + LLVMBool isVolatile, + LLVMValueRef p, + LLVMAtomicOrdering atomicOrdering, + LLVMSynchronizationScope synchScope, + unsigned align, + const char *name +) { + LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), MaybeAlign(align), isVolatile, name); + i->setOrdering(unwrap(atomicOrdering)); + if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); + return wrap(i); +} + +LLVMValueRef LLVM_Hs_BuildStore( + LLVMBuilderRef b, + LLVMBool isVolatile, + LLVMValueRef p, + LLVMValueRef v, + LLVMAtomicOrdering atomicOrdering, + LLVMSynchronizationScope synchScope, + unsigned align, + const char *name +) { + StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), MaybeAlign(align), isVolatile); + i->setName(name); + i->setOrdering(unwrap(atomicOrdering)); + if (atomicOrdering != LLVMAtomicOrderingNotAtomic) i->setSyncScopeID(unwrap(synchScope)); + return wrap(i); +} + +LLVMValueRef LLVM_Hs_BuildFence( + LLVMBuilderRef b, LLVMAtomicOrdering lao, LLVMSynchronizationScope lss, const char *name +) { + FenceInst *i = unwrap(b)->CreateFence(unwrap(lao), unwrap(lss)); + i->setName(name); + return wrap(i); +} + +LLVMValueRef LLVM_Hs_BuildAtomicCmpXchg( + LLVMBuilderRef b, + LLVMBool v, + LLVMValueRef ptr, + LLVMValueRef cmp, + LLVMValueRef n, + LLVMAtomicOrdering successOrdering, + LLVMAtomicOrdering failureOrdering, + LLVMSynchronizationScope lss, + const char *name +) { + AtomicCmpXchgInst *a = unwrap(b)->CreateAtomicCmpXchg( + unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(successOrdering), unwrap(failureOrdering), unwrap(lss) + ); + a->setVolatile(v); + a->setName(name); + return wrap(a); +} + +LLVMValueRef LLVM_Hs_BuildAtomicRMW( + LLVMBuilderRef b, + LLVMBool v, + LLVMAtomicRMWBinOp_ rmwOp, + LLVMValueRef ptr, + LLVMValueRef val, + LLVMAtomicOrdering lao, + LLVMSynchronizationScope lss, + const char *name +) { + AtomicRMWInst *a = unwrap(b)->CreateAtomicRMW( + unwrap(rmwOp), unwrap(ptr), unwrap(val), unwrap(lao), unwrap(lss) + ); + a->setVolatile(v); + a->setName(name); + return wrap(a); +} + +LLVMValueRef LLVM_Hs_BuildCleanupPad(LLVMBuilderRef b, LLVMValueRef parentPad, + LLVMValueRef *args, unsigned numArgs, + const char *name) { + return wrap(unwrap(b)->CreateCleanupPad(unwrap(parentPad), + makeArrayRef(unwrap(args), numArgs), + name)); +} + +LLVMValueRef LLVM_Hs_BuildCatchPad(LLVMBuilderRef b, LLVMValueRef catchSwitch, + LLVMValueRef *args, unsigned numArgs, + const char *name) { + return wrap(unwrap(b)->CreateCatchPad(unwrap(catchSwitch), + makeArrayRef(unwrap(args), numArgs), + name)); +} + +LLVMValueRef LLVM_Hs_BuildCleanupRet(LLVMBuilderRef b, LLVMValueRef cleanupPad, + LLVMBasicBlockRef unwindDest) { + // Due to the way name resolution works in llvm-hs, cleanupPad might not + // actually be a CleanupPadInst. However, it will later be replaced by one. + // Pretending that we have one is thus ok here. + auto cleanupPad_ = static_cast(unwrap(cleanupPad)); + return wrap(unwrap(b)->CreateCleanupRet(cleanupPad_, + unwrap(unwindDest))); +} + +LLVMValueRef LLVM_Hs_BuildCatchRet(LLVMBuilderRef b, LLVMValueRef catchPad, + LLVMBasicBlockRef successor) { + // Due to the way name resolution works in llvm-hs, catchPad might not + // actually be a CatchPadInst. However, it will later be replaced by one. + // Pretending that we have one is thus ok here. + auto catchPad_ = static_cast(unwrap(catchPad)); + return wrap(unwrap(b)->CreateCatchRet(catchPad_, unwrap(successor))); +} + +LLVMValueRef LLVM_Hs_BuildCatchSwitch(LLVMBuilderRef b, LLVMValueRef parentPad, + LLVMBasicBlockRef unwindDest, + unsigned numHandlers) { + return wrap(unwrap(b)->CreateCatchSwitch(unwrap(parentPad), + unwrap(unwindDest), numHandlers)); +} + +LLVMValueRef LLVM_Hs_BuildGEP(LLVMBuilderRef B, LLVMValueRef Pointer, + LLVMValueRef *Indices, unsigned NumIndices, + const char *Name) { + ArrayRef IdxList(unwrap(Indices), NumIndices); + return wrap(unwrap(B)->Insert(GetElementPtrInst::Create(nullptr, unwrap(Pointer), IdxList), Name)); +} + +LLVMValueRef LLVM_Hs_BuildInBoundsGEP(LLVMBuilderRef B, LLVMValueRef Pointer, + LLVMValueRef *Indices, unsigned NumIndices, + const char *Name) { + ArrayRef IdxList(unwrap(Indices), NumIndices); + return wrap(unwrap(B)->Insert(GetElementPtrInst::CreateInBounds(nullptr, unwrap(Pointer), IdxList), Name)); +} + +LLVMValueRef LLVM_Hs_BuildSelect(LLVMBuilderRef B, LLVMValueRef If, + LLVMValueRef Then, LLVMValueRef Else, + const char *Name) { + return wrap(unwrap(B)->Insert(SelectInst::Create(unwrap(If), unwrap(Then), unwrap(Else)))); +} + +LLVMValueRef LLVM_Hs_BuildExtractValue( + LLVMBuilderRef b, + LLVMValueRef a, + unsigned *idxs, + unsigned n, + const char *name +) { + return wrap(unwrap(b)->Insert(ExtractValueInst::Create(unwrap(a), ArrayRef(idxs, n)), name)); +} + +LLVMValueRef LLVM_Hs_BuildInsertValue( + LLVMBuilderRef b, + LLVMValueRef a, + LLVMValueRef v, + unsigned *idxs, + unsigned n, + const char *name +) { + return wrap(unwrap(b)->Insert(InsertValueInst::Create(unwrap(a), unwrap(v), ArrayRef(idxs, n)), name)); +} + +LLVMValueRef LLVM_Hs_BuildExtractElement(LLVMBuilderRef B, LLVMValueRef VecVal, + LLVMValueRef Index, const char *Name) { + return wrap(unwrap(B)->Insert(ExtractElementInst::Create(unwrap(VecVal), unwrap(Index)), + Name)); +} + +LLVMValueRef LLVM_Hs_BuildInsertElement(LLVMBuilderRef B, LLVMValueRef VecVal, + LLVMValueRef EltVal, LLVMValueRef Index, + const char *Name) { + return wrap(unwrap(B)->Insert(InsertElementInst::Create(unwrap(VecVal), unwrap(EltVal), + unwrap(Index)), + Name)); +} + +LLVMValueRef LLVM_Hs_BuildShuffleVector(LLVMBuilderRef B, LLVMValueRef V1, + LLVMValueRef V2, int *MaskArgs, + unsigned MaskSize, const char *Name) { + ArrayRef maskArray(MaskArgs, MaskSize); + return wrap(unwrap(B)->Insert(new ShuffleVectorInst(unwrap(V1), unwrap(V2), + maskArray), + Name)); +} +} diff --git a/src/LLVM/Internal/FFI/ByteRangeCallback.hs b/src/LLVM/Internal/FFI/ByteRangeCallback.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ByteRangeCallback.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.ByteRangeCallback where + +import LLVM.Prelude + +import Foreign.C +import Foreign.Ptr + +type ByteRangeCallback = Ptr CChar -> CSize -> IO () +foreign import ccall "wrapper" wrapByteRangeCallback :: + ByteRangeCallback -> IO (FunPtr ByteRangeCallback) + diff --git a/src/LLVM/Internal/FFI/CallingConvention.h b/src/LLVM/Internal/FFI/CallingConvention.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/CallingConvention.h @@ -0,0 +1,52 @@ +#ifndef __LLVM_INTERNAL_FFI__CALLING_CONVENTION__H__ +#define __LLVM_INTERNAL_FFI__CALLING_CONVENTION__H__ + +#define LLVM_HS_FOR_EACH_CALLING_CONVENTION(macro) \ + macro(C, 0) \ + macro(Fast, 8) \ + macro(Cold, 9) \ + macro(GHC, 10) \ + macro(HiPE, 11) \ + macro(WebKit_JS, 12) \ + macro(AnyReg, 13) \ + macro(PreserveMost, 14) \ + macro(PreserveAll, 15) \ + macro(Swift, 16) \ + macro(CXX_FAST_TLS, 17) \ + macro(X86_StdCall, 64) \ + macro(X86_FastCall, 65) \ + macro(ARM_APCS, 66) \ + macro(ARM_AAPCS, 67) \ + macro(ARM_AAPCS_VFP, 68) \ + macro(MSP430_INTR, 69) \ + macro(X86_ThisCall, 70) \ + macro(PTX_Kernel, 71) \ + macro(PTX_Device, 72) \ + macro(SPIR_FUNC, 75) \ + macro(SPIR_KERNEL, 76) \ + macro(Intel_OCL_BI, 77) \ + macro(X86_64_SysV, 78) \ + macro(Win64, 79) \ + macro(X86_VectorCall, 80) \ + macro(HHVM, 81) \ + macro(HHVM_C, 82) \ + macro(X86_INTR, 83) \ + macro(AVR_INTR, 84) \ + macro(AVR_SIGNAL, 85) \ + macro(AVR_BUILTIN, 86) \ + macro(AMDGPU_VS, 87) \ + macro(AMDGPU_GS, 88) \ + macro(AMDGPU_PS, 89) \ + macro(AMDGPU_CS, 90) \ + macro(AMDGPU_KERNEL, 91) \ + macro(X86_RegCall, 92) \ + macro(AMDGPU_HS, 93) \ + macro(MSP430_BUILTIN, 94) + +typedef enum { +#define ENUM_CASE(l,n) LLVM_Hs_CallingConvention_ ## l = n, + LLVM_HS_FOR_EACH_CALLING_CONVENTION(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_CallingConvention; + +#endif diff --git a/src/LLVM/Internal/FFI/CallingConventionC.cpp b/src/LLVM/Internal/FFI/CallingConventionC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/CallingConventionC.cpp @@ -0,0 +1,10 @@ +#include "LLVM/Internal/FFI/CallingConvention.h" +#include "llvm/IR/CallingConv.h" + +#define CHECK(l, n) \ + static_assert(unsigned(llvm::CallingConv::l) == \ + unsigned(LLVM_Hs_CallingConvention_##l), \ + "LLVM_Hs_CallingConvention enum out of sync w/ " \ + "llvm::CallingConv::ID for " #l); +LLVM_HS_FOR_EACH_CALLING_CONVENTION(CHECK) +#undef CHECK diff --git a/src/LLVM/Internal/FFI/Cleanup.hs b/src/LLVM/Internal/FFI/Cleanup.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Cleanup.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE + TemplateHaskell + #-} +module LLVM.Internal.FFI.Cleanup where + +import LLVM.Prelude + +import Language.Haskell.TH +import Data.Sequence as Seq + +import Foreign.C +import Foreign.Ptr + +import LLVM.Internal.FFI.LLVMCTypes +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI + +import qualified LLVM.AST.IntegerPredicate as A (IntegerPredicate) +import qualified LLVM.AST.FloatingPointPredicate as A (FloatingPointPredicate) +import qualified LLVM.AST.Constant as A.C (Constant) +import qualified LLVM.AST.Operand as A (Operand) +import qualified LLVM.AST.Type as A (Type) +import qualified LLVM.AST.Instruction as A (FastMathFlags) + +foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ +foreignDecl cName hName argTypeQs returnTypeQ = do + let retTyQ = appT (conT ''IO) returnTypeQ + foreignDecl' hName argTypeQs = + forImpD cCall unsafe cName (mkName hName) + (foldr (\a b -> appT (appT arrowT a) b) retTyQ argTypeQs) + splitTuples :: [Type] -> Q ([Type], [Pat], [Exp]) + splitTuples ts = do + let f :: Type -> Q (Seq Type, Pat, Seq Exp) + f x@(AppT _ _) = maybe (d x) (\q -> q >>= \(ts, ps, es) -> return (ts, TupP (toList ps), es)) (g 0 x) + f x = d x + g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp)) + g n (TupleT m) | m == n = return (return (Seq.empty, Seq.empty, Seq.empty)) + g n (AppT a b) = do + k <- g (n+1) a + return $ do + (ts, ps, es) <- k + (ts', p', es') <- f b + return (ts >< ts', ps |> p', es >< es') + g _ _ = Nothing + d :: Type -> Q (Seq Type, Pat, Seq Exp) + d x = do + n <- newName "v" + return (Seq.singleton x, VarP n, Seq.singleton (VarE n)) + seqsToList :: [Seq a] -> [a] + seqsToList = toList . foldr (><) Seq.empty + + (tss, ps, ess) <- liftM unzip3 . mapM f $ ts + return (seqsToList tss, ps, seqsToList ess) + + + argTypes <- sequence argTypeQs + (ts, ps, es) <- splitTuples argTypes + let phName = hName ++ "'" + sequence [ + foreignDecl' phName (map return ts), + sigD (mkName hName) (foldr (\argT retT -> appT (appT arrowT argT) retT) retTyQ argTypeQs), + funD (mkName hName) [ + clause (map return ps) (normalB (foldl appE (varE (mkName phName)) (map return es))) [] + ] + ] + +-- | The LLVM C-API for instructions with boolean flags (e.g. nsw) and is weak, so they get +-- separated out for different handling. This check is an accurate but crude test for whether +-- an instruction needs such handling. +hasFlags :: [Type] -> Bool +hasFlags = any (== ConT ''Bool) + +typeMapping :: Type -> TypeQ +typeMapping t = case t of + ConT h | h == ''Bool -> [t| LLVMBool |] + | h == ''Int32 -> [t| CInt |] + | h == ''Word32 -> [t| CUInt |] + | h == ''String -> [t| CString |] + | h == ''A.Operand -> [t| Ptr FFI.Value |] + | h == ''A.Type -> [t| Ptr FFI.Type |] + | h == ''A.C.Constant -> [t| Ptr FFI.Constant |] + | h == ''A.FloatingPointPredicate -> [t| FCmpPredicate |] + | h == ''A.IntegerPredicate -> [t| ICmpPredicate |] + | h == ''A.FastMathFlags -> [t| FastMathFlags |] + AppT ListT x -> foldl1 appT [tupleT 2, [t| CUInt |], appT [t| Ptr |] (typeMapping x)] + x -> error $ "type not handled in Cleanup typeMapping: " ++ show x diff --git a/src/LLVM/Internal/FFI/CommandLine.hs b/src/LLVM/Internal/FFI/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/CommandLine.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.CommandLine where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +foreign import ccall unsafe "LLVM_Hs_ParseCommandLineOptions" parseCommandLineOptions' :: + CUInt -> Ptr (Ptr CChar) -> Ptr CChar -> IO () + +parseCommandLineOptions :: (CUInt, Ptr (Ptr CChar)) -> Ptr CChar -> IO () +parseCommandLineOptions = uncurry parseCommandLineOptions' diff --git a/src/LLVM/Internal/FFI/CommandLineC.cpp b/src/LLVM/Internal/FFI/CommandLineC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/CommandLineC.cpp @@ -0,0 +1,12 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/Support/CommandLine.h" + +using namespace llvm; + +extern "C" { + +void LLVM_Hs_ParseCommandLineOptions(unsigned argc, const char * const *argv, const char *overview) { + cl::ParseCommandLineOptions(argc, argv, overview); +} + +} diff --git a/src/LLVM/Internal/FFI/Constant.h b/src/LLVM/Internal/FFI/Constant.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Constant.h @@ -0,0 +1,20 @@ +#ifndef __LLVM_INTERNAL_FFI__CONSTANT__H__ +#define __LLVM_INTERNAL_FFI__CONSTANT__H__ + +#define LLVM_HS_FOR_EACH_FLOAT_SEMANTICS(macro) \ + macro(IEEEhalf) \ + macro(IEEEsingle) \ + macro(IEEEdouble) \ + macro(IEEEquad) \ + macro(PPCDoubleDouble) \ + macro(x87DoubleExtended) \ + macro(Bogus) + +typedef enum { +#define ENUM_CASE(x) LLVMFloatSemantics ## x, +LLVM_HS_FOR_EACH_FLOAT_SEMANTICS(ENUM_CASE) +#undef ENUM_CASE +} LLVMFloatSemantics; + + +#endif diff --git a/src/LLVM/Internal/FFI/Constant.hs b/src/LLVM/Internal/FFI/Constant.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Constant.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE + TemplateHaskell, + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances, + ViewPatterns + #-} +-- | FFI functions for handling the LLVM Constant class +module LLVM.Internal.FFI.Constant where + +import LLVM.Prelude + +import qualified Language.Haskell.TH as TH +import qualified LLVM.Internal.InstructionDefs as ID + +import qualified Data.Map as Map + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.Cleanup +import LLVM.Internal.FFI.LLVMCTypes + +foreign import ccall unsafe "LLVMIsConstant" isConstant :: + Ptr Value -> IO (CUInt) + +foreign import ccall unsafe "LLVMIsAConstant" isAConstant :: + Ptr Value -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMIsAConstantInt" isAConstantInt :: + Ptr Value -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMGetOperand" getConstantOperand :: + Ptr Constant -> CUInt -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMIsAConstantPointerNull" isAConstantPointerNull :: + Ptr Value -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_Hs_GetConstantIntWords" getConstantIntWords :: + Ptr Constant -> Ptr CUInt -> IO (Ptr Word64) + +foreign import ccall unsafe "LLVM_Hs_ConstFloatDoubleValue" constFloatDoubleValue :: + Ptr Constant -> IO CDouble + +foreign import ccall unsafe "LLVM_Hs_ConstFloatFloatValue" constFloatFloatValue :: + Ptr Constant -> IO CFloat + +foreign import ccall unsafe "LLVMConstStructInContext" constStructInContext' :: + Ptr Context -> Ptr (Ptr Constant) -> CUInt -> LLVMBool -> IO (Ptr Constant) + +constStructInContext :: Ptr Context -> (CUInt, Ptr (Ptr Constant)) -> LLVMBool -> IO (Ptr Constant) +constStructInContext ctx (n, cs) p = constStructInContext' ctx cs n p + +foreign import ccall unsafe "LLVMConstNamedStruct" constNamedStruct' :: + Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) + +constNamedStruct :: Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) +constNamedStruct ty (n, cs) = constNamedStruct' ty cs n + +foreign import ccall unsafe "LLVM_Hs_GetConstantDataSequentialElementAsConstant" getConstantDataSequentialElementAsConstant :: + Ptr Constant -> CUInt -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMConstIntOfArbitraryPrecision" constantIntOfArbitraryPrecision' :: + Ptr Type -> CUInt -> Ptr Word64 -> IO (Ptr Constant) + +constantIntOfArbitraryPrecision :: Ptr Type -> (CUInt, Ptr Word64) -> IO (Ptr Constant) +constantIntOfArbitraryPrecision t = uncurry (constantIntOfArbitraryPrecision' t) + +foreign import ccall unsafe "LLVM_Hs_ConstFloatOfArbitraryPrecision" constantFloatOfArbitraryPrecision :: + Ptr Context -> CUInt -> Ptr Word64 -> FloatSemantics -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_Hs_GetConstantFloatWords" getConstantFloatWords :: + Ptr Constant -> Ptr Word64 -> IO () + +foreign import ccall unsafe "LLVMConstVector" constantVector' :: + Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) + +constantVector :: (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) +constantVector (n, cs) = constantVector' cs n + +foreign import ccall unsafe "LLVMConstNull" constantNull :: + Ptr Type -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMConstArray" constantArray' :: + Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) + +constantArray :: Ptr Type -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) +constantArray t (n, cs) = constantArray' t cs n + +foreign import ccall unsafe "LLVM_Hs_ConstCast" constantCast :: + CPPOpcode -> Ptr Constant -> Ptr Type -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_Hs_ConstBinaryOperator" constantBinaryOperator :: + CPPOpcode -> Ptr Constant -> Ptr Constant -> IO (Ptr Constant) + +$(do + let constExprInfo = ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs + liftM concat $ sequence $ do + (name, ((TH.RecC _ (unzip3 -> (_, _, fieldTypes)),_), ID.InstructionDef { ID.instructionKind = ik })) <- Map.toList constExprInfo + prefix <- case ik of + ID.Other -> return "LLVM" + ID.Binary | hasFlags fieldTypes -> return "LLVM_Hs_" + _ -> [] + return $ + foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) (map typeMapping fieldTypes) [t| Ptr Constant |] + ) + +foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' :: + Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMConstInBoundsGEP" constantInBoundsGetElementPtr' :: + Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant) + +constantGetElementPtr :: LLVMBool -> Ptr Constant -> (CUInt, Ptr (Ptr Constant)) -> IO (Ptr Constant) +constantGetElementPtr (LLVMBool ib) a (n, is) = + (case ib of + 0 -> constantGetElementPtr' + 1 -> constantInBoundsGetElementPtr' + _ -> error ("LLVMBool should be 0 or 1 but is " <> show ib) + ) a is n + +foreign import ccall unsafe "LLVM_Hs_GetConstCPPOpcode" getConstantCPPOpcode :: + Ptr Constant -> IO CPPOpcode + +foreign import ccall unsafe "LLVM_Hs_GetConstPredicate" getConstantICmpPredicate :: + Ptr Constant -> IO ICmpPredicate + +foreign import ccall unsafe "LLVM_Hs_GetConstPredicate" getConstantFCmpPredicate :: + Ptr Constant -> IO FCmpPredicate + +foreign import ccall unsafe "LLVM_Hs_GetConstIndices" getConstantIndices :: + Ptr Constant -> Ptr CUInt -> IO (Ptr CUInt) + +foreign import ccall unsafe "LLVMGetUndef" constantUndef :: + Ptr Type -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMBlockAddress" blockAddress :: + Ptr Value -> Ptr BasicBlock -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_Hs_GetBlockAddressFunction" getBlockAddressFunction :: + Ptr Constant -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_GetBlockAddressBlock" getBlockAddressBlock :: + Ptr Constant -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVM_Hs_GetConstTokenNone" getConstTokenNone :: + Ptr Context -> IO (Ptr Constant) diff --git a/src/LLVM/Internal/FFI/ConstantC.cpp b/src/LLVM/Internal/FFI/ConstantC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ConstantC.cpp @@ -0,0 +1,131 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/Constants.h" +#include "llvm/IR/Function.h" + +#include "llvm-c/Core.h" +#include "LLVM/Internal/FFI/Value.h" +#include "LLVM/Internal/FFI/Constant.h" + +using namespace llvm; + +namespace llvm { + +static const struct fltSemantics &unwrap(LLVMFloatSemantics s) { + switch(s) { +#define ENUM_CASE(x) case LLVMFloatSemantics ## x: return APFloat::x(); +LLVM_HS_FOR_EACH_FLOAT_SEMANTICS(ENUM_CASE) +#undef ENUM_CASE + default: return APFloat::Bogus(); + } +} + +} + +extern "C" { + +LLVMValueRef LLVM_Hs_GetConstantDataSequentialElementAsConstant(LLVMValueRef v, unsigned i) { + return wrap(unwrap(v)->getElementAsConstant(i)); +} + +LLVMValueRef LLVM_Hs_GetBlockAddressFunction(LLVMValueRef v) { + return wrap(unwrap(v)->getFunction()); +} + +LLVMBasicBlockRef LLVM_Hs_GetBlockAddressBlock(LLVMValueRef v) { + return wrap(unwrap(v)->getBasicBlock()); +} + +double LLVM_Hs_ConstFloatDoubleValue(LLVMValueRef v) { + return unwrap(v)->getValueAPF().convertToDouble(); +} + +float LLVM_Hs_ConstFloatFloatValue(LLVMValueRef v) { + return unwrap(v)->getValueAPF().convertToFloat(); +} + +LLVMValueRef LLVM_Hs_ConstCast(unsigned opcode, LLVMValueRef v, LLVMTypeRef t) { + return wrap(ConstantExpr::getCast(opcode, unwrap(v), unwrap(t))); +} + +LLVMValueRef LLVM_Hs_ConstBinaryOperator(unsigned opcode, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::get(opcode, unwrap(o0), unwrap(o1))); +} + +LLVMValueRef LLVM_Hs_ConstAdd(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getAdd(unwrap(o0), unwrap(o1), nuw != 0, nsw != 0)); +} + +LLVMValueRef LLVM_Hs_ConstMul(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getMul(unwrap(o0), unwrap(o1), nuw != 0, nsw != 0)); +} + +LLVMValueRef LLVM_Hs_ConstShl(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getShl(unwrap(o0), unwrap(o1), nuw != 0, nsw != 0)); +} + +LLVMValueRef LLVM_Hs_ConstSub(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getSub(unwrap(o0), unwrap(o1), nuw != 0, nsw != 0)); +} + +LLVMValueRef LLVM_Hs_ConstUDiv(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getUDiv(unwrap(o0), unwrap(o1), isExact != 0)); +} + +LLVMValueRef LLVM_Hs_ConstSDiv(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getSDiv(unwrap(o0), unwrap(o1), isExact != 0)); +} + +LLVMValueRef LLVM_Hs_ConstLShr(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getLShr(unwrap(o0), unwrap(o1), isExact != 0)); +} + +LLVMValueRef LLVM_Hs_ConstAShr(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { + return wrap(ConstantExpr::getAShr(unwrap(o0), unwrap(o1), isExact != 0)); +} + +unsigned LLVM_Hs_GetConstCPPOpcode(LLVMValueRef v) { + return unwrap(v)->getOpcode(); +} + +unsigned LLVM_Hs_GetConstPredicate(LLVMValueRef v) { + return unwrap(v)->getPredicate(); +} + +const unsigned *LLVM_Hs_GetConstIndices(LLVMValueRef v, unsigned *n) { + ArrayRef r = unwrap(v)->getIndices(); + *n = r.size(); + return r.data(); +} + +const uint64_t *LLVM_Hs_GetConstantIntWords(LLVMValueRef v, unsigned *n) { + const APInt &i = unwrap(v)->getValue(); + *n = i.getNumWords(); + return i.getRawData(); +} + +LLVMValueRef LLVM_Hs_ConstFloatOfArbitraryPrecision( + LLVMContextRef c, + unsigned bits, + const uint64_t *words, + LLVMFloatSemantics semantics +) { + return wrap( + ConstantFP::get( + *unwrap(c), + APFloat(unwrap(semantics), APInt(bits, ArrayRef(words, (bits-1)/64 + 1))) + ) + ); +} + +void LLVM_Hs_GetConstantFloatWords(LLVMValueRef v, uint64_t *bits) { + APInt a = unwrap(v)->getValueAPF().bitcastToAPInt(); + for(unsigned i=0; i != a.getNumWords(); ++i) bits[i] = a.getRawData()[i]; +} + +LLVMValueRef LLVM_Hs_GetConstTokenNone(LLVMContextRef context) { + return wrap(ConstantTokenNone::get(*unwrap(context))); +} + + +} diff --git a/src/LLVM/Internal/FFI/Context.hs b/src/LLVM/Internal/FFI/Context.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Context.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} + +-- | Functions for handling the LLVMContext class. In all other LLVM interfaces, +-- | prefer the newer explicitly thread-aware variants which use contexts +-- | over corresponding older variants which implicitly reference a global context. +-- | This choice allows multiple threads to do independent work with LLVM safely. +module LLVM.Internal.FFI.Context where + +import LLVM.Prelude + +import Foreign.Ptr + +-- | a blind type to correspond to LLVMContext +data Context + +-- | +foreign import ccall unsafe "LLVMContextCreate" contextCreate :: + IO (Ptr Context) + +-- | +foreign import ccall unsafe "LLVMGetGlobalContext" getGlobalContext :: + IO (Ptr Context) + +-- | +foreign import ccall unsafe "LLVMContextDispose" contextDispose :: + Ptr Context -> IO () diff --git a/src/LLVM/Internal/FFI/DataLayout.hs b/src/LLVM/Internal/FFI/DataLayout.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/DataLayout.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} + +module LLVM.Internal.FFI.DataLayout where + +import LLVM.Prelude + +import Foreign.C +import Foreign.Ptr + +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy + +data DataLayout + +-- Oooh those wacky LLVM C-API coders: C API called DataLayout TargetData. +-- Great. Just great. + +foreign import ccall unsafe "LLVMCreateTargetData" createDataLayout :: + CString -> IO (Ptr DataLayout) + +foreign import ccall unsafe "LLVMDisposeTargetData" disposeDataLayout :: + Ptr DataLayout -> IO () + +foreign import ccall unsafe "LLVMCopyStringRepOfTargetData" dataLayoutToString :: + Ptr DataLayout -> IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVMABISizeOfType" getTypeAllocSize :: + Ptr DataLayout -> Ptr Type -> IO Word64 + +foreign import ccall unsafe "LLVMOffsetOfElement" getOffsetOfElement :: + Ptr DataLayout -> Ptr Type -> CUInt -> IO Word64 diff --git a/src/LLVM/Internal/FFI/DynamicLibrary.hs b/src/LLVM/Internal/FFI/DynamicLibrary.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/DynamicLibrary.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | FFI functions for handling the DynamicLibrary class +module LLVM.Internal.FFI.DynamicLibrary where + +import LLVM.Prelude + +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes + +-- | +foreign import ccall safe "LLVMLoadLibraryPermanently" loadLibraryPermanently :: + CString -> IO LLVMBool diff --git a/src/LLVM/Internal/FFI/ErrorHandling.cpp b/src/LLVM/Internal/FFI/ErrorHandling.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ErrorHandling.cpp @@ -0,0 +1,9 @@ +#include "LLVM/Internal/FFI/ErrorHandling.hpp" +#include +#include + +void reportFatalError(const std::string &errorMsg) { + std::cerr << "LLVM-HS ERROR at " << __FILE__ << ":" << __LINE__ << ": " + << errorMsg << "\n "; + exit(1); +} diff --git a/src/LLVM/Internal/FFI/ErrorHandling.hpp b/src/LLVM/Internal/FFI/ErrorHandling.hpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ErrorHandling.hpp @@ -0,0 +1,7 @@ +#ifndef __LLVM_INTERNAL_FFI__ERRORHANDLING__H__ +#define __LLVM_INTERNAL_FFI__ERRORHANDLING__H__ +#include + +[[noreturn]] void reportFatalError(const std::string &errorMsg); + +#endif diff --git a/src/LLVM/Internal/FFI/ExecutionEngine.hs b/src/LLVM/Internal/FFI/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ExecutionEngine.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} + +module LLVM.Internal.FFI.ExecutionEngine where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.Module +import LLVM.Internal.FFI.LLVMCTypes + +data ExecutionEngine + +foreign import ccall unsafe "LLVMCreateExecutionEngineForModule" createExecutionEngineForModule :: + Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr (OwnerTransfered CString) -> IO CUInt + +foreign import ccall unsafe "LLVMCreateInterpreterForModule" createInterpreterForModule :: + Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr (OwnerTransfered CString) -> IO CUInt + +foreign import ccall unsafe "LLVMCreateJITCompilerForModule" createJITCompilerForModule :: + Ptr (Ptr ExecutionEngine) -> Ptr Module -> CUInt -> Ptr (OwnerTransfered CString) -> IO CUInt + +foreign import ccall unsafe "LLVMCreateMCJITCompilerForModule" createMCJITCompilerForModule :: + Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr MCJITCompilerOptions -> CSize -> Ptr (OwnerTransfered CString) -> IO CUInt + +foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine :: + Ptr ExecutionEngine -> IO () + +foreign import ccall unsafe "LLVMAddModule" addModule :: + Ptr ExecutionEngine -> Ptr Module -> IO () + +foreign import ccall unsafe "LLVMRemoveModule" removeModule :: + Ptr ExecutionEngine -> Ptr Module -> Ptr (Ptr Module) -> Ptr CString -> IO CUInt + +foreign import ccall unsafe "LLVMFindFunction" findFunction :: + Ptr ExecutionEngine -> CString -> Ptr (Ptr Function) -> IO CUInt + +foreign import ccall unsafe "LLVMGetPointerToGlobal" getPointerToGlobal :: + Ptr ExecutionEngine -> Ptr GlobalValue -> IO (Ptr ()) + +foreign import ccall unsafe "LLVMLinkInInterpreter" linkInInterpreter :: + IO () + +foreign import ccall unsafe "LLVMLinkInMCJIT" linkInMCJIT :: + IO () + +data MCJITCompilerOptions + +foreign import ccall unsafe "LLVM_Hs_GetMCJITCompilerOptionsSize" getMCJITCompilerOptionsSize :: + IO CSize + +foreign import ccall unsafe "LLVMInitializeMCJITCompilerOptions" initializeMCJITCompilerOptions :: + Ptr MCJITCompilerOptions -> CSize -> IO () + +foreign import ccall unsafe "LLVM_Hs_SetMCJITCompilerOptionsOptLevel" setMCJITCompilerOptionsOptLevel :: + Ptr MCJITCompilerOptions -> CUInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_SetMCJITCompilerOptionsCodeModel" setMCJITCompilerOptionsCodeModel :: + Ptr MCJITCompilerOptions -> CodeModel -> IO () + +foreign import ccall unsafe "LLVM_Hs_SetMCJITCompilerOptionsNoFramePointerElim" setMCJITCompilerOptionsNoFramePointerElim :: + Ptr MCJITCompilerOptions -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVM_Hs_SetMCJITCompilerOptionsEnableFastISel" setMCJITCompilerOptionsEnableFastISel :: + Ptr MCJITCompilerOptions -> LLVMBool -> IO () + + diff --git a/src/LLVM/Internal/FFI/ExecutionEngineC.cpp b/src/LLVM/Internal/FFI/ExecutionEngineC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ExecutionEngineC.cpp @@ -0,0 +1,30 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "llvm-c/ExecutionEngine.h" + +using namespace llvm; + +extern "C" { + +size_t LLVM_Hs_GetMCJITCompilerOptionsSize() { + return sizeof(struct LLVMMCJITCompilerOptions); +} + +void LLVM_Hs_SetMCJITCompilerOptionsOptLevel(struct LLVMMCJITCompilerOptions *o, unsigned x) { + o->OptLevel = x; +} + +void LLVM_Hs_SetMCJITCompilerOptionsCodeModel(struct LLVMMCJITCompilerOptions *o, LLVMCodeModel x) { + o->CodeModel = x; +} + +void LLVM_Hs_SetMCJITCompilerOptionsNoFramePointerElim(struct LLVMMCJITCompilerOptions *o, LLVMBool x) { + o->NoFramePointerElim = x; +} + +void LLVM_Hs_SetMCJITCompilerOptionsEnableFastISel(struct LLVMMCJITCompilerOptions *o, LLVMBool x) { + o->EnableFastISel = x; +} + +} + diff --git a/src/LLVM/Internal/FFI/Function.hs b/src/LLVM/Internal/FFI/Function.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Function.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses + #-} + +module LLVM.Internal.FFI.Function where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.Attribute +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy + +foreign import ccall unsafe "LLVMGetFunctionCallConv" getFunctionCallingConvention :: + Ptr Function -> IO CallingConvention + +foreign import ccall unsafe "LLVMSetFunctionCallConv" setFunctionCallingConvention :: + Ptr Function -> CallingConvention -> IO () + +foreign import ccall unsafe "LLVM_Hs_SetFunctionAttributeList" setAttributeList :: + Ptr Function -> AttributeList -> IO () + +foreign import ccall unsafe "LLVM_Hs_FunctionAttributesAtIndex" attributesAtIndex :: + Ptr Function -> AttributeIndex -> IO (AttributeSet b) + +foreign import ccall unsafe "LLVMGetFirstBasicBlock" getFirstBasicBlock :: + Ptr Function -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVMGetLastBasicBlock" getLastBasicBlock :: + Ptr Function -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVMGetNextBasicBlock" getNextBasicBlock :: + Ptr BasicBlock -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVMAppendBasicBlockInContext" appendBasicBlockInContext :: + Ptr Context -> Ptr Function -> CString -> IO (Ptr BasicBlock) + + +foreign import ccall unsafe "LLVMCountParams" countParams :: + Ptr Function -> IO CUInt + +foreign import ccall unsafe "LLVMGetParams" getParams :: + Ptr Function -> Ptr (Ptr Parameter) -> IO () + +foreign import ccall unsafe "LLVMGetGC" getGC :: + Ptr Function -> IO CString + +foreign import ccall unsafe "LLVMSetGC" setGC :: + Ptr Function -> CString -> IO () + + +foreign import ccall unsafe "LLVM_Hs_HasFunctionPrefixData" hasPrefixData :: + Ptr Function -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_GetFunctionPrefixData" getPrefixData :: + Ptr Function -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_Hs_SetFunctionPrefixData" setPrefixData :: + Ptr Function -> Ptr Constant -> IO () + +foreign import ccall unsafe "LLVMHasPersonalityFn" hasPersonalityFn :: + Ptr Function -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_SetPersonalityFn" setPersonalityFn :: + Ptr Function -> Ptr Constant -> IO () + +foreign import ccall unsafe "LLVMGetPersonalityFn" getPersonalityFn :: + Ptr Function -> IO (Ptr Constant) diff --git a/src/LLVM/Internal/FFI/FunctionC.cpp b/src/LLVM/Internal/FFI/FunctionC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/FunctionC.cpp @@ -0,0 +1,42 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/Attributes.h" +#include "llvm/IR/Function.h" +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/Value.h" + +#include "LLVM/Internal/FFI/AttributeC.hpp" +#include "llvm-c/Core.h" + +using namespace llvm; + +extern "C" { +void LLVM_Hs_SetFunctionAttributeList(LLVMValueRef f, + LLVMAttributeListRef attrs) { + unwrap(f)->setAttributes(*attrs); +} + +LLVMBool LLVM_Hs_HasFunctionPrefixData(LLVMValueRef f) { + return unwrap(f)->hasPrefixData(); +} + +LLVMValueRef LLVM_Hs_GetFunctionPrefixData(LLVMValueRef f) { + return wrap(unwrap(f)->getPrefixData()); +} + +void LLVM_Hs_SetFunctionPrefixData(LLVMValueRef f, LLVMValueRef p) { + unwrap(f)->setPrefixData(unwrap(p)); +} + +// This wrapper is necessary because LLVMSetPersonalityFn fails if +// personalityFn is a nullptr even though the C++ API allows that. +void LLVM_Hs_SetPersonalityFn(LLVMValueRef fn, LLVMValueRef personalityFn) { + unwrap(fn)->setPersonalityFn( + personalityFn == nullptr ? nullptr : unwrap(personalityFn)); +} + +LLVMAttributeSetRef LLVM_Hs_FunctionAttributesAtIndex(LLVMValueRef fn, + LLVMAttributeIndex idx) { + return new AttributeSet( + unwrap(fn)->getAttributes().getAttributes(idx)); +} +} diff --git a/src/LLVM/Internal/FFI/GlobalAlias.hs b/src/LLVM/Internal/FFI/GlobalAlias.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/GlobalAlias.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances + #-} +-- | FFI functions for handling the LLVM GlobalAlias class +module LLVM.Internal.FFI.GlobalAlias where + +import LLVM.Prelude + +import Foreign.Ptr + +import LLVM.Internal.FFI.PtrHierarchy + +-- | test if a 'Value' is a 'GlobalAlias' +foreign import ccall unsafe "LLVMIsAGlobalAlias" isAGlobalAlias :: + Ptr Value -> IO (Ptr GlobalAlias) + +-- | get the constant aliased by this alias +foreign import ccall unsafe "LLVM_Hs_GetAliasee" getAliasee :: + Ptr GlobalAlias -> IO (Ptr Constant) + +-- | set the constant aliased by this alias +foreign import ccall unsafe "LLVM_Hs_SetAliasee" setAliasee :: + Ptr GlobalAlias -> Ptr Constant -> IO () + diff --git a/src/LLVM/Internal/FFI/GlobalAliasC.cpp b/src/LLVM/Internal/FFI/GlobalAliasC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/GlobalAliasC.cpp @@ -0,0 +1,22 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/GlobalAlias.h" +#include "llvm/IR/GlobalObject.h" + +#include "llvm-c/Core.h" + +#include + +using namespace llvm; + +extern "C" { + +LLVMValueRef LLVM_Hs_GetAliasee(LLVMValueRef g) { + return wrap(unwrap(g)->getAliasee()); +} + +void LLVM_Hs_SetAliasee(LLVMValueRef g, LLVMValueRef c) { + unwrap(g)->setAliasee(unwrap(c)); +} + +} diff --git a/src/LLVM/Internal/FFI/GlobalValue.h b/src/LLVM/Internal/FFI/GlobalValue.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/GlobalValue.h @@ -0,0 +1,51 @@ +#ifndef __LLVM_INTERNAL_FFI__GLOBAL_VALUE__H__ +#define __LLVM_INTERNAL_FFI__GLOBAL_VALUE__H__ + +#define LLVM_HS_FOR_EACH_LINKAGE(macro) \ + macro(External) \ + macro(AvailableExternally) \ + macro(LinkOnceAny) \ + macro(LinkOnceODR) \ + macro(WeakAny) \ + macro(WeakODR) \ + macro(Appending) \ + macro(Internal) \ + macro(Private) \ + macro(ExternalWeak) \ + macro(Common) + +#define LLVM_HS_FOR_EACH_VISIBILITY(macro) \ + macro(Default) \ + macro(Hidden) \ + macro(Protected) \ + +#define LLVM_HS_FOR_EACH_COMDAT_SELECTION_KIND(macro) \ + macro(Any) \ + macro(ExactMatch) \ + macro(Largest) \ + macro(NoDuplicates) \ + macro(SameSize) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_COMDAT_Selection_Kind_ ## n, +LLVM_HS_FOR_EACH_COMDAT_SELECTION_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_COMDAT_Selection_Kind; + +#define LLVM_HS_FOR_EACH_DLL_STORAGE_CLASS(macro) \ + macro(Default) \ + macro(DLLImport) \ + macro(DLLExport) + +#define LLVM_HS_FOR_EACH_THREAD_LOCAL_MODE(macro) \ + macro(NotThreadLocal) \ + macro(GeneralDynamicTLSModel) \ + macro(LocalDynamicTLSModel) \ + macro(InitialExecTLSModel) \ + macro(LocalExecTLSModel) + +#define LLVM_HS_FOR_EACH_UNNAMED_ADDR(macro) \ + macro(No) \ + macro(Local) \ + macro(Global) +#endif diff --git a/src/LLVM/Internal/FFI/GlobalValue.hs b/src/LLVM/Internal/FFI/GlobalValue.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/GlobalValue.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances + #-} +-- | FFI functions for handling the LLVM GlobalValue class +module LLVM.Internal.FFI.GlobalValue where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.LLVMCTypes + +data COMDAT + +foreign import ccall unsafe "LLVMIsAGlobalValue" isAGlobalValue :: + Ptr Value -> IO (Ptr GlobalValue) + +foreign import ccall unsafe "LLVMGetLinkage" getLinkage :: + Ptr GlobalValue -> IO Linkage + +foreign import ccall unsafe "LLVMSetLinkage" setLinkage :: + Ptr GlobalValue -> Linkage -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetSection" getSection :: + Ptr GlobalValue -> Ptr CSize -> IO CString + +foreign import ccall unsafe "LLVMSetSection" setSection :: + Ptr GlobalValue -> CString -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetCOMDAT" getCOMDAT :: + Ptr GlobalValue -> IO (Ptr COMDAT) + +foreign import ccall unsafe "LLVM_Hs_SetCOMDAT" setCOMDAT :: + Ptr GlobalObject -> Ptr COMDAT -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetCOMDATName" getCOMDATName :: + Ptr COMDAT -> Ptr CSize -> IO (Ptr CChar) + +foreign import ccall unsafe "LLVM_Hs_GetCOMDATSelectionKind" getCOMDATSelectionKind :: + Ptr COMDAT -> IO COMDATSelectionKind + +foreign import ccall unsafe "LLVM_Hs_SetCOMDATSelectionKind" setCOMDATSelectionKind :: + Ptr COMDAT -> COMDATSelectionKind -> IO () + +foreign import ccall unsafe "LLVMGetVisibility" getVisibility :: + Ptr GlobalValue -> IO Visibility + +foreign import ccall unsafe "LLVMSetVisibility" setVisibility :: + Ptr GlobalValue -> Visibility -> IO () + +foreign import ccall unsafe "LLVMGetDLLStorageClass" getDLLStorageClass :: + Ptr GlobalValue -> IO DLLStorageClass + +foreign import ccall unsafe "LLVMSetDLLStorageClass" setDLLStorageClass :: + Ptr GlobalValue -> DLLStorageClass -> IO () + +foreign import ccall unsafe "LLVMGetAlignment" getAlignment :: + Ptr GlobalValue -> IO CUInt + +foreign import ccall unsafe "LLVMSetAlignment" setAlignment :: + Ptr GlobalValue -> CUInt -> IO () + +foreign import ccall unsafe "LLVMGetUnnamedAddress" getUnnamedAddr :: + Ptr GlobalValue -> IO UnnamedAddr + +foreign import ccall unsafe "LLVMSetUnnamedAddress" setUnnamedAddr :: + Ptr GlobalValue -> UnnamedAddr -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetThreadLocalMode" getThreadLocalMode :: + Ptr GlobalValue -> IO ThreadLocalMode + +foreign import ccall unsafe "LLVM_Hs_SetThreadLocalMode" setThreadLocalMode :: + Ptr GlobalValue -> ThreadLocalMode -> IO () + +foreign import ccall unsafe "LLVM_Hs_GlobalObject_GetNumMetadata" getNumMetadata :: + Ptr GlobalObject -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GlobalObject_GetAllMetadata" getAllMetadata :: + Ptr GlobalObject -> Ptr MDKindID -> Ptr (Ptr MDNode) -> IO () + +foreign import ccall unsafe "LLVM_Hs_GlobalObject_SetMetadata" setMetadata :: + Ptr GlobalObject -> MDKindID -> Ptr MDNode -> IO () diff --git a/src/LLVM/Internal/FFI/GlobalValueC.cpp b/src/LLVM/Internal/FFI/GlobalValueC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/GlobalValueC.cpp @@ -0,0 +1,81 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/Comdat.h" +#include "llvm/IR/GlobalValue.h" +#include "llvm/IR/GlobalObject.h" +#include "llvm/IR/Metadata.h" +#include "llvm-c/Core.h" +#include "LLVM/Internal/FFI/GlobalValue.h" + +using namespace llvm; + +extern "C" { + +const Comdat *LLVM_Hs_GetCOMDAT(LLVMValueRef globalVal) { + return unwrap(globalVal)->getComdat(); +} + +void LLVM_Hs_SetCOMDAT(LLVMValueRef globalObj, Comdat *comdat) { + return unwrap(globalObj)->setComdat(comdat); +} + +const char *LLVM_Hs_GetCOMDATName(const Comdat &comdat, size_t &size) { + StringRef ref = comdat.getName(); + size = ref.size(); + return ref.data(); +} + +#define ENUM_CASE(n) \ + static_assert(unsigned(Comdat::n) == \ + unsigned(LLVM_Hs_COMDAT_Selection_Kind_##n), \ + "COMDAT SelectionKind Enum mismatch"); +LLVM_HS_FOR_EACH_COMDAT_SELECTION_KIND(ENUM_CASE) +#undef ENUM_CASE + +const char* LLVM_Hs_GetSection(LLVMValueRef globalVal, size_t* strLength) { + const auto& section = unwrap(globalVal)->getSection(); + *strLength = section.size(); + return section.data(); +} + +unsigned LLVM_Hs_GetCOMDATSelectionKind(const Comdat &comdat) { + return unsigned(comdat.getSelectionKind()); +} + +void LLVM_Hs_SetCOMDATSelectionKind(Comdat &comdat, unsigned csk) { + comdat.setSelectionKind(Comdat::SelectionKind(csk)); +} + +#define ENUM_CASE(n) \ + static_assert(unsigned(GlobalValue::n) == unsigned(LLVM##n), \ + "TLS Model Enum mismatch"); +LLVM_HS_FOR_EACH_THREAD_LOCAL_MODE(ENUM_CASE) +#undef ENUM_CASE + +LLVMThreadLocalMode LLVM_Hs_GetThreadLocalMode(LLVMValueRef globalVal) { + return LLVMThreadLocalMode(unwrap(globalVal)->getThreadLocalMode()); +} + +void LLVM_Hs_SetThreadLocalMode(LLVMValueRef globalVal, LLVMThreadLocalMode mode) { + unwrap(globalVal)->setThreadLocalMode(GlobalValue::ThreadLocalMode(mode)); +} + +unsigned LLVM_Hs_GlobalObject_GetNumMetadata(GlobalObject* obj) { + SmallVector, 4> mds; + obj->getAllMetadata(mds); + return mds.size(); +} + +void LLVM_Hs_GlobalObject_GetAllMetadata(GlobalObject* obj, unsigned *kinds, LLVMMetadataRef *nodes) { + SmallVector, 4> mds; + obj->getAllMetadata(mds); + for (unsigned i = 0; i < mds.size(); ++i) { + kinds[i] = mds[i].first; + nodes[i] = wrap(mds[i].second); + } +} + +void LLVM_Hs_GlobalObject_SetMetadata(GlobalObject* obj, unsigned kind, MDNode* node) { + obj->setMetadata(kind, node); +} + +} diff --git a/src/LLVM/Internal/FFI/GlobalVariable.hs b/src/LLVM/Internal/FFI/GlobalVariable.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/GlobalVariable.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances + #-} +-- | FFI functions for handling the LLVM GlobalVariable class +module LLVM.Internal.FFI.GlobalVariable where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.LLVMCTypes + +foreign import ccall unsafe "LLVMIsAGlobalVariable" isAGlobalVariable :: + Ptr Value -> IO (Ptr GlobalVariable) + +foreign import ccall unsafe "LLVMIsGlobalConstant" isGlobalConstant :: + Ptr GlobalVariable -> IO LLVMBool + +foreign import ccall unsafe "LLVMSetGlobalConstant" setGlobalConstant :: + Ptr GlobalVariable -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVMGetInitializer" getInitializer :: + Ptr GlobalVariable -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVMSetInitializer" setInitializer :: + Ptr GlobalVariable -> Ptr Constant -> IO () + diff --git a/src/LLVM/Internal/FFI/InlineAssembly.h b/src/LLVM/Internal/FFI/InlineAssembly.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/InlineAssembly.h @@ -0,0 +1,14 @@ +#ifndef __LLVM_INTERNAL_FFI__INLINE_ASSEMBLY__H__ +#define __LLVM_INTERNAL_FFI__INLINE_ASSEMBLY__H__ + +#define LLVM_HS_FOR_EACH_ASM_DIALECT(macro) \ + macro(ATT) \ + macro(Intel) \ + +typedef enum { +#define ENUM_CASE(d) LLVMAsmDialect_ ## d, + LLVM_HS_FOR_EACH_ASM_DIALECT(ENUM_CASE) +#undef ENUM_CASE +} LLVMAsmDialect; + +#endif diff --git a/src/LLVM/Internal/FFI/InlineAssembly.hs b/src/LLVM/Internal/FFI/InlineAssembly.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/InlineAssembly.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} + +module LLVM.Internal.FFI.InlineAssembly where + +import LLVM.Prelude + +import Foreign.C +import Foreign.Ptr + +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy + +foreign import ccall unsafe "LLVMIsAInlineAsm" isAInlineAsm :: + Ptr Value -> IO (Ptr InlineAsm) + +foreign import ccall unsafe "LLVM_Hs_CreateInlineAsm" createInlineAsm :: + Ptr Type -> CString -> CString -> LLVMBool -> LLVMBool -> AsmDialect -> IO (Ptr InlineAsm) + +foreign import ccall unsafe "LLVM_Hs_GetInlineAsmAsmString" getInlineAsmAssemblyString :: + Ptr InlineAsm -> IO CString + +foreign import ccall unsafe "LLVM_Hs_GetInlineAsmConstraintString" getInlineAsmConstraintString :: + Ptr InlineAsm -> IO CString + +foreign import ccall unsafe "LLVM_Hs_InlineAsmHasSideEffects" inlineAsmHasSideEffects :: + Ptr InlineAsm -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_InlineAsmIsAlignStack" inlineAsmIsAlignStack :: + Ptr InlineAsm -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_GetInlineAsmDialect" getInlineAsmDialect :: + Ptr InlineAsm -> IO AsmDialect + diff --git a/src/LLVM/Internal/FFI/InlineAssemblyC.cpp b/src/LLVM/Internal/FFI/InlineAssemblyC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/InlineAssemblyC.cpp @@ -0,0 +1,73 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/InlineAsm.h" +#include "llvm/IR/Function.h" +#include "llvm-c/Core.h" + +#include "LLVM/Internal/FFI/InlineAssembly.h" + +using namespace llvm; + +namespace llvm { +static LLVMAsmDialect wrap(InlineAsm::AsmDialect d) { + switch(d) { +#define ENUM_CASE(x) case InlineAsm::AD_ ## x: return LLVMAsmDialect_ ## x; +LLVM_HS_FOR_EACH_ASM_DIALECT(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMAsmDialect(0); + } +} + +static InlineAsm::AsmDialect unwrap(LLVMAsmDialect d) { + switch(d) { +#define ENUM_CASE(x) case LLVMAsmDialect_ ## x: return InlineAsm::AD_ ## x; +LLVM_HS_FOR_EACH_ASM_DIALECT(ENUM_CASE) +#undef ENUM_CASE + default: return InlineAsm::AsmDialect(0); + } +} +} + +extern "C" { + +LLVMValueRef LLVM_Hs_CreateInlineAsm( + LLVMTypeRef t, + const char *asmStr, + const char *constraintsStr, + LLVMBool hasSideEffects, + LLVMBool isAlignStack, + LLVMAsmDialect dialect +) { + return wrap( + InlineAsm::get( + unwrap(t), + asmStr, + constraintsStr, + hasSideEffects, + isAlignStack, + unwrap(dialect) + ) + ); +} + +const char *LLVM_Hs_GetInlineAsmAsmString(LLVMValueRef v) { + return unwrap(v)->getAsmString().c_str(); +} + +const char *LLVM_Hs_GetInlineAsmConstraintString(LLVMValueRef v) { + return unwrap(v)->getConstraintString().c_str(); +} + +LLVMBool LLVM_Hs_InlineAsmHasSideEffects(LLVMValueRef v) { + return unwrap(v)->hasSideEffects(); +} + +LLVMBool LLVM_Hs_InlineAsmIsAlignStack(LLVMValueRef v) { + return unwrap(v)->isAlignStack(); +} + +LLVMAsmDialect LLVM_Hs_GetInlineAsmDialect(LLVMValueRef v) { + return wrap(unwrap(v)->getDialect()); +} + +} + diff --git a/src/LLVM/Internal/FFI/Instruction.h b/src/LLVM/Internal/FFI/Instruction.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Instruction.h @@ -0,0 +1,79 @@ +#ifndef __LLVM_INTERNAL_FFI__INSTRUCTION__H__ +#define __LLVM_INTERNAL_FFI__INSTRUCTION__H__ + +#include "llvm/Config/llvm-config.h" + +#define LLVM_HS_FOR_EACH_ATOMIC_ORDERING(macro) \ + macro(NotAtomic) \ + macro(Unordered) \ + macro(Monotonic) \ + macro(Acquire) \ + macro(Release) \ + macro(AcquireRelease) \ + macro(SequentiallyConsistent) + +#define LLVM_HS_FOR_EACH_RMW_OPERATION(macro) \ + macro(Xchg) \ + macro(Add) \ + macro(Sub) \ + macro(And) \ + macro(Nand) \ + macro(Or) \ + macro(Xor) \ + macro(Max) \ + macro(Min) \ + macro(UMax) \ + macro(UMin) \ + macro(FAdd) \ + macro(FSub) + +typedef enum { +#define ENUM_CASE(x) LLVMAtomicRMWBinOp_ ## x, +LLVM_HS_FOR_EACH_RMW_OPERATION(ENUM_CASE) +#undef ENUM_CASE +} LLVMAtomicRMWBinOp_; + +#define LLVM_HS_FOR_EACH_SYNCRONIZATION_SCOPE(macro) \ + macro(SingleThread) \ + macro(System) + +typedef enum { +#define ENUM_CASE(x) LLVM ## x ## SynchronizationScope, +LLVM_HS_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE) +#undef ENUM_CASE +} LLVMSynchronizationScope; + +/* The last parameter to the macro indicates whether the set function takes a boolean argument or not */ +#define LLVM_HS_FOR_EACH_FAST_MATH_FLAG(macro) \ + macro(AllowReassoc, allowReassoc, F) \ + macro(NoNaNs, noNaNs, F) \ + macro(NoInfs, noInfs, F) \ + macro(NoSignedZeros, noSignedZeros, F) \ + macro(AllowReciprocal, allowReciprocal, F) \ + macro(AllowContract, allowContract, T) \ + macro(ApproxFunc, approxFunc, F) + +typedef enum { +#define ENUM_CASE(x,l,takesArg) LLVM ## x ## Bit, +LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) +#undef ENUM_CASE +} LLVMFastMathFlagBit; + +typedef enum { +#define ENUM_CASE(x,l,takesArg) LLVM ## x = (1 << LLVM ## x ## Bit), +LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) +#undef ENUM_CASE +} LLVMFastMathFlags; + +#define LLVM_HS_FOR_EACH_TAIL_CALL_KIND(macro) \ + macro(None) \ + macro(Tail) \ + macro(MustTail) \ + macro(NoTail) + +typedef enum { +#define ENUM_CASE(x) LLVM_Hs_TailCallKind_ ## x, +LLVM_HS_FOR_EACH_TAIL_CALL_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_TailCallKind; +#endif diff --git a/src/LLVM/Internal/FFI/Instruction.hs b/src/LLVM/Internal/FFI/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Instruction.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances, + TemplateHaskell + #-} +module LLVM.Internal.FFI.Instruction where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.Attribute +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.LLVMCTypes + +foreign import ccall unsafe "LLVMIsAInstruction" isAInstruction :: + Ptr Value -> IO (Ptr Instruction) + +newtype COpcode = COpcode CUInt + +-- get the C API opcode +foreign import ccall unsafe "LLVMGetInstructionOpcode" getInstructionOpcode :: + Ptr Instruction -> IO COpcode + +-- get the C++ API opcode (one less level of mapping than for that from the C API) +foreign import ccall unsafe "LLVM_Hs_GetInstructionDefOpcode" getInstructionDefOpcode :: + Ptr Instruction -> IO CPPOpcode + +foreign import ccall unsafe "LLVMGetICmpPredicate" getICmpPredicate :: + Ptr Instruction -> IO ICmpPredicate + +foreign import ccall unsafe "LLVM_Hs_GetFCmpPredicate" getFCmpPredicate :: + Ptr Instruction -> IO FCmpPredicate + +foreign import ccall unsafe "LLVM_Hs_GetAbstractCallSiteCallingConvention" getCallSiteCallingConvention :: + Ptr Instruction -> IO CallingConvention + +foreign import ccall unsafe "LLVM_Hs_SetAbstractCallSiteCallingConvention" setCallSiteCallingConvention :: + Ptr Instruction -> CallingConvention -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetTailCallKind" getTailCallKind :: + Ptr Instruction -> IO TailCallKind + +foreign import ccall unsafe "LLVM_Hs_SetTailCallKind" setTailCallKind :: + Ptr Instruction -> TailCallKind -> IO () + +foreign import ccall unsafe "LLVMGetCalledValue" getCallSiteCalledValue :: + Ptr Instruction -> IO (Ptr Value) + +foreign import ccall unsafe "LLVMGetNumArgOperands" getCallSiteNumArgOperands :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_AbstractCallSiteAttributesAtIndex" getCallSiteAttributesAtIndex :: + Ptr Instruction -> AttributeIndex -> IO (AttributeSet a) + +foreign import ccall unsafe "LLVM_Hs_AbstractCallSiteSetAttributeList" setCallSiteAttributeList :: + Ptr Instruction -> AttributeList -> IO () + +foreign import ccall unsafe "LLVMAddIncoming" addIncoming' :: + Ptr Instruction -> Ptr (Ptr Value) -> Ptr (Ptr BasicBlock) -> CUInt -> IO () + +addIncoming :: Ptr Instruction -> (CUInt, Ptr (Ptr Value)) -> (CUInt, Ptr (Ptr BasicBlock)) -> IO () +addIncoming i (nvs, vs) (nbs, bs) + | nbs == nvs = addIncoming' i vs bs nbs + | otherwise = error "Number of incoming values and incoming blocks must be equal" + +foreign import ccall unsafe "LLVMCountIncoming" countIncoming :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVMGetIncomingValue" getIncomingValue :: + Ptr Instruction -> CUInt -> IO (Ptr Value) + +foreign import ccall unsafe "LLVMGetIncomingBlock" getIncomingBlock :: + Ptr Instruction -> CUInt -> IO (Ptr BasicBlock) + + +foreign import ccall unsafe "LLVMAddCase" addCase :: + Ptr Instruction -> Ptr Constant -> Ptr BasicBlock -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetSwitchCases" getSwitchCases :: + Ptr Instruction -> Ptr (Ptr Constant) -> Ptr (Ptr BasicBlock) -> IO () + +foreign import ccall unsafe "LLVMAddDestination" addDestination :: + Ptr Instruction -> Ptr BasicBlock -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetIndirectBrDests" getIndirectBrDests :: + Ptr Instruction -> Ptr (Ptr BasicBlock) -> IO () + + +foreign import ccall unsafe "LLVM_Hs_GetInstrAlignment" getInstrAlignment :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_SetInstrAlignment" setInstrAlignment :: + Ptr Instruction -> CUInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetAllocaNumElements" getAllocaNumElements :: + Ptr Instruction -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_GetAllocatedType" getAllocatedType :: + Ptr Instruction -> IO (Ptr Type) + +foreign import ccall unsafe "LLVM_Hs_GetAtomicOrdering" getAtomicOrdering :: + Ptr Instruction -> IO MemoryOrdering + +foreign import ccall unsafe "LLVM_Hs_GetFailureAtomicOrdering" getFailureAtomicOrdering :: + Ptr Instruction -> IO MemoryOrdering + +foreign import ccall unsafe "LLVM_Hs_GetSynchronizationScope" getSynchronizationScope :: + Ptr Instruction -> IO SynchronizationScope + +getAtomicity :: Ptr Instruction -> IO (SynchronizationScope, MemoryOrdering) +getAtomicity i = return (,) `ap` getSynchronizationScope i `ap` getAtomicOrdering i + +foreign import ccall unsafe "LLVM_Hs_GetVolatile" getVolatile :: + Ptr Instruction -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_GetInBounds" getInBounds :: + Ptr Value -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_GetAtomicRMWBinOp" getAtomicRMWBinOp :: + Ptr Instruction -> IO RMWOperation + +foreign import ccall unsafe "LLVM_Hs_CountInstStructureIndices" countInstStructureIndices :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GetInstStructureIndices" getInstStructureIndices :: + Ptr Instruction -> Ptr CUInt -> IO () + +foreign import ccall unsafe "LLVMAddClause" addClause :: + Ptr Instruction -> Ptr Constant -> IO () + +foreign import ccall unsafe "LLVMSetCleanup" setCleanup :: + Ptr Instruction -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVMIsCleanup" isCleanup :: + Ptr Instruction -> IO LLVMBool + +foreign import ccall unsafe "LLVMGetNumClauses" getNumClauses :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVMGetClause" getClause :: + Ptr Instruction -> CUInt -> IO (Ptr Constant) + +foreign import ccall unsafe "LLVM_Hs_SetMetadata" setMetadata :: + Ptr Instruction -> MDKindID -> Ptr MDNode -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetMetadata" getMetadata :: + Ptr Instruction -> Ptr MDKindID -> Ptr (Ptr MDNode) -> CUInt -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GetShuffleVectorMaskSize" getShuffleVectorMaskSize :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GetShuffleVectorMask" getShuffleVectorMask :: + Ptr Instruction -> CUInt -> Ptr CInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetCleanupPad" getCleanupPad :: + Ptr Instruction -> IO (Ptr Instruction) + +foreign import ccall unsafe "LLVM_Hs_GetUnwindDest" getUnwindDest :: + Ptr Instruction -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVM_Hs_GetParentPad" getParentPad :: + Ptr Instruction -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_GetNumArgOperands" getNumArgOperands :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GetArgOperand" getArgOperand :: + Ptr Instruction -> CUInt -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_CatchSwitch_GetParentPad" catchSwitchGetParentPad :: + Ptr Instruction -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_CatchSwitch_GetUnwindDest" catchSwitchGetUnwindDest :: + Ptr Instruction -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVM_Hs_CatchSwitch_GetNumHandlers" catchSwitchGetNumHandlers :: + Ptr Instruction -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_CatchSwitch_GetHandler" catchSwitchGetHandler :: + Ptr Instruction -> CUInt -> IO (Ptr BasicBlock) + +foreign import ccall unsafe "LLVM_Hs_CatchSwitch_AddHandler" catchSwitchAddHandler :: + Ptr Instruction -> Ptr BasicBlock -> IO () + +foreign import ccall unsafe "LLVM_Hs_CatchRet_GetCatchPad" catchRetGetCatchPad :: + Ptr Instruction -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_CatchRet_GetSuccessor" catchRetGetSuccessor :: + Ptr Instruction -> IO (Ptr BasicBlock) diff --git a/src/LLVM/Internal/FFI/InstructionC.cpp b/src/LLVM/Internal/FFI/InstructionC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/InstructionC.cpp @@ -0,0 +1,327 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/Config/llvm-config.h" +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/InstrTypes.h" +#include "llvm/IR/Instructions.h" +#include "llvm/IR/AbstractCallSite.h" +#include "llvm/IR/Attributes.h" +#include "llvm/IR/Operator.h" +#include "llvm/IR/BasicBlock.h" +#include "llvm/IR/Metadata.h" + +#include "llvm-c/Core.h" + +#include "LLVM/Internal/FFI/AttributeC.hpp" +#include "LLVM/Internal/FFI/ErrorHandling.hpp" +#include "LLVM/Internal/FFI/Instruction.h" + +using namespace llvm; + +namespace llvm { + +static LLVMAtomicOrdering wrap(AtomicOrdering l) { + switch(l) { +#define ENUM_CASE(x) case AtomicOrdering::x: return LLVMAtomicOrdering ## x; +LLVM_HS_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMAtomicOrdering(0); + } +} + +static LLVMSynchronizationScope wrap(SyncScope::ID l) { + switch(l) { +#define ENUM_CASE(x) case SyncScope::x: return LLVM ## x ## SynchronizationScope; +LLVM_HS_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE) +#undef ENUM_CASE + default: reportFatalError("Unknown synchronization scope"); + } +} + +static LLVMAtomicRMWBinOp_ wrap(AtomicRMWInst::BinOp l) { + switch(l) { +#define ENUM_CASE(x) case AtomicRMWInst::x: return LLVMAtomicRMWBinOp_ ## x; +LLVM_HS_FOR_EACH_RMW_OPERATION(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMAtomicRMWBinOp_(0); + } +} + +LLVMFastMathFlags wrap(FastMathFlags f) { + unsigned r = 0; +#define ENUM_CASE(u,l,takesArg) if (f.l()) r |= unsigned(LLVM ## u); +LLVM_HS_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE) +#undef ENUM_CASE + return LLVMFastMathFlags(r); +} + +} + +extern "C" { + +unsigned LLVM_Hs_GetInstructionDefOpcode(LLVMValueRef val) { + return unwrap(val)->getOpcode(); +} + +unsigned LLVM_Hs_HasNoSignedWrap(LLVMValueRef val) { + return unwrap(val)->hasNoSignedWrap(); +} + +unsigned LLVM_Hs_HasNoUnsignedWrap(LLVMValueRef val) { + return unwrap(val)->hasNoUnsignedWrap(); +} + +int LLVM_Hs_IsExact(LLVMValueRef val) { + return unwrap(val)->isExact(); +} + +LLVMFastMathFlags LLVM_Hs_GetFastMathFlags(LLVMValueRef val) { + return wrap(unwrap(val)->getFastMathFlags()); +} + +void LLVM_Hs_AbstractCallSiteSetAttributeList(LLVMValueRef i, LLVMAttributeListRef attrs) { + unwrap(i)->setAttributes(*attrs); +} + +unsigned LLVM_Hs_GetAbstractCallSiteCallingConvention(LLVMValueRef i) { + return unsigned(unwrap(i)->getCallingConv()); +} + +void LLVM_Hs_SetAbstractCallSiteCallingConvention(LLVMValueRef i, unsigned cc) { + unwrap(i)->setCallingConv(llvm::CallingConv::ID(cc)); +} + +LLVMAttributeSetRef LLVM_Hs_AbstractCallSiteAttributesAtIndex(LLVMValueRef i, LLVMAttributeIndex idx) { + auto cs = unwrap(i); + return new AttributeSet(cs->getAttributes().getAttributes(idx)); +} + +#define CHECK(name) \ + static_assert(unsigned(llvm::CallInst::TCK_##name) == \ + unsigned(LLVM_Hs_TailCallKind_##name), \ + "LLVM_Hs_TailCallKind enum out of sync w/ " \ + "llvm::CallInst::TailCallKind for " #name); +LLVM_HS_FOR_EACH_TAIL_CALL_KIND(CHECK) +#undef CHECK + +unsigned LLVM_Hs_GetTailCallKind(LLVMValueRef i) { + return unwrap(i)->getTailCallKind(); +} + +void LLVM_Hs_SetTailCallKind(LLVMValueRef i, unsigned kind) { + return unwrap(i)->setTailCallKind(llvm::CallInst::TailCallKind(kind)); +} + +LLVMValueRef LLVM_Hs_GetAllocaNumElements(LLVMValueRef a) { + return wrap(unwrap(a)->getArraySize()); +} + +LLVMTypeRef LLVM_Hs_GetAllocatedType(LLVMValueRef a) { + return wrap(unwrap(a)->getAllocatedType()); +} + +// ------------------------------------------------------------ + +#define LLVM_HS_FOR_EACH_ALIGNMENT_INST(macro) \ + macro(Alloca) \ + macro(Load) \ + macro(Store) + +unsigned LLVM_Hs_GetInstrAlignment(LLVMValueRef l) { + switch(unwrap(l)->getOpcode()) { +#define ENUM_CASE(n) case Instruction::n: return unwrap(l)->getAlignment(); + LLVM_HS_FOR_EACH_ALIGNMENT_INST(ENUM_CASE) +#undef ENUM_CASE + default: return 0; + } +} + +void LLVM_Hs_SetInstrAlignment(LLVMValueRef l, unsigned a) { + switch(unwrap(l)->getOpcode()) { +#define ENUM_CASE(n) case Instruction::n: unwrap(l)->setAlignment(Align(a)); break; + LLVM_HS_FOR_EACH_ALIGNMENT_INST(ENUM_CASE) +#undef ENUM_CASE + } +} + +// ------------------------------------------------------------ + +#define LLVM_HS_FOR_EACH_ATOMIC_INST(macro) \ + macro(Load,) \ + macro(Store,) \ + macro(Fence,) \ + macro(AtomicCmpXchg,Success) \ + macro(AtomicRMW,) + +LLVMAtomicOrdering LLVM_Hs_GetAtomicOrdering(LLVMValueRef i) { + switch(unwrap(i)->getOpcode()) { +#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap(i)->get ## s ## Ordering()); + LLVM_HS_FOR_EACH_ATOMIC_INST(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMAtomicOrdering(0); + } +} + +LLVMAtomicOrdering LLVM_Hs_GetFailureAtomicOrdering(LLVMValueRef i) { + switch(unwrap(i)->getOpcode()) { + case Instruction::AtomicCmpXchg: return wrap(unwrap(i)->getFailureOrdering()); + default: return LLVMAtomicOrdering(0); + } +} + +LLVMSynchronizationScope LLVM_Hs_GetSynchronizationScope(LLVMValueRef i) { + switch(unwrap(i)->getOpcode()) { +#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap(i)->getSyncScopeID()); + LLVM_HS_FOR_EACH_ATOMIC_INST(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMSynchronizationScope(0); + } +} + +#define LLVM_HS_FOR_EACH_VOLATILITY_INST(macro) \ + macro(Load) \ + macro(Store) \ + macro(AtomicCmpXchg) \ + macro(AtomicRMW) + +LLVMBool LLVM_Hs_GetVolatile(LLVMValueRef i) { + switch(unwrap(i)->getOpcode()) { +#define ENUM_CASE(n) case Instruction::n: return unwrap(i)->isVolatile(); + LLVM_HS_FOR_EACH_VOLATILITY_INST(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMBool(0); + } +} + +// ------------------------------------------------------------ + +LLVMBool LLVM_Hs_GetInBounds(LLVMValueRef i) { + return unwrap(i)->isInBounds(); +} + +LLVMAtomicRMWBinOp_ LLVM_Hs_GetAtomicRMWBinOp(LLVMValueRef i) { + return wrap(unwrap(i)->getOperation()); +} + +LLVMRealPredicate LLVM_Hs_GetFCmpPredicate(LLVMValueRef Inst) { + if (FCmpInst *I = dyn_cast(unwrap(Inst))) + return (LLVMRealPredicate)I->getPredicate(); + if (ConstantExpr *CE = dyn_cast(unwrap(Inst))) + if (CE->getOpcode() == Instruction::FCmp) + return (LLVMRealPredicate)CE->getPredicate(); + return (LLVMRealPredicate)0; +} + +unsigned LLVM_Hs_CountInstStructureIndices(LLVMValueRef v) { + if (ExtractValueInst *i = dyn_cast(unwrap(v))) return i->getNumIndices(); + if (InsertValueInst *i = dyn_cast(unwrap(v))) return i->getNumIndices(); + return 0; +} + +void LLVM_Hs_GetInstStructureIndices(LLVMValueRef v, unsigned *is) { + ArrayRef a; + if (ExtractValueInst *i = dyn_cast(unwrap(v))) a = i->getIndices(); + if (InsertValueInst *i = dyn_cast(unwrap(v))) a = i->getIndices(); + std::copy(a.begin(), a.end(), is); +} + +void LLVM_Hs_GetSwitchCases( + LLVMValueRef v, + LLVMValueRef *values, + LLVMBasicBlockRef *dests +) { + SwitchInst *s = unwrap(v); + for(SwitchInst::CaseIt i = s->case_begin(); i != s->case_end(); ++i, ++values, ++dests) { + *values = wrap(i->getCaseValue()); + *dests = wrap(i->getCaseSuccessor()); + } +} + +void LLVM_Hs_GetIndirectBrDests( + LLVMValueRef v, + LLVMBasicBlockRef *dests +) { + IndirectBrInst *ib = unwrap(v); + for(unsigned i=0; i != ib->getNumDestinations(); ++i, ++dests) + *dests = wrap(ib->getDestination(i)); +} + +void LLVM_Hs_SetMetadata(LLVMValueRef inst, unsigned kindID, LLVMMetadataRef md) { + MDNode *N = md ? unwrap(md) : nullptr; + unwrap(inst)->setMetadata(kindID, N); +} + +unsigned LLVM_Hs_GetMetadata( + LLVMValueRef i, + unsigned *kinds, + LLVMMetadataRef *nodes, + unsigned nKinds +) { + SmallVector, 4> mds; + unwrap(i)->getAllMetadata(mds); + if (mds.size() <= nKinds) { + for(unsigned i=0; i(i)->getShuffleMask().size(); +} + +void LLVM_Hs_GetShuffleVectorMask(LLVMValueRef i, unsigned int numResults, int *result) { + const auto& mask = unwrap(i)->getShuffleMask(); + assert(numResults == mask.size()); + std::copy(mask.begin(), mask.end(), result); +} + +LLVMValueRef LLVM_Hs_GetCleanupPad(LLVMValueRef i) { + return wrap(unwrap(i)->getCleanupPad()); +} + +LLVMBasicBlockRef LLVM_Hs_GetUnwindDest(LLVMValueRef i) { + return wrap(unwrap(i)->getUnwindDest()); +} + +LLVMValueRef LLVM_Hs_GetParentPad(LLVMValueRef i) { + return wrap(unwrap(i)->getParentPad()); +} + +unsigned LLVM_Hs_GetNumArgOperands(LLVMValueRef i) { + return unwrap(i)->getNumArgOperands(); +} + +LLVMValueRef LLVM_Hs_GetArgOperand(LLVMValueRef i, unsigned op) { + return wrap(unwrap(i)->getArgOperand(op)); +} + +LLVMValueRef LLVM_Hs_CatchSwitch_GetParentPad(LLVMValueRef i) { + return wrap(unwrap(i)->getParentPad()); +} + +LLVMBasicBlockRef LLVM_Hs_CatchSwitch_GetUnwindDest(LLVMValueRef i) { + return wrap(unwrap(i)->getUnwindDest()); +} + +unsigned LLVM_Hs_CatchSwitch_GetNumHandlers(LLVMValueRef i) { + return unwrap(i)->getNumHandlers(); +} + +LLVMBasicBlockRef LLVM_Hs_CatchSwitch_GetHandler(LLVMValueRef instr, unsigned i) { + return wrap(*(unwrap(instr)->handler_begin() + i)); +} + +void LLVM_Hs_CatchSwitch_AddHandler(LLVMValueRef instr, LLVMBasicBlockRef bb) { + unwrap(instr)->addHandler(unwrap(bb)); +} + +LLVMValueRef LLVM_Hs_CatchRet_GetCatchPad(LLVMValueRef i) { + return wrap(unwrap(i)->getCatchPad()); +} + +LLVMBasicBlockRef LLVM_Hs_CatchRet_GetSuccessor(LLVMValueRef i) { + return wrap(unwrap(i)->getSuccessor()); +} +} diff --git a/src/LLVM/Internal/FFI/InstructionDefs.hsc b/src/LLVM/Internal/FFI/InstructionDefs.hsc new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/InstructionDefs.hsc @@ -0,0 +1,62 @@ +-- This module translates the instruction data in "llvm/Instruction.def" into a Haskell data structure, +-- so it may be accessed conveniently with Template Haskell code +module LLVM.Internal.FFI.InstructionDefs where + +import LLVM.Prelude + +import LLVM.Internal.FFI.LLVMCTypes + +#define FIRST_TERM_INST(num) struct inst { const char *kind; int opcode; const char *name; const char *clas; } insts[] = { { "Terminator", }, + +#define FIRST_UNARY_INST(num) { "Unary" }, +#define FIRST_BINARY_INST(num) { "Binary" }, +#define FIRST_MEMORY_INST(num) { "Memory" }, +#define FIRST_CAST_INST(num) { "Cast" }, +#define FIRST_OTHER_INST(num) { "Other" }, +#define FIRST_FUNCLETPAD_INST(num) { "FuncletPad" }, + +#define HANDLE_INST(num,opcode,class) { 0, num, #opcode, #class, }, + +#define LAST_OTHER_INST(num) { 0, 0, 0, 0, } }; + +#include "llvm/Config/llvm-config.h" + +#include "llvm/IR/Instruction.def" + +#{ +define hsc_inject() { \ + hsc_printf("["); \ + struct inst *i; \ + const char *kind = NULL; \ + int first = 1; \ + for(i = insts; i->kind || i->opcode; ++i) { \ + if (i->kind) { kind = i->kind; continue; } \ + if (!first) { hsc_printf("\n ,"); } else { first = 0; } \ + hsc_printf( \ + " (CPPOpcode %d,\"%s\",\"%s\", %s)", \ + i->opcode, i->name, i->clas, kind \ + ); \ + } \ + hsc_printf(" ] "); \ +} +} + +data InstructionKind = Terminator | Unary | Binary | Memory | Cast | FuncletPad | Other + deriving (Eq, Ord, Show) + +data InstructionDef = InstructionDef { + cppOpcode :: CPPOpcode, + cAPIName :: String, + cAPIClassName :: String, + instructionKind :: InstructionKind + } + deriving (Eq, Ord, Show) + +instructionDefs :: [InstructionDef] +instructionDefs = [ + InstructionDef o an acn k + | (o, an, acn, k) <- + #{inject}, + an /= "UserOp1" && an /= "UserOp2" + ] + diff --git a/src/LLVM/Internal/FFI/Iterate.hs b/src/LLVM/Internal/FFI/Iterate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Iterate.hs @@ -0,0 +1,13 @@ +-- | Functions to help handle LLVM iteration patterns +module LLVM.Internal.FFI.Iterate where + +import LLVM.Prelude + +import Foreign.Ptr + +-- | retrieve a sequence of objects which form a linked list, given an action to +-- | retrieve the first member and an action to proceed through the list +getXs :: IO (Ptr a) -> (Ptr a -> IO (Ptr a)) -> IO [Ptr a] +getXs firstX nextX = walk =<< firstX + where walk x | x == nullPtr = return [] + walk x = (x:) <$> (walk <=< nextX) x diff --git a/src/LLVM/Internal/FFI/LLVMCTypes.hsc b/src/LLVM/Internal/FFI/LLVMCTypes.hsc new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/LLVMCTypes.hsc @@ -0,0 +1,378 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + PatternSynonyms + #-} +-- | Define types which correspond cleanly with some simple types on the C/C++ side. +-- Encapsulate hsc macro weirdness here, supporting higher-level tricks elsewhere. +module LLVM.Internal.FFI.LLVMCTypes where + +import LLVM.Prelude + +#ifndef __STDC_LIMIT_MACROS +#define __STDC_LIMIT_MACROS +#endif +#include "llvm-c/Core.h" +#include "llvm-c/Linker.h" +#include "llvm-c/Orc.h" +#include "llvm-c/Target.h" +#include "llvm-c/TargetMachine.h" +#include "LLVM/Internal/FFI/Analysis.h" +#include "LLVM/Internal/FFI/Attribute.h" +#include "LLVM/Internal/FFI/CallingConvention.h" +#include "LLVM/Internal/FFI/Constant.h" +#include "LLVM/Internal/FFI/GlobalValue.h" +#include "LLVM/Internal/FFI/InlineAssembly.h" +#include "LLVM/Internal/FFI/Instruction.h" +#include "LLVM/Internal/FFI/LibFunc.h" +#include "LLVM/Internal/FFI/Metadata.h" +#include "LLVM/Internal/FFI/OrcJIT.h" +#include "LLVM/Internal/FFI/SMDiagnostic.h" +#include "LLVM/Internal/FFI/Target.h" +#include "LLVM/Internal/FFI/Type.h" +#include "LLVM/Internal/FFI/Value.h" + +import Language.Haskell.TH.Quote + +import Data.Bits +import Foreign.C +import Foreign.Storable + +#{ +define hsc_inject(l, typ, cons, hprefix, recmac) { \ + struct { const char *s; unsigned n; } *p, list[] = { LLVM_HS_FOR_EACH_ ## l(recmac) }; \ + for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \ + hsc_printf(#hprefix "%s :: " #typ "\n", p->s); \ + hsc_printf(#hprefix "%s = " #cons " %u\n", p->s, p->n); \ + } \ + hsc_printf(#hprefix "P :: QuasiQuoter\n" \ + #hprefix "P = QuasiQuoter {\n" \ + " quoteExp = undefined,\n" \ + " quotePat = \\s -> dataToPatQ (const Nothing) $ case s of"); \ + for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \ + hsc_printf("\n \"%s\" -> " #hprefix "%s", p->s, p->s); \ + } \ + hsc_printf("\n x -> error $ \"bad quasiquoted FFI constant for " #hprefix ": \" ++ x"); \ + hsc_printf(",\n" \ + " quoteType = undefined,\n" \ + " quoteDec = undefined\n" \ + " }\n"); \ +} +} + +#{ +define hsc_patsyn(l, typ, cons, hprefix, recmac) { \ + struct { const char *s; unsigned n; } *p, list[] = { LLVM_HS_FOR_EACH_ ## l(recmac) }; \ + for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \ + hsc_printf("pattern " #hprefix "%s :: " #typ "\n", p->s); \ + hsc_printf("pattern " #hprefix "%s = " #cons " %u\n", p->s, p->n); \ + } \ +} +} + +#define DW_OP_Rec(n) { #n, LLVM_Hs_DwOp_##n }, +#{patsyn DW_OP, Word64, , DwOp_, DW_OP_Rec} + +newtype Encoding = Encoding CUInt + deriving (Data, Show) + +#define DW_ATE_Rec(n) { #n, LLVM_Hs_DwAtE_##n }, +#{patsyn DW_ATE, Encoding, Encoding, DwAtE_, DW_ATE_Rec} + +newtype DwTag = DwTag Word16 + deriving (Data, Show) + +#define DW_TAG_Rec(n) { #n, LLVM_Hs_DwTag_##n }, +#{patsyn DW_TAG, DwTag, DwTag, DwTag_, DW_TAG_Rec} + +newtype DwVirtuality = DwVirtuality Word8 + deriving (Data, Show) + +#define DW_VIRTUALITY_Rec(n) { #n, LLVM_Hs_DwVirtuality_##n }, +#{patsyn DW_VIRTUALITY, DwVirtuality, DwVirtuality, DwVirtuality_, DW_VIRTUALITY_Rec} + +deriving instance Data CUInt + +newtype LLVMBool = LLVMBool CUInt + +-- | If an FFI function returns a value wrapped in 'OwnerTransfered', +-- this value needs to be freed after it has been processed. Usually +-- this is done automatically in the 'DecodeM' instance. +newtype OwnerTransfered a = OwnerTransfered a + deriving (Eq, Storable) + +newtype NothingAsMinusOne h = NothingAsMinusOne CInt + deriving (Storable) + +newtype NothingAsEmptyString c = NothingAsEmptyString c + deriving (Storable) + +newtype CPPOpcode = CPPOpcode CUInt + deriving (Eq, Ord, Show, Typeable, Data, Generic) + +newtype ICmpPredicate = ICmpPredicate CUInt + deriving (Eq, Ord, Show, Typeable, Data, Generic) +#{enum ICmpPredicate, ICmpPredicate, + iCmpPredEQ = LLVMIntEQ, + iCmpPredNE = LLVMIntNE, + iCmpPredUGT = LLVMIntUGT, + iCmpPredUGE = LLVMIntUGE, + iCmpPredULT = LLVMIntULT, + iCmpPredULE = LLVMIntULE, + iCmpPredSGT = LLVMIntSGT, + iCmpPredSGE = LLVMIntSGE, + iCmpPredSLT = LLVMIntSLT, + iCmpPredSLE = LLVMIntSLE +} + +newtype FCmpPredicate = FCmpPredicate CUInt + deriving (Eq, Ord, Show, Typeable, Data, Generic) +#{enum FCmpPredicate, FCmpPredicate, + fCmpPredFalse = LLVMRealPredicateFalse, + fCmpPredOEQ = LLVMRealOEQ, + fCmpPredOGT = LLVMRealOGT, + fCmpPredOGE = LLVMRealOGE, + fCmpPredOLT = LLVMRealOLT, + fCmpPredOLE = LLVMRealOLE, + fCmpPredONE = LLVMRealONE, + fCmpPredORD = LLVMRealORD, + fCmpPredUNO = LLVMRealUNO, + fCmpPredUEQ = LLVMRealUEQ, + fCmpPredUGT = LLVMRealUGT, + fCmpPredUGE = LLVMRealUGE, + fCmpPredULT = LLVMRealULT, + fCmpPredULE = LLVMRealULE, + fCmpPredUNE = LLVMRealUNE, + fcmpPredTrue = LLVMRealPredicateTrue +} + +newtype MDKindID = MDKindID CUInt + deriving (Storable) + +newtype MDSubclassID = MDSubclassID CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define MDSID_Rec(n) { #n, n ## Kind }, +#{inject MDNODE_SUBCLASS, MDSubclassID, MDSubclassID, mdSubclassId, MDSID_Rec} + +newtype FastMathFlags = FastMathFlags CUInt + deriving (Eq, Ord, Show, Typeable, Data, Num, Bits, Generic) +#define FMF_Rec(n,l,ignored) { #n, LLVM ## n, }, +#{inject FAST_MATH_FLAG, FastMathFlags, FastMathFlags, fastMathFlags, FMF_Rec} + +newtype MemoryOrdering = MemoryOrdering CUInt + deriving (Eq, Show, Typeable, Data, Generic) +#define MO_Rec(n) { #n, LLVMAtomicOrdering ## n }, +#{inject ATOMIC_ORDERING, MemoryOrdering, MemoryOrdering, memoryOrdering, MO_Rec} + +newtype UnnamedAddr = UnnamedAddr CUInt + deriving (Eq, Show, Typeable, Data, Generic) +#define UA_Rec(n) { #n, LLVM ## n ## UnnamedAddr }, +#{inject UNNAMED_ADDR, UnnamedAddr, UnnamedAddr, unnamedAddr, UA_Rec} + +newtype SynchronizationScope = SynchronizationScope CUInt + deriving (Eq, Show, Typeable, Data, Generic) +#define SS_Rec(n) { #n, LLVM ## n ## SynchronizationScope }, +#{inject SYNCRONIZATION_SCOPE, SynchronizationScope, SynchronizationScope, synchronizationScope, SS_Rec} + +newtype TailCallKind = TailCallKind CUInt + deriving (Eq, Show, Typeable, Data, Generic) +#define TCK_Rec(n) { #n, LLVM_Hs_TailCallKind_ ## n }, +#{inject TAIL_CALL_KIND, TailCallKind, TailCallKind, tailCallKind, TCK_Rec} + +newtype Linkage = Linkage CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define LK_Rec(n) { #n, LLVM ## n ## Linkage }, +#{inject LINKAGE, Linkage, Linkage, linkage, LK_Rec} + +newtype Visibility = Visibility CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define VIS_Rec(n) { #n, LLVM ## n ## Visibility }, +#{inject VISIBILITY, Visibility, Visibility, visibility, VIS_Rec} + +newtype COMDATSelectionKind = COMDATSelectionKind CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define CSK(n) { #n, LLVM_Hs_COMDAT_Selection_Kind_ ## n }, +#{inject COMDAT_SELECTION_KIND, COMDATSelectionKind, COMDATSelectionKind, comdatSelectionKind, CSK} + +newtype DLLStorageClass = DLLStorageClass CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define DLLSC_Rec(n) { #n, LLVM ## n ## StorageClass }, +#{inject DLL_STORAGE_CLASS, DLLStorageClass, DLLStorageClass, dllStorageClass, DLLSC_Rec} + +newtype CallingConvention = CallingConvention CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define CC_Rec(l, n) { #l, LLVM_Hs_CallingConvention_ ## l }, +#{inject CALLING_CONVENTION, CallingConvention, CallingConvention, callingConvention, CC_Rec} + +newtype ThreadLocalMode = ThreadLocalMode CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define TLS_Rec(n) { #n, LLVM ## n }, +#{inject THREAD_LOCAL_MODE, ThreadLocalMode, ThreadLocalMode, threadLocalMode, TLS_Rec} + +newtype ValueSubclassId = ValueSubclassId CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define VSID_Rec(n) { #n, LLVM ## n ## SubclassId }, +#{inject VALUE_SUBCLASS, ValueSubclassId, ValueSubclassId, valueSubclassId, VSID_Rec} + +newtype DiagnosticKind = DiagnosticKind CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define DK_Rec(n) { #n, LLVMDiagnosticKind ## n }, +#{inject DIAGNOSTIC_KIND, DiagnosticKind, DiagnosticKind, diagnosticKind, DK_Rec} + +newtype AsmDialect = AsmDialect CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define ASM_Rec(n) { #n, LLVMAsmDialect_ ## n }, +#{inject ASM_DIALECT, AsmDialect, AsmDialect, asmDialect, ASM_Rec} + +newtype RMWOperation = RMWOperation CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define RMWOp_Rec(n) { #n, LLVMAtomicRMWBinOp_ ## n }, +#{inject RMW_OPERATION, RMWOperation, RMWOperation, rmwOperation, RMWOp_Rec} + +newtype RelocModel = RelocModel CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define RM_Rec(n,m) { #n, LLVMReloc ## n }, +#{inject RELOC_MODEL, RelocModel, RelocModel, relocModel, RM_Rec} + +newtype CodeModel = CodeModel CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define CM_Rec(n) { #n, LLVMCodeModel ## n }, +#{inject CODE_MODEL, CodeModel, CodeModel, codeModel, CM_Rec} + +newtype CodeGenOptLevel = CodeGenOptLevel CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define CGOL_Rec(n) { #n, LLVMCodeGenLevel ## n }, +#{inject CODE_GEN_OPT_LEVEL, CodeGenOptLevel, CodeGenOptLevel, codeGenOptLevel, CGOL_Rec} + +newtype CodeGenFileType = CodeGenFileType CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define CGFT_Rec(n) { #n, LLVM ## n ## File }, +#{inject CODE_GEN_FILE_TYPE, CodeGenFileType, CodeGenFileType, codeGenFileType, CGFT_Rec} + +newtype FloatABIType = FloatABIType CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define FAT_Rec(n) { #n, LLVM_Hs_FloatABI_ ## n }, +#{inject FLOAT_ABI, FloatABIType, FloatABIType, floatABI, FAT_Rec} + +newtype FPOpFusionMode = FPOpFusionMode CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define FPOFM_Rec(n) { #n, LLVM_Hs_FPOpFusionMode_ ## n }, +#{inject FP_OP_FUSION_MODE, FPOpFusionMode, FPOpFusionMode, fpOpFusionMode, FPOFM_Rec} + +newtype ThreadModel = ThreadModel CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define TM_Rec(n) { #n, LLVM_Hs_ThreadModel_ ## n }, +#{inject THREAD_MODEL, ThreadModel, ThreadModel, threadModel, TM_Rec} + +newtype EABI = EABI CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define EABI_Rec(n) { #n, LLVM_Hs_EABI_ ## n }, +#{inject EABI, EABI, EABI, eabiVersion, EABI_Rec} + +newtype DebuggerKind = DebuggerKind CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define DBGK_Rec(n) { #n, LLVM_Hs_DebuggerKind_ ## n }, +#{inject DEBUGGER_KIND, DebuggerKind, DebuggerKind, debuggerKind, DBGK_Rec} + +newtype FPDenormalMode = FPDenormalMode CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define FPDM_Rec(n) { #n, LLVM_Hs_FPDenormalMode_ ## n }, +#{inject FP_DENORMAL_MODE, FPDenormalMode, FPDenormalMode, fpDenormalMode, FPDM_Rec} + +newtype ExceptionHandling = ExceptionHandling CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define EH_Rec(n) { #n, LLVM_Hs_ExceptionHandling_ ## n }, +#{inject EXCEPTION_HANDLING, ExceptionHandling, ExceptionHandling, exceptionHandling, EH_Rec} + +newtype TargetOptionFlag = TargetOptionFlag CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define TOF_Rec(n) { #n, LLVM_Hs_TargetOptionFlag_ ## n }, +#{inject TARGET_OPTION_FLAG, TargetOptionFlag, TargetOptionFlag, targetOptionFlag, TOF_Rec} + +newtype MCTargetOptionFlag = MCTargetOptionFlag CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define MCTOF_Rec(n) { #n, LLVM_Hs_MCTargetOptionFlag_ ## n }, +#{inject MC_TARGET_OPTION_FLAG, MCTargetOptionFlag, MCTargetOptionFlag, mcTargetOptionFlag, MCTOF_Rec} + +newtype DebugCompressionType = DebugCompressionType CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define DCT_Rec(n) { #n, LLVM_Hs_DebugCompressionType_ ## n }, +#{inject DEBUG_COMPRESSION_TYPE, DebugCompressionType, DebugCompressionType, debugCompressionType, DCT_Rec} + +newtype TypeKind = TypeKind CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define TK_Rec(n) { #n, LLVM ## n ## TypeKind }, +#{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec} + +#define COMMA , +#define IF_T(z) z +#define IF_F(z) +#define IF2(x) IF_ ## x +#define IF(x) IF2(x) +#define OR_TT T +#define OR_TF T +#define OR_FT T +#define OR_FF F +#define OR(x,y) OR_ ## x ## y +newtype ParameterAttributeKind = ParameterAttributeKind CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define PAK_Rec(n,p,r,f) IF(OR(p,r))({ #n COMMA LLVM_Hs_AttributeKind_ ## n} COMMA) +#{inject ATTRIBUTE_KIND, ParameterAttributeKind, ParameterAttributeKind, parameterAttributeKind, PAK_Rec} + +newtype FunctionAttributeKind = FunctionAttributeKind CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define FAK_Rec(n,p,r,f) IF(f)({ #n COMMA LLVM_Hs_AttributeKind_ ## n} COMMA) +#{inject ATTRIBUTE_KIND, FunctionAttributeKind, FunctionAttributeKind, functionAttributeKind, FAK_Rec} + +newtype FloatSemantics = FloatSemantics CUInt + deriving (Eq, Read, Show, Typeable, Data, Generic) +#define FS_Rec(n) { #n, LLVMFloatSemantics ## n }, +#{inject FLOAT_SEMANTICS, FloatSemantics, FloatSemantics, floatSemantics, FS_Rec} + +newtype VerifierFailureAction = VerifierFailureAction CUInt + deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Generic) +#define VFA_Rec(n) { #n, LLVM ## n ## Action }, +#{inject VERIFIER_FAILURE_ACTION, VerifierFailureAction, VerifierFailureAction, verifierFailureAction, VFA_Rec} + +newtype LibFunc = LibFunc CUInt + deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable, Generic) +#define LF_Rec(n) { #n, LLVMLibFunc__ ## n }, +#{inject LIB_FUNC, LibFunc, LibFunc, libFunc__, LF_Rec} + +newtype JITSymbolFlags = JITSymbolFlags CUInt + deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable, Generic) + +#define SF_Rec(n) { #n, LLVMJITSymbolFlag ## n }, +#{inject JIT_SYMBOL_FLAG, JITSymbolFlags, JITSymbolFlags, jitSymbolFlags, SF_Rec} + +newtype ChecksumKind = ChecksumKind CUInt + deriving (Data, Show) + +newtype Macinfo = Macinfo CUInt + deriving (Data, Show) + +pattern DW_Macinfo_Define :: Macinfo +pattern DW_Macinfo_Define = Macinfo 0x01 +pattern DW_Macinfo_Undef :: Macinfo +pattern DW_Macinfo_Undef = Macinfo 0x02 + +newtype DebugEmissionKind = DebugEmissionKind CUInt + deriving (Data, Show) + +pattern NoDebug :: DebugEmissionKind +pattern NoDebug = DebugEmissionKind 0 +pattern FullDebug :: DebugEmissionKind +pattern FullDebug = DebugEmissionKind 1 +pattern LineTablesOnly :: DebugEmissionKind +pattern LineTablesOnly = DebugEmissionKind 2 + +newtype DebugNameTableKind = DebugNameTableKind CUInt + deriving (Data, Show) + +pattern NameTableKindDefault :: DebugNameTableKind +pattern NameTableKindDefault = DebugNameTableKind 0 + +pattern NameTableKindGNU :: DebugNameTableKind +pattern NameTableKindGNU = DebugNameTableKind 1 + +pattern NameTableKindNone :: DebugNameTableKind +pattern NameTableKindNone = DebugNameTableKind 2 diff --git a/src/LLVM/Internal/FFI/LibFunc.h b/src/LLVM/Internal/FFI/LibFunc.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/LibFunc.h @@ -0,0 +1,332 @@ +#ifndef __LLVM_INTERNAL_FFI__LIB_FUNC__H__ +#define __LLVM_INTERNAL_FFI__LIB_FUNC__H__ + +#define LLVM_HS_FOR_EACH_LIB_FUNC(macro) \ + macro(under_IO_getc) \ + macro(under_IO_putc) \ + macro(ZdaPv) \ + macro(ZdaPvRKSt9nothrow_t) \ + macro(ZdlPv) \ + macro(ZdlPvRKSt9nothrow_t) \ + macro(Znaj) \ + macro(ZnajRKSt9nothrow_t) \ + macro(Znam) \ + macro(ZnamRKSt9nothrow_t) \ + macro(Znwj) \ + macro(ZnwjRKSt9nothrow_t) \ + macro(Znwm) \ + macro(ZnwmRKSt9nothrow_t) \ + macro(cospi) \ + macro(cospif) \ + macro(cxa_atexit) \ + macro(cxa_guard_abort) \ + macro(cxa_guard_acquire) \ + macro(cxa_guard_release) \ + macro(dunder_isoc99_scanf) \ + macro(dunder_isoc99_sscanf) \ + macro(memcpy_chk) \ + macro(sincospi_stret) \ + macro(sincospif_stret) \ + macro(sinpi) \ + macro(sinpif) \ + macro(sqrt_finite) \ + macro(sqrtf_finite) \ + macro(sqrtl_finite) \ + macro(dunder_strdup) \ + macro(dunder_strndup) \ + macro(dunder_strtok_r) \ + macro(abs) \ + macro(access) \ + macro(acos) \ + macro(acosf) \ + macro(acosh) \ + macro(acoshf) \ + macro(acoshl) \ + macro(acosl) \ + macro(asin) \ + macro(asinf) \ + macro(asinh) \ + macro(asinhf) \ + macro(asinhl) \ + macro(asinl) \ + macro(atan) \ + macro(atan2) \ + macro(atan2f) \ + macro(atan2l) \ + macro(atanf) \ + macro(atanh) \ + macro(atanhf) \ + macro(atanhl) \ + macro(atanl) \ + macro(atof) \ + macro(atoi) \ + macro(atol) \ + macro(atoll) \ + macro(bcmp) \ + macro(bcopy) \ + macro(bzero) \ + macro(calloc) \ + macro(cbrt) \ + macro(cbrtf) \ + macro(cbrtl) \ + macro(ceil) \ + macro(ceilf) \ + macro(ceill) \ + macro(chmod) \ + macro(chown) \ + macro(clearerr) \ + macro(closedir) \ + macro(copysign) \ + macro(copysignf) \ + macro(copysignl) \ + macro(cos) \ + macro(cosf) \ + macro(cosh) \ + macro(coshf) \ + macro(coshl) \ + macro(cosl) \ + macro(ctermid) \ + macro(exp) \ + macro(exp10) \ + macro(exp10f) \ + macro(exp10l) \ + macro(exp2) \ + macro(exp2f) \ + macro(exp2l) \ + macro(expf) \ + macro(expl) \ + macro(expm1) \ + macro(expm1f) \ + macro(expm1l) \ + macro(fabs) \ + macro(fabsf) \ + macro(fabsl) \ + macro(fclose) \ + macro(fdopen) \ + macro(feof) \ + macro(ferror) \ + macro(fflush) \ + macro(ffs) \ + macro(ffsl) \ + macro(ffsll) \ + macro(fgetc) \ + macro(fgetpos) \ + macro(fgets) \ + macro(fileno) \ + macro(fiprintf) \ + macro(flockfile) \ + macro(floor) \ + macro(floorf) \ + macro(floorl) \ + macro(fmax) \ + macro(fmaxf) \ + macro(fmaxl) \ + macro(fmin) \ + macro(fminf) \ + macro(fminl) \ + macro(fmod) \ + macro(fmodf) \ + macro(fmodl) \ + macro(fopen) \ + macro(fopen64) \ + macro(fprintf) \ + macro(fputc) \ + macro(fputs) \ + macro(fread) \ + macro(free) \ + macro(frexp) \ + macro(frexpf) \ + macro(frexpl) \ + macro(fscanf) \ + macro(fseek) \ + macro(fseeko) \ + macro(fseeko64) \ + macro(fsetpos) \ + macro(fstat) \ + macro(fstat64) \ + macro(fstatvfs) \ + macro(fstatvfs64) \ + macro(ftell) \ + macro(ftello) \ + macro(ftello64) \ + macro(ftrylockfile) \ + macro(funlockfile) \ + macro(fwrite) \ + macro(getc) \ + macro(getc_unlocked) \ + macro(getchar) \ + macro(getenv) \ + macro(getitimer) \ + macro(getlogin_r) \ + macro(getpwnam) \ + macro(gets) \ + macro(gettimeofday) \ + macro(htonl) \ + macro(htons) \ + macro(iprintf) \ + macro(isascii) \ + macro(isdigit) \ + macro(labs) \ + macro(lchown) \ + macro(ldexp) \ + macro(ldexpf) \ + macro(ldexpl) \ + macro(llabs) \ + macro(log) \ + macro(log10) \ + macro(log10f) \ + macro(log10l) \ + macro(log1p) \ + macro(log1pf) \ + macro(log1pl) \ + macro(log2) \ + macro(log2f) \ + macro(log2l) \ + macro(logb) \ + macro(logbf) \ + macro(logbl) \ + macro(logf) \ + macro(logl) \ + macro(lstat) \ + macro(lstat64) \ + macro(malloc) \ + macro(memalign) \ + macro(memccpy) \ + macro(memchr) \ + macro(memcmp) \ + macro(memcpy) \ + macro(memmove) \ + macro(memrchr) \ + macro(memset) \ + macro(memset_pattern16) \ + macro(mkdir) \ + macro(mktime) \ + macro(modf) \ + macro(modff) \ + macro(modfl) \ + macro(nearbyint) \ + macro(nearbyintf) \ + macro(nearbyintl) \ + macro(ntohl) \ + macro(ntohs) \ + macro(open) \ + macro(open64) \ + macro(opendir) \ + macro(pclose) \ + macro(perror) \ + macro(popen) \ + macro(posix_memalign) \ + macro(pow) \ + macro(powf) \ + macro(powl) \ + macro(pread) \ + macro(printf) \ + macro(putc) \ + macro(putchar) \ + macro(puts) \ + macro(pwrite) \ + macro(qsort) \ + macro(read) \ + macro(readlink) \ + macro(realloc) \ + macro(reallocf) \ + macro(realpath) \ + macro(remove) \ + macro(rename) \ + macro(rewind) \ + macro(rint) \ + macro(rintf) \ + macro(rintl) \ + macro(rmdir) \ + macro(round) \ + macro(roundf) \ + macro(roundl) \ + macro(scanf) \ + macro(setbuf) \ + macro(setitimer) \ + macro(setvbuf) \ + macro(sin) \ + macro(sinf) \ + macro(sinh) \ + macro(sinhf) \ + macro(sinhl) \ + macro(sinl) \ + macro(siprintf) \ + macro(snprintf) \ + macro(sprintf) \ + macro(sqrt) \ + macro(sqrtf) \ + macro(sqrtl) \ + macro(sscanf) \ + macro(stat) \ + macro(stat64) \ + macro(statvfs) \ + macro(statvfs64) \ + macro(stpcpy) \ + macro(stpncpy) \ + macro(strcasecmp) \ + macro(strcat) \ + macro(strchr) \ + macro(strcmp) \ + macro(strcoll) \ + macro(strcpy) \ + macro(strcspn) \ + macro(strdup) \ + macro(strlen) \ + macro(strncasecmp) \ + macro(strncat) \ + macro(strncmp) \ + macro(strncpy) \ + macro(strndup) \ + macro(strnlen) \ + macro(strpbrk) \ + macro(strrchr) \ + macro(strspn) \ + macro(strstr) \ + macro(strtod) \ + macro(strtof) \ + macro(strtok) \ + macro(strtok_r) \ + macro(strtol) \ + macro(strtold) \ + macro(strtoll) \ + macro(strtoul) \ + macro(strtoull) \ + macro(strxfrm) \ + macro(system) \ + macro(tan) \ + macro(tanf) \ + macro(tanh) \ + macro(tanhf) \ + macro(tanhl) \ + macro(tanl) \ + macro(times) \ + macro(tmpfile) \ + macro(tmpfile64) \ + macro(toascii) \ + macro(trunc) \ + macro(truncf) \ + macro(truncl) \ + macro(uname) \ + macro(ungetc) \ + macro(unlink) \ + macro(unsetenv) \ + macro(utime) \ + macro(utimes) \ + macro(valloc) \ + macro(vfprintf) \ + macro(vfscanf) \ + macro(vprintf) \ + macro(vscanf) \ + macro(vsnprintf) \ + macro(vsprintf) \ + macro(vsscanf) \ + macro(write) + +typedef enum { +#define ENUM_CASE(x) LLVMLibFunc__ ## x, +LLVM_HS_FOR_EACH_LIB_FUNC(ENUM_CASE) +#undef ENUM_CASE +} LLVMLibFunc; + +#endif diff --git a/src/LLVM/Internal/FFI/MemoryBuffer.hs b/src/LLVM/Internal/FFI/MemoryBuffer.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/MemoryBuffer.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.MemoryBuffer where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes + +data MemoryBuffer + +foreign import ccall unsafe "LLVMCreateMemoryBufferWithContentsOfFile" createMemoryBufferWithContentsOfFile :: + Ptr CChar -> Ptr (Ptr MemoryBuffer) -> Ptr (OwnerTransfered CString) -> IO LLVMBool + +foreign import ccall unsafe "LLVMCreateMemoryBufferWithMemoryRange" createMemoryBufferWithMemoryRange :: + Ptr CChar -> CSize -> CString -> LLVMBool -> IO (Ptr MemoryBuffer) + +foreign import ccall unsafe "LLVMGetBufferStart" getBufferStart :: + Ptr MemoryBuffer -> IO (Ptr CChar) + +foreign import ccall unsafe "LLVMGetBufferSize" getBufferSize :: + Ptr MemoryBuffer -> IO CSize + +foreign import ccall unsafe "LLVMDisposeMemoryBuffer" disposeMemoryBuffer :: + Ptr MemoryBuffer -> IO () diff --git a/src/LLVM/Internal/FFI/Metadata.h b/src/LLVM/Internal/FFI/Metadata.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Metadata.h @@ -0,0 +1,142 @@ +#ifndef __LLVM_INTERNAL_FFI__METADATA__H__ +#define __LLVM_INTERNAL_FFI__METADATA__H__ + +enum { +#define HANDLE_METADATA_LEAF(CLASS) CLASS##Kind, +#include "llvm/IR/Metadata.def" +#undef HANDLE_METADATA_LEAF +} MetadataSubclassId; + +#define LLVM_HS_FOR_EACH_MDNODE_SUBCLASS(macro) \ + macro(MDString) \ + macro(ConstantAsMetadata) \ + macro(LocalAsMetadata) \ + macro(DistinctMDOperandPlaceholder) \ + macro(MDTuple) \ + macro(DILocation) \ + macro(DIExpression) \ + macro(DIGlobalVariableExpression) \ + macro(GenericDINode) \ + macro(DISubrange) \ + macro(DIEnumerator) \ + macro(DIBasicType) \ + macro(DIDerivedType) \ + macro(DICompositeType) \ + macro(DISubroutineType) \ + macro(DIFile) \ + macro(DICompileUnit) \ + macro(DISubprogram) \ + macro(DILexicalBlock) \ + macro(DILexicalBlockFile) \ + macro(DINamespace) \ + macro(DIModule) \ + macro(DITemplateTypeParameter) \ + macro(DITemplateValueParameter) \ + macro(DIGlobalVariable) \ + macro(DILocalVariable) \ + macro(DIObjCProperty) \ + macro(DIImportedEntity) \ + macro(DIMacro) \ + macro(DIMacroFile) + +enum LLVM_Hs_DwOp { +#define HANDLE_DW_OP(ID, NAME, VERSION, VENDOR) LLVM_Hs_DwOp_##NAME = ID, +#include "llvm/BinaryFormat/Dwarf.def" +#undef HANDLE_DW_OP + LLVM_Hs_DwOp_LLVM_fragment = 0x1000 +}; + +#define LLVM_HS_FOR_EACH_DW_OP(macro) \ + macro(and) \ + macro(bregx) \ + macro(constu) \ + macro(deref) \ + macro(div) \ + macro(dup) \ + macro(lit0) \ + macro(LLVM_fragment) \ + macro(minus) \ + macro(mod) \ + macro(mul) \ + macro(not) \ + macro(or) \ + macro(plus) \ + macro(plus_uconst) \ + macro(push_object_address) \ + macro(shl) \ + macro(shr) \ + macro(shra) \ + macro(stack_value) \ + macro(swap) \ + macro(xderef) \ + macro(xor) + +enum LLVM_Hs_DwAtE { +#define HANDLE_DW_ATE(ID, NAME, VERSION, VENDOR) LLVM_Hs_DwAtE_##NAME = ID, +#include "llvm/BinaryFormat/Dwarf.def" +#undef HANDLE_DW_ATE +}; + +#define LLVM_HS_FOR_EACH_DW_ATE(macro) \ + macro(address) \ + macro(boolean) \ + macro(complex_float) \ + macro(float) \ + macro(signed) \ + macro(signed_char) \ + macro(unsigned) \ + macro(unsigned_char) \ + macro(imaginary_float) \ + macro(packed_decimal) \ + macro(numeric_string) \ + macro(edited) \ + macro(signed_fixed) \ + macro(unsigned_fixed) \ + macro(decimal_float) \ + macro(UTF) \ + macro(UCS) \ + macro(ASCII) + +enum LLVM_Hs_DwTag { +#define HANDLE_DW_TAG(ID, NAME, VERSION, VENDOR, KIND) LLVM_Hs_DwTag_##NAME = ID, +#include "llvm/BinaryFormat/Dwarf.def" +#undef HANDLE_DW_TAG +}; + +#define LLVM_HS_FOR_EACH_DW_TAG(macro) \ + macro(imported_module) \ + macro(imported_declaration) \ + macro(typedef) \ + macro(pointer_type) \ + macro(ptr_to_member_type) \ + macro(reference_type) \ + macro(rvalue_reference_type) \ + macro(const_type) \ + macro(volatile_type) \ + macro(restrict_type) \ + macro(atomic_type) \ + macro(member) \ + macro(inheritance) \ + macro(friend) \ + macro(base_type) \ + macro(unspecified_type) \ + macro(template_value_parameter) \ + macro(GNU_template_template_param) \ + macro(GNU_template_parameter_pack) \ + macro(array_type) \ + macro(enumeration_type) \ + macro(structure_type) \ + macro(class_type) \ + macro(union_type) + +enum LLVM_Hs_DwVirtuality { +#define HANDLE_DW_VIRTUALITY(ID, NAME) LLVM_Hs_DwVirtuality_##NAME = ID, +#include "llvm/BinaryFormat/Dwarf.def" +#undef HANDLE_DW_VIRTUALITY +}; + +#define LLVM_HS_FOR_EACH_DW_VIRTUALITY(macro) \ + macro(none) \ + macro(virtual) \ + macro(pure_virtual) +#endif diff --git a/src/LLVM/Internal/FFI/Metadata.hs b/src/LLVM/Internal/FFI/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Metadata.hs @@ -0,0 +1,655 @@ +{-# + LANGUAGE + ForeignFunctionInterface + #-} + +module LLVM.Internal.FFI.Metadata where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.LLVMCTypes + +newtype DIFlags = DIFlags Word32 + deriving (Show, Eq) + +data DITemplateParameterArray + +-- | A 'TupleArray a' stores an array of elements of type 'Ptr a' using an 'MDTuple'. +newtype TupleArray a = TupleArray (Ptr MDTuple) + +foreign import ccall unsafe "LLVM_Hs_IsAMDString" isAMDString :: + Ptr Metadata -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_IsAMDNode" isAMDNode :: + Ptr Metadata -> IO (Ptr MDNode) + +foreign import ccall unsafe "LLVM_Hs_IsAMDValue" isAMDValue :: + Ptr Metadata -> IO (Ptr MDValue) + +foreign import ccall unsafe "LLVM_Hs_IsAMetadataOperand" isAMetadataOperand :: + Ptr Value -> IO (Ptr MetadataAsVal) + +foreign import ccall unsafe "LLVM_Hs_GetMetadataClassId" getMetadataClassId :: + Ptr MDNode -> IO (MDSubclassID) + +foreign import ccall unsafe "LLVM_Hs_IsADIVariable" isADIVariable :: + Ptr Metadata -> IO (Ptr DIVariable) + +foreign import ccall unsafe "LLVM_Hs_IsADIExpression" isADIExpression :: + Ptr Metadata -> IO (Ptr DIExpression) + +-- DILocation + +foreign import ccall unsafe "LLVM_Hs_DILocation_GetLine" getDILocationLine :: + Ptr DILocation -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DILocation_GetColumn" getDILocationColumn :: + Ptr DILocation -> IO Word16 + +foreign import ccall unsafe "LLVM_Hs_DILocation_GetScope" getDILocationScope :: + Ptr DILocation -> IO (Ptr DILocalScope) + +foreign import ccall unsafe "LLVM_Hs_Get_DILocation" getDILocation :: + Ptr Context -> Word32 -> Word16 -> Ptr DILocalScope -> IO (Ptr DILocation) + +foreign import ccall unsafe "LLVM_Hs_GetMDValue" getMDValue :: + Ptr MDValue -> IO (Ptr Value) + +{- +foreign import ccall unsafe "LLVM_Hs_DumpMetadata" dumpMetadata :: + Ptr Metadata -> IO () +-} + +foreign import ccall unsafe "LLVM_Hs_GetMetadataOperand" getMetadataOperand :: + Ptr MetadataAsVal -> IO (Ptr Metadata) + +foreign import ccall unsafe "LLVMGetMDKindIDInContext" getMDKindIDInContext' :: + Ptr Context -> Ptr CChar -> CUInt -> IO MDKindID + +getMDKindIDInContext :: Ptr Context -> (Ptr CChar, CUInt) -> IO MDKindID +getMDKindIDInContext ctx (c, n) = getMDKindIDInContext' ctx c n + +foreign import ccall unsafe "LLVM_Hs_GetMDKindNames" getMDKindNames :: + Ptr Context -> Ptr (Ptr CChar) -> Ptr CUInt -> CUInt -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GetMDString" getMDString' :: + Ptr Context -> CString -> CUInt -> IO (Ptr MDString) + +getMDString :: Ptr Context -> (CString, CUInt) -> IO (Ptr MDString) +getMDString ctx (p, n) = getMDString' ctx p n + +foreign import ccall unsafe "LLVM_Hs_MDValue" mdValue :: + Ptr Value -> IO (Ptr MDValue) + +foreign import ccall unsafe "LLVM_Hs_MetadataOperand" metadataOperand :: + Ptr Context -> Ptr Metadata -> IO (Ptr Value) + +foreign import ccall unsafe "LLVM_Hs_GetMDStringValue" getMDStringValue :: + Ptr MDString -> Ptr CUInt -> IO CString + +foreign import ccall unsafe "LLVM_Hs_Get_MDTuple" getMDTuple' :: + Ptr Context -> Ptr (Ptr Metadata) -> CUInt -> IO (Ptr MDTuple) + +getMDTuple :: Ptr Context -> (CUInt, Ptr (Ptr Metadata)) -> IO (Ptr MDTuple) +getMDTuple ctx (n, vs) = getMDTuple' ctx vs n + +foreign import ccall unsafe "LLVM_Hs_CreateTemporaryMDNodeInContext" createTemporaryMDNodeInContext :: + Ptr Context -> IO (Ptr MDNode) + +foreign import ccall unsafe "LLVM_Hs_DestroyTemporaryMDNode" destroyTemporaryMDNode :: + Ptr MDNode -> IO () + +foreign import ccall unsafe "LLVM_Hs_MDNode_GetNumOperands" getMDNodeNumOperands :: + Ptr MDNode -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_MDNode_GetOperand" getMDNodeOperand :: + Ptr MDNode -> CUInt -> IO (Ptr Metadata) + +foreign import ccall unsafe "LLVM_Hs_GetNamedMetadataName" getNamedMetadataName :: + Ptr NamedMetadata -> Ptr CUInt -> IO (Ptr CChar) + +foreign import ccall unsafe "LLVM_Hs_GetNamedMetadataNumOperands" getNamedMetadataNumOperands :: + Ptr NamedMetadata -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_GetNamedMetadataOperands" getNamedMetadataOperands :: + Ptr NamedMetadata -> Ptr (Ptr MDNode) -> IO () + +foreign import ccall unsafe "LLVM_Hs_NamedMetadataAddOperands" namedMetadataAddOperands' :: + Ptr NamedMetadata -> Ptr (Ptr MDNode) -> CUInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_MetadataReplaceAllUsesWith" metadataReplaceAllUsesWith :: + Ptr MDNode -> Ptr Metadata -> IO () + +namedMetadataAddOperands :: Ptr NamedMetadata -> (CUInt, Ptr (Ptr MDNode)) -> IO () +namedMetadataAddOperands nm (n, vs) = namedMetadataAddOperands' nm vs n + +-- DIEnumerator + +foreign import ccall unsafe "LLVM_Hs_Get_DIEnumerator" getDIEnumerator :: + Ptr Context -> Int64 -> LLVMBool -> Ptr MDString -> IO (Ptr DIEnumerator) + +foreign import ccall unsafe "LLVM_Hs_DIEnumerator_GetValue" getDIEnumeratorValue :: + Ptr DIEnumerator -> IO Int64 + +foreign import ccall unsafe "LLVM_Hs_DIEnumerator_GetIsUnsigned" getDIEnumeratorIsUnsigned :: + Ptr DIEnumerator -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DIEnumerator_GetName" getDIEnumeratorName :: + Ptr DIEnumerator -> IO (Ptr MDString) + + +foreign import ccall unsafe "LLVM_Hs_DIFileGetFilename" getFileFilename :: + Ptr DIFile -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIFileGetDirectory" getFileDirectory :: + Ptr DIFile -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIFileGetChecksum" getFileChecksumValue :: + Ptr DIFile -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIFileGetChecksumKind" getFileChecksumKind :: + Ptr DIFile -> IO ChecksumKind + +foreign import ccall unsafe "LLVM_Hs_DIScope_GetName" getScopeName :: + Ptr DIScope -> Ptr CUInt -> IO CString + +foreign import ccall unsafe "LLVM_Hs_DITypeGetName" getTypeName :: + Ptr DIType -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DITypeGetAlignInBits" getTypeAlignInBits :: + Ptr DIType -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DITypeGetSizeInBits" getTypeSizeInBits :: + Ptr DIType -> IO Word64 + +foreign import ccall unsafe "LLVM_Hs_DITypeGetOffsetInBits" getTypeOffsetInBits :: + Ptr DIType -> IO Word64 + +foreign import ccall unsafe "LLVM_Hs_DINodeGetTag" getTag :: + Ptr DINode -> IO DwTag + +foreign import ccall unsafe "LLVM_Hs_DITypeGetLine" getTypeLine :: + Ptr DIType -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DITypeGetFlags" getTypeFlags :: + Ptr DIType -> IO DIFlags + +foreign import ccall unsafe "LLVM_Hs_DICompositeType_GetElements" getElements :: + Ptr DICompositeType -> IO (Ptr MDTuple) + +foreign import ccall unsafe "LLVM_Hs_DICompositeTypeGetVTableHolder" getVTableHolder :: + Ptr DICompositeType -> IO (Ptr DIType) + +foreign import ccall unsafe "LLVM_Hs_DICompositeTypeGetBaseType" getCompositeBaseType :: + Ptr DICompositeType -> IO (Ptr DIType) + +foreign import ccall unsafe "LLVM_Hs_DICompositeTypeGetRuntimeLang" getRuntimeLang :: + Ptr DICompositeType -> IO Word16 + +foreign import ccall unsafe "LLVM_Hs_DICompositeType_GetTemplateParameters" getTemplateParams :: + Ptr DICompositeType -> IO (TupleArray DITemplateParameter) + +foreign import ccall unsafe "LLVM_Hs_DICompositeTypeGetIdentifier" getIdentifier :: + Ptr DICompositeType -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_Get_DIArrayType" getDIArrayType :: + Ptr Context -> TupleArray DISubrange -> Ptr DIType -> Word64 -> Word32 -> DIFlags -> IO (Ptr DICompositeType) + +foreign import ccall unsafe "LLVM_Hs_Get_DIEnumerationType" getDIEnumerationType :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> Ptr DIFile -> Word32 -> Word64 -> Word32 -> TupleArray DIEnumerator -> Ptr DIType -> Ptr MDString -> IO (Ptr DICompositeType) + +foreign import ccall unsafe "LLVM_Hs_Get_DIStructType" getDIStructType :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> Ptr DIFile -> + Word32 -> Word64 -> Word32 -> DIFlags -> + Ptr DIType -> TupleArray DIScope -> + Word16 -> Ptr DIType -> Ptr MDString -> + IO (Ptr DICompositeType) + +foreign import ccall unsafe "LLVM_Hs_Get_DIUnionType" getDIUnionType :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> Ptr DIFile -> + Word32 -> Word64 -> Word32 -> DIFlags -> + TupleArray DIScope -> + Word16 -> Ptr MDString -> + IO (Ptr DICompositeType) + +foreign import ccall unsafe "LLVM_Hs_Get_DIClassType" getDIClassType :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> Ptr DIFile -> + Word32 -> Word64 -> Word32 -> DIFlags -> + Ptr DIType -> TupleArray DIScope -> + Ptr DIType -> TupleArray DITemplateParameter -> Ptr MDString -> + IO (Ptr DICompositeType) + +foreign import ccall unsafe "LLVM_Hs_Get_DINamespace" getDINamespace :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> LLVMBool -> IO (Ptr DINamespace) + +foreign import ccall unsafe "LLVM_Hs_DINamespace_GetExportSymbols" getNamespaceExportedSymbols :: + Ptr DINamespace -> IO LLVMBool + +-- DIScope + +foreign import ccall unsafe "LLVM_Hs_DIScope_GetScope" getScopeScope :: + Ptr DIScope -> IO (Ptr DIScope) + +foreign import ccall unsafe "LLVM_Hs_DIScope_GetFile" getScopeFile :: + Ptr DIScope -> IO (Ptr DIFile) + +-- DILexicalBlockBase +foreign import ccall unsafe "LLVM_Hs_DILexicalBlockBaseGetScope" getLexicalBlockScope :: + Ptr DILexicalBlockBase -> IO (Ptr DILocalScope) + +-- DILexicalBlockFile +foreign import ccall unsafe "LLVM_Hs_DILexicalBlockFileGetDiscriminator" getLexicalBlockFileDiscriminator :: + Ptr DILexicalBlockBase -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_Get_DILexicalBlockFile" getDILexicalBlockFile :: + Ptr Context -> Ptr DILocalScope -> Ptr DIFile -> Word32 -> IO (Ptr DILexicalBlockFile) + +-- DILexicalBlock +foreign import ccall unsafe "LLVM_Hs_DILexicalBlockGetLine" getLexicalBlockLine :: + Ptr DILexicalBlockBase -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DILexicalBlockGetColumn" getLexicalBlockColumn :: + Ptr DILexicalBlockBase -> IO Word16 + +foreign import ccall unsafe "LLVM_Hs_Get_DILexicalBlock" getDILexicalBlock :: + Ptr Context -> Ptr DILocalScope -> Ptr DIFile -> Word32 -> Word16 -> IO (Ptr DILexicalBlock) + +foreign import ccall unsafe "LLVM_Hs_DIDerivedTypeGetBaseType" getDerivedBaseType :: + Ptr DIType -> IO (Ptr DIType) + +foreign import ccall unsafe "LLVM_Hs_DIDerivedTypeGetAddressSpace" getDerivedAddressSpace :: + Ptr DIType -> Ptr CUInt -> IO LLVMBool + +-- DISubroutineType + +foreign import ccall unsafe "LLVM_Hs_Get_DISubroutineType" getDISubroutineType :: + Ptr Context -> DIFlags -> Word8 -> TupleArray DIType -> IO (Ptr DISubroutineType) + +foreign import ccall unsafe "LLVM_Hs_DISubroutineType_GetCC" getSubroutineCC :: + Ptr DISubroutineType -> IO Word8 + +foreign import ccall unsafe "LLVM_Hs_DISubroutine_GetTypeArray" getSubroutineTypeArray :: + Ptr DISubroutineType -> IO (TupleArray DIType) + +-- | DIBasicType + +foreign import ccall unsafe "LLVM_Hs_Get_DIBasicType" getDIBasicType :: + Ptr Context -> DwTag -> Ptr MDString -> Word64 -> Word32 -> Encoding -> DIFlags -> IO (Ptr DIBasicType) + +foreign import ccall unsafe "LLVM_Hs_DIBasicType_GetEncoding" getBasicTypeEncoding :: + Ptr DIBasicType -> IO Encoding + +-- DIDerivedType + +foreign import ccall unsafe "LLVM_Hs_Get_DIDerivedType" getDIDerivedType :: + Ptr Context -> + DwTag -> Ptr MDString -> Ptr DIFile -> CUInt -> Ptr DIScope -> + Ptr DIType -> Word64 -> Word32 -> Word64 -> Word32 -> LLVMBool -> DIFlags -> + IO (Ptr DIDerivedType) + +foreign import ccall unsafe "LLVM_Hs_Get_DIFile" getDIFile :: + Ptr Context -> Ptr MDString -> Ptr MDString -> ChecksumKind -> Ptr MDString -> IO (Ptr DIFile) + +-- DISubrange +foreign import ccall unsafe "LLVM_Hs_Get_DISubrangeConstantCount" getDISubrangeConstantCount :: + Ptr Context -> Int64 -> Int64 -> IO (Ptr DISubrange) + +foreign import ccall unsafe "LLVM_Hs_Get_DISubrangeVariableCount" getDISubrangeVariableCount :: + Ptr Context -> Ptr DIVariable -> Int64 -> IO (Ptr DISubrange) + +foreign import ccall unsafe "LLVM_Hs_Get_DISubrangeVariableFields" getDISubrangeVariableFields :: + Ptr Context -> + Ptr Metadata -> -- count + Ptr Metadata -> -- lowerBound + Ptr Metadata -> -- upperBound + Ptr Metadata -> -- strides + IO (Ptr DISubrange) + +foreign import ccall unsafe "LLVM_Hs_DISubrange_HasConstantCount" getDISubrangeHasConstantCount :: + Ptr DISubrange -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DISubrange_GetCount" getDISubrangeCount :: + Ptr DISubrange -> IO (Ptr Metadata) + +foreign import ccall unsafe "LLVM_Hs_DISubrange_GetCountVariable" getDISubrangeCountVariable :: + Ptr DISubrange -> IO (Ptr DIVariable) + +foreign import ccall unsafe "LLVM_Hs_DISubrange_GetCountConstant" getDISubrangeCountConstant :: + Ptr DISubrange -> IO Int64 + +foreign import ccall unsafe "LLVM_Hs_DISubrange_GetLowerBound" getDISubrangeLowerBound :: + Ptr DISubrange -> IO (Ptr Metadata) + +foreign import ccall unsafe "LLVM_Hs_DISubrange_GetUpperBound" getDISubrangeUpperBound :: + Ptr DISubrange -> IO (Ptr Metadata) + +foreign import ccall unsafe "LLVM_Hs_DISubrange_GetStride" getDISubrangeStride :: + Ptr DISubrange -> IO (Ptr Metadata) + +-- DISubprogram + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetLine" getDISubprogramLine :: + Ptr DISubprogram -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetVirtuality" getDISubprogramVirtuality :: + Ptr DISubprogram -> IO DwVirtuality + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetVirtualIndex" getDISubprogramVirtualIndex :: + Ptr DISubprogram -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetScopeLine" getDISubprogramScopeLine :: + Ptr DISubprogram -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_IsOptimized" getDISubprogramIsOptimized :: + Ptr DISubprogram -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_IsDefinition" getDISubprogramIsDefinition :: + Ptr DISubprogram -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetLocalToUnit" getDISubprogramLocalToUnit :: + Ptr DISubprogram -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetThisAdjustment" getDISubprogramThisAdjustment :: + Ptr DISubprogram -> IO Int32 + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetFlags" getDISubprogramFlags :: + Ptr DISubprogram -> IO DIFlags + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetLinkageName" getDISubprogramLinkageName :: + Ptr DISubprogram -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetType" getDISubprogramType :: + Ptr DISubprogram -> IO (Ptr DISubroutineType) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetContainingType" getDISubprogramContainingType :: + Ptr DISubprogram -> IO (Ptr DIType) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetUnit" getDISubprogramUnit :: + Ptr DISubprogram -> IO (Ptr DICompileUnit) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetTemplateParams" getDISubprogramTemplateParams :: + Ptr DISubprogram -> IO (TupleArray DITemplateParameter) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetRetainedNodes" getDISubprogramRetainedNodes :: + Ptr DISubprogram -> IO (TupleArray DILocalVariable) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetThrownTypes" getDISubprogramThrownTypes :: + Ptr DISubprogram -> IO (TupleArray DIType) + +foreign import ccall unsafe "LLVM_Hs_DISubprogram_GetDeclaration" getDISubprogramDeclaration :: + Ptr DISubprogram -> IO (Ptr DISubprogram) + +foreign import ccall unsafe "LLVM_Hs_Get_DISubprogram" getDISubprogram :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> + Ptr MDString -> Ptr DIFile -> CUInt -> + Ptr DISubroutineType -> LLVMBool -> LLVMBool -> CUInt -> + Ptr DIType -> DwVirtuality -> CUInt -> + Int32 -> DIFlags -> LLVMBool -> + Ptr DICompileUnit -> TupleArray DITemplateParameter -> Ptr DISubprogram -> + TupleArray DILocalVariable -> TupleArray DIType -> + IO (Ptr DISubprogram) + +-- DIExpression + +foreign import ccall unsafe "LLVM_Hs_Get_DIExpression" getDIExpression' :: + Ptr Context -> CUInt -> Ptr Word64 -> IO (Ptr DIExpression) + +getDIExpression :: Ptr Context -> (CUInt, Ptr Word64) -> IO (Ptr DIExpression) +getDIExpression ctx (numOps, ops) = getDIExpression' ctx numOps ops + +foreign import ccall unsafe "LLVM_Hs_DIExpression_GetNumElements" getDIExpressionNumElements :: + Ptr DIExpression -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DIExpression_GetElement" getDIExpressionElement :: + Ptr DIExpression -> CUInt -> IO Word64 + +-- DIVariable + +foreign import ccall unsafe "LLVM_Hs_DIVariable_GetScope" getDIVariableScope :: + Ptr DIVariable -> IO (Ptr DIScope) + +foreign import ccall unsafe "LLVM_Hs_DIVariable_GetFile" getDIVariableFile :: + Ptr DIVariable -> IO (Ptr DIFile) + +foreign import ccall unsafe "LLVM_Hs_DIVariable_GetName" getDIVariableName :: + Ptr DIVariable -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIVariable_GetLine" getDIVariableLine :: + Ptr DIVariable -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DIVariable_GetType" getDIVariableType :: + Ptr DIVariable -> IO (Ptr DIType) + +foreign import ccall unsafe "LLVM_Hs_DIVariable_GetAlignInBits" getDIVariableAlignInBits :: + Ptr DIVariable -> IO Word32 + +-- DILocalVariable + +foreign import ccall unsafe "LLVM_Hs_Get_DILocalVariable" getDILocalVariable :: + Ptr Context -> + Ptr DIScope -> CString -> Ptr DIFile -> Word32 -> Ptr DIType -> Word16 -> DIFlags -> Word32 -> + IO (Ptr DILocalVariable) + +foreign import ccall unsafe "LLVM_Hs_DILocalVariable_GetArg" getDILocalVariableArg :: + Ptr DILocalVariable -> IO Word16 + +foreign import ccall unsafe "LLVM_Hs_DILocalVariable_GetFlags" getDILocalVariableFlags :: + Ptr DILocalVariable -> IO DIFlags + +-- DIGlobalVariable + +foreign import ccall unsafe "LLVM_Hs_Get_DIGlobalVariable" getDIGlobalVariable :: + Ptr Context -> + Ptr DIScope -> Ptr MDString -> Ptr MDString -> + Ptr DIFile -> CUInt -> Ptr DIType -> + LLVMBool -> LLVMBool -> + Ptr DIDerivedType -> + TupleArray DITemplateParameter -> + Word32 -> + IO (Ptr DIGlobalVariable) + +foreign import ccall unsafe "LLVM_Hs_DIGlobalVariable_GetLocal" getDIGlobalVariableLocal :: + Ptr DIGlobalVariable -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DIGlobalVariable_GetDefinition" getDIGlobalVariableDefinition :: + Ptr DIGlobalVariable -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DIGlobalVariable_GetLinkageName" getDIGlobalVariableLinkageName :: + Ptr DIGlobalVariable -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIGlobalVariable_GetStaticDataMemberDeclaration" getDIGlobalVariableStaticDataMemberDeclaration :: + Ptr DIGlobalVariable -> IO (Ptr DIDerivedType) + +-- DICompileUnit + +foreign import ccall unsafe "LLVM_Hs_Get_DICompileUnit" getDICompileUnit :: + Ptr Context -> + CUInt -> Ptr DIFile -> Ptr MDString -> LLVMBool -> Ptr MDString -> + CUInt -> Ptr MDString -> DebugEmissionKind -> TupleArray DICompositeType -> TupleArray DIScope -> + TupleArray DIGlobalVariableExpression -> TupleArray DIImportedEntity -> TupleArray DIMacroNode -> + Word64 -> LLVMBool -> + LLVMBool -> DebugNameTableKind -> LLVMBool -> + IO (Ptr DICompileUnit) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetLanguage" getDICompileUnitLanguage :: + Ptr DICompileUnit -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetSplitDebugInlining" getDICompileUnitSplitDebugInlining :: + Ptr DICompileUnit -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetDebugInfoForProfiling" getDICompileUnitDebugInfoForProfiling :: + Ptr DICompileUnit -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetOptimized" getDICompileUnitOptimized :: + Ptr DICompileUnit -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetRuntimeVersion" getDICompileUnitRuntimeVersion :: + Ptr DICompileUnit -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetProducer" getDICompileUnitProducer :: + Ptr DICompileUnit -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetFlags" getDICompileUnitFlags :: + Ptr DICompileUnit -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetSplitDebugFilename" getDICompileUnitSplitDebugFilename :: + Ptr DICompileUnit -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetEmissionKind" getDICompileUnitEmissionKind :: + Ptr DICompileUnit -> IO DebugEmissionKind + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetNameTableKind" getDICompileUnitNameTableKind :: + Ptr DICompileUnit -> IO DebugNameTableKind + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetDWOId" getDICompileUnitDWOId :: + Ptr DICompileUnit -> IO Word64 + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetEnumTypes" getDICompileUnitEnumTypes :: + Ptr DICompileUnit -> IO (TupleArray DICompositeType) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetRetainedTypes" getDICompileUnitRetainedTypes :: + Ptr DICompileUnit -> IO (TupleArray DIScope) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetGlobalVariables" getDICompileUnitGlobalVariables :: + Ptr DICompileUnit -> IO (TupleArray DIGlobalVariableExpression) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetImportedEntities" getDICompileUnitImportedEntities :: + Ptr DICompileUnit -> IO (TupleArray DIImportedEntity) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetMacros" getDICompileUnitMacros :: + Ptr DICompileUnit -> IO (TupleArray DIMacroNode) + +foreign import ccall unsafe "LLVM_Hs_DICompileUnit_GetRangesBaseAddress" getDICompileUnitRangesBaseAddress :: + Ptr DICompileUnit -> IO LLVMBool + +-- DIFlags +foreign import ccall unsafe "LLVM_Hs_DIFlags_GetFlag" getDIFlag :: + CString -> IO DIFlags + +-- DITemplateParameter + +foreign import ccall unsafe "LLVM_Hs_DITemplateParameter_GetName" getDITemplateParameterName :: + Ptr DITemplateParameter -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DITemplateParameter_GetType" getDITemplateParameterType :: + Ptr DITemplateParameter -> IO (Ptr DIType) + +-- DITemplateTypeParameter + +foreign import ccall unsafe "LLVM_Hs_Get_DITemplateTypeParameter" getDITemplateTypeParameter :: + Ptr Context -> Ptr MDString -> Ptr DIType -> IO (Ptr DITemplateTypeParameter) + +-- DITemplateValueParameter + +foreign import ccall unsafe "LLVM_Hs_Get_DITemplateValueParameter" getDITemplateValueParameter :: + Ptr Context -> Ptr MDString -> Ptr DIType -> DwTag -> Bool -> Ptr Metadata -> IO (Ptr DITemplateValueParameter) + +foreign import ccall unsafe "LLVM_Hs_DITemplateValueParameter_GetValue" getDITemplateValueParameterValue :: + Ptr DITemplateValueParameter -> IO (Ptr Metadata) + +-- DIMacro +foreign import ccall unsafe "LLVM_Hs_Get_DIMacro" getDIMacro :: + Ptr Context -> Macinfo -> Word32 -> Ptr MDString -> Ptr MDString -> IO (Ptr DIMacro) + +foreign import ccall unsafe "LLVM_Hs_DIMacro_GetMacinfo" getDIMacroMacinfo :: + Ptr DIMacro -> IO Macinfo + +foreign import ccall unsafe "LLVM_Hs_DIMacro_GetLine" getDIMacroLine :: + Ptr DIMacro -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DIMacro_GetName" getDIMacroName :: + Ptr DIMacro -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIMacro_GetValue" getDIMacroValue :: + Ptr DIMacro -> IO (Ptr MDString) + +-- DIMacroFile +foreign import ccall unsafe "LLVM_Hs_Get_DIMacroFile" getDIMacroFile :: + Ptr Context -> Word32 -> Ptr DIFile -> TupleArray DIMacroNode -> IO (Ptr DIMacroFile) + +foreign import ccall unsafe "LLVM_Hs_DIMacroFile_GetLine" getDIMacroFileLine :: + Ptr DIMacroFile -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DIMacroFile_GetFile" getDIMacroFileFile :: + Ptr DIMacroFile -> IO (Ptr DIFile) + +foreign import ccall unsafe "LLVM_Hs_DIMacroFile_GetNumElements" getDIMacroFileNumElements :: + Ptr DIMacroFile -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_DIMacroFile_GetElement" getDIMacroFileElement :: + Ptr DIMacroFile -> CUInt -> IO (Ptr DIMacroNode) + +-- DIImportedEntity +foreign import ccall unsafe "LLVM_Hs_Get_DIImportedEntity" getDIImportedEntity :: + Ptr Context -> DwTag -> Ptr DIScope -> Ptr DINode -> Ptr DIFile -> Word32 -> Ptr MDString -> IO (Ptr DIImportedEntity) + +foreign import ccall unsafe "LLVM_Hs_DIImportedEntity_GetLine" getDIImportedEntityLine :: + Ptr DIImportedEntity -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DIImportedEntity_GetScope" getDIImportedEntityScope :: + Ptr DIImportedEntity -> IO (Ptr DIScope) + +foreign import ccall unsafe "LLVM_Hs_DIImportedEntity_GetEntity" getDIImportedEntityEntity :: + Ptr DIImportedEntity -> IO (Ptr DINode) + +foreign import ccall unsafe "LLVM_Hs_DIImportedEntity_GetName" getDIImportedEntityName :: + Ptr DIImportedEntity -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIImportedEntity_GetFile" getDIImportedEntityFile :: + Ptr DIImportedEntity -> IO (Ptr DIFile) + +-- DIGlobalVariableExpression +foreign import ccall unsafe "LLVM_Hs_Get_DIGlobalVariableExpression" getDIGlobalVariableExpression :: + Ptr Context -> Ptr DIGlobalVariable -> Ptr DIExpression -> IO (Ptr DIGlobalVariableExpression) + +foreign import ccall unsafe "LLVM_Hs_DIGlobalVariableExpression_GetVariable" getDIGlobalVariableExpressionVariable :: + Ptr DIGlobalVariableExpression -> IO (Ptr DIGlobalVariable) + +foreign import ccall unsafe "LLVM_Hs_DIGlobalVariableExpression_GetExpression" getDIGlobalVariableExpressionExpression :: + Ptr DIGlobalVariableExpression -> IO (Ptr DIExpression) + +-- DIObjCProperty +foreign import ccall unsafe "LLVM_Hs_Get_DIObjCProperty" getDIObjCProperty :: + Ptr Context -> Ptr MDString -> Ptr DIFile -> Word32 -> Ptr MDString -> Ptr MDString -> Word32 -> Ptr DIType -> IO (Ptr DIObjCProperty) + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetLine" getDIObjCPropertyLine :: + Ptr DIObjCProperty -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetAttributes" getDIObjCPropertyAttributes :: + Ptr DIObjCProperty -> IO Word32 + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetName" getDIObjCPropertyName :: + Ptr DIObjCProperty -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetFile" getDIObjCPropertyFile :: + Ptr DIObjCProperty -> IO (Ptr DIFile) + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetGetterName" getDIObjCPropertyGetterName :: + Ptr DIObjCProperty -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetSetterName" getDIObjCPropertySetterName :: + Ptr DIObjCProperty -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIObjCProperty_GetType" getDIObjCPropertyType :: + Ptr DIObjCProperty -> IO (Ptr DIType) + +-- DIModule +foreign import ccall unsafe "LLVM_Hs_Get_DIModule" getDIModule :: + Ptr Context -> Ptr DIScope -> Ptr MDString -> Ptr MDString -> Ptr MDString -> Ptr MDString -> Word32 -> IO (Ptr DIModule) + +foreign import ccall unsafe "LLVM_Hs_DIModule_GetConfigurationMacros" getDIModuleConfigurationMacros :: + Ptr DIModule -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIModule_GetIncludePath" getDIModuleIncludePath :: + Ptr DIModule -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIModule_GetAPINotesFile" getDIModuleAPINotesFile :: + Ptr DIModule -> IO (Ptr MDString) + +foreign import ccall unsafe "LLVM_Hs_DIModule_GetLineNo" getDIModuleLineNo :: + Ptr DIModule -> IO Word32 diff --git a/src/LLVM/Internal/FFI/MetadataC.cpp b/src/LLVM/Internal/FFI/MetadataC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/MetadataC.cpp @@ -0,0 +1,937 @@ +#define __STDC_LIMIT_MACROS + +#include +#include "llvm/Support/FormattedStream.h" + +#include "llvm/Config/llvm-config.h" +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/Metadata.h" +#include "llvm/IR/DebugInfoMetadata.h" +#include "llvm-c/Core.h" + +using namespace llvm; + +extern "C" { + +LLVMMetadataRef LLVM_Hs_IsAMDString(LLVMMetadataRef md) { + if (isa(unwrap(md))) { + return md; + } + return nullptr; +} + +const char *LLVM_Hs_GetMDStringValue(LLVMMetadataRef md, unsigned* len) { + if (const MDString *S = dyn_cast(unwrap(md))) { + *len = S->getString().size(); + return S->getString().data(); + } + *len = 0; + return nullptr; +} + +MDString* LLVM_Hs_GetMDString(LLVMContextRef c, const char* str, unsigned len) { + if (len == 0) { + return nullptr; + } + return MDString::get(*unwrap(c), StringRef(str, len)); +} + +LLVMMetadataRef LLVM_Hs_MDValue(LLVMValueRef v) { + return wrap(ValueAsMetadata::get(unwrap(v))); +} + +LLVMValueRef LLVM_Hs_MetadataOperand(LLVMContextRef c, LLVMMetadataRef md) { + return wrap(MetadataAsValue::get(*unwrap(c), unwrap(md))); +} + +LLVMMetadataRef LLVM_Hs_IsAMDNode(LLVMMetadataRef md) { + if (isa(unwrap(md))) { + return md; + } + return nullptr; +} + +LLVMMetadataRef LLVM_Hs_IsAMDValue(LLVMMetadataRef md) { + if (isa(unwrap(md))) { + return md; + } + return nullptr; +} + +LLVMValueRef LLVM_Hs_GetMDValue(LLVMMetadataRef md) { + return wrap(unwrap(md)->getValue()); +} + +LLVMValueRef LLVM_Hs_IsAMetadataOperand(LLVMValueRef val) { + if (isa(unwrap(val))) { + return val; + } + return nullptr; +} + +LLVMMetadataRef LLVM_Hs_GetMetadataOperand(LLVMValueRef val) { + return wrap(unwrap(val)->getMetadata()); +} + +MDTuple* LLVM_Hs_Get_MDTuple(LLVMContextRef c, + LLVMMetadataRef *mds, + unsigned count) { + return MDTuple::get(*unwrap(c), {unwrap(mds), count}); +} + +/* +void LLVM_Hs_DumpMetadata(LLVMMetadataRef md) { + unwrap(md)->dump(); +} +*/ + +unsigned LLVM_Hs_GetMDKindNames( + LLVMContextRef c, + const char **s, + unsigned *l, + unsigned n +) { + SmallVector ns; + unwrap(c)->getMDKindNames(ns); + if (ns.size() <= n) { + for(unsigned i=0; i < ns.size(); ++i) { + s[i] = ns[i].data(); + l[i] = ns[i].size(); + } + } + return ns.size(); +} + +unsigned LLVM_Hs_MDNode_GetNumOperands(MDNode* v) { + return v->getNumOperands(); +} + +Metadata* LLVM_Hs_MDNode_GetOperand(MDNode* v, unsigned i) { + return v->getOperand(i).get(); +} + +void LLVM_Hs_NamedMetadataAddOperands( + NamedMDNode *n, + LLVMMetadataRef *ops, + unsigned nOps +) { + for(unsigned i = 0; i != nOps; ++i) n->addOperand(unwrap(ops[i])); +} + +const char *LLVM_Hs_GetNamedMetadataName( + NamedMDNode *n, + unsigned *len +) { + StringRef s = n->getName(); + *len = s.size(); + return s.data(); +} + +const char *LLVM_Hs_GetStringRef( + StringRef* s, + unsigned *len +) { + *len = s->size(); + return s->data(); +} + +unsigned LLVM_Hs_GetNamedMetadataNumOperands(NamedMDNode *n) { + return n->getNumOperands(); +} + +void LLVM_Hs_GetNamedMetadataOperands(NamedMDNode *n, LLVMMetadataRef *dest) { + for(unsigned i = 0; i != n->getNumOperands(); ++i) + dest[i] = wrap(n->getOperand(i)); +} + +LLVMMetadataRef LLVM_Hs_CreateTemporaryMDNodeInContext(LLVMContextRef c) { + return wrap(MDNode::getTemporary(*unwrap(c), ArrayRef()).release()); +} + +void LLVM_Hs_DestroyTemporaryMDNode(LLVMMetadataRef v) { + MDNode::deleteTemporary(unwrap(v)); +} + +void LLVM_Hs_GetMDNodeOperands(LLVMMetadataRef md, LLVMMetadataRef *dest) { + const auto *N = cast(unwrap(md)); + const unsigned numOperands = N->getNumOperands(); + for (unsigned i = 0; i < numOperands; i++) + dest[i] = wrap(N->getOperand(i)); +} + +void LLVM_Hs_MetadataReplaceAllUsesWith(LLVMMetadataRef md, LLVMMetadataRef replacement) { + auto *Node = unwrap(md); + Node->replaceAllUsesWith(unwrap(replacement)); + MDNode::deleteTemporary(Node); +} + +// DILocation + +DILocation* LLVM_Hs_Get_DILocation(LLVMContextRef cxt, uint32_t line, uint16_t column, DILocalScope* scope) { + LLVMContext& c = *unwrap(cxt); + + return DILocation::get(c, line, column, scope); +} + +uint32_t LLVM_Hs_DILocation_GetLine(DILocation *md) { + return md->getLine(); +} + +uint16_t LLVM_Hs_DILocation_GetColumn(DILocation *md) { + return md->getColumn(); +} + +DILocalScope* LLVM_Hs_DILocation_GetScope(DILocation *md) { + return md->getScope(); +} + +unsigned LLVM_Hs_GetMetadataClassId(LLVMMetadataRef md) { + return (unwrap(md))->getMetadataID(); +} + +uint16_t LLVM_Hs_DINodeGetTag(DINode *md) { + return md->getTag(); +} + +DINode::DIFlags LLVM_Hs_DITypeGetFlags(DIType *md) { + return md->getFlags(); +} + +// DIEnumerator + +DIEnumerator* LLVM_Hs_Get_DIEnumerator(LLVMContextRef cxt, int64_t value, LLVMBool isUnsigned, MDString* name) { + LLVMContext& c = *unwrap(cxt); + return DIEnumerator::get(c, value, isUnsigned, name); +} + +int64_t LLVM_Hs_DIEnumerator_GetValue(DIEnumerator* md) { + return md->getValue().getLimitedValue(); +} + +LLVMBool LLVM_Hs_DIEnumerator_GetIsUnsigned(DIEnumerator* md) { + return md->isUnsigned(); +} + +MDString* LLVM_Hs_DIEnumerator_GetName(DIEnumerator* md) { + return md->getRawName(); +} + +MDString* LLVM_Hs_DIFileGetFilename(DIFile *di) { + return di->getRawFilename(); +} + +MDString* LLVM_Hs_DIFileGetDirectory(DIFile *di) { + return di->getRawDirectory(); +} + +MDString* LLVM_Hs_DIFileGetChecksum(DIFile *di) { + auto checksumInfo = di->getRawChecksum(); + if (checksumInfo.hasValue()) { + return checksumInfo->Value; + } + return nullptr; +} + +llvm::DIFile::ChecksumKind LLVM_Hs_DIFileGetChecksumKind(DIFile *di) { + auto checksumInfo = di->getRawChecksum(); + if (checksumInfo.hasValue()) { + return checksumInfo->Kind; + } + return static_cast(0); +} + +// DIScope + +DIScope* LLVM_Hs_DIScope_GetScope(DIScope *ds) { + return cast_or_null(ds->getScope()); +} + +DIFile* LLVM_Hs_DIScope_GetFile(DIScope *ds) { + return ds->getFile(); +} + +const char* LLVM_Hs_DIScope_GetName(DIScope *ds, unsigned *len) { + StringRef s = ds->getName(); + *len = s.size(); + return s.data(); +} + +// DINamespace + +DINamespace* LLVM_Hs_Get_DINamespace(LLVMContextRef ctx, DIScope* scope, MDString* name, LLVMBool exportSymbols) { + return DINamespace::get(*unwrap(ctx), scope, name, exportSymbols); +} + +LLVMBool LLVM_Hs_DINamespace_GetExportSymbols(DINamespace *ds) { + return ds->getExportSymbols(); +} + +MDString* LLVM_Hs_DITypeGetName(DIType *ds) { + return ds->getRawName(); +} + +uint64_t LLVM_Hs_DITypeGetSizeInBits(DIType *ds) { + return ds->getSizeInBits(); +} + +uint64_t LLVM_Hs_DITypeGetOffsetInBits(DIType *ds) { + return ds->getOffsetInBits(); +} + +uint32_t LLVM_Hs_DITypeGetAlignInBits(DIType *ds) { + return ds->getAlignInBits(); +} + +uint32_t LLVM_Hs_DITypeGetLine(DIType *ds) { + return ds->getLine(); +} + +// DIBasicType + +DIBasicType* LLVM_Hs_Get_DIBasicType(LLVMContextRef ctx, uint16_t tag, MDString *name, uint64_t sizeInBits, uint32_t alignInBits, unsigned encoding, DINode::DIFlags flags) { + return DIBasicType::get(*unwrap(ctx), tag, name, sizeInBits, alignInBits, encoding, flags); +} + + +unsigned LLVM_Hs_DIBasicType_GetEncoding(DIBasicType *ds) { + return ds->getEncoding(); +} + +// DIDerivedType +DIDerivedType* LLVM_Hs_Get_DIDerivedType(LLVMContextRef ctx, uint16_t tag, MDString* name, DIFile *file, unsigned line, DIScope *scope, DIType *baseType, uint64_t sizeInBits, uint32_t alignInBits, uint64_t offsetInBits, uint32_t dwarfAddressSpace, LLVMBool dwarfAddressSpacePresent, DINode::DIFlags flags) { + LLVMContext& c = *unwrap(ctx); + Optional addrSpace; + if (dwarfAddressSpacePresent) { + addrSpace = dwarfAddressSpace; + } + return DIDerivedType::get(c, tag, name, file, line, scope, baseType, sizeInBits, alignInBits, offsetInBits, addrSpace, flags); +} + +DIFile* LLVM_Hs_Get_DIFile(LLVMContextRef ctx, MDString* filename, MDString* directory, unsigned checksumKind, MDString* checksum) { + LLVMContext& c = *unwrap(ctx); + if (!checksum) { + return DIFile::get(c, filename, directory); + } + return DIFile::get(c, filename, directory, DIFile::ChecksumInfo(static_cast(checksumKind), checksum)); +} + +DISubrange* LLVM_Hs_Get_DISubrangeConstantCount(LLVMContextRef ctx, int64_t count, int64_t lowerBound) { + return DISubrange::get(*unwrap(ctx), count, lowerBound); +} + +DISubrange* LLVM_Hs_Get_DISubrangeVariableCount(LLVMContextRef ctx, DIVariable* count, int64_t lowerBound) { + return DISubrange::get(*unwrap(ctx), count, lowerBound); +} + +DISubrange* LLVM_Hs_Get_DISubrangeVariableFields(LLVMContextRef ctx, Metadata* count, Metadata* lowerBound, Metadata* upperBound, Metadata* stride) { + return DISubrange::get(*unwrap(ctx), count, lowerBound, upperBound, stride); +} + +LLVMBool LLVM_Hs_DISubrange_HasConstantCount(DISubrange* range) { + return range->getCount().is(); +} + +Metadata* LLVM_Hs_DISubrange_GetCount(DISubrange* range) { + return range->getRawCountNode(); +} + +int64_t LLVM_Hs_DISubrange_GetCountConstant(DISubrange* range) { + return range->getCount().dyn_cast()->getSExtValue(); +} + +DIVariable* LLVM_Hs_DISubrange_GetCountVariable(DISubrange* range) { + return range->getCount().dyn_cast(); +} + +Metadata* LLVM_Hs_DISubrange_GetLowerBound(DISubrange* range) { + return range->getRawLowerBound(); +} + +Metadata* LLVM_Hs_DISubrange_GetUpperBound(DISubrange* range) { + return range->getRawUpperBound(); +} + +Metadata* LLVM_Hs_DISubrange_GetStride(DISubrange* range) { + return range->getRawStride(); +} + +LLVMMetadataRef LLVM_Hs_IsADIVariable(LLVMMetadataRef md) { + if (isa(unwrap(md))) { + return md; + } + return nullptr; +} + +LLVMMetadataRef LLVM_Hs_IsADIExpression(LLVMMetadataRef md) { + if (isa(unwrap(md))) { + return md; + } + return nullptr; +} + +MDTuple* LLVM_Hs_DICompositeType_GetElements(DICompositeType *dt) { + return cast_or_null(dt->getRawElements()); +} + +DIType* LLVM_Hs_DICompositeTypeGetVTableHolder(DICompositeType *dt) { + return dt->getVTableHolder(); +} + +DIType* LLVM_Hs_DICompositeTypeGetBaseType(DICompositeType *dt) { + return dt->getBaseType(); +} + +DIType* LLVM_Hs_DIDerivedTypeGetBaseType(DIDerivedType *dt) { + return dt->getBaseType(); +} + +uint16_t LLVM_Hs_DICompositeTypeGetRuntimeLang(DICompositeType *dt) { + return dt->getRuntimeLang(); +} + +MDTuple* LLVM_Hs_DICompositeType_GetTemplateParameters(DICompositeType *dt) { + return cast_or_null(dt->getRawTemplateParams()); +} + +MDString* LLVM_Hs_DICompositeTypeGetIdentifier(DICompositeType *dt) { + return dt->getRawIdentifier(); +} + +DICompositeType *LLVM_Hs_Get_DIArrayType(LLVMContextRef ctx, MDTuple* subscripts, DIType* elTy, uint64_t size, uint32_t align, DINode::DIFlags flags) { + return DICompositeType::get(*unwrap(ctx), dwarf::DW_TAG_array_type, "", nullptr, 0, nullptr, elTy, size, align, 0, flags, subscripts, 0, nullptr); +} + +DICompositeType* LLVM_Hs_Get_DIEnumerationType(LLVMContextRef ctx, DIScope* scope, MDString* name, DIFile *file, uint32_t line, uint64_t size, uint32_t align, MDTuple* elements, DIType* underlyingType, MDString* uniqueIdentifier) { + return DICompositeType::get(*unwrap(ctx), dwarf::DW_TAG_enumeration_type, name, file, line, scope, underlyingType, size, align, 0, DINode::FlagZero, elements, 0, nullptr, nullptr, uniqueIdentifier); +} + +DICompositeType *LLVM_Hs_Get_DIStructType( + LLVMContextRef ctx, DIScope *scope, MDString *name, DIFile *file, + uint32_t line, uint64_t size, uint32_t align, DINode::DIFlags flags, + DIType *derivedFrom, MDTuple *elements, + uint16_t runtimeLang, DIType *vtableHolder, MDString *uniqueIdentifier) { + return DICompositeType::get(*unwrap(ctx), dwarf::DW_TAG_structure_type, name, file, + line, scope, derivedFrom, size, align, 0, flags, + elements, runtimeLang, vtableHolder, nullptr, + uniqueIdentifier); +} + +DICompositeType *LLVM_Hs_Get_DIUnionType( + LLVMContextRef ctx, DIScope *scope, MDString *name, DIFile *file, + uint32_t line, uint64_t size, uint32_t align, DINode::DIFlags flags, + MDTuple *elements, + uint16_t runtimeLang, MDString *uniqueIdentifier) { + return DICompositeType::get(*unwrap(ctx), dwarf::DW_TAG_union_type, name, file, + line, scope, nullptr, size, align, 0, flags, + elements, runtimeLang, nullptr, nullptr, + uniqueIdentifier); +} + +DICompositeType *LLVM_Hs_Get_DIClassType( + LLVMContextRef ctx, DIScope *scope, MDString *name, DIFile *file, + uint32_t line, uint64_t size, uint32_t align, DINode::DIFlags flags, + DIType *derivedFrom, MDTuple *elements, + DIType *vtableHolder, MDTuple* templateParams, MDString *uniqueIdentifier) { + return DICompositeType::get(*unwrap(ctx), dwarf::DW_TAG_class_type, name, file, + line, scope, derivedFrom, size, align, 0, flags, + elements, 0, vtableHolder, templateParams, + uniqueIdentifier); +} + + +// DILexicalBlockBase + +DILocalScope* LLVM_Hs_DILexicalBlockBaseGetScope(DILexicalBlockBase* bb) { + return bb->getScope(); +} + +// DILexicalBlockFile + +uint32_t LLVM_Hs_DILexicalBlockFileGetDiscriminator(DILexicalBlockFile* bf) { + return bf->getDiscriminator(); +} + +DILexicalBlockFile* LLVM_Hs_Get_DILexicalBlockFile(LLVMContextRef ctx, DILocalScope* scope, DIFile* file, uint32_t discriminator) { + return DILexicalBlockFile::get(*unwrap(ctx), scope, file, discriminator); +} + +// DILexicalBlock + +uint32_t LLVM_Hs_DILexicalBlockGetLine(DILexicalBlock* lb) { + return lb->getLine(); +} + +uint16_t LLVM_Hs_DILexicalBlockGetColumn(DILexicalBlock* lb) { + return lb->getColumn(); +} + +DILexicalBlock* LLVM_Hs_Get_DILexicalBlock(LLVMContextRef ctx, DILocalScope* scope, DIFile *file, uint32_t line, uint16_t column) { + return DILexicalBlock::get(*unwrap(ctx), scope, file, line, column); +} + +LLVMBool LLVM_Hs_DIDerivedTypeGetAddressSpace(DIDerivedType *a, unsigned *x) { + auto addressSpace = a->getDWARFAddressSpace(); + if (addressSpace.hasValue()) { + *x = addressSpace.getValue(); + return 1; + } else { + return 0; + } +} + +// DISubroutineType + +DISubroutineType* LLVM_Hs_Get_DISubroutineType(LLVMContextRef ctx, DINode::DIFlags flags, uint8_t cc, MDTuple* types) { + return DISubroutineType::get(*unwrap(ctx), flags, cc, types); +} + +uint8_t LLVM_Hs_DISubroutineType_GetCC(DISubroutineType *a) { + return a->getCC(); +} + +MDTuple* LLVM_Hs_DISubroutine_GetTypeArray(DISubroutineType *md) { + return cast_or_null(md->getRawTypeArray()); +} + +// DISubprogram + +unsigned LLVM_Hs_DISubprogram_GetLine(DISubprogram* p) { + return p->getLine(); +} + +uint8_t LLVM_Hs_DISubprogram_GetVirtuality(DISubprogram* p) { + return p->getVirtuality(); +} + +unsigned LLVM_Hs_DISubprogram_GetVirtualIndex(DISubprogram* p) { + return p->getVirtualIndex(); +} + +unsigned LLVM_Hs_DISubprogram_GetScopeLine(DISubprogram* p) { + return p->getScopeLine(); +} + +LLVMBool LLVM_Hs_DISubprogram_IsOptimized(DISubprogram* p) { + return p->isOptimized(); +} + +LLVMBool LLVM_Hs_DISubprogram_IsDefinition(DISubprogram* p) { + return p->isDefinition(); +} + +LLVMBool LLVM_Hs_DISubprogram_GetLocalToUnit(DISubprogram* p) { + return p->isLocalToUnit(); +} + +int32_t LLVM_Hs_DISubprogram_GetThisAdjustment(DISubprogram* p) { + return p->getThisAdjustment(); +} + +DINode::DIFlags LLVM_Hs_DISubprogram_GetFlags(DISubprogram* p) { + return p->getFlags(); +} + +MDString* LLVM_Hs_DISubprogram_GetLinkageName(DISubprogram* p) { + return p->getRawLinkageName(); +} + +DISubroutineType* LLVM_Hs_DISubprogram_GetType(DISubprogram* p) { + return p->getType(); +} + +DIType* LLVM_Hs_DISubprogram_GetContainingType(DISubprogram* p) { + return p->getContainingType(); +} + +DICompileUnit* LLVM_Hs_DISubprogram_GetUnit(DISubprogram* p) { + return p->getUnit(); +} + +MDTuple* LLVM_Hs_DISubprogram_GetTemplateParams(DISubprogram* p) { + return cast_or_null(p->getRawTemplateParams()); +} + +MDTuple* LLVM_Hs_DISubprogram_GetRetainedNodes(DISubprogram* p) { + return cast_or_null(p->getRawRetainedNodes()); +} + +MDTuple* LLVM_Hs_DISubprogram_GetThrownTypes(DISubprogram* p) { + return cast_or_null(p->getRawThrownTypes()); +} + +DISubprogram* LLVM_Hs_DISubprogram_GetDeclaration(DISubprogram* p) { + return p->getDeclaration(); +} + +DISubprogram *LLVM_Hs_Get_DISubprogram( + LLVMContextRef ctx, DIScope *scope, MDString *name, + MDString *linkageName, DIFile *file, unsigned line, + DISubroutineType *type, LLVMBool isLocal, LLVMBool isDefinition, unsigned scopeLine, + DIType *containingType, uint8_t virtuality, unsigned virtualIndex, + int32_t thisAdjustment, DINode::DIFlags flags, LLVMBool isOptimized, + DICompileUnit *unit, Metadata *templateParams, DISubprogram *declaration, + Metadata *variables, Metadata *thrownTypes) { + LLVMContext &c = *unwrap(ctx); + DISubprogram::DISPFlags spFlags = DISubprogram::toSPFlags(isLocal, isDefinition, isOptimized, virtuality); + if (isDefinition) { + return DISubprogram::getDistinct( + c, scope, name, linkageName, file, + line, type, scopeLine, containingType, + virtualIndex, thisAdjustment, flags, spFlags, unit, + templateParams, declaration, variables, thrownTypes); + } else { + return DISubprogram::get( + c, scope, name, linkageName, file, + line, type, scopeLine, containingType, + virtualIndex, thisAdjustment, flags, spFlags, unit, + templateParams, declaration, variables, thrownTypes); + } +} + +// DIExpression + +DIExpression* LLVM_Hs_Get_DIExpression(LLVMContextRef ctx, unsigned numOps, uint64_t* ops) { + return DIExpression::get(*unwrap(ctx), {ops, numOps}); +} + +unsigned LLVM_Hs_DIExpression_GetNumElements(DIExpression* e) { + return e->getNumElements(); +} + +uint64_t LLVM_Hs_DIExpression_GetElement(DIExpression* e, unsigned i) { + return e->getElement(i); +} + +// DIVariable + +DIScope* LLVM_Hs_DIVariable_GetScope(DIVariable* v) { + return v->getScope(); +} + +DIFile* LLVM_Hs_DIVariable_GetFile(DIVariable* v) { + return v->getFile(); +} + +MDString* LLVM_Hs_DIVariable_GetName(DIVariable* v) { + return v->getRawName(); +} + +unsigned LLVM_Hs_DIVariable_GetLine(DIVariable* v) { + return v->getLine(); +} + +DIType* LLVM_Hs_DIVariable_GetType(DIVariable* v) { + return v->getType(); +} + +uint32_t LLVM_Hs_DIVariable_GetAlignInBits(DIVariable* v) { + return v->getAlignInBits(); +} + +// DILocalVariable + +DILocalVariable* LLVM_Hs_Get_DILocalVariable(LLVMContextRef ctx, + DIScope* scope, MDString* name, DIFile* file, + uint32_t line, DIType* type, uint16_t arg, + DINode::DIFlags flags, uint32_t alignInBits) { + LLVMContext &c = *unwrap(ctx); + return DILocalVariable::get(c, static_cast(scope), name, file, line, type, + arg, flags, alignInBits); +} + +uint16_t LLVM_Hs_DILocalVariable_GetArg(DILocalVariable* v) { + return v->getArg(); +} + +DINode::DIFlags LLVM_Hs_DILocalVariable_GetFlags(DILocalVariable* v) { + return v->getFlags(); +} + +// DIGlobalVariable + +DIGlobalVariable* LLVM_Hs_Get_DIGlobalVariable(LLVMContextRef ctx, + DIScope* scope, MDString* name, MDString* linkageName, + DIFile* file, unsigned line, DIType* type, + LLVMBool isLocalToUnit, LLVMBool isDefinition, + DIDerivedType* declaration, + Metadata* templateParams, + uint32_t alignInBits) { + LLVMContext &c = *unwrap(ctx); + return DIGlobalVariable::get(c, scope, name, linkageName, + file, line, type, + isLocalToUnit, isDefinition, + declaration, templateParams, + alignInBits); +} + +LLVMBool LLVM_Hs_DIGlobalVariable_GetLocal(DIGlobalVariable* v) { + return v->isLocalToUnit(); +} + +LLVMBool LLVM_Hs_DIGlobalVariable_GetDefinition(DIGlobalVariable* v) { + return v->isDefinition(); +} + +MDString* LLVM_Hs_DIGlobalVariable_GetLinkageName(DIGlobalVariable* v) { + return v->getRawLinkageName(); +} + +DIDerivedType* LLVM_Hs_DIGlobalVariable_GetStaticDataMemberDeclaration(DIGlobalVariable* v) { + return v->getStaticDataMemberDeclaration(); +} + +// DICompileUnit +DICompileUnit* LLVM_Hs_Get_DICompileUnit + (LLVMContextRef ctx, + unsigned sourceLanguage, DIFile* file, MDString* producer, LLVMBool isOptimized, MDString* flags, + unsigned runtimeVersion, MDString* splitDebugFilename, unsigned emissionKind, Metadata* enumTypes, Metadata* retainedTypes, + Metadata* globalVariables, Metadata* importedEntities, Metadata* macros, uint64_t dwoid, LLVMBool splitDebugInlining, + LLVMBool debugInfoForProfiling, unsigned nameTableKind, LLVMBool debugBaseAddress, MDString *sysRoot, MDString *sdk) { + LLVMContext &c = *unwrap(ctx); + return DICompileUnit::getDistinct + (c, + sourceLanguage, file, producer, isOptimized, flags, + runtimeVersion, splitDebugFilename, emissionKind, enumTypes, retainedTypes, + globalVariables, importedEntities, macros, dwoid, splitDebugInlining, + debugInfoForProfiling, nameTableKind, debugBaseAddress, sysRoot, sdk); +} + +unsigned LLVM_Hs_DICompileUnit_GetLanguage(DICompileUnit* cu) { + return cu->getSourceLanguage(); +} + +LLVMBool LLVM_Hs_DICompileUnit_GetSplitDebugInlining(DICompileUnit* cu) { + return cu->getSplitDebugInlining(); +} + +LLVMBool LLVM_Hs_DICompileUnit_GetDebugInfoForProfiling(DICompileUnit* cu) { + return cu->getDebugInfoForProfiling(); +} + +LLVMBool LLVM_Hs_DICompileUnit_GetOptimized(DICompileUnit* cu) { + return cu->isOptimized(); +} + +unsigned LLVM_Hs_DICompileUnit_GetRuntimeVersion(DICompileUnit* cu) { + return cu->getRuntimeVersion(); +} + +MDString* LLVM_Hs_DICompileUnit_GetProducer(DICompileUnit* cu) { + return cu->getRawProducer(); +} + +MDString* LLVM_Hs_DICompileUnit_GetFlags(DICompileUnit* cu) { + return cu->getRawFlags(); +} + +MDString* LLVM_Hs_DICompileUnit_GetSplitDebugFilename(DICompileUnit* cu) { + return cu->getRawSplitDebugFilename(); +} + +unsigned LLVM_Hs_DICompileUnit_GetEmissionKind(DICompileUnit* cu) { + return cu->getEmissionKind(); +} + +unsigned LLVM_Hs_DICompileUnit_GetNameTableKind(DICompileUnit* cu) { + return static_cast(cu->getNameTableKind()); +} + +uint64_t LLVM_Hs_DICompileUnit_GetDWOId(DICompileUnit* cu) { + return cu->getDWOId(); +} + +MDTuple* LLVM_Hs_DICompileUnit_GetEnumTypes(DICompileUnit* cu) { + return cast_or_null(cu->getRawEnumTypes()); +} + +MDTuple* LLVM_Hs_DICompileUnit_GetRetainedTypes(DICompileUnit* cu) { + return cast_or_null(cu->getRawRetainedTypes()); +} + +MDTuple* LLVM_Hs_DICompileUnit_GetGlobalVariables(DICompileUnit* cu) { + return cast_or_null(cu->getRawGlobalVariables()); +} + +MDTuple* LLVM_Hs_DICompileUnit_GetImportedEntities(DICompileUnit* cu) { + return cast_or_null(cu->getRawImportedEntities()); +} + +MDTuple* LLVM_Hs_DICompileUnit_GetMacros(DICompileUnit* cu) { + return cast_or_null(cu->getRawMacros()); +} + +LLVMBool LLVM_Hs_DICompileUnit_GetRangesBaseAddress(DICompileUnit* cu) { + return cu->getRangesBaseAddress(); +} + +// DIFlags + +// This is mainly intended for testing purposes +DINode::DIFlags LLVM_Hs_DIFlags_GetFlag(const char* flag) { + return DINode::getFlag(flag); +} + +// DITemplateParameter + +MDString* LLVM_Hs_DITemplateParameter_GetName(DITemplateParameter* p) { + return p->getRawName(); +} + +DIType* LLVM_Hs_DITemplateParameter_GetType(DITemplateParameter* p) { + return p->getType(); +} + +// DITemplateTypeParameter + +DITemplateTypeParameter* LLVM_Hs_Get_DITemplateTypeParameter(LLVMContextRef ctx, MDString* name, DIType* type, bool isDefault) { + return DITemplateTypeParameter::get(*unwrap(ctx), name, type, isDefault); +} + +// DITemplateValueParameter + +DITemplateValueParameter* LLVM_Hs_Get_DITemplateValueParameter(LLVMContextRef ctx, MDString* name, DIType* type, uint16_t tag, bool isDefault, Metadata* value) { + return DITemplateValueParameter::get(*unwrap(ctx), tag, name, type, isDefault, value); +} + +Metadata* LLVM_Hs_DITemplateValueParameter_GetValue(DITemplateValueParameter* p) { + return p->getValue(); +} + +// DIMacro +DIMacro* LLVM_Hs_Get_DIMacro(LLVMContextRef ctx, unsigned macinfo, uint32_t line, MDString* name, MDString* value) { + return DIMacro::get(*unwrap(ctx), macinfo, line, name, value); +} + +unsigned LLVM_Hs_DIMacro_GetMacinfo(DIMacro* m) { + return m->getMacinfoType(); +} + +uint32_t LLVM_Hs_DIMacro_GetLine(DIMacro* m) { + return m->getLine(); +} + +MDString* LLVM_Hs_DIMacro_GetName(DIMacro* m) { + return m->getRawName(); +} + +MDString* LLVM_Hs_DIMacro_GetValue(DIMacro* m) { + return m->getRawValue(); +} + +// DIMacroFile +DIMacroFile* LLVM_Hs_Get_DIMacroFile(LLVMContextRef ctx, uint32_t line, DIFile* file, MDTuple* elems) { + return DIMacroFile::get(*unwrap(ctx), dwarf::DW_MACINFO_start_file, line, file, static_cast(elems)); +} + +uint32_t LLVM_Hs_DIMacroFile_GetLine(DIMacroFile* m) { + return m->getLine(); +} + +DIFile* LLVM_Hs_DIMacroFile_GetFile(DIMacroFile* m) { + return m->getFile(); +} + +unsigned LLVM_Hs_DIMacroFile_GetNumElements(DIMacroFile* m) { + return m->getElements().size(); +} + +DIMacroNode* LLVM_Hs_DIMacroFile_GetElement(DIMacroFile* m, unsigned i) { + return m->getElements()[i]; +} + +// DIImportedEntity + +DIImportedEntity* LLVM_Hs_Get_DIImportedEntity(LLVMContextRef ctx, uint16_t tag, DIScope* scope, DINode* entity, DIFile* file, uint32_t line, MDString* name) { + return DIImportedEntity::get(*unwrap(ctx), tag, scope, entity, file, line, name); +} + +uint32_t LLVM_Hs_DIImportedEntity_GetLine(DIImportedEntity* e) { + return e->getLine(); +} + +DIScope* LLVM_Hs_DIImportedEntity_GetScope(DIImportedEntity* e) { + return e->getScope(); +} + +DINode* LLVM_Hs_DIImportedEntity_GetEntity(DIImportedEntity* e) { + return e->getEntity(); +} + +MDString* LLVM_Hs_DIImportedEntity_GetName(DIImportedEntity* e) { + return e->getRawName(); +} + +DIFile* LLVM_Hs_DIImportedEntity_GetFile(DIImportedEntity* e) { + return e->getFile(); +} + +// DIGlobalVariableExpression + +DIGlobalVariableExpression* LLVM_Hs_Get_DIGlobalVariableExpression(LLVMContextRef ctx, DIGlobalVariable* var, DIExpression* expr) { + return DIGlobalVariableExpression::get(*unwrap(ctx), var, expr); +} + +DIGlobalVariable* LLVM_Hs_DIGlobalVariableExpression_GetVariable(DIGlobalVariableExpression* e) { + return e->getVariable(); +} + +DIExpression* LLVM_Hs_DIGlobalVariableExpression_GetExpression(DIGlobalVariableExpression* e) { + return e->getExpression(); +} + +// DIObjCProperty + +DIObjCProperty* LLVM_Hs_Get_DIObjCProperty(LLVMContextRef ctx, MDString* name, DIFile* file, uint32_t line, MDString* getterName, MDString* setterName, uint32_t attributes, DIType* type) { + return DIObjCProperty::get(*unwrap(ctx), name, file, line, getterName, setterName, attributes, type); +} + +uint32_t LLVM_Hs_DIObjCProperty_GetLine(DIObjCProperty* o) { + return o->getLine(); +} + +uint32_t LLVM_Hs_DIObjCProperty_GetAttributes(DIObjCProperty* o) { + return o->getAttributes(); +} + +MDString* LLVM_Hs_DIObjCProperty_GetName(DIObjCProperty* o) { + return o->getRawName(); +} + +DIFile* LLVM_Hs_DIObjCProperty_GetFile(DIObjCProperty* o) { + return o->getFile(); +} + +MDString* LLVM_Hs_DIObjCProperty_GetGetterName(DIObjCProperty* o) { + return o->getRawGetterName(); +} + +MDString* LLVM_Hs_DIObjCProperty_GetSetterName(DIObjCProperty* o) { + return o->getRawSetterName(); +} + +DIType* LLVM_Hs_DIObjCProperty_GetType(DIObjCProperty* o) { + return o->getType(); +} + +// DIModule + +DIModule* LLVM_Hs_Get_DIModule(LLVMContextRef ctx, DIFile* file, DIScope* scope, MDString* name, MDString* configurationMacros, MDString* includePath, MDString* apiNotesFile, unsigned lineNo) { + return DIModule::get(*unwrap(ctx), file, scope, name, configurationMacros, includePath, apiNotesFile, lineNo); +} + +MDString* LLVM_Hs_DIModule_GetConfigurationMacros(DIModule* m) { + return m->getRawConfigurationMacros(); +} + +MDString* LLVM_Hs_DIModule_GetIncludePath(DIModule* m) { + return m->getRawIncludePath(); +} + +MDString* LLVM_Hs_DIModule_GetAPINotesFile(DIModule* m) { + return m->getRawAPINotesFile(); +} + +uint32_t LLVM_Hs_DIModule_GetLineNo(DIModule* m) { + return m->getLineNo(); +} +} diff --git a/src/LLVM/Internal/FFI/Module.hs b/src/LLVM/Internal/FFI/Module.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Module.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.Module where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.GlobalValue (COMDAT) +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.Type + +data Module + +foreign import ccall unsafe "LLVMModuleCreateWithNameInContext" moduleCreateWithNameInContext :: + CString -> Ptr Context -> IO (Ptr Module) + +foreign import ccall unsafe "LLVMGetModuleContext" getModuleContext :: + Ptr Module -> IO (Ptr Context) + +foreign import ccall unsafe "LLVMDisposeModule" disposeModule :: + Ptr Module -> IO () + +foreign import ccall unsafe "LLVMGetDataLayout" getDataLayout :: + Ptr Module -> IO CString + +foreign import ccall unsafe "LLVMSetDataLayout" setDataLayout :: + Ptr Module -> CString -> IO () + +foreign import ccall unsafe "LLVMGetTarget" getTargetTriple :: + Ptr Module -> IO CString + +foreign import ccall unsafe "LLVMSetTarget" setTargetTriple :: + Ptr Module -> CString -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetModuleIdentifier" getModuleIdentifier :: + Ptr Module -> IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVM_Hs_GetSourceFileName" getSourceFileName :: + Ptr Module -> IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVM_Hs_SetSourceFileName" setSourceFileName :: + Ptr Module -> Ptr CChar -> IO () + +foreign import ccall unsafe "LLVMGetFirstGlobal" getFirstGlobal :: + Ptr Module -> IO (Ptr GlobalVariable) + +foreign import ccall unsafe "LLVMGetNextGlobal" getNextGlobal :: + Ptr GlobalVariable -> IO (Ptr GlobalVariable) + +foreign import ccall unsafe "LLVM_Hs_GetFirstAlias" getFirstAlias :: + Ptr Module -> IO (Ptr GlobalAlias) + +foreign import ccall unsafe "LLVM_Hs_GetNextAlias" getNextAlias :: + Ptr GlobalAlias -> IO (Ptr GlobalAlias) + +foreign import ccall unsafe "LLVM_Hs_GetOrInsertCOMDAT" getOrInsertCOMDAT :: + Ptr Module -> CString -> IO (Ptr COMDAT) + +foreign import ccall unsafe "LLVMGetFirstFunction" getFirstFunction :: + Ptr Module -> IO (Ptr Function) + +foreign import ccall unsafe "LLVMGetNextFunction" getNextFunction :: + Ptr Function -> IO (Ptr Function) + +foreign import ccall unsafe "LLVM_Hs_GetFirstNamedMetadata" getFirstNamedMetadata :: + Ptr Module -> IO (Ptr NamedMetadata) + +foreign import ccall unsafe "LLVM_Hs_GetNextNamedMetadata" getNextNamedMetadata :: + Ptr NamedMetadata -> IO (Ptr NamedMetadata) + +foreign import ccall unsafe "LLVMAddGlobalInAddressSpace" addGlobalInAddressSpace :: + Ptr Module -> Ptr Type -> CString -> CUInt -> IO (Ptr GlobalVariable) + +foreign import ccall unsafe "LLVM_Hs_JustAddAlias" justAddAlias :: + Ptr Module -> Ptr Type -> AddrSpace -> CString -> IO (Ptr GlobalAlias) + +foreign import ccall unsafe "LLVMAddFunction" addFunction :: + Ptr Module -> CString -> Ptr Type -> IO (Ptr Function) + +foreign import ccall unsafe "LLVMGetNamedFunction" getNamedFunction :: + Ptr Module -> CString -> IO (Ptr Function) + +foreign import ccall unsafe "LLVM_Hs_GetOrAddNamedMetadata" getOrAddNamedMetadata :: + Ptr Module -> CString -> IO (Ptr NamedMetadata) + +foreign import ccall unsafe "LLVM_Hs_ModuleAppendInlineAsm" moduleAppendInlineAsm' :: + Ptr Module -> Ptr CChar -> CUInt -> IO () + +newtype ModuleAsm a = ModuleAsm a + +moduleAppendInlineAsm :: Ptr Module -> ModuleAsm (Ptr CChar, CUInt) -> IO () +moduleAppendInlineAsm m (ModuleAsm (c, n)) = moduleAppendInlineAsm' m c n + +foreign import ccall unsafe "LLVM_Hs_ModuleGetInlineAsm" moduleGetInlineAsm :: + Ptr Module -> IO (ModuleAsm CString) + +foreign import ccall unsafe "LLVMLinkModules2" linkModules :: + Ptr Module -> Ptr Module -> IO LLVMBool diff --git a/src/LLVM/Internal/FFI/ModuleC.cpp b/src/LLVM/Internal/FFI/ModuleC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ModuleC.cpp @@ -0,0 +1,70 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/Module.h" +#include "llvm-c/Core.h" + +using namespace llvm; + +extern "C" { + +char *LLVM_Hs_GetModuleIdentifier(LLVMModuleRef val) { + return strdup(unwrap(val)->getModuleIdentifier().c_str()); +} + +char *LLVM_Hs_GetSourceFileName(LLVMModuleRef val) { + return strdup(unwrap(val)->getSourceFileName().c_str()); +} + +void LLVM_Hs_SetSourceFileName(LLVMModuleRef val, const char* sourceFileName) { + return unwrap(val)->setSourceFileName(sourceFileName); +} + +LLVMValueRef LLVM_Hs_GetFirstAlias(LLVMModuleRef m) { + Module *mod = unwrap(m); + Module::alias_iterator i = mod->alias_begin(); + if (i == mod->alias_end()) { + return 0; + } + return wrap(&*i); +} + +LLVMValueRef LLVM_Hs_GetNextAlias(LLVMValueRef a) { + GlobalAlias *alias = unwrap(a); + Module::alias_iterator i(alias); + if (++i == alias->getParent()->alias_end()) return 0; + return wrap(&*i); +} + +Comdat *LLVM_Hs_GetOrInsertCOMDAT(LLVMModuleRef m, const char *name) { + return unwrap(m)->getOrInsertComdat(name); +} + +// TODO (cocreature): Figure out if we can just change the linkage here +LLVMValueRef LLVM_Hs_JustAddAlias(LLVMModuleRef m, LLVMTypeRef ty, unsigned addrspace, const char *name) { + return wrap(GlobalAlias::create(unwrap(ty), addrspace, GlobalValue::ExternalLinkage, name, 0, unwrap(m))); +} + +NamedMDNode *LLVM_Hs_GetOrAddNamedMetadata(LLVMModuleRef m, const char *name) { + return unwrap(m)->getOrInsertNamedMetadata(name); +} + +NamedMDNode *LLVM_Hs_GetFirstNamedMetadata(LLVMModuleRef m) { + Module *mod = unwrap(m); + Module::named_metadata_iterator i = mod->named_metadata_begin(); + return i == mod->named_metadata_end() ? 0 : &*i; +} + +NamedMDNode *LLVM_Hs_GetNextNamedMetadata(NamedMDNode *a) { + Module::named_metadata_iterator i(a); + if (++i == a->getParent()->named_metadata_end()) return 0; + return &*i; +} + +void LLVM_Hs_ModuleAppendInlineAsm(LLVMModuleRef m, const char *s, unsigned l) { + unwrap(m)->appendModuleInlineAsm(StringRef(s,l)); +} + +const char *LLVM_Hs_ModuleGetInlineAsm(LLVMModuleRef m) { + return unwrap(m)->getModuleInlineAsm().c_str(); +} + +} diff --git a/src/LLVM/Internal/FFI/ObjectFile.hs b/src/LLVM/Internal/FFI/ObjectFile.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ObjectFile.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +module LLVM.Internal.FFI.ObjectFile where + +import Foreign.Ptr + +import LLVM.Prelude +import LLVM.Internal.FFI.MemoryBuffer + +data ObjectFile + +foreign import ccall unsafe "LLVMCreateObjectFile" createObjectFile :: + Ptr MemoryBuffer -> IO (Ptr ObjectFile) + +foreign import ccall unsafe "LLVMDisposeObjectFile" disposeObjectFile :: + Ptr ObjectFile -> IO () diff --git a/src/LLVM/Internal/FFI/OrcJIT.h b/src/LLVM/Internal/FFI/OrcJIT.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/OrcJIT.h @@ -0,0 +1,25 @@ +#ifndef __LLVM_INTERNAL_FFI__ORC_JIT__H__ +#define __LLVM_INTERNAL_FFI__ORC_JIT__H__ + +#define LLVM_HS_FOR_EACH_JIT_SYMBOL_FLAG(macro) \ + macro(None) \ + macro(HasError) \ + macro(Weak) \ + macro(Common) \ + macro(Absolute) \ + macro(Exported) \ + macro(Callable) \ + macro(MaterializationSideEffectsOnly) + +typedef enum { + LLVMJITSymbolFlagNone = 0, + LLVMJITSymbolFlagHasError = 1U << 0, + LLVMJITSymbolFlagWeak = 1U << 1, + LLVMJITSymbolFlagCommon = 1U << 2, + LLVMJITSymbolFlagAbsolute = 1U << 3, + LLVMJITSymbolFlagExported = 1U << 4, + LLVMJITSymbolFlagCallable = 1U << 5, + LLVMJITSymbolFlagMaterializationSideEffectsOnly = 1U << 6 +} LLVMJITSymbolFlags_; + +#endif diff --git a/src/LLVM/Internal/FFI/OrcJIT.hs b/src/LLVM/Internal/FFI/OrcJIT.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/OrcJIT.hs @@ -0,0 +1,113 @@ +module LLVM.Internal.FFI.OrcJIT where + +import LLVM.Prelude + +import LLVM.Internal.FFI.DataLayout (DataLayout) +import LLVM.Internal.FFI.Module (Module) +import LLVM.Internal.FFI.Target (TargetMachine) +import LLVM.Internal.FFI.LLVMCTypes + +import Foreign.Ptr +import Foreign.C + +newtype TargetAddress = TargetAddress Word64 + +data JITEvaluatedSymbol +data ExpectedJITEvaluatedSymbol +data MangleAndInterner +data ThreadSafeContext +data ThreadSafeModule +data ObjectLayer +data IRLayer +data JITDylib +data ExecutionSession +data SymbolStringPtr + +foreign import ccall safe "LLVM_Hs_createExecutionSession" createExecutionSession :: + IO (Ptr ExecutionSession) + +foreign import ccall safe "LLVM_Hs_disposeExecutionSession" disposeExecutionSession :: + Ptr ExecutionSession -> IO () + +foreign import ccall safe "LLVM_Hs_ExecutionSession_endSession" endSession :: + Ptr ExecutionSession -> IO () + +foreign import ccall safe "LLVM_Hs_ExecutionSession_createJITDylib" createJITDylib :: + Ptr ExecutionSession -> CString -> IO (Ptr JITDylib) + +foreign import ccall safe "LLVM_Hs_ExecutionSession_lookupSymbol" lookupSymbol :: + Ptr ExecutionSession -> Ptr JITDylib -> Ptr MangleAndInterner -> CString -> IO (Ptr ExpectedJITEvaluatedSymbol) + +foreign import ccall safe "LLVM_Hs_createThreadSafeContext" createThreadSafeContext :: + IO (Ptr ThreadSafeContext) + +foreign import ccall safe "LLVM_Hs_disposeThreadSafeContext" disposeThreadSafeContext :: + Ptr ThreadSafeContext -> IO () + +foreign import ccall safe "LLVM_Hs_cloneAsThreadSafeModule" cloneAsThreadSafeModule :: + Ptr Module -> IO (Ptr ThreadSafeModule) + +foreign import ccall safe "LLVM_Hs_disposeThreadSafeModule" disposeThreadSafeModule :: + Ptr ThreadSafeModule -> IO () + +foreign import ccall safe "LLVM_Hs_createRTDyldObjectLinkingLayer" createRTDyldObjectLinkingLayer :: + Ptr ExecutionSession -> IO (Ptr ObjectLayer) + +foreign import ccall safe "LLVM_Hs_createObjectLinkingLayer" createObjectLinkingLayer :: + Ptr ExecutionSession -> IO (Ptr ObjectLayer) + +foreign import ccall safe "LLVM_Hs_ObjectLayerAddObjectFile" objectLayerAddObjectFile :: + Ptr ObjectLayer -> Ptr JITDylib -> CString -> IO () + +foreign import ccall safe "LLVM_Hs_disposeObjectLayer" disposeObjectLayer :: + Ptr ObjectLayer -> IO () + +foreign import ccall safe "LLVM_Hs_createIRCompileLayer" createIRCompileLayer :: + Ptr ExecutionSession -> Ptr ObjectLayer -> Ptr TargetMachine -> IO (Ptr IRLayer) + +foreign import ccall safe "LLVM_Hs_disposeIRLayer" disposeIRLayer :: + Ptr IRLayer -> IO () + +foreign import ccall safe "LLVM_Hs_JITDylib_addDynamicLibrarySearchGenerator_forCurrentProcess" + addDynamicLibrarySearchGeneratorForCurrentProcess :: + Ptr JITDylib -> Ptr DataLayout -> IO () + +foreign import ccall safe "LLVM_Hs_JITDylib_addDynamicLibrarySearchGenerator_load" + addDynamicLibrarySearchGenerator :: + Ptr JITDylib -> Ptr DataLayout -> CString -> IO () + +foreign import ccall safe "LLVM_Hs_JITDylib_defineAbsoluteSymbols" + defineAbsoluteSymbols :: Ptr JITDylib -> CUInt -> Ptr (Ptr SymbolStringPtr) -> Ptr (Ptr JITEvaluatedSymbol) -> IO () + +foreign import ccall safe "LLVM_Hs_IRLayer_addModule" irLayerAddModule :: + Ptr ThreadSafeModule -> Ptr JITDylib -> Ptr DataLayout -> Ptr IRLayer -> IO () + +foreign import ccall safe "LLVM_Hs_getExpectedJITEvaluatedSymbolAddress" getExpectedSymbolAddress :: + Ptr ExpectedJITEvaluatedSymbol -> Ptr (OwnerTransfered CString) -> IO TargetAddress + +foreign import ccall safe "LLVM_Hs_getExpectedJITEvaluatedSymbolFlags" getExpectedSymbolFlags :: + Ptr ExpectedJITEvaluatedSymbol -> IO JITSymbolFlags + +foreign import ccall safe "LLVM_Hs_disposeExpectedJITEvaluatedSymbol" disposeExpectedJITEvaluatedSymbol :: + Ptr ExpectedJITEvaluatedSymbol -> IO () + +foreign import ccall safe "LLVM_Hs_createJITEvaluatedSymbol" createJITEvaluatedSymbol :: + TargetAddress -> JITSymbolFlags -> IO (Ptr JITEvaluatedSymbol) + +foreign import ccall safe "LLVM_Hs_disposeJITEvaluatedSymbol" disposeJITEvaluatedSymbol :: + Ptr JITEvaluatedSymbol -> IO () + +foreign import ccall safe "LLVM_Hs_createMangleAndInterner" createMangleAndInterner :: + Ptr ExecutionSession -> Ptr DataLayout -> IO (Ptr MangleAndInterner) + +foreign import ccall safe "LLVM_Hs_disposeMangleAndInterner" disposeMangleAndInterner :: + Ptr MangleAndInterner -> IO () + +foreign import ccall safe "LLVM_Hs_MangleAndInterner_call" mangleSymbol :: + Ptr MangleAndInterner -> CString -> IO (Ptr SymbolStringPtr) + +foreign import ccall safe "LLVM_Hs_SymbolStringPtr_c_str" mangledSymbolString :: + Ptr SymbolStringPtr -> IO CString + +foreign import ccall safe "LLVM_Hs_disposeSymbolStringPtr" disposeMangledSymbol :: + Ptr SymbolStringPtr -> IO () diff --git a/src/LLVM/Internal/FFI/OrcJITC.cpp b/src/LLVM/Internal/FFI/OrcJITC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/OrcJITC.cpp @@ -0,0 +1,258 @@ +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "LLVM/Internal/FFI/OrcJIT.h" +#include "LLVM/Internal/FFI/Target.hpp" + +using namespace llvm; +using namespace orc; + +#define SYMBOL_CASE(x) \ + static_assert((unsigned)LLVMJITSymbolFlag##x == \ + (unsigned)llvm::JITSymbolFlags::FlagNames::x, \ + "JITSymbolFlag values should agree"); +LLVM_HS_FOR_EACH_JIT_SYMBOL_FLAG(SYMBOL_CASE) + +static JITSymbolFlags unwrap(LLVMJITSymbolFlags_ f) { + JITSymbolFlags flags = JITSymbolFlags::None; +#define ENUM_CASE(x) \ + if (f & LLVMJITSymbolFlag##x) \ + flags |= JITSymbolFlags::x; + LLVM_HS_FOR_EACH_JIT_SYMBOL_FLAG(ENUM_CASE) +#undef ENUM_CASE + return flags; +} + +static LLVMJITSymbolFlags_ wrap(JITSymbolFlags f) { + unsigned r = 0; +#define ENUM_CASE(x) \ + if (f & JITSymbolFlags::x) \ + r |= (unsigned)LLVMJITSymbolFlag##x; + LLVM_HS_FOR_EACH_JIT_SYMBOL_FLAG(ENUM_CASE) +#undef ENUM_CASE + return LLVMJITSymbolFlags_(r); +} + +extern "C" { + +// ExecutionSession + +ExecutionSession *LLVM_Hs_createExecutionSession() { + return new ExecutionSession(); +} + +void LLVM_Hs_disposeExecutionSession(ExecutionSession *es) { + delete es; +} + +void LLVM_Hs_ExecutionSession_endSession(ExecutionSession *es) { + if (Error err = es->endSession()) { + llvm::errs() << err << "\n"; + // FIXME: Better error handling + exit(1); + } +} + +// Thread-safe context + +ThreadSafeContext* LLVM_Hs_createThreadSafeContext() { + return new ThreadSafeContext(std::make_unique()); +} + +void LLVM_Hs_disposeThreadSafeContext(ThreadSafeContext* ctx) { + delete ctx; +} + +// Thread-safe module + +// TODO: Figure out a way to do this without cloning the module +// The cloning is inspired by the code in llvm::orc::cloneToNewContext +ThreadSafeModule* LLVM_Hs_cloneAsThreadSafeModule(LLVMModuleRef m) { + Module* module = unwrap(m); + SmallVector bitcode; + BitcodeWriter writer(bitcode); + writer.writeModule(*module); + writer.writeSymtab(); + writer.writeStrtab(); + + ThreadSafeContext clone_context(std::make_unique()); + MemoryBufferRef bitcode_ref(StringRef(bitcode.data(), bitcode.size()), "clone bitcode"); + std::unique_ptr cloned_module = cantFail( + parseBitcodeFile(bitcode_ref, *clone_context.getContext())); + cloned_module->setModuleIdentifier(module->getName()); + return new ThreadSafeModule(std::move(cloned_module), std::move(clone_context)); +} + +void LLVM_Hs_disposeThreadSafeModule(ThreadSafeModule* module) { + delete module; +} + +// Object layer + +ObjectLayer* LLVM_Hs_createRTDyldObjectLinkingLayer(ExecutionSession* es) { + return new RTDyldObjectLinkingLayer(*es, []() { + return std::make_unique(); + }); +} + +ObjectLayer* LLVM_Hs_createObjectLinkingLayer(ExecutionSession* es) { + return new ObjectLinkingLayer(*es, std::make_unique()); +} + +void LLVM_Hs_ObjectLayerAddObjectFile(ObjectLayer* ol, JITDylib* dylib, const char* path) { + ExitOnError ExitOnErr; + if (auto errorOrBuffer = MemoryBuffer::getFile(path)) { + ExitOnErr(ol->add(*dylib, std::move(errorOrBuffer.get()))); + } else exit(1); +} + +void LLVM_Hs_disposeObjectLayer(ObjectLayer* ol) { + delete ol; +} + +// Compile layer + +IRLayer* LLVM_Hs_createIRCompileLayer(ExecutionSession* es, ObjectLayer* baseLayer, LLVMTargetMachineRef tm) { + return new IRCompileLayer(*es, *baseLayer, std::make_unique(SimpleCompiler(*unwrap(tm)))); +} + +void LLVM_Hs_disposeIRLayer(IRLayer* il) { + delete il; +} + +void LLVM_Hs_JITDylib_addDynamicLibrarySearchGenerator_forCurrentProcess(JITDylib* dylib, LLVMTargetDataRef dataLayout) { + auto dataLayoutCpp = *unwrap(dataLayout); + ExitOnError ExitOnErr; + dylib->addGenerator( + ExitOnErr(orc::DynamicLibrarySearchGenerator::GetForCurrentProcess( + dataLayoutCpp.getGlobalPrefix()))); +} + +void LLVM_Hs_JITDylib_addDynamicLibrarySearchGenerator_load(JITDylib* dylib, LLVMTargetDataRef dataLayout, const char* name) { + auto dataLayoutCpp = *unwrap(dataLayout); + ExitOnError ExitOnErr; + dylib->addGenerator( + ExitOnErr(orc::DynamicLibrarySearchGenerator::Load( + name, dataLayoutCpp.getGlobalPrefix()))); +} + +void LLVM_Hs_JITDylib_defineAbsoluteSymbols( + JITDylib* dylib, unsigned num_symbols, const SymbolStringPtr** names, const JITEvaluatedSymbol** symbols) { + orc::SymbolMap map; + for (unsigned i = 0; i < num_symbols; ++i) { + map[*names[i]] = *symbols[i]; + } + if (Error err = dylib->define(orc::absoluteSymbols(std::move(map)))) { + llvm::errs() << err << "\n"; + // FIXME: Better error handling + exit(1); + } +} + +// Warning: This consumes the module. +void LLVM_Hs_IRLayer_addModule(ThreadSafeModule* tsm, JITDylib* dylib, LLVMTargetDataRef dataLayout, IRLayer* il) { + auto dataLayoutCpp = *unwrap(dataLayout); + tsm->withModuleDo([&](auto& module) { + if (module.getDataLayout().isDefault()) { + module.setDataLayout(dataLayoutCpp); + } + }); + if (Error err = il->add(*dylib, std::move(*tsm))) { + llvm::errs() << err << "\n"; + // FIXME: Better error handling + exit(1); + } +} + +JITDylib* LLVM_Hs_ExecutionSession_createJITDylib(ExecutionSession* es, const char* name) { + if (auto dylibOrErr = es->createJITDylib(name)) { + auto& dylib = *dylibOrErr; + return &dylib; + } else { + Error err = dylibOrErr.takeError(); + llvm::errs() << err << "\n"; + // FIXME: Better error handling + exit(1); + } +} + + +Expected* LLVM_Hs_ExecutionSession_lookupSymbol( + ExecutionSession* es, JITDylib* dylib, + MangleAndInterner* mangler, const char* name) { + // Printing here will show unresolved symbols. + // es->dump(llvm::errs()); + return new Expected(es->lookup({dylib}, (*mangler)(name))); +} + +uint64_t LLVM_Hs_getExpectedJITEvaluatedSymbolAddress( + Expected* symbolPtr, + char** errMsg) { + auto& symbol = *symbolPtr; + *errMsg = nullptr; + if (symbol) { + return symbol->getAddress(); + } else { + *errMsg = strdup(toString(symbol.takeError()).c_str()); + return 0; + } +} + +LLVMJITSymbolFlags_ LLVM_Hs_getExpectedJITEvaluatedSymbolFlags( + Expected* symbolPtr) { + auto& symbol = *symbolPtr; + if (!symbol) { + return LLVMJITSymbolFlagHasError; + } + return wrap(symbol->getFlags()); +} + +JITEvaluatedSymbol* LLVM_Hs_createJITEvaluatedSymbol(uint64_t ptr, LLVMJITSymbolFlags_ flags) { + return new JITEvaluatedSymbol(ptr, unwrap(flags)); +} + +void LLVM_Hs_disposeJITEvaluatedSymbol(JITEvaluatedSymbol* symbol) { + delete symbol; +} + +void LLVM_Hs_disposeExpectedJITEvaluatedSymbol(Expected* symbol) { + delete symbol; +} + +MangleAndInterner* LLVM_Hs_createMangleAndInterner(ExecutionSession* es, + LLVMTargetDataRef dl) { + return new MangleAndInterner(*es, *unwrap(dl)); +} + +void LLVM_Hs_disposeMangleAndInterner(MangleAndInterner* mangler) { + delete mangler; +} + +SymbolStringPtr* LLVM_Hs_MangleAndInterner_call(MangleAndInterner* mangler, const char* name) { + return new SymbolStringPtr((*mangler)(name)); +} + +const char* LLVM_Hs_SymbolStringPtr_c_str(SymbolStringPtr* ptr) { + return (*(*ptr)).data(); +} + +void LLVM_Hs_disposeSymbolStringPtr(SymbolStringPtr* ptr) { + delete ptr; +} + +} diff --git a/src/LLVM/Internal/FFI/PassManager.hs b/src/LLVM/Internal/FFI/PassManager.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/PassManager.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE + TemplateHaskell, + ForeignFunctionInterface, + CPP + #-} + +module LLVM.Internal.FFI.PassManager where + +import LLVM.Prelude + +import qualified Language.Haskell.TH as TH + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy +import LLVM.Internal.FFI.Cleanup +import LLVM.Internal.FFI.Module +import LLVM.Internal.FFI.Target +import LLVM.Internal.FFI.Transforms + +import qualified LLVM.Transforms as G + +data PassManager + +foreign import ccall unsafe "LLVMCreatePassManager" createPassManager :: + IO (Ptr PassManager) + +foreign import ccall unsafe "LLVMDisposePassManager" disposePassManager :: + Ptr PassManager -> IO () + +foreign import ccall unsafe "LLVMRunPassManager" runPassManager :: + Ptr PassManager -> Ptr Module -> IO CUInt + +foreign import ccall unsafe "LLVMCreateFunctionPassManagerForModule" createFunctionPassManagerForModule :: + Ptr Module -> IO (Ptr PassManager) + +foreign import ccall unsafe "LLVMInitializeFunctionPassManager" initializeFunctionPassManager :: + Ptr PassManager -> IO CUInt + +foreign import ccall unsafe "LLVMRunFunctionPassManager" runFunctionPassManager :: + Ptr PassManager -> Ptr Value -> IO CUInt + +foreign import ccall unsafe "LLVMFinalizeFunctionPassManager" finalizeFunctionPassManager :: + Ptr PassManager -> IO CUInt + +foreign import ccall unsafe "LLVMAddAnalysisPasses" addAnalysisPasses :: + Ptr TargetMachine -> Ptr PassManager -> IO () + +foreign import ccall unsafe "LLVMAddTargetLibraryInfo" addTargetLibraryInfoPass' :: + Ptr TargetLibraryInfo -> Ptr PassManager -> IO () + +addTargetLibraryInfoPass :: Ptr PassManager -> Ptr TargetLibraryInfo -> IO () +addTargetLibraryInfoPass = flip addTargetLibraryInfoPass' + +$(do + let declareForeign :: TH.Name -> [TH.Type] -> TH.DecsQ + declareForeign hName extraParams = do + let n = TH.nameBase hName + passTypeMapping :: TH.Type -> TH.TypeQ + passTypeMapping t = case t of + TH.ConT h | h == ''Word -> [t| CUInt |] + | h == ''G.GCOVVersion -> [t| CString |] + -- some of the LLVM methods for making passes use "-1" as a special value + -- handle those here + TH.AppT (TH.ConT mby) t' | mby == ''Maybe -> + case t' of + TH.ConT h | h == ''Bool -> [t| NothingAsMinusOne Bool |] + | h == ''Word -> [t| NothingAsMinusOne Word |] + | h == ''FilePath -> [t| NothingAsEmptyString CString |] + _ -> typeMapping t + _ -> typeMapping t + foreignDecl + (cName n) + ("add" ++ n ++ "Pass") + ([[t| Ptr PassManager |]] + ++ [[t| Ptr TargetMachine |] | needsTargetMachine n] + ++ map passTypeMapping extraParams) + (TH.tupleT 0) +#if __GLASGOW_HASKELL__ < 800 + TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''G.Pass +#else + TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''G.Pass +#endif + liftM concat $ forM cons $ \con -> case con of + TH.RecC n l -> declareForeign n [ t | (_,_,t) <- l ] + TH.NormalC n [] -> declareForeign n [] + _ -> error "pass descriptor constructors with fields need to be records" + ) + +data PassManagerBuilder + +foreign import ccall unsafe "LLVMPassManagerBuilderCreate" passManagerBuilderCreate :: + IO (Ptr PassManagerBuilder) + +foreign import ccall unsafe "LLVMPassManagerBuilderDispose" passManagerBuilderDispose :: + Ptr PassManagerBuilder -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderSetOptLevel" passManagerBuilderSetOptLevel :: + Ptr PassManagerBuilder -> CUInt -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderSetSizeLevel" passManagerBuilderSetSizeLevel :: + Ptr PassManagerBuilder -> CUInt -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnitAtATime" passManagerBuilderSetDisableUnitAtATime :: + Ptr PassManagerBuilder -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnrollLoops" passManagerBuilderSetDisableUnrollLoops :: + Ptr PassManagerBuilder -> CUInt -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableSimplifyLibCalls" passManagerBuilderSetDisableSimplifyLibCalls :: + Ptr PassManagerBuilder -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderUseInlinerWithThreshold" passManagerBuilderUseInlinerWithThreshold :: + Ptr PassManagerBuilder -> CUInt -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderPopulateFunctionPassManager" passManagerBuilderPopulateFunctionPassManager :: + Ptr PassManagerBuilder -> Ptr PassManager -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderPopulateModulePassManager" passManagerBuilderPopulateModulePassManager :: + Ptr PassManagerBuilder -> Ptr PassManager -> IO () + +foreign import ccall unsafe "LLVMPassManagerBuilderPopulateLTOPassManager" passManagerBuilderPopulateLTOPassManager :: + Ptr PassManagerBuilder -> Ptr PassManager -> CUChar -> CUChar -> IO () + +foreign import ccall unsafe "LLVM_Hs_PassManagerBuilderSetLibraryInfo" passManagerBuilderSetLibraryInfo :: + Ptr PassManagerBuilder -> Ptr TargetLibraryInfo -> IO () + +foreign import ccall unsafe "LLVM_Hs_PassManagerBuilderSetLoopVectorize" passManagerBuilderSetLoopVectorize :: + Ptr PassManagerBuilder -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVM_Hs_PassManagerBuilderSetSuperwordLevelParallelismVectorize" passManagerBuilderSetSuperwordLevelParallelismVectorize :: + Ptr PassManagerBuilder -> LLVMBool -> IO () diff --git a/src/LLVM/Internal/FFI/PassManagerC.cpp b/src/LLVM/Internal/FFI/PassManagerC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/PassManagerC.cpp @@ -0,0 +1,206 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/DataLayout.h" +#include "llvm/IR/LegacyPassManager.h" +#include "llvm/Transforms/Scalar.h" +#include "llvm/Transforms/Scalar/GVN.h" +#include "llvm/Transforms/IPO.h" +#include "llvm/Transforms/IPO/Internalize.h" +#include "llvm/Transforms/IPO/PassManagerBuilder.h" +#include "llvm/Transforms/Vectorize.h" +#include "llvm/Transforms/Instrumentation.h" +#include "llvm/Transforms/Instrumentation/AddressSanitizer.h" +#include "llvm/Transforms/Instrumentation/BoundsChecking.h" +#include "llvm/Transforms/Instrumentation/MemorySanitizer.h" +#include "llvm/Transforms/Instrumentation/ThreadSanitizer.h" +#include "llvm/Transforms/Utils.h" +#include "llvm/LinkAllPasses.h" +#include "llvm/CodeGen/Passes.h" +#include "llvm/CodeGen/TargetLowering.h" +#include "llvm-c/Target.h" +#include "llvm-c/Transforms/PassManagerBuilder.h" +#include "llvm/Analysis/TargetLibraryInfo.h" +#include "llvm/Target/TargetMachine.h" + +#include "llvm-c/Core.h" + +using namespace llvm; + +extern "C" { +typedef struct LLVMOpaqueVectorizationConfig *LLVMVectorizationConfigRef; +typedef struct LLVMOpaqueTargetLowering *LLVMTargetLoweringRef; +typedef struct LLVMOpaqueTargetMachine *LLVMTargetMachineRef; +} + +namespace llvm { +inline TargetLowering *unwrap(LLVMTargetLoweringRef P) { + return reinterpret_cast(P); +} + +inline LLVMTargetLoweringRef wrap(const TargetLowering *P) { + return reinterpret_cast(const_cast(P)); +} + +inline TargetMachine *unwrap(LLVMTargetMachineRef P) { + return reinterpret_cast(P); +} + +inline LLVMTargetMachineRef wrap(const TargetMachine *P) { + return reinterpret_cast(const_cast(P)); +} + +inline TargetLibraryInfoImpl *unwrap(LLVMTargetLibraryInfoRef P) { + return reinterpret_cast(P); +} + +} + +extern "C" { + +#define LLVM_HS_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(macro) \ + macro(BreakCriticalEdges) \ + macro(DeadCodeElimination) \ + macro(DemoteRegisterToMemory) \ + macro(LCSSA) \ + macro(LoopInstSimplify) \ + macro(LowerAtomic) \ + macro(LowerSwitch) \ + macro(MergeFunctions) \ + macro(PartialInlining) \ + macro(Sinking) \ + macro(StripDeadDebugInfo) \ + macro(StripDebugDeclare) \ + macro(StripNonDebugSymbols) \ + +#define ENUM_CASE(p) \ +void LLVM_Hs_Add ## p ## Pass(LLVMPassManagerRef PM) { \ + unwrap(PM)->add(create ## p ## Pass()); \ +} +LLVM_HS_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(ENUM_CASE) +#undef ENUM_CASE + +void LLVM_Hs_AddCodeGenPreparePass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createCodeGenPreparePass()); +} + +void LLVM_Hs_AddGlobalValueNumberingPass(LLVMPassManagerRef PM, LLVMBool noLoads) { + unwrap(PM)->add(createGVNPass(noLoads)); +} + +void LLVM_Hs_AddInternalizePass(LLVMPassManagerRef PM, unsigned nExports, const char **exports) { + std::vector exportList(nExports); + for (unsigned i = 0; i < nExports; ++i) { + exportList.at(i) = exports[i]; + } + std::function mustPreserveGV = [exportList](const GlobalValue & gv) { + for (const auto& exp : exportList) { + if (gv.getName().equals(exp)) { + return true; + } + } + return false; + }; + unwrap(PM)->add(createInternalizePass(std::move(mustPreserveGV))); +} + +void LLVM_Hs_AddLoopStrengthReducePass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createLoopStrengthReducePass()); +} + +void LLVM_Hs_AddLowerInvokePass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createLowerInvokePass()); +} + +void LLVM_Hs_AddSROAPass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createSROAPass()); +} + +void LLVM_Hs_AddGCOVProfilerPass( + LLVMPassManagerRef PM, + LLVMBool emitNotes, + LLVMBool emitData, + const char *version, + LLVMBool noRedZone, + LLVMBool atomic, + const char *filter, + const char *exclude +) { + auto options = GCOVOptions::getDefault(); + options.EmitNotes = emitNotes; + options.EmitData = emitData; + std::copy(version, version+4, options.Version); + options.NoRedZone = noRedZone; + options.Atomic = atomic; + options.Filter = filter; + options.Exclude = exclude; + unwrap(PM)->add(createGCOVProfilerPass(options)); +} + +void LLVM_Hs_AddAddressSanitizerFunctionPass( + LLVMPassManagerRef PM +) { + unwrap(PM)->add(createAddressSanitizerFunctionPass()); +} + +void LLVM_Hs_AddAddressSanitizerModulePass( + LLVMPassManagerRef PM +) { + unwrap(PM)->add(createModuleAddressSanitizerLegacyPassPass()); +} + +void LLVM_Hs_AddMemorySanitizerPass( + LLVMPassManagerRef PM, + LLVMBool trackOrigins, + LLVMBool recover, + LLVMBool kernel +) { + unwrap(PM)->add(createMemorySanitizerLegacyPassPass( + {trackOrigins, static_cast(recover), static_cast(kernel)})); +} + +void LLVM_Hs_AddThreadSanitizerPass( + LLVMPassManagerRef PM +) { + unwrap(PM)->add(createThreadSanitizerLegacyPassPass()); +} + +void LLVM_Hs_AddBoundsCheckingPass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createBoundsCheckingLegacyPass()); +} + +void LLVM_Hs_AddIPSCCPPass(LLVMPassManagerRef PM) { + unwrap(PM)->add(createIPSCCPPass()); +} + +void LLVM_Hs_AddLoopVectorizePass( + LLVMPassManagerRef PM, + LLVMBool interleaveOnlyWhenForced, + LLVMBool vectorizeOnlyWhenForced +) { + unwrap(PM)->add(createLoopVectorizePass(interleaveOnlyWhenForced, vectorizeOnlyWhenForced)); +} + +void LLVM_Hs_PassManagerBuilderSetLibraryInfo( + LLVMPassManagerBuilderRef PMB, + LLVMTargetLibraryInfoRef l +) { + // The PassManager frees the TargetLibraryInfo when done, + // but we also free our ref, so give it a new copy. + unwrap(PMB)->LibraryInfo = new TargetLibraryInfoImpl(*unwrap(l)); +} + +void LLVM_Hs_PassManagerBuilderSetLoopVectorize( + LLVMPassManagerBuilderRef PMB, + LLVMBool runLoopVectorization +) { + unwrap(PMB)->LoopVectorize = runLoopVectorization; +} + +void LLVM_Hs_PassManagerBuilderSetSuperwordLevelParallelismVectorize( + LLVMPassManagerBuilderRef PMB, + LLVMBool runSLPVectorization +) { + unwrap(PMB)->SLPVectorize = runSLPVectorization; +} + +} diff --git a/src/LLVM/Internal/FFI/PtrHierarchy.hs b/src/LLVM/Internal/FFI/PtrHierarchy.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/PtrHierarchy.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + FunctionalDependencies, + UndecidableInstances + #-} +-- | This module defines typeclasses to represent the relationships of an object-oriented inheritance hierarchy +module LLVM.Internal.FFI.PtrHierarchy where + +import LLVM.Prelude + +import Foreign.Ptr + +-- | a class to represent safe casting of pointers to objects of descendant-classes to ancestor-classes. +class DescendentOf a b where + upCast :: Ptr b -> Ptr a + upCast = castPtr + +-- | trivial casts +instance {-# OVERLAPPING #-} DescendentOf a a where + upCast = id + +-- | a class to represent direct parent-child relationships +class ChildOf b c | c -> b + +-- | ancestor-descentant relationships are build out of parent-child relationships +instance (DescendentOf a b, ChildOf b c) => DescendentOf a c + +-- | +data Value + +-- | +data Constant + +instance ChildOf User Constant + +-- | +data GlobalValue + +instance ChildOf Constant GlobalValue + +-- | +data GlobalObject + +instance ChildOf GlobalValue GlobalObject + +-- | +data GlobalVariable + +instance ChildOf GlobalObject GlobalVariable + +-- | +data GlobalAlias + +instance ChildOf GlobalValue GlobalAlias + +-- | +data Function + +instance ChildOf GlobalObject Function + +-- | +data BasicBlock + +instance ChildOf Value BasicBlock + +-- | +data Parameter + +instance ChildOf Value Parameter + +-- | +data Instruction + +instance ChildOf User Instruction + +-- | +data UnaryOperator + +-- This is not strictly true in the sense of the definition of the typeclass +-- ChildOf, since Instruction -> UnaryInstruction -> UnaryOperator is the +-- derivation. However, we never need to reference UnaryInstruction methods +-- so we can elide it. It is valid to cast a UnaryOperator* to an Instruction*. +instance ChildOf Instruction UnaryOperator + +-- | +data BinaryOperator + +instance ChildOf Instruction BinaryOperator + +-- | +data User + +instance ChildOf Value User + +-- | +data MDNode + +instance ChildOf Metadata MDNode + +data MDTuple + +instance ChildOf MDNode MDTuple + +-- | +data MDString + +instance ChildOf Metadata MDString + +-- | http://llvm.org/doxygen/classllvm_1_1ValueAsMetadata.html +data MDValue + +instance ChildOf Metadata MDValue + +-- | https://llvm.org/doxygen/classllvm_1_1DIExpression.html +data DIExpression + +instance ChildOf MDNode DIExpression + +-- | https://llvm.org/doxygen/classllvm_1_1DIGlobalVariableExpression.html +data DIGlobalVariableExpression + +instance ChildOf MDNode DIGlobalVariableExpression + +-- | https://llvm.org/doxygen/classllvm_1_1DILocation.html +data DILocation + +instance ChildOf MDNode DILocation + +-- | https://llvm.org/doxygen/classllvm_1_1DINode.html +data DINode + +instance ChildOf MDNode DINode + +-- | https://llvm.org/doxygen/classllvm_1_1DIImportedEntity.html +data DIImportedEntity + +instance ChildOf DINode DIImportedEntity + +-- | https://llvm.org/doxygen/classllvm_1_1DIObjCProperty.html +data DIObjCProperty + +instance ChildOf DINode DIObjCProperty + +-- | https://llvm.org/doxygen/classllvm_1_1DISubrange.html +data DISubrange + +instance ChildOf DINode DISubrange + +-- | https://llvm.org/doxygen/classllvm_1_1DIEnumerator.html +data DIEnumerator + +instance ChildOf DINode DIEnumerator + +-- | https://llvm.org/doxygen/classllvm_1_1DIVariable.html +data DIVariable + +instance ChildOf DINode DIVariable + +-- | https://llvm.org/doxygen/classllvm_1_1DILocalVariable.html +data DILocalVariable + +instance ChildOf DIVariable DILocalVariable + +-- | https://llvm.org/doxygen/classllvm_1_1DIGlobalVariable.html +data DIGlobalVariable + +instance ChildOf DIVariable DIGlobalVariable + +-- | https://llvm.org/doxygen/classllvm_1_1DITemplateParameter.html +data DITemplateParameter + +instance ChildOf DINode DITemplateParameter + +-- | https://llvm.org/doxygen/classllvm_1_1DITemplateTypeParameter.html +data DITemplateTypeParameter + +instance ChildOf DITemplateParameter DITemplateTypeParameter + +-- | https://llvm.org/doxygen/classllvm_1_1DITemplateValueParameter.html +data DITemplateValueParameter + +instance ChildOf DITemplateParameter DITemplateValueParameter + +-- | https://llvm.org/doxygen/classllvm_1_1DIScope.html +data DIScope + +instance ChildOf DINode DIScope + +-- | https://llvm.org/doxygen/classllvm_1_1DIModule.html +data DIModule + +instance ChildOf DIScope DIModule + +-- | https://llvm.org/doxygen/classllvm_1_1DINamespace.html +data DINamespace + +instance ChildOf DIScope DINamespace + +-- | https://llvm.org/doxygen/classllvm_1_1DIFile.html +data DIFile + +instance ChildOf DIScope DIFile + +-- | https://llvm.org/doxygen/classllvm_1_1DICompileUnit.html +data DICompileUnit + +instance ChildOf DIScope DICompileUnit + +-- | https://llvm.org/doxygen/classllvm_1_1DIType.html +data DIType + +instance ChildOf DIScope DIType + +-- | https://llvm.org/doxygen/classllvm_1_1DIBasicType.html +data DIBasicType + +instance ChildOf DIType DIBasicType + +-- | https://llvm.org/doxygen/classllvm_1_1DIDerivedType.html +data DIDerivedType + +instance ChildOf DIType DIDerivedType + +-- | https://llvm.org/doxygen/classllvm_1_1DISubroutineType.html +data DISubroutineType + +instance ChildOf DIType DISubroutineType + +-- | https://llvm.org/doxygen/classllvm_1_1DICompositeType.html +data DICompositeType + +instance ChildOf DIType DICompositeType + +-- | https://llvm.org/doxygen/classllvm_1_1DILocalScope.html +data DILocalScope + +instance ChildOf DIScope DILocalScope + +-- | +data DILexicalBlockBase + +instance ChildOf DILocalScope DILexicalBlockBase + +-- | +data DILexicalBlock + +instance ChildOf DILexicalBlockBase DILexicalBlock + +-- | +data DILexicalBlockFile + +instance ChildOf DILexicalBlockBase DILexicalBlockFile + +-- | +data DISubprogram + +instance ChildOf DILocalScope DISubprogram + +-- +data DIMacroNode + +instance ChildOf MDNode DIMacroNode + +-- +data DIMacro + +instance ChildOf DIMacroNode DIMacro + +-- +data DIMacroFile + +instance ChildOf DIMacroNode DIMacroFile + +-- | +data NamedMetadata + +-- | +data InlineAsm + +instance ChildOf Value InlineAsm + +-- | +data Type + +-- | +data Metadata + +-- | +data MetadataAsVal + +instance ChildOf Value MetadataAsVal + +-- | +data RawOStream + +-- | +data RawPWriteStream + +instance ChildOf RawOStream RawPWriteStream + +-- | +data StringRef diff --git a/src/LLVM/Internal/FFI/RTDyldMemoryManager.cpp b/src/LLVM/Internal/FFI/RTDyldMemoryManager.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/RTDyldMemoryManager.cpp @@ -0,0 +1,14 @@ +#define __STDC_LIMIT_MACROS + +#include "llvm/ExecutionEngine/RTDyldMemoryManager.h" + +using namespace llvm; + +extern "C" { + +uint64_t LLVM_Hs_GetSymbolAddressInProcess(const char *name) { + std::string nameStr(name); + return RTDyldMemoryManager::getSymbolAddressInProcess(nameStr); +} + +} diff --git a/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs b/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/RTDyldMemoryManager.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | FFI functions for handling the RTDyldMemoryManager class +module LLVM.Internal.FFI.RTDyldMemoryManager where + +import LLVM.Prelude + +import Foreign.C.String + +-- | +foreign import ccall safe "LLVM_Hs_GetSymbolAddressInProcess" getSymbolAddressInProcess :: + CString -> IO Word64 diff --git a/src/LLVM/Internal/FFI/RawOStream.hs b/src/LLVM/Internal/FFI/RawOStream.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/RawOStream.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.RawOStream where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C +import Control.Exception (bracket) + +import LLVM.Internal.FFI.ByteRangeCallback +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy + +type RawPWriteStreamCallback = Ptr RawPWriteStream -> IO () + +foreign import ccall "wrapper" wrapRawPWriteStreamCallback :: + RawPWriteStreamCallback -> IO (FunPtr RawPWriteStreamCallback) + +foreign import ccall safe "LLVM_Hs_WithFileRawPWriteStream" withFileRawPWriteStream' :: + CString -> LLVMBool -> LLVMBool -> Ptr (OwnerTransfered CString) -> FunPtr RawPWriteStreamCallback -> IO LLVMBool + +withFileRawPWriteStream :: CString -> LLVMBool -> LLVMBool -> Ptr (OwnerTransfered CString) -> RawPWriteStreamCallback -> IO LLVMBool +withFileRawPWriteStream p ex bin err c = + bracket (wrapRawPWriteStreamCallback c) freeHaskellFunPtr (withFileRawPWriteStream' p ex bin err) + +foreign import ccall safe "LLVM_Hs_WithBufferRawPWriteStream" withBufferRawPWriteStream' :: + FunPtr ByteRangeCallback -> FunPtr RawPWriteStreamCallback -> IO () + +withBufferRawPWriteStream :: ByteRangeCallback -> RawPWriteStreamCallback -> IO () +withBufferRawPWriteStream oc c = + bracket (wrapRawPWriteStreamCallback c) freeHaskellFunPtr $ \c -> + bracket (wrapByteRangeCallback oc) freeHaskellFunPtr $ \oc -> + withBufferRawPWriteStream' oc c diff --git a/src/LLVM/Internal/FFI/RawOStreamC.cpp b/src/LLVM/Internal/FFI/RawOStreamC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/RawOStreamC.cpp @@ -0,0 +1,35 @@ +#define __STDC_LIMIT_MACROS +#include "llvm-c/Core.h" +#include "llvm/Support/FileSystem.h" +#include "llvm/Support/raw_ostream.h" + +using namespace llvm; + +extern "C" { + +LLVMBool +LLVM_Hs_WithFileRawPWriteStream(const char *filename, LLVMBool excl, + LLVMBool text, char **error, + void (&callback)(raw_pwrite_stream &ostream)) { + std::error_code e; + raw_fd_ostream os(filename, e, + excl ? sys::fs::CD_CreateNew : sys::fs::CD_OpenAlways, + sys::fs::FA_Write, + text ? sys::fs::OF_Text : sys::fs::OF_None); + if (e) { + *error = strdup(e.message().c_str()); + return false; + } + callback(os); + return true; +} + +void LLVM_Hs_WithBufferRawPWriteStream( + void (&outputCallback)(const char *start, size_t length), + void (&streamCallback)(raw_pwrite_stream &ostream)) { + SmallString<0> s; + raw_svector_ostream os(s); + streamCallback(os); + outputCallback(os.str().data(), s.size()); +} +} diff --git a/src/LLVM/Internal/FFI/SMDiagnostic.h b/src/LLVM/Internal/FFI/SMDiagnostic.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/SMDiagnostic.h @@ -0,0 +1,15 @@ +#ifndef __LLVM_INTERNAL_FFI__SMDIAGNOSTIC__ +#define __LLVM_INTERNAL_FFI__SMDIAGNOSTIC__ + +#define LLVM_HS_FOR_EACH_DIAGNOSTIC_KIND(macro) \ + macro(Error) \ + macro(Warning) \ + macro(Note) + +typedef enum { +#define ENUM_CASE(k) LLVMDiagnosticKind ## k, +LLVM_HS_FOR_EACH_DIAGNOSTIC_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVMDiagnosticKind; + +#endif diff --git a/src/LLVM/Internal/FFI/SMDiagnostic.hs b/src/LLVM/Internal/FFI/SMDiagnostic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/SMDiagnostic.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +-- | FFI functions for handling the LLVM SMDiagnostic class +module LLVM.Internal.FFI.SMDiagnostic where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes + +data SMDiagnostic + +-- | allocate an SMDiagnostic object +foreign import ccall unsafe "LLVM_Hs_CreateSMDiagnostic" createSMDiagnostic :: + IO (Ptr SMDiagnostic) + +foreign import ccall unsafe "LLVM_Hs_DisposeSMDiagnostic" disposeSMDiagnostic :: + Ptr SMDiagnostic -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetSMDiagnosticKind" getSMDiagnosticKind :: + Ptr SMDiagnostic -> IO DiagnosticKind + +foreign import ccall unsafe "LLVM_Hs_GetSMDiagnosticLineNo" getSMDiagnosticLineNo :: + Ptr SMDiagnostic -> IO CInt + +foreign import ccall unsafe "LLVM_Hs_GetSMDiagnosticColumnNo" getSMDiagnosticColumnNo :: + Ptr SMDiagnostic -> IO CInt + +foreign import ccall unsafe "LLVM_Hs_GetSMDiagnosticFilename" getSMDiagnosticFilename :: + Ptr SMDiagnostic -> Ptr CUInt -> IO CString + +foreign import ccall unsafe "LLVM_Hs_GetSMDiagnosticMessage" getSMDiagnosticMessage :: + Ptr SMDiagnostic -> Ptr CUInt -> IO CString + +foreign import ccall unsafe "LLVM_Hs_GetSMDiagnosticLineContents" getSMDiagnosticLineContents :: + Ptr SMDiagnostic -> Ptr CUInt -> IO CString + diff --git a/src/LLVM/Internal/FFI/SMDiagnosticC.cpp b/src/LLVM/Internal/FFI/SMDiagnosticC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/SMDiagnosticC.cpp @@ -0,0 +1,42 @@ +#define __STDC_LIMIT_MACROS +#include "llvm/Config/llvm-config.h" +#include "llvm/IR/LLVMContext.h" + +#include "llvm/Support/SourceMgr.h" +#include "llvm-c/Core.h" + +#include "LLVM/Internal/FFI/SMDiagnostic.h" + +using namespace llvm; + +extern "C" { + +SMDiagnostic *LLVM_Hs_CreateSMDiagnostic() { return new SMDiagnostic(); } +void LLVM_Hs_DisposeSMDiagnostic(SMDiagnostic *p) { delete p; } + +LLVMDiagnosticKind LLVM_Hs_GetSMDiagnosticKind(SMDiagnostic *p) { + switch(p->getKind()) { +#define ENUM_CASE(k) case SourceMgr::DK_ ## k: return LLVMDiagnosticKind ## k; + LLVM_HS_FOR_EACH_DIAGNOSTIC_KIND(ENUM_CASE) +#undef ENUM_CASE + default: return LLVMDiagnosticKind(0); + } +} + +int LLVM_Hs_GetSMDiagnosticLineNo(SMDiagnostic *p) { return p->getLineNo(); } +int LLVM_Hs_GetSMDiagnosticColumnNo(SMDiagnostic *p) { return p->getColumnNo(); } + +const char *LLVM_Hs_GetSMDiagnosticFilename(SMDiagnostic *p, unsigned *len) { + *len = p->getFilename().size(); + return p->getFilename().data(); +} +const char *LLVM_Hs_GetSMDiagnosticMessage(SMDiagnostic *p, unsigned *len) { + *len = p->getMessage().size(); + return p->getMessage().data(); +} +const char *LLVM_Hs_GetSMDiagnosticLineContents(SMDiagnostic *p, unsigned *len) { + *len = p->getLineContents().size(); + return p->getLineContents().data(); +} + +} diff --git a/src/LLVM/Internal/FFI/ShortByteString.hs b/src/LLVM/Internal/FFI/ShortByteString.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ShortByteString.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +module LLVM.Internal.FFI.ShortByteString + ( packCString + , packCStringLen + , useAsCString + , useAsCStringLen + ) where + + + +#if MIN_VERSION_bytestring(0,10,9) +import Data.ByteString.Short +#else +import LLVM.Prelude +import Data.ByteString.Internal (c_strlen) +import Data.ByteString.Short.Internal +import qualified Data.ByteString.Short as ByteString +import Foreign.C.String +import Foreign.Marshal.Alloc +import Foreign.Storable + + +{-# INLINABLE packCString #-} +packCString :: CString -> IO ShortByteString +packCString cstr = do + len <- c_strlen cstr + packCStringLen (cstr, fromIntegral len) + +{-# INLINABLE packCStringLen #-} +packCStringLen :: CStringLen -> IO ShortByteString +packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len +packCStringLen (_, len) = + error ("negative length: " ++ show len) + +{-# INLINABLE useAsCString #-} +useAsCString :: ShortByteString -> (CString -> IO a) -> IO a +useAsCString bs action = + allocaBytes (l+1) $ \buf -> do + copyToPtr bs 0 buf (fromIntegral l) + pokeByteOff buf l (0::Word8) + action buf + where l = ByteString.length bs + +{-# INLINABLE useAsCStringLen #-} +useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a +useAsCStringLen bs action = + allocaBytes l $ \buf -> do + copyToPtr bs 0 buf (fromIntegral l) + action (buf, l) + where l = ByteString.length bs +#endif diff --git a/src/LLVM/Internal/FFI/Target.h b/src/LLVM/Internal/FFI/Target.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Target.h @@ -0,0 +1,183 @@ +#ifndef __LLVM_INTERNAL_FFI__TARGET__H__ +#define __LLVM_INTERNAL_FFI__TARGET__H__ + +#define LLVM_HS_FOR_EACH_RELOC_MODEL(macro) \ + macro(Default, Default) \ + macro(Static, Static) \ + macro(PIC, PIC_) \ + macro(DynamicNoPic, DynamicNoPIC) + +#define LLVM_HS_FOR_EACH_CODE_MODEL(macro) \ + macro(Default) \ + macro(JITDefault) \ + macro(Small) \ + macro(Kernel) \ + macro(Medium) \ + macro(Large) + +#define LLVM_HS_FOR_EACH_CODE_GEN_OPT_LEVEL(macro) \ + macro(None) \ + macro(Less) \ + macro(Default) \ + macro(Aggressive) + +#define LLVM_HS_FOR_EACH_CODE_GEN_FILE_TYPE(macro) \ + macro(Assembly) \ + macro(Object) + +#define LLVM_HS_FOR_EACH_TARGET_OPTION_FLAG(macro) \ + macro(UnsafeFPMath) \ + macro(NoInfsFPMath) \ + macro(NoNaNsFPMath) \ + macro(NoTrappingFPMath) \ + macro(NoSignedZerosFPMath) \ + macro(HonorSignDependentRoundingFPMathOption) \ + macro(NoZerosInBSS) \ + macro(GuaranteedTailCallOpt) \ + macro(StackSymbolOrdering) \ + macro(EnableFastISel) \ + macro(EnableGlobalISel) \ + macro(UseInitArray) \ + macro(DisableIntegratedAS) \ + macro(RelaxELFRelocations) \ + macro(FunctionSections) \ + macro(DataSections) \ + macro(IgnoreXCOFFVisibility) \ + macro(UniqueSectionNames) \ + macro(UniqueBasicBlockSectionNames) \ + macro(TrapUnreachable) \ + macro(NoTrapAfterNoreturn) \ + macro(EmulatedTLS) \ + macro(ExplicitEmulatedTLS) \ + macro(EnableIPRA) \ + macro(EmitStackSizeSection) \ + macro(EnableMachineOutliner) \ + macro(EnableMachineFunctionSplitter) \ + macro(SupportsDefaultOutlining) \ + macro(EmitAddrsig) \ + macro(EmitCallSiteInfo) \ + macro(SupportsDebugEntryValues) \ + macro(EnableDebugEntryValues) \ + macro(ValueTrackingVariableLocations) \ + macro(ForceDwarfFrameSection) \ + macro(XRayOmitFunctionIndex) \ + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_TargetOptionFlag_ ## n, + LLVM_HS_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_TargetOptionFlag; + +#define LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(macro) \ + macro(MCRelaxAll) \ + macro(MCNoExecStack) \ + macro(MCFatalWarnings) \ + macro(MCNoWarn) \ + macro(MCNoDeprecatedWarn) \ + macro(MCSaveTempLabels) \ + macro(MCUseDwarfDirectory) \ + macro(MCIncrementalLinkerCompatible) \ + macro(ShowMCEncoding) \ + macro(ShowMCInst) \ + macro(AsmVerbose) \ + macro(PreserveAsmComments) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_MCTargetOptionFlag_ ## n, + LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_MCTargetOptionFlag; + +#define LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(macro) \ + macro(None) \ + macro(GNU) \ + macro(Z) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_DebugCompressionType_ ## n, + LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_DebugCompressionType; + +#define LLVM_HS_FOR_EACH_FLOAT_ABI(macro) \ + macro(Default) \ + macro(Soft) \ + macro(Hard) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_FloatABI_ ## n, + LLVM_HS_FOR_EACH_FLOAT_ABI(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_FloatABI; + +#define LLVM_HS_FOR_EACH_FP_OP_FUSION_MODE(macro) \ + macro(Fast) \ + macro(Standard) \ + macro(Strict) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_FPOpFusionMode_ ## n, + LLVM_HS_FOR_EACH_FP_OP_FUSION_MODE(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_FPOpFusionMode; + +#define LLVM_HS_FOR_EACH_THREAD_MODEL(macro) \ + macro(POSIX) \ + macro(Single) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_ThreadModel_ ## n, + LLVM_HS_FOR_EACH_THREAD_MODEL(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_ThreadModel; + +#define LLVM_HS_FOR_EACH_EABI(macro) \ + macro(Unknown) \ + macro(Default) \ + macro(EABI4) \ + macro(EABI5) \ + macro(GNU) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_EABI_ ## n, + LLVM_HS_FOR_EACH_EABI(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_EABI; + +#define LLVM_HS_FOR_EACH_DEBUGGER_KIND(macro) \ + macro(Default) \ + macro(GDB) \ + macro(LLDB) \ + macro(SCE) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_DebuggerKind_ ## n, + LLVM_HS_FOR_EACH_DEBUGGER_KIND(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_DebuggerKind; + +#define LLVM_HS_FOR_EACH_FP_DENORMAL_MODE(macro) \ + macro(IEEE) \ + macro(PreserveSign) \ + macro(PositiveZero) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_FPDenormalMode_ ## n, + LLVM_HS_FOR_EACH_FP_DENORMAL_MODE(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_FPDenormalMode; + +#define LLVM_HS_FOR_EACH_EXCEPTION_HANDLING(macro) \ + macro(None) \ + macro(DwarfCFI) \ + macro(SjLj) \ + macro(ARM) \ + macro(WinEH) + +typedef enum { +#define ENUM_CASE(n) LLVM_Hs_ExceptionHandling_ ## n, + LLVM_HS_FOR_EACH_EXCEPTION_HANDLING(ENUM_CASE) +#undef ENUM_CASE +} LLVM_Hs_ExceptionHandling; + +#endif diff --git a/src/LLVM/Internal/FFI/Target.hpp b/src/LLVM/Internal/FFI/Target.hpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Target.hpp @@ -0,0 +1,11 @@ +#ifndef __LLVM_INTERNAL_FFI__TARGET__HPP__ +#define __LLVM_INTERNAL_FFI__TARGET__HPP__ + +#include "llvm-c/TargetMachine.h" +#include "llvm/Target/TargetMachine.h" + +namespace llvm { +DEFINE_SIMPLE_CONVERSION_FUNCTIONS(TargetMachine, LLVMTargetMachineRef) +} + +#endif diff --git a/src/LLVM/Internal/FFI/Target.hs b/src/LLVM/Internal/FFI/Target.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Target.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE + ForeignFunctionInterface, + GeneralizedNewtypeDeriving + #-} +module LLVM.Internal.FFI.Target where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.DataLayout +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.MemoryBuffer +import LLVM.Internal.FFI.Module +import LLVM.Internal.FFI.PtrHierarchy + +data Target + +foreign import ccall unsafe "LLVM_Hs_InitializeNativeTarget" initializeNativeTarget :: + IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_LookupTarget" lookupTarget :: + CString -> CString -> Ptr (OwnerTransfered CString) -> Ptr (OwnerTransfered CString) -> IO (Ptr Target) + +data TargetOptions +data MCTargetOptions + +foreign import ccall unsafe "LLVM_Hs_CreateTargetOptions" createTargetOptions :: + IO (Ptr TargetOptions) + +foreign import ccall unsafe "LLVM_Hs_SetTargetOptionFlag" setTargetOptionFlag :: + Ptr TargetOptions -> TargetOptionFlag -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetTargetOptionFlag" getTargetOptionsFlag :: + Ptr TargetOptions -> TargetOptionFlag -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_SetMCTargetOptionFlag" setMCTargetOptionFlag :: + Ptr MCTargetOptions -> MCTargetOptionFlag -> LLVMBool -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetMCTargetOptionFlag" getMCTargetOptionsFlag :: + Ptr MCTargetOptions -> MCTargetOptionFlag -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_GetCompressDebugSections" getCompressDebugSections :: + Ptr TargetOptions -> IO DebugCompressionType + +foreign import ccall unsafe "LLVM_Hs_SetCompressDebugSections" setCompressDebugSections :: + Ptr TargetOptions -> DebugCompressionType -> IO () + +foreign import ccall unsafe "LLVM_Hs_SetStackAlignmentOverride" setStackAlignmentOverride :: + Ptr TargetOptions -> CUInt -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetStackAlignmentOverride" getStackAlignmentOverride :: + Ptr TargetOptions -> IO CUInt + +foreign import ccall unsafe "LLVM_Hs_SetFloatABIType" setFloatABIType :: + Ptr TargetOptions -> FloatABIType -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetFloatABIType" getFloatABIType :: + Ptr TargetOptions -> IO FloatABIType + +foreign import ccall unsafe "LLVM_Hs_SetAllowFPOpFusion" setAllowFPOpFusion :: + Ptr TargetOptions -> FPOpFusionMode -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetAllowFPOpFusion" getAllowFPOpFusion :: + Ptr TargetOptions -> IO FPOpFusionMode + +foreign import ccall unsafe "LLVM_Hs_SetThreadModel" setThreadModel :: + Ptr TargetOptions -> ThreadModel -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetThreadModel" getThreadModel :: + Ptr TargetOptions -> IO ThreadModel + +foreign import ccall unsafe "LLVM_Hs_SetEABIVersion" setEABIVersion :: + Ptr TargetOptions -> EABI -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetEABIVersion" getEABIVersion :: + Ptr TargetOptions -> IO EABI + +foreign import ccall unsafe "LLVM_Hs_SetDebuggerTuning" setDebuggerTuning :: + Ptr TargetOptions -> DebuggerKind -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetDebuggerTuning" getDebuggerTuning :: + Ptr TargetOptions -> IO DebuggerKind + +foreign import ccall unsafe "LLVM_Hs_SetFPDenormalMode" setFPDenormalMode :: + Ptr TargetOptions -> FPDenormalMode -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetFPDenormalMode" getFPDenormalMode :: + Ptr TargetOptions -> IO FPDenormalMode + +foreign import ccall unsafe "LLVM_Hs_SetExceptionModel" setExceptionModel :: + Ptr TargetOptions -> ExceptionHandling -> IO () + +foreign import ccall unsafe "LLVM_Hs_GetExceptionModel" getExceptionModel :: + Ptr TargetOptions -> IO ExceptionHandling + +foreign import ccall unsafe "LLVM_Hs_DisposeTargetOptions" disposeTargetOptions :: + Ptr TargetOptions -> IO () + +data TargetMachine + +foreign import ccall unsafe "LLVM_Hs_CreateTargetMachine" createTargetMachine :: + Ptr Target + -> CString + -> CString + -> CString + -> Ptr TargetOptions + -> RelocModel + -> CodeModel + -> CodeGenOptLevel + -> IO (Ptr TargetMachine) + +foreign import ccall unsafe "LLVMDisposeTargetMachine" disposeTargetMachine :: + Ptr TargetMachine -> IO () + +foreign import ccall unsafe "LLVM_Hs_TargetMachineOptions" targetMachineOptions :: + Ptr TargetMachine -> IO (Ptr TargetOptions) + +foreign import ccall unsafe "LLVM_Hs_MCTargetOptions" machineCodeOptions :: + Ptr TargetOptions -> IO (Ptr MCTargetOptions) + +foreign import ccall unsafe "LLVM_Hs_TargetMachineEmit" targetMachineEmit :: + Ptr TargetMachine + -> Ptr Module + -> Ptr RawPWriteStream + -> CodeGenFileType + -> Ptr (OwnerTransfered CString) + -> IO LLVMBool + +foreign import ccall unsafe "LLVMTargetMachineEmitToFile" targetMachineEmitToFile :: + Ptr TargetMachine + -> Ptr Module + -> CString + -> CodeGenFileType + -> Ptr (OwnerTransfered CString) + -> IO LLVMBool + +foreign import ccall unsafe "LLVMTargetMachineEmitToMemoryBuffer" targetMachineEmitToMemoryBuffer :: + Ptr TargetMachine + -> Ptr Module + -> CodeGenFileType + -> Ptr (OwnerTransfered CString) + -> Ptr (Ptr MemoryBuffer) + -> IO LLVMBool + +data TargetLowering + +-- foreign import ccall unsafe "LLVM_Hs_GetTargetLowering" getTargetLowering :: +-- Ptr TargetMachine -> IO (Ptr TargetLowering) + +foreign import ccall unsafe "LLVMGetTargetMachineTriple" getTargetMachineTriple :: + Ptr TargetMachine -> IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVM_Hs_GetDefaultTargetTriple" getDefaultTargetTriple :: + IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVM_Hs_GetProcessTargetTriple" getProcessTargetTriple :: + IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVM_Hs_GetHostCPUName" getHostCPUName :: + Ptr CSize -> IO CString + +foreign import ccall unsafe "LLVM_Hs_GetHostCPUFeatures" getHostCPUFeatures :: + IO (OwnerTransfered CString) + +foreign import ccall unsafe "LLVM_Hs_GetTargetMachineDataLayout" getTargetMachineDataLayout :: + Ptr TargetMachine -> IO (OwnerTransfered CString) + +data TargetLibraryInfo + +foreign import ccall unsafe "LLVM_Hs_CreateTargetLibraryInfo" createTargetLibraryInfo :: + CString -> IO (Ptr TargetLibraryInfo) + +foreign import ccall unsafe "LLVM_Hs_GetLibFunc" getLibFunc :: + Ptr TargetLibraryInfo -> CString -> Ptr LibFunc -> IO LLVMBool + +foreign import ccall unsafe "LLVM_Hs_LibFuncGetName" libFuncGetName :: + Ptr TargetLibraryInfo -> LibFunc -> Ptr CSize -> IO CString + +foreign import ccall unsafe "LLVM_Hs_LibFuncSetAvailableWithName" libFuncSetAvailableWithName :: + Ptr TargetLibraryInfo -> LibFunc -> CString -> IO () + +foreign import ccall unsafe "LLVM_Hs_DisposeTargetLibraryInfo" disposeTargetLibraryInfo :: + Ptr TargetLibraryInfo -> IO () + +foreign import ccall unsafe "LLVM_Hs_InitializeAllTargets" initializeAllTargets :: IO () + +foreign import ccall unsafe "LLVMCreateTargetDataLayout" createTargetDataLayout :: + Ptr TargetMachine -> IO (Ptr DataLayout) diff --git a/src/LLVM/Internal/FFI/TargetC.cpp b/src/LLVM/Internal/FFI/TargetC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/TargetC.cpp @@ -0,0 +1,586 @@ +#define __STDC_LIMIT_MACROS +#include "LLVM/Internal/FFI/ErrorHandling.hpp" +#include "LLVM/Internal/FFI/LibFunc.h" +#include "LLVM/Internal/FFI/Target.h" +#include "LLVM/Internal/FFI/Target.hpp" +#include "llvm-c/Core.h" +#include "llvm-c/Target.h" +#include "llvm-c/TargetMachine.h" +#include "llvm/ADT/Triple.h" +#include "llvm/Analysis/TargetLibraryInfo.h" +#include "llvm/ExecutionEngine/Interpreter.h" +#include "llvm/IR/DataLayout.h" +#include "llvm/IR/LegacyPassManager.h" +#include "llvm/IR/Module.h" +#include "llvm/Support/FormattedStream.h" +#include "llvm/Support/Host.h" +#include "llvm/Support/TargetRegistry.h" +#include "llvm/Support/TargetSelect.h" +#include "llvm/Target/CodeGenCWrappers.h" +#include "llvm/Target/TargetMachine.h" + +using namespace llvm; + +namespace llvm { +// Taken from llvm/lib/Target/TargetMachineC.cpp +// These functions need to be marked as static to avoid undefined behavior +// due to multiple definitions +static LLVMTargetRef wrap(const Target *P) { + return reinterpret_cast(const_cast(P)); +} + +static Target *unwrap(LLVMTargetRef P) { return reinterpret_cast(P); } + +static inline TargetLibraryInfoImpl *unwrap(LLVMTargetLibraryInfoRef P) { + return reinterpret_cast(P); +} + +static inline LLVMTargetLibraryInfoRef wrap(const TargetLibraryInfoImpl *P) { + TargetLibraryInfoImpl *X = const_cast(P); + return reinterpret_cast(X); +} + +static FloatABI::ABIType unwrap(LLVM_Hs_FloatABI x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_FloatABI_##x: \ + return FloatABI::x; + LLVM_HS_FOR_EACH_FLOAT_ABI(ENUM_CASE) +#undef ENUM_CASE + default: + return FloatABI::ABIType(0); + } +} + +static LibFunc unwrap(LLVMLibFunc x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVMLibFunc__##x: \ + return LibFunc_##x; + LLVM_HS_FOR_EACH_LIB_FUNC(ENUM_CASE) +#undef ENUM_CASE + default: + return LibFunc(0); + } +} + +static LLVMLibFunc wrap(LibFunc x) { + switch (x) { +#define ENUM_CASE(x) \ + case LibFunc_##x: \ + return LLVMLibFunc__##x; + LLVM_HS_FOR_EACH_LIB_FUNC(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVMLibFunc(0); + } +} + +static LLVM_Hs_FloatABI wrap(FloatABI::ABIType x) { + switch (x) { +#define ENUM_CASE(x) \ + case FloatABI::x: \ + return LLVM_Hs_FloatABI_##x; + LLVM_HS_FOR_EACH_FLOAT_ABI(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_FloatABI(0); + } +} + +static FPOpFusion::FPOpFusionMode unwrap(LLVM_Hs_FPOpFusionMode x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_FPOpFusionMode_##x: \ + return FPOpFusion::x; + LLVM_HS_FOR_EACH_FP_OP_FUSION_MODE(ENUM_CASE) +#undef ENUM_CASE + default: + return FPOpFusion::FPOpFusionMode(0); + } +} + +static LLVM_Hs_FPOpFusionMode wrap(FPOpFusion::FPOpFusionMode x) { + switch (x) { +#define ENUM_CASE(x) \ + case FPOpFusion::x: \ + return LLVM_Hs_FPOpFusionMode_##x; + LLVM_HS_FOR_EACH_FP_OP_FUSION_MODE(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_FPOpFusionMode(0); + } +} + +static ThreadModel::Model unwrap(LLVM_Hs_ThreadModel x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_ThreadModel_##x: \ + return ThreadModel::x; + LLVM_HS_FOR_EACH_THREAD_MODEL(ENUM_CASE) +#undef ENUM_CASE + default: + return ThreadModel::Model(0); + } +} + +static LLVM_Hs_ThreadModel wrap(ThreadModel::Model x) { + switch (x) { +#define ENUM_CASE(x) \ + case ThreadModel::x: \ + return LLVM_Hs_ThreadModel_##x; + LLVM_HS_FOR_EACH_THREAD_MODEL(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_ThreadModel(0); + } +} +static EABI unwrap(LLVM_Hs_EABI x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_EABI_##x: \ + return EABI::x; + LLVM_HS_FOR_EACH_EABI(ENUM_CASE) +#undef ENUM_CASE + default: + return EABI(0); + } +} + +static LLVM_Hs_EABI wrap(EABI x) { + switch (x) { +#define ENUM_CASE(x) \ + case EABI::x: \ + return LLVM_Hs_EABI_##x; + LLVM_HS_FOR_EACH_EABI(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_EABI(0); + } +} + +static DebuggerKind unwrap(LLVM_Hs_DebuggerKind x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_DebuggerKind_##x: \ + return DebuggerKind::x; + LLVM_HS_FOR_EACH_DEBUGGER_KIND(ENUM_CASE) +#undef ENUM_CASE + default: + return DebuggerKind(0); + } +} + +static LLVM_Hs_DebuggerKind wrap(DebuggerKind x) { + switch (x) { +#define ENUM_CASE(x) \ + case DebuggerKind::x: \ + return LLVM_Hs_DebuggerKind_##x; + LLVM_HS_FOR_EACH_DEBUGGER_KIND(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_DebuggerKind(0); + } +} + +static DenormalMode::DenormalModeKind unwrap(LLVM_Hs_FPDenormalMode x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_FPDenormalMode_##x: \ + return DenormalMode::DenormalModeKind::x; + LLVM_HS_FOR_EACH_FP_DENORMAL_MODE(ENUM_CASE) +#undef ENUM_CASE + default: + return DenormalMode::DenormalModeKind(0); + } +} + +static LLVM_Hs_FPDenormalMode wrap(DenormalMode::DenormalModeKind x) { + switch (x) { +#define ENUM_CASE(x) \ + case DenormalMode::DenormalModeKind::x: \ + return LLVM_Hs_FPDenormalMode_##x; + LLVM_HS_FOR_EACH_FP_DENORMAL_MODE(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_FPDenormalMode(0); + } +} +static ExceptionHandling unwrap(LLVM_Hs_ExceptionHandling x) { + switch (x) { +#define ENUM_CASE(x) \ + case LLVM_Hs_ExceptionHandling_##x: \ + return ExceptionHandling::x; + LLVM_HS_FOR_EACH_EXCEPTION_HANDLING(ENUM_CASE) +#undef ENUM_CASE + default: + return ExceptionHandling(0); + } +} + +static LLVM_Hs_ExceptionHandling wrap(ExceptionHandling x) { + switch (x) { +#define ENUM_CASE(x) \ + case ExceptionHandling::x: \ + return LLVM_Hs_ExceptionHandling_##x; + LLVM_HS_FOR_EACH_EXCEPTION_HANDLING(ENUM_CASE) +#undef ENUM_CASE + default: + return LLVM_Hs_ExceptionHandling(0); + } +} + +} // namespace llvm + +extern "C" { + +LLVMBool LLVM_Hs_InitializeNativeTarget() { + return LLVMInitializeNativeTarget() || InitializeNativeTargetAsmPrinter() || + InitializeNativeTargetAsmParser(); +} + +LLVMTargetRef LLVM_Hs_LookupTarget(const char *arch, const char *ctriple, + const char **tripleOut, + const char **cerror) { + std::string error; + Triple triple(ctriple); + if (const Target *result = + TargetRegistry::lookupTarget(arch, triple, error)) { + *tripleOut = strdup(triple.getTriple().c_str()); + return wrap(result); + } + *cerror = strdup(error.c_str()); + return 0; +} + +TargetOptions *LLVM_Hs_CreateTargetOptions() { + TargetOptions *to = new TargetOptions(); + return to; +} + +void LLVM_Hs_SetTargetOptionFlag(TargetOptions *to, LLVM_Hs_TargetOptionFlag f, + unsigned v) { + switch (f) { +#define ENUM_CASE(op) \ + case LLVM_Hs_TargetOptionFlag_##op: \ + to->op = v ? 1 : 0; \ + break; + LLVM_HS_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE) +#undef ENUM_CASE + } +} + +void LLVM_Hs_SetMCTargetOptionFlag(MCTargetOptions *to, + LLVM_Hs_MCTargetOptionFlag f, unsigned v) { + switch (f) { +#define ENUM_CASE(op) \ + case LLVM_Hs_MCTargetOptionFlag_##op: \ + to->op = v ? 1 : 0; \ + break; + LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(ENUM_CASE) +#undef ENUM_CASE + } +} + +static llvm::DebugCompressionType +unwrap(LLVM_Hs_DebugCompressionType compressionType) { + switch (compressionType) { +#define ENUM_CASE(op) \ + case LLVM_Hs_DebugCompressionType_##op: \ + return llvm::DebugCompressionType::op; + LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(ENUM_CASE) +#undef ENUM_CASE + default: + reportFatalError("Unknown debug compression type"); + return llvm::DebugCompressionType::None; + } +} + +static LLVM_Hs_DebugCompressionType +wrap(llvm::DebugCompressionType compressionType) { + switch (compressionType) { +#define ENUM_CASE(op) \ + case llvm::DebugCompressionType::op: \ + return LLVM_Hs_DebugCompressionType_##op; + LLVM_HS_FOR_EACH_DEBUG_COMPRESSION_TYPE(ENUM_CASE) +#undef ENUM_CASE + default: { + reportFatalError("Unknown debug compression type"); + return LLVM_Hs_DebugCompressionType_None; + } + } +} + +void LLVM_Hs_SetCompressDebugSections(TargetOptions *to, + LLVM_Hs_DebugCompressionType compress) { + to->CompressDebugSections = unwrap(compress); +} + +LLVM_Hs_DebugCompressionType +LLVM_Hs_GetCompressDebugSections(TargetOptions *to) { + return wrap(to->CompressDebugSections); +} + +unsigned LLVM_Hs_GetTargetOptionFlag(TargetOptions *to, + LLVM_Hs_TargetOptionFlag f) { + switch (f) { +#define ENUM_CASE(op) \ + case LLVM_Hs_TargetOptionFlag_##op: \ + return to->op; + LLVM_HS_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE) +#undef ENUM_CASE + default: + reportFatalError("Unknown target option flag"); + return 0; + } +} + +unsigned LLVM_Hs_GetMCTargetOptionFlag(MCTargetOptions *to, + LLVM_Hs_MCTargetOptionFlag f) { + switch (f) { +#define ENUM_CASE(op) \ + case LLVM_Hs_MCTargetOptionFlag_##op: \ + return to->op; + LLVM_HS_FOR_EACH_MC_TARGET_OPTION_FLAG(ENUM_CASE) +#undef ENUM_CASE + default: + reportFatalError("Unknown machine code target option flag"); + return 0; + } +} + +void LLVM_Hs_SetStackAlignmentOverride(TargetOptions *to, unsigned v) { + to->StackAlignmentOverride = v; +} + +unsigned LLVM_Hs_GetStackAlignmentOverride(TargetOptions *to) { + return to->StackAlignmentOverride; +} + +void LLVM_Hs_SetFloatABIType(TargetOptions *to, LLVM_Hs_FloatABI v) { + to->FloatABIType = unwrap(v); +} + +LLVM_Hs_FloatABI LLVM_Hs_GetFloatABIType(TargetOptions *to) { + return wrap(to->FloatABIType); +} + +void LLVM_Hs_SetAllowFPOpFusion(TargetOptions *to, LLVM_Hs_FPOpFusionMode v) { + to->AllowFPOpFusion = unwrap(v); +} + +LLVM_Hs_FPOpFusionMode LLVM_Hs_GetAllowFPOpFusion(TargetOptions *to) { + return wrap(to->AllowFPOpFusion); +} + +void LLVM_Hs_SetThreadModel(TargetOptions *to, LLVM_Hs_ThreadModel v) { + to->ThreadModel = unwrap(v); +} + +LLVM_Hs_ThreadModel LLVM_Hs_GetThreadModel(TargetOptions *to) { + return wrap(to->ThreadModel); +} + +void LLVM_Hs_SetEABIVersion(TargetOptions *to, LLVM_Hs_EABI v) { + to->EABIVersion = unwrap(v); +} + +LLVM_Hs_EABI LLVM_Hs_GetEABIVersion(TargetOptions *to) { + return wrap(to->EABIVersion); +} + +void LLVM_Hs_SetDebuggerTuning(TargetOptions *to, LLVM_Hs_DebuggerKind v) { + to->DebuggerTuning = unwrap(v); +} + +LLVM_Hs_DebuggerKind LLVM_Hs_GetDebuggerTuning(TargetOptions *to) { + return wrap(to->DebuggerTuning); +} + +void LLVM_Hs_SetFPDenormalMode(TargetOptions *to, LLVM_Hs_FPDenormalMode v) { + auto denormalModeKind = unwrap(v); + DenormalMode denormalMode{denormalModeKind, denormalModeKind}; + to->setFPDenormalMode(denormalMode); +} + +LLVM_Hs_FPDenormalMode LLVM_Hs_GetFPDenormalMode(TargetOptions *to) { + auto denormalMode = to->getRawFPDenormalMode(); + assert(denormalMode.isSimple() && "Input and output kinds must match"); + return wrap(denormalMode.Input); +} + +void LLVM_Hs_SetExceptionModel(TargetOptions *to, LLVM_Hs_ExceptionHandling v) { + to->ExceptionModel = unwrap(v); +} + +LLVM_Hs_ExceptionHandling LLVM_Hs_GetExceptionModel(TargetOptions *to) { + return wrap(to->ExceptionModel); +} + +void LLVM_Hs_DisposeTargetOptions(TargetOptions *t) { delete t; } + +// const TargetLowering *LLVM_Hs_GetTargetLowering(LLVMTargetMachineRef t) +// { +// return unwrap(t)->getTargetLowering(); +// } + +char *LLVM_Hs_GetDefaultTargetTriple() { + return strdup(sys::getDefaultTargetTriple().c_str()); +} + +char *LLVM_Hs_GetProcessTargetTriple() { + return strdup(sys::getProcessTriple().c_str()); +} + +const char *LLVM_Hs_GetHostCPUName(size_t &len) { + StringRef r = sys::getHostCPUName(); + len = r.size(); + return r.data(); +} + +char *LLVM_Hs_GetHostCPUFeatures() { + StringMap featureMap; + std::string features; + if (sys::getHostCPUFeatures(featureMap)) { + bool first = true; + for (llvm::StringMap::const_iterator it = featureMap.begin(); + it != featureMap.end(); ++it) { + if (!first) { + features += ","; + } + first = false; + features += (it->second ? "+" : "-") + it->first().str(); + } + } + return strdup(features.c_str()); +} + +char *LLVM_Hs_GetTargetMachineDataLayout(LLVMTargetMachineRef t) { + return strdup( + unwrap(t)->createDataLayout().getStringRepresentation().c_str()); +} + +LLVMTargetLibraryInfoRef LLVM_Hs_CreateTargetLibraryInfo(const char *triple) { + const TargetLibraryInfoImpl *p = new TargetLibraryInfoImpl(Triple(triple)); + return wrap(p); +} + +LLVMBool LLVM_Hs_GetLibFunc(LLVMTargetLibraryInfoRef l, const char *funcName, + LLVMLibFunc *f) { + LibFunc func; + LLVMBool result = unwrap(l)->getLibFunc(funcName, func); + *f = wrap(func); + return result; +} + +const char *LLVM_Hs_LibFuncGetName(LLVMTargetLibraryInfoRef l, LLVMLibFunc f, + size_t *nameSize) { + TargetLibraryInfo impl(*unwrap(l)); + StringRef s = impl.getName(unwrap(f)); + *nameSize = s.size(); + return s.data(); +} + +void LLVM_Hs_LibFuncSetAvailableWithName(LLVMTargetLibraryInfoRef l, + LLVMLibFunc f, const char *name) { + unwrap(l)->setAvailableWithName(unwrap(f), name); +} + +void LLVM_Hs_DisposeTargetLibraryInfo(LLVMTargetLibraryInfoRef l) { + delete unwrap(l); +} + +void LLVM_Hs_InitializeAllTargets() { + InitializeAllTargetInfos(); + InitializeAllTargets(); + InitializeAllTargetMCs(); + InitializeAllAsmPrinters(); + // None of the other components are bound yet +} + +LLVMTargetMachineRef LLVM_Hs_CreateTargetMachine( + LLVMTargetRef T, const char *Triple, const char *CPU, const char *Features, + TargetOptions *TO, LLVMRelocMode Reloc, LLVMCodeModel CodeModel, + LLVMCodeGenOptLevel Level) { + Optional RM; + switch (Reloc) { + case LLVMRelocStatic: + RM = Reloc::Static; + break; + case LLVMRelocPIC: + RM = Reloc::PIC_; + break; + case LLVMRelocDynamicNoPic: + RM = Reloc::DynamicNoPIC; + break; + default: + break; + } + + bool JIT; + Optional CM = unwrap(CodeModel, JIT); + + CodeGenOpt::Level OL; + switch (Level) { + case LLVMCodeGenLevelNone: + OL = CodeGenOpt::None; + break; + case LLVMCodeGenLevelLess: + OL = CodeGenOpt::Less; + break; + case LLVMCodeGenLevelAggressive: + OL = CodeGenOpt::Aggressive; + break; + default: + OL = CodeGenOpt::Default; + break; + } + + return wrap(unwrap(T)->createTargetMachine(Triple, CPU, Features, *TO, RM, + CM, OL, JIT)); +} + +TargetOptions *LLVM_Hs_TargetMachineOptions(LLVMTargetMachineRef TM) { + return &unwrap(TM)->Options; +} + +MCTargetOptions *LLVM_Hs_MCTargetOptions(TargetOptions *to) { + return &to->MCOptions; +} + +// This is identical to LLVMTargetMachineEmit but LLVM doesn’t expose this +// function so we copy it here. +LLVMBool LLVM_Hs_TargetMachineEmit(LLVMTargetMachineRef T, LLVMModuleRef M, + raw_pwrite_stream *OS, + LLVMCodeGenFileType codegen, + char **ErrorMessage) { + TargetMachine *TM = unwrap(T); + Module *Mod = unwrap(M); + + legacy::PassManager pass; + + std::string error; + + Mod->setDataLayout(TM->createDataLayout()); + + CodeGenFileType ft; + switch (codegen) { + case LLVMAssemblyFile: + ft = CGFT_AssemblyFile; + break; + default: + ft = CGFT_ObjectFile; + break; + } + if (TM->addPassesToEmitFile(pass, *OS, nullptr, ft)) { + error = "TargetMachine can't emit a file of this type"; + *ErrorMessage = strdup(error.c_str()); + return true; + } + + pass.run(*Mod); + + OS->flush(); + return false; +} +} diff --git a/src/LLVM/Internal/FFI/Threading.hs b/src/LLVM/Internal/FFI/Threading.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Threading.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +module LLVM.Internal.FFI.Threading where + +import LLVM.Prelude + +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes + +foreign import ccall unsafe "LLVMIsMultithreaded" isMultithreaded :: + IO LLVMBool diff --git a/src/LLVM/Internal/FFI/Transforms.hs b/src/LLVM/Internal/FFI/Transforms.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Transforms.hs @@ -0,0 +1,75 @@ +-- | Code used with Template Haskell to build the FFI for transform passes. +module LLVM.Internal.FFI.Transforms where + +import LLVM.Prelude + +-- | does the constructor for this pass require a TargetMachine object +needsTargetMachine :: String -> Bool +needsTargetMachine "CodeGenPrepare" = True +needsTargetMachine _ = False + +-- | Translate a Haskell name (used in the public Haskell interface, typically not abbreviated) +-- | for a pass into the (sometimes obscure, sometimes abbreviated) name used in the LLVM C interface. +-- | This translation includes, by choice of prefix, whether the C interface implementation is found in +-- | the LLVM distribution ("LLVM" prefix) or either not available or broken there and so implemented +-- | as part of this Haskell package ("LLVM_Hs_" prefix). +cName :: String -> String +cName n = + let core = case n of + "AddressSanitizer" -> "AddressSanitizerFunction" + "AggressiveDeadCodeElimination" -> "AggressiveDCE" + "AlwaysInline" -> "AlwaysInliner" + "DeadInstructionElimination" -> "DeadInstElimination" + "EarlyCommonSubexpressionElimination" -> "EarlyCSE" + "FunctionAttributes" -> "FunctionAttrs" + "GlobalDeadCodeElimination" -> "GlobalDCE" + "InductionVariableSimplify" -> "IndVarSimplify" + "InternalizeFunctions" -> "Internalize" + "InterproceduralSparseConditionalConstantPropagation" -> "IPSCCP" + "LoopClosedSingleStaticAssignment" -> "LCSSA" + "LoopInvariantCodeMotion" -> "LICM" + "LoopInstructionSimplify" -> "LoopInstSimplify" + "MemcpyOptimization" -> "MemCpyOpt" + "PruneExceptionHandling" -> "PruneEH" + "ScalarReplacementOfAggregates" -> "SROA" + "OldScalarReplacementOfAggregates" -> "ScalarReplAggregates" + "SimplifyControlFlowGraph" -> "CFGSimplification" + "SparseConditionalConstantPropagation" -> "SCCP" + "SuperwordLevelParallelismVectorize" -> "SLPVectorize" + h -> h + patchImpls = [ + "AddressSanitizer", + "AddressSanitizerModule", + "BoundsChecking", + "CodeGenPrepare", + "GlobalValueNumbering", + "InternalizeFunctions", + "BasicBlockVectorize", + "BlockPlacement", + "BreakCriticalEdges", + "DeadCodeElimination", + "DeadInstructionElimination", + "DemoteRegisterToMemory", + "EdgeProfiler", + "GCOVProfiler", + "LoopClosedSingleStaticAssignment", + "LoopInstructionSimplify", + "LoopStrengthReduce", + "LoopVectorize", + "LowerAtomic", + "LowerInvoke", + "LowerSwitch", + "MemorySanitizer", + "MergeFunctions", + "OptimalEdgeProfiler", + "PathProfiler", + "PartialInlining", + "ScalarReplacementOfAggregates", + "Sinking", + "StripDeadDebugInfo", + "StripDebugDeclare", + "StripNonDebugSymbols", + "ThreadSanitizer" + ] + in + (if (n `elem` patchImpls) then "LLVM_Hs_" else "LLVM") ++ "Add" ++ core ++ "Pass" diff --git a/src/LLVM/Internal/FFI/Type.h b/src/LLVM/Internal/FFI/Type.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Type.h @@ -0,0 +1,23 @@ +#ifndef __LLVM_INTERNAL_FFI__TYPE__H__ +#define __LLVM_INTERNAL_FFI__TYPE__H__ + +#define LLVM_HS_FOR_EACH_TYPE_KIND(macro) \ + macro(Void) \ + macro(Half) \ + macro(Float) \ + macro(Double) \ + macro(X86_FP80) \ + macro(FP128) \ + macro(PPC_FP128) \ + macro(Label) \ + macro(Integer) \ + macro(Function) \ + macro(Struct) \ + macro(Array) \ + macro(Pointer) \ + macro(Vector) \ + macro(Metadata) \ + macro(X86_MMX) \ + macro(Token) + +#endif diff --git a/src/LLVM/Internal/FFI/Type.hs b/src/LLVM/Internal/FFI/Type.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Type.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE + ForeignFunctionInterface + #-} +-- | Functions for handling the LLVM types +module LLVM.Internal.FFI.Type where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.Context +import LLVM.Internal.FFI.PtrHierarchy + +-- | +foreign import ccall unsafe "LLVMGetTypeKind" getTypeKind :: + Ptr Type -> IO TypeKind + +-- | +foreign import ccall unsafe "LLVMGetIntTypeWidth" getIntTypeWidth :: + Ptr Type -> IO (CUInt) + +-- | +foreign import ccall unsafe "LLVMIsFunctionVarArg" isFunctionVarArg :: + Ptr Type -> IO LLVMBool + +-- | +foreign import ccall unsafe "LLVMGetReturnType" getReturnType :: + Ptr Type -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMCountParamTypes" countParamTypes :: + Ptr Type -> IO CUInt + +-- | +foreign import ccall unsafe "LLVMGetParamTypes" getParamTypes :: + Ptr Type -> Ptr (Ptr Type) -> IO () + +-- | +foreign import ccall unsafe "LLVMGetElementType" getElementType :: + Ptr Type -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMIntTypeInContext" intTypeInContext :: + Ptr Context -> CUInt -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMFunctionType" functionType' :: + Ptr Type -> Ptr (Ptr Type) -> CUInt -> LLVMBool -> IO (Ptr Type) + +functionType :: Ptr Type -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO (Ptr Type) +functionType rt (n, ats) va = functionType' rt ats n va + +newtype AddrSpace = AddrSpace CUInt +-- | +foreign import ccall unsafe "LLVMPointerType" pointerType :: + Ptr Type -> AddrSpace -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMGetPointerAddressSpace" getPointerAddressSpace :: + Ptr Type -> IO AddrSpace + +-- | +foreign import ccall unsafe "LLVMVectorType" vectorType :: + Ptr Type -> CUInt -> IO (Ptr Type) + +-- | what +-- | would be if it supported 64-bit array sizes, as the C++ type does. +foreign import ccall unsafe "LLVM_Hs_ArrayType" arrayType :: + Ptr Type -> Word64 -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMStructTypeInContext" structTypeInContext' :: + Ptr Context -> Ptr (Ptr Type) -> CUInt -> LLVMBool -> IO (Ptr Type) + +structTypeInContext :: Ptr Context -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO (Ptr Type) +structTypeInContext ctx (n, ts) p = structTypeInContext' ctx ts n p + +-- | The reason we don't just use +-- | is because we LLVM may adjust the typename, and we need to capture the new name if that happens. +foreign import ccall unsafe "LLVM_Hs_StructCreateNamed" structCreateNamed :: + Ptr Context -> CString -> Ptr (OwnerTransfered CString) -> IO (Ptr Type) + +foreign import ccall unsafe "LLVMGetStructName" getStructName :: + Ptr Type -> IO CString + +-- | +foreign import ccall unsafe "LLVMIsLiteralStruct" structIsLiteral :: + Ptr Type -> IO LLVMBool + +-- | +foreign import ccall unsafe "LLVMIsOpaqueStruct" structIsOpaque :: + Ptr Type -> IO LLVMBool + +-- | +foreign import ccall unsafe "LLVMIsPackedStruct" isPackedStruct :: + Ptr Type -> IO LLVMBool + +-- | +foreign import ccall unsafe "LLVMCountStructElementTypes" countStructElementTypes :: + Ptr Type -> IO CUInt + +foreign import ccall unsafe "LLVMGetStructElementTypes" getStructElementTypes :: + Ptr Type -> Ptr (Ptr Type) -> IO () + +foreign import ccall unsafe "LLVMStructSetBody" structSetBody' :: + Ptr Type -> Ptr (Ptr Type) -> CUInt -> LLVMBool -> IO () + +structSetBody :: Ptr Type -> (CUInt, Ptr (Ptr Type)) -> LLVMBool -> IO () +structSetBody s (n,ts) p = structSetBody' s ts n p + +-- | +foreign import ccall unsafe "LLVMGetVectorSize" getVectorSize :: + Ptr Type -> IO CUInt + +-- | what +-- | would be if it supported 64 bit lengths +foreign import ccall unsafe "LLVM_Hs_GetArrayLength" getArrayLength :: + Ptr Type -> IO Word64 + +-- | +foreign import ccall unsafe "LLVMVoidTypeInContext" voidTypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMHalfTypeInContext" halfTypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMFloatTypeInContext" floatTypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMDoubleTypeInContext" doubleTypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMX86FP80TypeInContext" x86FP80TypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMFP128TypeInContext" fP128TypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMPPCFP128TypeInContext" ppcFP128TypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMMetadataTypeInContext" metadataTypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMTokenTypeInContext" tokenTypeInContext :: + Ptr Context -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMLabelTypeInContext" labelTypeInContext :: + Ptr Context -> IO (Ptr Type) diff --git a/src/LLVM/Internal/FFI/TypeC.cpp b/src/LLVM/Internal/FFI/TypeC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/TypeC.cpp @@ -0,0 +1,31 @@ +#define __STDC_LIMIT_MACROS +#include "llvm-c/Core.h" +#include "llvm/IR/DerivedTypes.h" +#include "llvm/IR/LLVMContext.h" +#include "llvm/IR/Type.h" + +using namespace llvm; + +extern "C" { + +// LLVM may rename the type, which we must capture. +LLVMTypeRef LLVM_Hs_StructCreateNamed(LLVMContextRef C, const char *Name, char** renamedName) { + if (Name) { + auto t = StructType::create(*unwrap(C), Name); + *renamedName = strdup(t->getName().str().c_str()); + return wrap(t); + } else { + *renamedName = nullptr; + return wrap(StructType::create(*unwrap(C))); + } +} + +LLVMTypeRef LLVM_Hs_ArrayType(LLVMTypeRef ElementType, uint64_t ElementCount) { + return wrap(ArrayType::get(unwrap(ElementType), ElementCount)); +} + +uint64_t LLVM_Hs_GetArrayLength(LLVMTypeRef ArrayTy) { + return unwrap(ArrayTy)->getNumElements(); +} + +} diff --git a/src/LLVM/Internal/FFI/User.hs b/src/LLVM/Internal/FFI/User.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/User.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances + #-} +-- | FFI functions for handling the LLVM User class +module LLVM.Internal.FFI.User where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.PtrHierarchy + +-- | a blind type to correspond to llvm::Use +data Use + +-- | test if a 'Value' is a 'User' +foreign import ccall unsafe "LLVMIsAUser" isAUser :: + Ptr Value -> IO (Ptr User) + +-- | +foreign import ccall unsafe "LLVMGetFirstUse" getFirstUse :: + Ptr User -> IO (Ptr Use) + +-- | +foreign import ccall unsafe "LLVMGetNextUse" getNextUse :: + Ptr Use -> IO (Ptr Use) + +-- | +foreign import ccall unsafe "LLVMGetNumOperands" getNumOperands :: + Ptr User -> IO CUInt + +-- | +foreign import ccall unsafe "LLVMGetOperand" getOperand :: + Ptr User -> CUInt -> IO (Ptr Value) + diff --git a/src/LLVM/Internal/FFI/Value.h b/src/LLVM/Internal/FFI/Value.h new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Value.h @@ -0,0 +1,32 @@ +#ifndef __LLVM_INTERNAL_FFI__VALUE__H__ +#define __LLVM_INTERNAL_FFI__VALUE__H__ + +#define LLVM_HS_FOR_EACH_VALUE_SUBCLASS(macro) \ + macro(Argument) \ + macro(BasicBlock) \ + macro(Function) \ + macro(GlobalAlias) \ + macro(GlobalVariable) \ + macro(UndefValue) \ + macro(BlockAddress) \ + macro(ConstantExpr) \ + macro(ConstantAggregateZero) \ + macro(ConstantDataArray) \ + macro(ConstantDataVector) \ + macro(ConstantInt) \ + macro(ConstantFP) \ + macro(ConstantArray) \ + macro(ConstantStruct) \ + macro(ConstantTokenNone) \ + macro(ConstantVector) \ + macro(ConstantPointerNull) \ + macro(InlineAsm) \ + macro(Instruction) + +typedef enum { +#define ENUM_CASE(class) LLVM ## class ## SubclassId, +LLVM_HS_FOR_EACH_VALUE_SUBCLASS(ENUM_CASE) +#undef ENUM_CASE +} LLVMValueSubclassId; + +#endif diff --git a/src/LLVM/Internal/FFI/Value.hs b/src/LLVM/Internal/FFI/Value.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/Value.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE + ForeignFunctionInterface, + MultiParamTypeClasses, + UndecidableInstances + #-} +-- | FFI functions for handling the LLVM Value class +module LLVM.Internal.FFI.Value where + +import LLVM.Prelude + +import Foreign.Ptr +import Foreign.C + +import LLVM.Internal.FFI.LLVMCTypes +import LLVM.Internal.FFI.PtrHierarchy + +-- | +foreign import ccall unsafe "LLVMTypeOf" typeOf :: + Ptr Value -> IO (Ptr Type) + +-- | +foreign import ccall unsafe "LLVMGetValueName" getValueName :: + Ptr Value -> IO CString + +-- | +foreign import ccall unsafe "LLVMSetValueName" setValueName :: + Ptr Value -> CString -> IO () + +-- | This function exposes the ID returned by llvm::Value::getValueID() +-- | . +foreign import ccall unsafe "LLVM_Hs_GetValueSubclassId" getValueSubclassId :: + Ptr Value -> IO ValueSubclassId + +foreign import ccall unsafe "LLVMReplaceAllUsesWith" replaceAllUsesWith :: + Ptr Value -> Ptr Value -> IO () + +foreign import ccall unsafe "LLVM_Hs_CreateArgument" createArgument :: + Ptr Type -> CString -> IO (Ptr Value) + +foreign import ccall unsafe "LLVMDumpValue" dumpValue :: + Ptr Value -> IO () diff --git a/src/LLVM/Internal/FFI/ValueC.cpp b/src/LLVM/Internal/FFI/ValueC.cpp new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FFI/ValueC.cpp @@ -0,0 +1,30 @@ +#define __STDC_LIMIT_MACROS +#include "llvm-c/Core.h" +#include "llvm/IR/Type.h" +#include "llvm/IR/DerivedTypes.h" +#include "llvm/IR/Value.h" +#include "llvm/IR/Argument.h" +#include "LLVM/Internal/FFI/Value.h" + +using namespace llvm; + +extern "C" { + +LLVMValueSubclassId LLVM_Hs_GetValueSubclassId(LLVMValueRef v) { + switch(unwrap(v)->getValueID()) { +#define VALUE_SUBCLASS_ID_CASE(class) case Value::class ## Val: return LLVM ## class ## SubclassId; +LLVM_HS_FOR_EACH_VALUE_SUBCLASS(VALUE_SUBCLASS_ID_CASE) +#undef VALUE_SUBCLASS_ID_CASE + default: break; + } + return LLVMValueSubclassId(0); +} + +LLVMValueRef LLVM_Hs_CreateArgument( + LLVMTypeRef t, + const char *name +) { + return wrap(new Argument(unwrap(t), name)); +} + +} diff --git a/src/LLVM/Internal/FastMathFlags.hs b/src/LLVM/Internal/FastMathFlags.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FastMathFlags.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE + MultiParamTypeClasses + #-} +module LLVM.Internal.FastMathFlags where + +import LLVM.Prelude + +import Control.Monad.Trans +import Control.Monad.AnyCont +import Control.Monad.State +import Control.Exception + +import Data.Bits + +import qualified LLVM.Internal.FFI.Builder as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Coding +import LLVM.Internal.EncodeAST + +import qualified LLVM.AST as A + +instance EncodeM IO A.FastMathFlags FFI.FastMathFlags where + encodeM f = return $ foldr1 (.|.) [ + if a f then b else 0 + | (a,b) <- [ + (A.allowReassoc, FFI.fastMathFlagsAllowReassoc), + (A.noNaNs, FFI.fastMathFlagsNoNaNs), + (A.noInfs, FFI.fastMathFlagsNoInfs), + (A.noSignedZeros, FFI.fastMathFlagsNoSignedZeros), + (A.allowReciprocal, FFI.fastMathFlagsAllowReciprocal), + (A.allowContract, FFI.fastMathFlagsAllowContract), + (A.approxFunc, FFI.fastMathFlagsApproxFunc) + ] + ] + +instance EncodeM EncodeAST A.FastMathFlags () where + encodeM f = do + f <- liftIO $ encodeM f + builder <- gets encodeStateBuilder + anyContToM $ bracket (FFI.setFastMathFlags builder f) (\() -> FFI.setFastMathFlags builder 0) + +instance Monad m => DecodeM m A.FastMathFlags FFI.FastMathFlags where + decodeM f = return A.FastMathFlags { + A.allowReassoc = FFI.fastMathFlagsAllowReassoc .&. f /= 0, + A.noNaNs = FFI.fastMathFlagsNoNaNs .&. f /= 0, + A.noInfs = FFI.fastMathFlagsNoInfs .&. f /= 0, + A.noSignedZeros = FFI.fastMathFlagsNoSignedZeros .&. f /= 0, + A.allowReciprocal = FFI.fastMathFlagsAllowReciprocal .&. f /= 0, + A.allowContract = FFI.fastMathFlagsAllowContract .&. f /= 0, + A.approxFunc = FFI.fastMathFlagsApproxFunc .&. f /= 0 + } + diff --git a/src/LLVM/Internal/FloatingPointPredicate.hs b/src/LLVM/Internal/FloatingPointPredicate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/FloatingPointPredicate.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE + MultiParamTypeClasses, + TemplateHaskell + #-} +module LLVM.Internal.FloatingPointPredicate where + +import LLVM.Internal.Coding + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.AST.FloatingPointPredicate as A.FPPred + +genCodingInstance [t| A.FPPred.FloatingPointPredicate |] ''FFI.FCmpPredicate [ + (FFI.fCmpPredFalse, A.FPPred.False), + (FFI.fCmpPredOEQ, A.FPPred.OEQ), + (FFI.fCmpPredOGT, A.FPPred.OGT), + (FFI.fCmpPredOGE, A.FPPred.OGE), + (FFI.fCmpPredOLT, A.FPPred.OLT), + (FFI.fCmpPredOLE, A.FPPred.OLE), + (FFI.fCmpPredONE, A.FPPred.ONE), + (FFI.fCmpPredORD, A.FPPred.ORD), + (FFI.fCmpPredUNO, A.FPPred.UNO), + (FFI.fCmpPredUEQ, A.FPPred.UEQ), + (FFI.fCmpPredUGT, A.FPPred.UGT), + (FFI.fCmpPredUGE, A.FPPred.UGE), + (FFI.fCmpPredULT, A.FPPred.ULT), + (FFI.fCmpPredULE, A.FPPred.ULE), + (FFI.fCmpPredUNE, A.FPPred.UNE), + (FFI.fcmpPredTrue, A.FPPred.True) + ] diff --git a/src/LLVM/Internal/Function.hs b/src/LLVM/Internal/Function.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Function.hs @@ -0,0 +1,68 @@ +module LLVM.Internal.Function where + +import LLVM.Prelude + +import Control.Monad.Trans +import Control.Monad.AnyCont + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.Function as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Attribute as FFI + +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import LLVM.Internal.Value +import LLVM.Internal.Coding +import LLVM.Internal.Constant () +import LLVM.Internal.Attribute + +import qualified LLVM.AST as A +import qualified LLVM.AST.Constant as A +import qualified LLVM.AST.ParameterAttribute as A.PA + +getAttributeList :: Ptr FFI.Function -> DecodeAST AttributeList +getAttributeList f = do + decodeM (FFI.AttrSetDecoder FFI.attributesAtIndex FFI.countParams, f) + +setFunctionAttributes :: Ptr FFI.Function -> AttributeList -> EncodeAST () +setFunctionAttributes f = liftIO . FFI.setAttributeList f <=< encodeM + +getParameters :: Ptr FFI.Function -> [[A.PA.ParameterAttribute]] -> DecodeAST [A.Parameter] +getParameters f attrs = scopeAnyCont $ do + n <- liftIO (FFI.countParams f) + ps <- allocaArray n + liftIO $ FFI.getParams f ps + params <- peekArray n ps + forM (leftBiasedZip params attrs) $ \(param, pAttrs) -> + A.Parameter + <$> typeOf param + <*> getLocalName param + <*> (return $ fromMaybe [] pAttrs) + +getGC :: Ptr FFI.Function -> DecodeAST (Maybe ShortByteString) +getGC f = scopeAnyCont $ decodeM =<< liftIO (FFI.getGC f) + +setGC :: Ptr FFI.Function -> Maybe ShortByteString -> EncodeAST () +setGC f gc = scopeAnyCont $ liftIO . FFI.setGC f =<< encodeM gc + +getPrefixData :: Ptr FFI.Function -> DecodeAST (Maybe A.Constant) +getPrefixData f = do + has <- decodeM =<< (liftIO $ FFI.hasPrefixData f) + if has + then decodeM =<< (liftIO $ FFI.getPrefixData f) + else return Nothing + +setPrefixData :: Ptr FFI.Function -> Maybe A.Constant -> EncodeAST () +setPrefixData f = traverse_ (liftIO . FFI.setPrefixData f <=< encodeM) + +getPersonalityFn :: Ptr FFI.Function -> DecodeAST (Maybe A.Constant) +getPersonalityFn f = do + has <- decodeM =<< liftIO (FFI.hasPersonalityFn f) + if has + then decodeM =<< liftIO (FFI.getPersonalityFn f) + else pure Nothing + +setPersonalityFn :: Ptr FFI.Function -> Maybe A.Constant -> EncodeAST () +setPersonalityFn f personality = (liftIO . FFI.setPersonalityFn f =<< encodeM personality) diff --git a/src/LLVM/Internal/Global.hs b/src/LLVM/Internal/Global.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Global.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses, + OverloadedStrings + #-} +module LLVM.Internal.Global where + +import LLVM.Prelude + +import Control.Monad.State +import Control.Monad.AnyCont +import Foreign.Ptr +import qualified Data.Map as Map + +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.GlobalValue as FFI + +import LLVM.Internal.Coding +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST + +import qualified LLVM.AST.Linkage as A.L +import qualified LLVM.AST.Visibility as A.V +import qualified LLVM.AST.COMDAT as A.COMDAT +import qualified LLVM.AST.DLL as A.DLL +import qualified LLVM.AST.ThreadLocalStorage as A.TLS +import qualified LLVM.AST.Global as A.G + +genCodingInstance [t| A.L.Linkage |] ''FFI.Linkage [ + (FFI.linkageExternal, A.L.External), + (FFI.linkageAvailableExternally, A.L.AvailableExternally), + (FFI.linkageLinkOnceAny, A.L.LinkOnce), + (FFI.linkageLinkOnceODR, A.L.LinkOnceODR), + (FFI.linkageWeakAny, A.L.Weak), + (FFI.linkageWeakODR, A.L.WeakODR), + (FFI.linkageAppending, A.L.Appending), + (FFI.linkageInternal, A.L.Internal), + (FFI.linkagePrivate, A.L.Private), + (FFI.linkageExternalWeak, A.L.ExternWeak), + (FFI.linkageCommon, A.L.Common) + ] + +getLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.L.Linkage +getLinkage g = liftIO $ decodeM =<< FFI.getLinkage (FFI.upCast g) + +setLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.L.Linkage -> EncodeAST () +setLinkage g l = liftIO . FFI.setLinkage (FFI.upCast g) =<< encodeM l + +genCodingInstance [t| A.V.Visibility |] ''FFI.Visibility [ + (FFI.visibilityDefault, A.V.Default), + (FFI.visibilityHidden, A.V.Hidden), + (FFI.visibilityProtected, A.V.Protected) + ] + +getVisibility :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.V.Visibility +getVisibility g = liftIO $ decodeM =<< FFI.getVisibility (FFI.upCast g) + +setVisibility :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.V.Visibility -> EncodeAST () +setVisibility g v = liftIO . FFI.setVisibility (FFI.upCast g) =<< encodeM v + +genCodingInstance [t| Maybe A.DLL.StorageClass |] ''FFI.DLLStorageClass [ + (FFI.dllStorageClassDefault, Nothing), + (FFI.dllStorageClassDLLImport, Just A.DLL.Import), + (FFI.dllStorageClassDLLExport, Just A.DLL.Export) + ] + +getDLLStorageClass :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe A.DLL.StorageClass) +getDLLStorageClass g = liftIO $ decodeM =<< FFI.getDLLStorageClass (FFI.upCast g) + +setDLLStorageClass :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe A.DLL.StorageClass -> EncodeAST () +setDLLStorageClass g sc = liftIO . FFI.setDLLStorageClass (FFI.upCast g) =<< encodeM sc + +getSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe ShortByteString) +getSection g = do + sectionLengthPtr <- alloca + sectionNamePtr <- liftIO $ FFI.getSection (FFI.upCast g) sectionLengthPtr + if sectionNamePtr == nullPtr then + return Nothing + else + do sectionLength <- peek sectionLengthPtr + sectionName <- decodeM (sectionNamePtr, sectionLength) + return (Just sectionName) + +setSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe ShortByteString -> EncodeAST () +setSection g s = scopeAnyCont $ do + s <- encodeM (fromMaybe "" s) + liftIO $ FFI.setSection (FFI.upCast g) s + +genCodingInstance [t| A.COMDAT.SelectionKind |] ''FFI.COMDATSelectionKind [ + (FFI.comdatSelectionKindAny, A.COMDAT.Any), + (FFI.comdatSelectionKindExactMatch, A.COMDAT.ExactMatch), + (FFI.comdatSelectionKindLargest, A.COMDAT.Largest), + (FFI.comdatSelectionKindNoDuplicates, A.COMDAT.NoDuplicates), + (FFI.comdatSelectionKindSameSize, A.COMDAT.SameSize) + ] + +instance DecodeM DecodeAST (ShortByteString, A.COMDAT.SelectionKind) (Ptr FFI.COMDAT) where + decodeM c = + (,) + <$> decodeM (FFI.getCOMDATName c) + <*> (decodeM =<< liftIO (FFI.getCOMDATSelectionKind c)) + +getCOMDATName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe ShortByteString) +getCOMDATName g = do + c <- liftIO $ FFI.getCOMDAT (FFI.upCast g) + if c == nullPtr + then return Nothing + else do + cds <- gets comdats + liftM Just $ case Map.lookup c cds of + Just (name, _) -> return name + Nothing -> do + cd@(name, _) <- decodeM c + modify $ \s -> s { comdats = Map.insert c cd cds } + return name + +setCOMDAT :: FFI.DescendentOf FFI.GlobalObject v => Ptr v -> Maybe ShortByteString -> EncodeAST () +setCOMDAT _ Nothing = return () +setCOMDAT g (Just name) = do + cd <- referCOMDAT name + liftIO $ FFI.setCOMDAT (FFI.upCast g) cd + +setAlignment :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Word32 -> EncodeAST () +setAlignment g i = liftIO $ FFI.setAlignment (FFI.upCast g) (fromIntegral i) + +getAlignment :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST Word32 +getAlignment g = liftIO $ fromIntegral <$> FFI.getAlignment (FFI.upCast g) + +genCodingInstance [t| Maybe A.TLS.Model |] ''FFI.ThreadLocalMode [ + (FFI.threadLocalModeNotThreadLocal, Nothing), + (FFI.threadLocalModeGeneralDynamicTLSModel, Just A.TLS.GeneralDynamic), + (FFI.threadLocalModeLocalDynamicTLSModel, Just A.TLS.LocalDynamic), + (FFI.threadLocalModeInitialExecTLSModel, Just A.TLS.InitialExec), + (FFI.threadLocalModeLocalExecTLSModel, Just A.TLS.LocalExec) + ] + +getThreadLocalMode :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe A.TLS.Model) +getThreadLocalMode g = liftIO $ decodeM =<< FFI.getThreadLocalMode (FFI.upCast g) + +setThreadLocalMode :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe A.TLS.Model -> EncodeAST () +setThreadLocalMode g m = liftIO . FFI.setThreadLocalMode (FFI.upCast g) =<< encodeM m + +genCodingInstance [t| Maybe A.G.UnnamedAddr |] ''FFI.UnnamedAddr [ + (FFI.unnamedAddrNo, Nothing), + (FFI.unnamedAddrLocal, Just A.G.LocalAddr), + (FFI.unnamedAddrGlobal, Just A.G.GlobalAddr) + ] diff --git a/src/LLVM/Internal/InlineAssembly.hs b/src/LLVM/Internal/InlineAssembly.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/InlineAssembly.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses, + OverloadedStrings + #-} +module LLVM.Internal.InlineAssembly where + +import LLVM.Prelude + +import Control.Monad.IO.Class + +import qualified Data.ByteString.Char8 as ByteString + +import Foreign.C +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.InlineAssembly as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.Module as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI + +import qualified LLVM.AST as A (Definition(..)) +import qualified LLVM.AST.InlineAssembly as A +import qualified LLVM.AST.Type as A + +import LLVM.Internal.Coding +import LLVM.Internal.EncodeAST +import LLVM.Internal.DecodeAST +import LLVM.Internal.Value + +genCodingInstance [t| A.Dialect |] ''FFI.AsmDialect [ + (FFI.asmDialectATT, A.ATTDialect), + (FFI.asmDialectIntel, A.IntelDialect) + ] + +instance EncodeM EncodeAST A.InlineAssembly (Ptr FFI.InlineAsm) where + encodeM (A.InlineAssembly { + A.type' = t, + A.assembly = assembly, + A.constraints = constraints, + A.hasSideEffects = hasSideEffects, + A.alignStack = alignStack, + A.dialect = dialect + }) = do + t <- encodeM t + assembly <- encodeM assembly + constraints <- encodeM constraints + hasSideEffects <- encodeM hasSideEffects + alignStack <- encodeM alignStack + dialect <- encodeM dialect + liftIO $ FFI.createInlineAsm t assembly constraints hasSideEffects alignStack dialect + +instance DecodeM DecodeAST A.InlineAssembly (Ptr FFI.InlineAsm) where + decodeM p = do + return A.InlineAssembly + `ap` (liftM (\(A.PointerType f _) -> f) (typeOf p)) + `ap` (decodeM =<< liftIO (FFI.getInlineAsmAssemblyString p)) + `ap` (decodeM =<< liftIO (FFI.getInlineAsmConstraintString p)) + `ap` (decodeM =<< liftIO (FFI.inlineAsmHasSideEffects p)) + `ap` (decodeM =<< liftIO (FFI.inlineAsmIsAlignStack p)) + `ap` (decodeM =<< liftIO (FFI.getInlineAsmDialect p)) + +instance DecodeM DecodeAST [A.Definition] (FFI.ModuleAsm CString) where + decodeM (FFI.ModuleAsm s) = do + s' <- decodeM s + return . map A.ModuleInlineAssembly $ ByteString.lines s' diff --git a/src/LLVM/Internal/Instruction.hs b/src/LLVM/Internal/Instruction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Instruction.hs @@ -0,0 +1,653 @@ +{-# LANGUAGE + TemplateHaskell, + QuasiQuotes, + MultiParamTypeClasses, + UndecidableInstances, + ViewPatterns + #-} +module LLVM.Internal.Instruction where + +import LLVM.Prelude + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TH +import qualified LLVM.Internal.InstructionDefs as ID +import LLVM.Internal.InstructionDefs (instrP) + +import Control.Monad.AnyCont +import Control.Monad.IO.Class +import Control.Monad.State (gets) + +import Foreign.Ptr + +import Control.Exception (assert) +import Control.Monad.Catch +import qualified Data.Map as Map +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty + +import qualified LLVM.Internal.FFI.Attribute as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.BinaryOperator as FFI +import qualified LLVM.Internal.FFI.Instruction as FFI +import qualified LLVM.Internal.FFI.Value as FFI +import qualified LLVM.Internal.FFI.User as FFI +import qualified LLVM.Internal.FFI.Builder as FFI +import qualified LLVM.Internal.FFI.BasicBlock as FFI + +import LLVM.Internal.Atomicity () +import LLVM.Internal.Attribute +import LLVM.Internal.CallingConvention () +import LLVM.Internal.Coding +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import LLVM.Internal.FastMathFlags () +import LLVM.Internal.Metadata () +import LLVM.Internal.Operand () +import LLVM.Internal.RMWOperation () +import LLVM.Internal.TailCallKind () +import LLVM.Internal.Type +import LLVM.Internal.Value + +import qualified LLVM.AST as A +import qualified LLVM.AST.Constant as A.C +import LLVM.Exception + +callInstAttributeList :: Ptr FFI.Instruction -> DecodeAST AttributeList +callInstAttributeList instr = + decodeM + ( FFI.AttrSetDecoder + FFI.getCallSiteAttributesAtIndex + FFI.getCallSiteNumArgOperands + , instr) + +meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata +meta i = do + let getMetadata n = scopeAnyCont $ do + ks <- allocaArray n + ps <- allocaArray n + n' <- liftIO $ FFI.getMetadata i ks ps n + if (n' > n) + then getMetadata n' + else return zip `ap` decodeM (n', ks) `ap` decodeM (n', ps) + getMetadata 4 + +setMD :: Ptr FFI.Instruction -> A.InstructionMetadata -> EncodeAST () +setMD i md = forM_ md $ \(kindName, anode) -> do + kindID <- encodeM kindName + node <- encodeM anode + liftIO $ FFI.setMetadata i kindID node + +instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where + decodeM i = scopeAnyCont $ do + n <- liftIO $ FFI.getInstructionDefOpcode i + nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i) + md <- meta i + let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n) + successor n = decodeM =<< (liftIO $ FFI.isABasicBlock =<< FFI.getOperand (FFI.upCast i) n) + case n of + [instrP|Ret|] -> do + returnOperand' <- if nOps == 0 then return Nothing else Just <$> op 0 + return $ A.Ret { A.returnOperand = returnOperand', A.metadata' = md } + [instrP|Br|] -> do + n <- liftIO $ FFI.getNumOperands (FFI.upCast i) + case n of + 1 -> do + dest <- successor 0 + return $ A.Br { A.dest = dest, A.metadata' = md } + 3 -> do + condition <- op 0 + falseDest <- successor 1 + trueDest <- successor 2 + return $ A.CondBr { + A.condition = condition, + A.falseDest = falseDest, + A.trueDest = trueDest, + A.metadata' = md + } + _ -> error "Branch instructions should always have 1 or 3 operands" + [instrP|Switch|] -> do + op0 <- op 0 + dd <- successor 1 + let nCases = (nOps - 2) `div` 2 + values <- allocaArray nCases + dests <- allocaArray nCases + liftIO $ FFI.getSwitchCases i values dests + cases <- return zip `ap` peekArray nCases values `ap` peekArray nCases dests + dests <- forM cases $ \(c, d) -> return (,) `ap` decodeM c `ap` decodeM d + return A.Switch { + A.operand0' = op0, + A.defaultDest = dd, + A.dests = dests, + A.metadata' = md + } + [instrP|IndirectBr|] -> do + op0 <- op 0 + let nDests = nOps - 1 + dests <- allocaArray nDests + liftIO $ FFI.getIndirectBrDests i dests + dests <- decodeM (nDests, dests) + return A.IndirectBr { + A.operand0' = op0, + A.possibleDests = dests, + A.metadata' = md + } + [instrP|Invoke|] -> do + cc <- decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) + attrs <- callInstAttributeList i + fv <- liftIO $ FFI.getCallSiteCalledValue i + f <- decodeM fv + let argIndices = if nOps >= 4 then [0 .. nOps - 4] else [] + args <- + forM (leftBiasedZip argIndices (parameterAttributes attrs)) $ \(j, pAttrs) -> + (, fromMaybe [] pAttrs) <$> op j + rd <- successor (nOps - 3) + ed <- successor (nOps - 2) + return A.Invoke { + A.callingConvention' = cc, + A.returnAttributes' = returnAttributes attrs, + A.function' = f, + A.arguments' = args, + A.functionAttributes' = functionAttributes attrs, + A.returnDest = rd, + A.exceptionDest = ed, + A.metadata' = md + } + [instrP|Resume|] -> do + op0 <- op 0 + return A.Resume { + A.operand0' = op0, + A.metadata' = md + } + [instrP|Unreachable|] -> do + return A.Unreachable { + A.metadata' = md + } + [instrP|CleanupRet|] -> do + dest <- decodeM =<< liftIO (FFI.upCast <$> (FFI.getCleanupPad i) :: IO (Ptr FFI.Value)) + unwindDest <- decodeM =<< liftIO (FFI.getUnwindDest i) + return A.CleanupRet { + A.cleanupPad = dest, + A.unwindDest = unwindDest, + A.metadata' = md + } + [instrP|CatchRet|] -> do + catchPad <- decodeM =<< liftIO (FFI.catchRetGetCatchPad i) + successor <- decodeM =<< liftIO (FFI.catchRetGetSuccessor i) + return A.CatchRet { + A.catchPad = catchPad, + A.successor = successor, + A.metadata' = md + } + [instrP|CatchSwitch|] -> do + parentPad' <- decodeM =<< liftIO (FFI.catchSwitchGetParentPad i) + numHandlers <- liftIO (FFI.catchSwitchGetNumHandlers i) + handlers <- assert (numHandlers > 0) $ + forM (0 :| [1..numHandlers - 1]) $ decodeM <=< liftIO . FFI.catchSwitchGetHandler i + unwindDest <- decodeM =<< liftIO (FFI.catchSwitchGetUnwindDest i) + return A.CatchSwitch { + A.parentPad' = parentPad', + A.catchHandlers = handlers, + A.defaultUnwindDest = unwindDest, + A.metadata' = md + } + i -> error ("Unknown terminator instruction kind: " <> show i) + +instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where + encodeM t = scopeAnyCont $ do + builder <- gets encodeStateBuilder + s <- encodeM "" + t' <- case t of + A.Ret { A.returnOperand = r } -> do + rv <- maybe (return nullPtr) encodeM r + FFI.upCast <$> do liftIO $ FFI.buildRet builder rv + A.Br { A.dest = d } -> do + db <- encodeM d + FFI.upCast <$> do liftIO $ FFI.buildBr builder db + A.CondBr { A.condition = c, A.trueDest = t, A.falseDest = f } -> do + cv <- encodeM c + tb <- encodeM t + fb <- encodeM f + FFI.upCast <$> do liftIO $ FFI.buildCondBr builder cv tb fb + A.Switch { + A.operand0' = op0, + A.defaultDest = dd, + A.dests = ds + } -> do + op0' <- encodeM op0 + dd' <- encodeM dd + i <- liftIO $ FFI.buildSwitch builder op0' dd' (fromIntegral $ length ds) + forM_ ds $ \(v,d) -> do + v' <- encodeM v + d' <- encodeM d + liftIO $ FFI.addCase i v' d' + return $ FFI.upCast i + A.IndirectBr { + A.operand0' = op0, + A.possibleDests = dests + } -> do + op0' <- encodeM op0 + i <- liftIO $ FFI.buildIndirectBr builder op0' (fromIntegral $ length dests) + forM_ dests $ \dest -> do + d <- encodeM dest + liftIO $ FFI.addDestination i d + return $ FFI.upCast i + A.Invoke { + A.callingConvention' = cc, + A.returnAttributes' = rAttrs, + A.function' = fun, + A.arguments' = args, + A.functionAttributes' = fAttrs, + A.returnDest = rd, + A.exceptionDest = ed + } -> do + fv <- encodeM fun + rb <- encodeM rd + eb <- encodeM ed + let (argvs, argAttrs) = unzip args + (n, argvs) <- encodeM argvs + i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s + attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs + liftIO $ FFI.setCallSiteAttributeList i attrs + cc <- encodeM cc + liftIO $ FFI.setCallSiteCallingConvention i cc + return $ FFI.upCast i + A.Resume { + A.operand0' = op0 + } -> do + op0' <- encodeM op0 + i <- liftIO $ FFI.buildResume builder op0' + return $ FFI.upCast i + A.Unreachable { + } -> do + i <- liftIO $ FFI.buildUnreachable builder + return $ FFI.upCast i + A.CleanupRet { + A.cleanupPad = cleanupPad, + A.unwindDest = unwindDest + } -> do + cleanupPad' <- encodeM cleanupPad + unwindDest' <- encodeM unwindDest + liftIO $ FFI.buildCleanupRet builder cleanupPad' unwindDest' + A.CatchRet { + A.catchPad = catchPad, + A.successor = successor + } -> do + catchPad' <- encodeM catchPad + successor' <- encodeM successor + liftIO $ FFI.buildCatchRet builder catchPad' successor' + A.CatchSwitch { + A.parentPad' = parentPad, + A.catchHandlers = catchHandlers, + A.defaultUnwindDest = unwindDest + } -> do + parentPad' <- encodeM parentPad + unwindDest' <- encodeM unwindDest + let numHandlers = fromIntegral (NonEmpty.length catchHandlers) + i <- liftIO $ FFI.buildCatchSwitch builder parentPad' unwindDest' numHandlers + mapM_ (liftIO . FFI.catchSwitchAddHandler i <=< encodeM) catchHandlers + return i + setMD t' (A.metadata' t) + return t' + +$(do + let findInstrFields s = Map.findWithDefault (error $ "instruction missing from AST: " ++ show s) s + ID.astInstructionRecs + + [d| + instance DecodeM DecodeAST A.Instruction (Ptr FFI.Instruction) where + decodeM i = scopeAnyCont $ do + t <- typeOf i + nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i) + let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n) + get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap (FFI.upCast b) + get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap (FFI.upCast b) + get_exact b = liftIO $ decodeM =<< FFI.isExact (FFI.upCast b) + get_fastMathFlags b = liftIO $ decodeM =<< FFI.getFastMathFlags (FFI.upCast b) + + n <- liftIO $ FFI.getInstructionDefOpcode i + $( + let fieldDecoders :: String -> String -> ([String], TH.ExpQ) + fieldDecoders lrn s = case s of + "b" -> ([], [| liftIO $ FFI.isABinaryOperator (FFI.upCast i) |]) + "nsw" -> (["b"], [| get_nsw $(TH.dyn "b") |]) + "nuw" -> (["b"], [| get_nuw $(TH.dyn "b") |]) + "exact" -> (["b"], [| get_exact $(TH.dyn "b") |]) + "fastMathFlags" -> (["b"], [| get_fastMathFlags $(TH.dyn "b") |]) + "operand0" -> ([], [| op 0 |]) + "operand1" -> ([], [| op 1 |]) + "address" -> ([], case lrn of "Store" -> [| op 1 |]; _ -> [| op 0 |]) + "value" -> ([], case lrn of "Store" -> [| op 0 |]; _ -> [| op 1 |]) + "expected" -> ([], [| op 1 |]) + "replacement" -> ([], [| op 2 |]) + "condition'" -> ([], [| op 0 |]) + "trueValue" -> ([], [| op 1 |]) + "falseValue" -> ([], [| op 2 |]) + "argList" -> ([], [| op 0 |]) + "vector" -> ([], [| op 0 |]) + "element" -> ([], [| op 1 |]) + "index" -> ([], case lrn of + "ExtractElement" -> [| op 1 |] + "InsertElement" -> [| op 2 |] + _ -> [|error "Index fields are only supported for 'ExtractElement' and 'InsertElement': " <> lrn|]) + "mask" -> + ([], [| do + n <- liftIO $ FFI.getShuffleVectorMaskSize i + a <- allocaArray n + liftIO $ FFI.getShuffleVectorMask i n a + decodeM (n, a) |]) + "aggregate" -> ([], [| op 0 |]) + "metadata" -> ([], [| meta i |]) + "iPredicate" -> ([], [| decodeM =<< liftIO (FFI.getICmpPredicate i) |]) + "fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |]) + "tailCallKind" -> ([], [| decodeM =<< liftIO (FFI.getTailCallKind i) |]) + "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) |]) + "attrs" -> ([], [| callInstAttributeList i |]) + "returnAttributes" -> (["attrs"], [| return $ returnAttributes $(TH.dyn "attrs") |]) + "f" -> ([], [| liftIO $ FFI.getCallSiteCalledValue i |]) + "function" -> (["f"], [| decodeM $(TH.dyn "f") |]) + "arguments" -> ([], [| forM (leftBiasedZip [1..nOps-1] (parameterAttributes $(TH.dyn "attrs"))) $ \(j, pAttrs) -> + (\p -> (p, fromMaybe [] pAttrs)) <$> op (j - 1) |]) + "clauses" -> + ([], [|do + nClauses <- liftIO $ FFI.getNumClauses i + -- We need to convert nClauses to a signed + -- value before subtracting + forM [0..fromIntegral nClauses - (1 :: Int)] $ \j -> do + v <- liftIO $ FFI.getClause i (fromIntegral j) + c <- decodeM v + t <- typeOf v + return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |]) + "functionAttributes" -> (["attrs"], [| return $ functionAttributes $(TH.dyn "attrs") |]) + "type'" -> ([], [| return t |]) + "incomingValues" -> + ([], [| do + n <- liftIO $ FFI.countIncoming i + forM [0..n-1] $ \m -> do + iv <- decodeM =<< (liftIO $ FFI.getIncomingValue i m) + ib <- decodeM =<< (liftIO $ FFI.getIncomingBlock i m) + return (iv,ib) |]) + "allocatedType" -> ([], [| decodeM =<< liftIO (FFI.getAllocatedType i) |]) + "numElements" -> + ([], [| do + n <- decodeM =<< (liftIO $ FFI.getAllocaNumElements i) + return $ case n of + A.ConstantOperand (A.C.Int { A.C.integerValue = 1 }) -> Nothing + _ -> Just n + |]) + "alignment" -> ([], [| decodeM =<< liftIO (FFI.getInstrAlignment i) |]) + "maybeAtomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |]) + "atomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |]) + "volatile" -> ([], [| decodeM =<< liftIO (FFI.getVolatile i) |]) + "inBounds" -> ([], [| decodeM =<< liftIO (FFI.getInBounds (FFI.upCast i)) |]) + "failureMemoryOrdering" -> ([], [| decodeM =<< liftIO (FFI.getFailureAtomicOrdering i) |]) + "indices" -> ([], [| mapM op [1..nOps-1] |]) + "indices'" -> + ([], [| do + n <- liftIO $ FFI.countInstStructureIndices i + a <- allocaArray n + liftIO $ FFI.getInstStructureIndices i a + decodeM (n, a) |]) + "rmwOperation" -> ([], [| decodeM =<< liftIO (FFI.getAtomicRMWBinOp i) |]) + "cleanup" -> ([], [| decodeM =<< liftIO (FFI.isCleanup i) |]) + "parentPad" -> ([], [| decodeM =<< liftIO (FFI.getParentPad i) |]) + "catchSwitch" -> ([], [| decodeM =<< liftIO (FFI.getParentPad i) |]) + "args" -> ([], [| do numArgs <- liftIO (FFI.getNumArgOperands i) + if (numArgs == 0) + then return [] + else forM [0..numArgs-1] $ \op -> + decodeM =<< liftIO (FFI.getArgOperand i op) |]) + _ -> ([], [| error $ "unrecognized instruction field or dependency thereof: " ++ show s |]) + in + TH.caseE [| n |] $ + [ TH.match opcodeP (TH.normalB (TH.doE handlerBody)) [] + | (lrn, iDef) <- Map.toList ID.instructionDefs, + ID.instructionKind iDef /= ID.Terminator, + let opcodeP = TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef) + handlerBody = + let TH.RecC fullName fields = findInstrFields lrn + (fieldNames,_,_) = unzip3 fields + allNames ns = List.nub $ [ d | n <- ns, d <- allNames . fst . fieldDecoders lrn $ n ] ++ ns + in + [ + TH.bindS (TH.varP (TH.mkName n)) (snd . fieldDecoders lrn $ n) + | n <- allNames . map TH.nameBase $ fieldNames + ] ++ [ + TH.noBindS [| + return $(TH.recConE + fullName + [ (f,) <$> (TH.varE . TH.mkName . TH.nameBase $ f) | f <- fieldNames ]) + |] + ] + ] ++ + [ TH.match TH.wildP (TH.normalB [| error ("Unknown instruction opcode: " <> show n) |]) [] ] + ) + + instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction, EncodeAST ()) where + encodeM o = scopeAnyCont $ do + builder <- gets encodeStateBuilder + let return' i = return (FFI.upCast i, return ()) + s <- encodeM "" + (inst, act) <- case o of + A.ICmp { + A.iPredicate = pred, + A.operand0 = op0, + A.operand1 = op1 + } -> do + op0' <- encodeM op0 + op1' <- encodeM op1 + pred <- encodeM pred + i <- liftIO $ FFI.buildICmp builder pred op0' op1' s + return' i + A.FCmp { + A.fpPredicate = pred, + A.operand0 = op0, + A.operand1 = op1 + } -> do + op0' <- encodeM op0 + op1' <- encodeM op1 + pred <- encodeM pred + i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s + return' i + A.Phi { A.type' = t, A.incomingValues = ivs } -> do + t' <- encodeM t + i <- liftIO $ FFI.buildPhi builder t' s + return ( + FFI.upCast i, + do + let (ivs3, bs3) = unzip ivs + ivs3' <- encodeM ivs3 + bs3' <- encodeM bs3 + liftIO $ FFI.addIncoming i ivs3' bs3' + ) + A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do + c' <- encodeM c + t' <- encodeM t + f' <- encodeM f + i <- liftIO $ FFI.buildSelect builder c' t' f' s + return' i + A.Freeze { A.operand0 = op0, A.type' = t } -> do + op0' <- encodeM op0 + t' <- encodeM t + i <- liftIO $ FFI.buildFreeze builder op0' t' + return' i + A.Call { + A.tailCallKind = tck, + A.callingConvention = cc, + A.returnAttributes = rAttrs, + A.function = f, + A.arguments = args, + A.functionAttributes = fAttrs + } -> do + fv <- encodeM f + let (argvs, argAttrs) = unzip args + (n, argvs) <- encodeM argvs + i <- liftIO $ FFI.buildCall builder fv argvs n s + attrs <- encodeM $ AttributeList fAttrs rAttrs argAttrs + liftIO $ FFI.setCallSiteAttributeList i attrs + tck <- encodeM tck + liftIO $ FFI.setTailCallKind i tck + cc <- encodeM cc + liftIO $ FFI.setCallSiteCallingConvention i cc + return' i + A.VAArg { A.argList = al, A.type' = t } -> do + al' <- encodeM al + t' <- encodeM t + i <- liftIO $ FFI.buildVAArg builder al' t' s + return' i + A.ExtractElement { A.vector = v, A.index = idx } -> do + v' <- encodeM v + idx' <- encodeM idx + i <- liftIO $ FFI.buildExtractElement builder v' idx' s + return' i + A.InsertElement { A.vector = v, A.element = e, A.index = idx } -> do + v' <- encodeM v + e' <- encodeM e + idx' <- encodeM idx + i <- liftIO $ FFI.buildInsertElement builder v' e' idx' s + return' i + A.ShuffleVector { A.operand0 = o0, A.operand1 = o1, A.mask = mask } -> do + o0' <- encodeM o0 + o1' <- encodeM o1 + (sizeMask, mask') <- encodeM mask + i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' sizeMask s + return' i + A.ExtractValue { A.aggregate = a, A.indices' = is } -> do + a' <- encodeM a + (n, is') <- encodeM is + i <- liftIO $ FFI.buildExtractValue builder a' is' n s + return' i + A.InsertValue { A.aggregate = a, A.element = e, A.indices' = is } -> do + a' <- encodeM a + e' <- encodeM e + (n, is') <- encodeM is + i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s + return' i + A.LandingPad { + A.type' = t, + A.cleanup = cl, + A.clauses = cs + } -> do + t' <- encodeM t + i <- liftIO $ FFI.buildLandingPad builder t' (fromIntegral $ length cs) s + forM_ cs $ \c -> + case c of + A.Catch a -> do + cn <- encodeM a + isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn) + when isArray $ throwM . EncodeException $ "Catch clause cannot take an array: " ++ show c + liftIO $ FFI.addClause i cn + A.Filter a -> do + cn <- encodeM a + isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn) + unless isArray $ throwM . EncodeException $ "filter clause must take an array: " ++ show c + liftIO $ FFI.addClause i cn + when cl $ do + cl <- encodeM cl + liftIO $ FFI.setCleanup i cl + return' i + A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do + alt' <- encodeM alt + n' <- encodeM n + i <- liftIO $ FFI.buildAlloca builder alt' n' s + unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment) + return' i + A.CleanupPad { A.parentPad = parentPad, A.args = args } -> do + parentPad' <- encodeM parentPad + (numArgs, args') <- encodeM args + i <- liftIO $ FFI.buildCleanupPad builder parentPad' args' numArgs s + return' i + A.CatchPad { A.catchSwitch = catchSwitch, A.args = args } -> do + catchSwitch' <- encodeM catchSwitch + (numArgs, args') <- encodeM args + i <- liftIO $ FFI.buildCatchPad builder catchSwitch' args' numArgs s + return' i + o -> $(TH.caseE [| o |] $ + [TH.match + (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- encodeFieldNames ]) + (TH.normalB (TH.doE handlerBody)) + [] + | + (name, ID.instructionKind -> k) <- Map.toList ID.instructionDefs, + case (k, name) of + (ID.Unary, _) -> True + (ID.Binary, _) -> True + (ID.Cast, _) -> True + (ID.Memory, "Alloca") -> False + (ID.Memory, _) -> True + _ -> False, + let + TH.RecC fullName (unzip3 -> (fieldNames, _, _)) = findInstrFields name + encodeFieldNames = filter (\f -> TH.nameBase f /= "metadata") fieldNames + encodeMFields = map TH.nameBase encodeFieldNames + handlerBody = ([ + TH.bindS (if s == "fastMathFlags" then TH.tupP [] else TH.varP (TH.mkName s)) + [| encodeM $(TH.dyn s) |] | s <- encodeMFields + ] ++ [ + TH.bindS (TH.varP (TH.mkName "i")) [| liftIO $ $( + foldl1 TH.appE . map TH.dyn $ + [ "FFI.build" ++ name, "builder" ] ++ (encodeMFields List.\\ [ "fastMathFlags" ]) ++ [ "s" ] + ) |], + TH.noBindS [| return' $(TH.dyn "i") |] + ]) + ] ++ + (map (\p -> TH.match p (TH.normalB [|inconsistentCases "Instruction" o|]) []) + [[p|A.Alloca{}|], + [p|A.ICmp{}|], + [p|A.FCmp{}|], + [p|A.Phi{}|], + [p|A.Select{}|], + [p|A.Freeze{}|], + [p|A.Call{}|], + [p|A.VAArg{}|], + [p|A.ExtractElement{}|], + [p|A.InsertElement{}|], + [p|A.ShuffleVector{}|], + [p|A.ExtractValue{}|], + [p|A.InsertValue{}|], + [p|A.LandingPad{}|], + [p|A.CatchPad{}|], + [p|A.CleanupPad{}|]]) + ) + + setMD inst (A.metadata o) + return (inst, act) + |] + ) + + +instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (DecodeAST (A.Named a)) (Ptr FFI.Instruction) where + decodeM i = do + t <- typeOf i + w <- if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i) + return $ return w `ap` decodeM i + +guardNonVoidType :: (MonadIO m, MonadThrow m) => Ptr FFI.Instruction -> String -> m () +guardNonVoidType instr expr = do + ty <- (liftIO . runDecodeAST . typeOf) instr + case ty of + A.VoidType -> throwM (EncodeException ("Instruction of type void must not have a name: " ++ expr)) + _ -> return () + +instance (EncodeM EncodeAST a (Ptr FFI.Instruction), Show a) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where + encodeM (A.Do o) = encodeM o + encodeM assgn@(n A.:= o) = do + i <- encodeM o + let v = FFI.upCast i + n' <- encodeM n + liftIO $ FFI.setValueName v n' + defineLocal n v + guardNonVoidType i (show assgn) + return i + +instance (EncodeM EncodeAST a (Ptr FFI.Instruction, EncodeAST ()), Show a) => EncodeM EncodeAST (A.Named a) (EncodeAST ()) where + encodeM (A.Do o) = liftM snd $ (encodeM o :: EncodeAST (Ptr FFI.Instruction, EncodeAST ())) + encodeM assgn@(n A.:= o) = do + (i, later) <- encodeM o + let v = FFI.upCast (i :: Ptr FFI.Instruction) + n' <- encodeM n + liftIO $ FFI.setValueName v n' + defineLocal n v + guardNonVoidType i (show assgn) + return later diff --git a/src/LLVM/Internal/InstructionDefs.hs b/src/LLVM/Internal/InstructionDefs.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/InstructionDefs.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE + TemplateHaskell, + CPP + #-} +module LLVM.Internal.InstructionDefs ( + astInstructionRecs, + astConstantRecs, + instructionDefs, + ID.InstructionKind(..), + ID.InstructionDef(..), + instrP, + innerJoin, + outerJoin + ) where + +import LLVM.Prelude + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as TH + +import Data.Map (Map) +import qualified Data.Map as Map + +import qualified LLVM.Internal.FFI.InstructionDefs as ID + +import qualified LLVM.AST.Instruction as A +import qualified LLVM.AST.Constant as A.C + +$(do + let ctorRecs t = do +#if __GLASGOW_HASKELL__ < 800 + TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify t +#else + TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify t +#endif + TH.dataToExpQ (const Nothing) $ [ (TH.nameBase n, rec) | rec@(TH.RecC n _) <- cons ] + + [d| + astInstructionRecs :: Map String TH.Con + astInstructionRecs = Map.fromList $(ctorRecs ''A.Instruction) + astConstantRecs :: Map String TH.Con + astConstantRecs = Map.fromList $(ctorRecs ''A.C.Constant) + |] + ) + +instructionDefs :: Map String ID.InstructionDef +instructionDefs = Map.fromList [ ((refName . ID.cAPIName $ i), i) | i <- ID.instructionDefs ] + where + refName "AtomicCmpXchg" = "CmpXchg" + refName "PHI" = "Phi" + refName x = x + +innerJoin :: Ord k => Map k a -> Map k b -> Map k (a,b) +innerJoin = Map.intersectionWith (,) + +outerJoin :: Ord k => Map k a -> Map k b -> Map k (Maybe a, Maybe b) +outerJoin xs ys = Map.unionWith combine + (Map.map (\a -> (Just a, Nothing)) xs) + (Map.map (\b -> (Nothing, Just b)) ys) + where + combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) + combine _ _ = error "outerJoin: the impossible happened" + +instrP :: TH.QuasiQuoter +instrP = TH.QuasiQuoter { + TH.quoteExp = undefined, + TH.quotePat = let m = Map.fromList [ (ID.cAPIName i, ID.cppOpcode i) | i <- ID.instructionDefs ] + in TH.dataToPatQ (const Nothing) . (m Map.!), + TH.quoteType = undefined, + TH.quoteDec = undefined + } diff --git a/src/LLVM/Internal/IntegerPredicate.hs b/src/LLVM/Internal/IntegerPredicate.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/IntegerPredicate.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses + #-} +module LLVM.Internal.IntegerPredicate where + +import LLVM.Internal.Coding + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.AST.IntegerPredicate as A.IPred + +genCodingInstance [t| A.IPred.IntegerPredicate |] ''FFI.ICmpPredicate [ + (FFI.iCmpPredEQ, A.IPred.EQ), + (FFI.iCmpPredNE, A.IPred.NE), + (FFI.iCmpPredUGT, A.IPred.UGT), + (FFI.iCmpPredUGE, A.IPred.UGE), + (FFI.iCmpPredULT, A.IPred.ULT), + (FFI.iCmpPredULE, A.IPred.ULE), + (FFI.iCmpPredSGT, A.IPred.SGT), + (FFI.iCmpPredSGE, A.IPred.SGE), + (FFI.iCmpPredSLT, A.IPred.SLT), + (FFI.iCmpPredSLE, A.IPred.SLE) + ] diff --git a/src/LLVM/Internal/LibraryFunction.hsc b/src/LLVM/Internal/LibraryFunction.hsc new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/LibraryFunction.hsc @@ -0,0 +1,38 @@ +{-# LANGUAGE + MultiParamTypeClasses + #-} +module LLVM.Internal.LibraryFunction where + +import LLVM.Prelude + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Coding + +#include "LLVM/Internal/FFI/LibFunc.h" + +#{ +define hsc_inject(m) { \ + struct { const char *s; unsigned n; } *p, list[] = { LLVM_HS_FOR_EACH_LIB_FUNC(m) }; \ + hsc_printf("data LibraryFunction\n"); \ + for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \ + hsc_printf(" %s LF__%s\n", (p == list ? "=" : "|"), p->s); \ + } \ + hsc_printf(" deriving (Eq, Ord, Enum, Bounded, Read, Show)"); \ + hsc_printf("\n"); \ + hsc_printf("instance Monad m => EncodeM m LibraryFunction FFI.LibFunc where\n"); \ + for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \ + hsc_printf(" encodeM LF__%s = return (FFI.LibFunc %u)\n", p->s, p->n); \ + } \ + hsc_printf("\n"); \ + hsc_printf("instance Monad m => DecodeM m LibraryFunction FFI.LibFunc where\n"); \ + for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \ + hsc_printf(" decodeM (FFI.LibFunc %u) = return LF__%s \n", p->n, p->s); \ + } \ + hsc_printf(" decodeM f = error (\"Unknown libfunc: \" <> show f)\n"); \ +} +} + +-- | +#define Mac(n) { #n, LLVMLibFunc__ ## n }, +#{inject Mac} diff --git a/src/LLVM/Internal/Linking.hs b/src/LLVM/Internal/Linking.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Linking.hs @@ -0,0 +1,31 @@ +module LLVM.Internal.Linking + ( loadLibraryPermanently + , getSymbolAddressInProcess + )where + +import LLVM.Prelude + +import Foreign.C.String +import Foreign.Ptr +import LLVM.Internal.Coding +import LLVM.Internal.OrcJIT +import qualified LLVM.Internal.FFI.OrcJIT as FFI +import qualified LLVM.Internal.FFI.DynamicLibrary as DL +import qualified LLVM.Internal.FFI.RTDyldMemoryManager as Dyld + +-- | Get the address of the given symbol in +-- the current process' address space. +getSymbolAddressInProcess + :: MangledSymbol -> IO WordPtr +getSymbolAddressInProcess (MangledSymbol sym) = do + symStr <- FFI.mangledSymbolString sym + fromIntegral <$> Dyld.getSymbolAddressInProcess symStr + +-- | Loads the given dynamic library permanently. If 'Nothing' +-- is given, this will make the symbols from the current +-- process available. +loadLibraryPermanently + :: Maybe FilePath + -> IO Bool +loadLibraryPermanently (Just fp) = decodeM =<< withCString fp DL.loadLibraryPermanently +loadLibraryPermanently Nothing = decodeM =<< DL.loadLibraryPermanently nullPtr diff --git a/src/LLVM/Internal/MemoryBuffer.hs b/src/LLVM/Internal/MemoryBuffer.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/MemoryBuffer.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE + MultiParamTypeClasses, + UndecidableInstances + #-} +module LLVM.Internal.MemoryBuffer where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS +import Foreign.Ptr + +import LLVM.Exception +import LLVM.Internal.Coding +import LLVM.Internal.String +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.MemoryBuffer as FFI + +data Specification + = Bytes { name :: String, content :: BS.ByteString } + | File { pathName :: String } + +instance (MonadThrow m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where + encodeM spec = liftM FFI.OwnerTransfered $ do + case spec of + Bytes name content -> do + (s,l) <- anyContToM $ BS.unsafeUseAsCStringLen (BS.snoc content 0) + name <- encodeM name + nullTerminate <- encodeM True + liftIO $ FFI.createMemoryBufferWithMemoryRange s (fromIntegral (l-1)) name nullTerminate + File pathName -> do + pathName <- encodeM pathName + mbPtr <- alloca + msgPtr <- alloca + result <- decodeM =<< (liftIO $ FFI.createMemoryBufferWithContentsOfFile pathName mbPtr msgPtr) + when result $ do + msg <- decodeM msgPtr + throwM (EncodeException msg) + peek mbPtr + +instance (MonadThrow m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (Ptr FFI.MemoryBuffer) where + encodeM spec = do + FFI.OwnerTransfered mb <- encodeM spec + anyContToM $ bracket (return mb) FFI.disposeMemoryBuffer + +instance MonadIO d => DecodeM d BS.ByteString (Ptr FFI.MemoryBuffer) where + decodeM p = do + s <- liftIO $ FFI.getBufferStart p + l <- liftIO $ FFI.getBufferSize p + liftIO $ BS.packCStringLen (s, fromIntegral l) + +instance MonadIO d => DecodeM d String (Ptr FFI.MemoryBuffer) where + decodeM = decodeM . UTF8ByteString <=< decodeM diff --git a/src/LLVM/Internal/Metadata.hs b/src/LLVM/Internal/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Metadata.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE + MultiParamTypeClasses + #-} +module LLVM.Internal.Metadata where + +import LLVM.Prelude + +import Control.Monad.State hiding (mapM, forM) +import Control.Monad.AnyCont + +import Foreign.Ptr + +import qualified Foreign.Marshal.Array as FMA +import qualified Data.Array as Array + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.Metadata as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI + +import LLVM.Internal.Context +import LLVM.Internal.Coding +import LLVM.Internal.EncodeAST +import LLVM.Internal.DecodeAST +import LLVM.Internal.Value () + +import Foreign.C + +instance EncodeM EncodeAST ShortByteString FFI.MDKindID where + encodeM s = do + Context c <- gets encodeStateContext + s <- encodeM s + liftIO $ FFI.getMDKindIDInContext c s + +getMetadataKindNames :: Context -> DecodeAST () +getMetadataKindNames (Context c) = scopeAnyCont $ do + let g n = do + ps <- allocaArray n + ls <- allocaArray n + n' <- liftIO $ FFI.getMDKindNames c ps ls n + if n' > n + then g n' + else do + csls <- return zip + `ap` liftIO (FMA.peekArray (fromIntegral n') ps) + `ap` liftIO (FMA.peekArray (fromIntegral n') ls) + mapM decodeM csls + strs <- g 16 + modify $ \s -> s { metadataKinds = Array.listArray (0, fromIntegral (length strs) - 1) strs } + +instance DecodeM DecodeAST ShortByteString FFI.MDKindID where + decodeM (FFI.MDKindID k) = gets $ (Array.! (fromIntegral k)) . metadataKinds + +instance DecodeM DecodeAST ShortByteString (Ptr FFI.MDString) where + -- LLVM appears to use null pts to indicate empty byte string fields + -- including literal empty strings + decodeM = getByteStringFromFFI FFI.getMDStringValue + +getByteStringFromFFI :: (Ptr a -> Ptr CUInt -> IO CString) -> Ptr a -> DecodeAST ShortByteString +getByteStringFromFFI _ p | nullPtr == p = return mempty +getByteStringFromFFI f p = do + np <- alloca + s <- liftIO $ f p np + n <- peek np + decodeM (s, n) diff --git a/src/LLVM/Internal/Module.hs b/src/LLVM/Internal/Module.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Module.hs @@ -0,0 +1,566 @@ +{-# + LANGUAGE + TemplateHaskell, + ScopedTypeVariables, + MultiParamTypeClasses + #-} +-- | This Haskell module is for/of functions for handling LLVM modules. +module LLVM.Internal.Module where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.Trans.Except +import Control.Monad.State (gets) +import Control.Monad.Trans + +import Foreign.Ptr +import Foreign.C +import Data.IORef +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as SBS +import qualified Data.Map as Map + +import qualified LLVM.Internal.FFI.Assembly as FFI +import qualified LLVM.Internal.FFI.Attribute as FFI +import qualified LLVM.Internal.FFI.Builder as FFI +import qualified LLVM.Internal.FFI.Bitcode as FFI +import qualified LLVM.Internal.FFI.Function as FFI +import qualified LLVM.Internal.FFI.GlobalAlias as FFI +import qualified LLVM.Internal.FFI.GlobalValue as FFI +import qualified LLVM.Internal.FFI.GlobalVariable as FFI +import qualified LLVM.Internal.FFI.Iterate as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.MemoryBuffer as FFI +import qualified LLVM.Internal.FFI.Metadata as FFI +import qualified LLVM.Internal.FFI.Module as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.RawOStream as FFI +import qualified LLVM.Internal.FFI.Target as FFI +import qualified LLVM.Internal.FFI.Value as FFI + +import LLVM.Internal.Attribute +import LLVM.Internal.BasicBlock +import LLVM.Internal.Coding +import LLVM.Internal.Context +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import LLVM.Internal.Function +import LLVM.Internal.Global +import LLVM.Internal.Instruction () +import qualified LLVM.Internal.MemoryBuffer as MB +import LLVM.Internal.Metadata +import LLVM.Internal.Operand +import LLVM.Internal.RawOStream +import LLVM.Internal.String +import LLVM.Internal.Target +import LLVM.Internal.Type +import LLVM.Internal.Value + +import LLVM.DataLayout +import LLVM.Exception + +import qualified LLVM.AST as A +import qualified LLVM.AST.DataLayout as A +import qualified LLVM.AST.AddrSpace as A +import qualified LLVM.AST.Global as A.G + +-- | +newtype Module = Module (IORef (Ptr FFI.Module)) + +newModule :: Ptr FFI.Module -> IO (Module) +newModule m = fmap Module (newIORef m) + +readModule :: MonadIO m => Module -> m (Ptr FFI.Module) +readModule (Module ref) = liftIO $ readIORef ref + +-- | Signal that a module does no longer exist and thus must not be +-- disposed. It is the responsibility of the caller to ensure that the +-- module has been disposed. If you use only the functions provided by +-- llvm-hs you should never call this yourself. +deleteModule :: Module -> IO () +deleteModule (Module r) = writeIORef r nullPtr + +-- | A newtype to distinguish strings used for paths from other strings +newtype File = File FilePath + deriving (Eq, Ord, Read, Show) + +-- | link LLVM modules - move or copy parts of a source module into a +-- destination module. Note that this operation is not commutative - +-- not only concretely (e.g. the destination module is modified, +-- becoming the result) but abstractly (e.g. unused private globals in +-- the source module do not appear in the result, but similar globals +-- in the destination remain). The source module is destroyed. May +-- throw a 'LinkException'. +linkModules :: + Module -- ^ The module into which to link + -> Module -- ^ The module to link into the other (this module is destroyed) + -> IO () +linkModules dest src = runAnyContT' return $ do + dest' <- readModule dest + src' <- readModule src + result <- decodeM =<< liftIO (FFI.linkModules dest' src') + -- linkModules takes care of deleting the sourcemodule + liftIO $ deleteModule src + when result (throwM $ LinkException "Couldn’t link modules") + +class LLVMAssemblyInput s where + llvmAssemblyMemoryBuffer :: (MonadThrow m, MonadIO m, MonadAnyCont IO m) + => s -> m (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) + +instance LLVMAssemblyInput (String, String) where + llvmAssemblyMemoryBuffer (id, s) = do + UTF8ByteString bs <- encodeM s + encodeM (MB.Bytes id bs) + +instance LLVMAssemblyInput (String, ByteString) where + llvmAssemblyMemoryBuffer (id, s) = do + encodeM (MB.Bytes id s) + +instance LLVMAssemblyInput String where + llvmAssemblyMemoryBuffer s = llvmAssemblyMemoryBuffer ("", s) + +instance LLVMAssemblyInput ByteString where + llvmAssemblyMemoryBuffer s = llvmAssemblyMemoryBuffer ("", s) + +instance LLVMAssemblyInput File where + llvmAssemblyMemoryBuffer (File p) = encodeM (MB.File p) + +-- | parse 'Module' from LLVM assembly. May throw 'ParseFailureException'. +withModuleFromLLVMAssembly :: LLVMAssemblyInput s + => Context -> s -> (Module -> IO a) -> IO a +withModuleFromLLVMAssembly (Context c) s f = runAnyContT' return $ do + mb <- llvmAssemblyMemoryBuffer s + msgPtr <- alloca + m <- anyContToM $ bracket (newModule =<< FFI.parseLLVMAssembly c mb msgPtr) (FFI.disposeModule <=< readModule) + m' <- readModule m + when (m' == nullPtr) $ throwM . ParseFailureException =<< decodeM msgPtr + liftIO $ f m + +-- | generate LLVM assembly from a 'Module' +moduleLLVMAssembly :: Module -> IO ByteString +moduleLLVMAssembly m = do + resultRef <- newIORef Nothing + let saveBuffer :: Ptr CChar -> CSize -> IO () + saveBuffer start size = do + r <- decodeM (start, size) + writeIORef resultRef (Just r) + m' <- readModule m + FFI.withBufferRawPWriteStream saveBuffer $ FFI.writeLLVMAssembly m' . FFI.upCast + Just s <- readIORef resultRef + return s + +-- | write LLVM assembly for a 'Module' to a file +writeLLVMAssemblyToFile :: File -> Module -> IO () +writeLLVMAssemblyToFile (File path) m = runAnyContT' return $ do + m' <- readModule m + withFileRawOStream path False True $ FFI.writeLLVMAssembly m' + +class BitcodeInput b where + bitcodeMemoryBuffer :: (MonadThrow m, MonadIO m, MonadAnyCont IO m) + => b -> m (Ptr FFI.MemoryBuffer) + +instance BitcodeInput (String, BS.ByteString) where + bitcodeMemoryBuffer (s, bs) = encodeM (MB.Bytes s bs) + +instance BitcodeInput File where + bitcodeMemoryBuffer (File p) = encodeM (MB.File p) + +-- | parse 'Module' from LLVM bitcode. May throw 'ParseFailureException'. +withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> IO a +withModuleFromBitcode (Context c) b f = runAnyContT' return $ do + mb <- bitcodeMemoryBuffer b + msgPtr <- alloca + m <- anyContToM $ bracket (newModule =<< FFI.parseBitcode c mb msgPtr) (FFI.disposeModule <=< readModule) + m' <- readModule m + when (m' == nullPtr) $ throwM . ParseFailureException =<< decodeM msgPtr + liftIO $ f m + +-- | generate LLVM bitcode from a 'Module' +moduleBitcode :: Module -> IO BS.ByteString +moduleBitcode m = do + m' <- readModule m + withBufferRawOStream (FFI.writeBitcode m') + +-- | write LLVM bitcode from a 'Module' into a file +writeBitcodeToFile :: File -> Module -> IO () +writeBitcodeToFile (File path) m = runAnyContT' return $ do + m' <- readModule m + withFileRawOStream path False False $ FFI.writeBitcode m' + +-- | May throw 'TargetMachineEmitException'. +targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawPWriteStream -> IO () +targetMachineEmit fileType (TargetMachine tm) m os = runAnyContT' return $ do + msgPtr <- alloca + m' <- readModule m + r <- decodeM =<< (liftIO $ FFI.targetMachineEmit tm m' os fileType msgPtr) + when r $ throwM . TargetMachineEmitException =<< decodeM msgPtr + +-- | May throw 'FdStreamException' and 'TargetMachineEmitException'. +emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> IO () +emitToFile fileType tm (File path) m = runAnyContT' return $ do + withFileRawPWriteStream path False False $ targetMachineEmit fileType tm m + +-- | May throw 'TargetMachineEmitException'. +emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> IO BS.ByteString +emitToByteString fileType tm m = runAnyContT' return $ do + withBufferRawPWriteStream $ targetMachineEmit fileType tm m + +-- | write target-specific assembly directly into a file +writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> IO () +writeTargetAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly + +-- | produce target-specific assembly as a 'ByteString' +moduleTargetAssembly :: TargetMachine -> Module -> IO ByteString +moduleTargetAssembly tm m = emitToByteString FFI.codeGenFileTypeAssembly tm m + +-- | produce target-specific object code as a 'ByteString' +moduleObject :: TargetMachine -> Module -> IO BS.ByteString +moduleObject = emitToByteString FFI.codeGenFileTypeObject + +-- | write target-specific object code directly into a file +writeObjectToFile :: TargetMachine -> File -> Module -> IO () +writeObjectToFile = emitToFile FFI.codeGenFileTypeObject + +setTargetTriple :: Ptr FFI.Module -> ShortByteString -> EncodeAST () +setTargetTriple m t = do + t <- encodeM t + liftIO $ FFI.setTargetTriple m t + +getTargetTriple :: Ptr FFI.Module -> IO (Maybe ShortByteString) +getTargetTriple m = do + s <- decodeM =<< liftIO (FFI.getTargetTriple m) + return $ if SBS.null s then Nothing else Just s + +setDataLayout :: Ptr FFI.Module -> A.DataLayout -> EncodeAST () +setDataLayout m dl = do + s <- encodeM (dataLayoutToString dl) + liftIO $ FFI.setDataLayout m s + +getDataLayout :: Ptr FFI.Module -> IO (Maybe A.DataLayout) +getDataLayout m = do + dlString <- decodeM =<< FFI.getDataLayout m + either fail return . runExcept . parseDataLayout A.BigEndian $ dlString + +-- | Execute a function after encoding the module in LLVM’s internal representation. +-- May throw 'EncodeException'. +withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> IO a +withModuleFromAST context ast = + bracket (createModuleFromAST context ast) disposeModule + +-- | Encode the module AST in LLVM’s internal representation. +-- May throw 'EncodeException'. +createModuleFromAST :: Context -> A.Module -> IO Module +createModuleFromAST context@(Context c) (A.Module moduleId sourceFileName dataLayout triple definitions) = runEncodeAST context $ do + moduleId <- encodeM moduleId + m <- liftIO $ newModule =<< FFI.moduleCreateWithNameInContext moduleId c + ffiMod <- readModule m + sourceFileName' <- encodeM sourceFileName + liftIO $ FFI.setSourceFileName ffiMod sourceFileName' + Context context <- gets encodeStateContext + traverse_ (setDataLayout ffiMod) dataLayout + traverse_ (setTargetTriple ffiMod) triple + let sequencePhases :: EncodeAST [EncodeAST (EncodeAST (EncodeAST (EncodeAST ())))] -> EncodeAST () + sequencePhases l = (l >>= (sequence >=> sequence >=> sequence >=> sequence)) >> (return ()) + sequencePhases $ forM definitions $ \d -> case d of + A.TypeDefinition n t -> do + (t', n') <- createNamedType n + defineType n n' t' + return $ do + traverse_ (setNamedType t') t + return . return . return . return $ () + + A.COMDAT n csk -> do + n' <- encodeM n + csk <- encodeM csk + cd <- liftIO $ FFI.getOrInsertCOMDAT ffiMod n' + liftIO $ FFI.setCOMDATSelectionKind cd csk + defineCOMDAT n cd + return . return . return . return . return $ () + + A.MetadataNodeDefinition i md -> return . return $ do + t <- liftIO $ FFI.createTemporaryMDNodeInContext context + defineMDNode i t + return $ do + n <- encodeM md + liftIO $ FFI.metadataReplaceAllUsesWith (FFI.upCast t) (FFI.upCast n) + defineMDNode i n + return $ return () + + A.NamedMetadataDefinition n ids -> return . return . return . return $ do + n <- encodeM n + ids <- encodeM (map A.MDRef ids :: [A.MDRef A.MDNode]) + nm <- liftIO $ FFI.getOrAddNamedMetadata ffiMod n + liftIO $ FFI.namedMetadataAddOperands nm ids + return () + + A.ModuleInlineAssembly s -> do + s <- encodeM s + liftIO $ FFI.moduleAppendInlineAsm ffiMod (FFI.ModuleAsm s) + return . return . return . return . return $ () + + A.FunctionAttributes gid attrs -> do + attrs <- encodeM attrs + defineAttributeGroup gid attrs + return . return . return . return . return $ () + + A.GlobalDefinition g -> return . phase $ do + eg' :: EncodeAST (Ptr FFI.GlobalValue) <- case g of + g@(A.GlobalVariable { A.G.name = n }) -> do + typ <- encodeM (A.G.type' g) + g' <- liftIO $ withName n $ \gName -> + FFI.addGlobalInAddressSpace ffiMod typ gName + (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g)) + defineGlobal n g' + setThreadLocalMode g' (A.G.threadLocalMode g) + liftIO $ do + hua <- encodeM (A.G.unnamedAddr g) + FFI.setUnnamedAddr (FFI.upCast g') hua + ic <- encodeM (A.G.isConstant g) + FFI.setGlobalConstant g' ic + return $ do + traverse_ ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g) + setSection g' (A.G.section g) + setCOMDAT g' (A.G.comdat g) + setAlignment g' (A.G.alignment g) + setMetadata (FFI.upCast g') (A.G.metadata g) + return (FFI.upCast g') + (a@A.G.GlobalAlias { A.G.name = n }) -> do + typ <- encodeM (A.G.type' a) + as <- encodeM (A.G.addrSpace a) + a' <- liftIO $ withName n $ \name -> FFI.justAddAlias ffiMod typ as name + defineGlobal n a' + liftIO $ do + hua <- encodeM (A.G.unnamedAddr a) + FFI.setUnnamedAddr (FFI.upCast a') hua + return $ do + setThreadLocalMode a' (A.G.threadLocalMode a) + (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a) + return (FFI.upCast a') + (A.Function _ _ _ cc rAttrs resultType fName (args, isVarArgs) attrs _ _ _ gc prefix blocks personality metadata) -> do + typ <- encodeM $ A.FunctionType resultType [t | A.Parameter t _ _ <- args] isVarArgs + f <- liftIO . withName fName $ \fName -> FFI.addFunction ffiMod fName typ + defineGlobal fName f + cc <- encodeM cc + liftIO $ FFI.setFunctionCallingConvention f cc + setFunctionAttributes f (AttributeList attrs rAttrs [pa | A.Parameter _ _ pa <- args]) + setPrefixData f prefix + setSection f (A.G.section g) + setCOMDAT f (A.G.comdat g) + setAlignment f (A.G.alignment g) + setGC f gc + setPersonalityFn f personality + forM_ blocks $ \(A.BasicBlock bName _ _) -> do + b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext context f bName + defineBasicBlock fName bName b + phase $ do + let nParams = length args + ps <- allocaArray nParams + liftIO $ FFI.getParams f ps + params <- peekArray nParams ps + forM_ (zip args params) $ \(A.Parameter _ n _, p) -> do + defineLocal n p + n <- encodeM n + liftIO $ FFI.setValueName (FFI.upCast p) n + finishInstrs <- forM blocks $ \(A.BasicBlock bName namedInstrs term) -> do + b <- encodeM bName + (do + builder <- gets encodeStateBuilder + liftIO $ FFI.positionBuilderAtEnd builder b) + finishes <- mapM encodeM namedInstrs :: EncodeAST [EncodeAST ()] + void (encodeM term :: EncodeAST (Ptr FFI.Instruction)) + return (sequence_ finishes) + sequence_ finishInstrs + locals <- gets $ Map.toList . encodeStateLocals + forM_ [ n | (n, ForwardValue _) <- locals ] $ \n -> undefinedReference "local" n + setMetadata (FFI.upCast f) metadata + return (FFI.upCast f) + return $ do + g' <- eg' + setLinkage g' (A.G.linkage g) + setVisibility g' (A.G.visibility g) + setDLLStorageClass g' (A.G.dllStorageClass g) + return $ return () + return m + +-- | Destroys a module created by 'createModuleFromAST'. +disposeModule :: Module -> IO () +disposeModule m = FFI.disposeModule =<< readModule m + +-- | Retrieves the context associated with a module. +moduleContext :: Module -> IO Context +moduleContext m = Context <$> (FFI.getModuleContext =<< readModule m) + +-- This returns a nested DecodeAST to allow interleaving of different +-- decoding steps. Take a look at the call site in moduleAST for more +-- details. +decodeGlobalVariables :: Ptr FFI.Module -> DecodeAST (DecodeAST [A.G.Global]) +decodeGlobalVariables mod = do + ffiGlobals <- liftIO $ FFI.getXs (FFI.getFirstGlobal mod) FFI.getNextGlobal + fmap sequence . forM ffiGlobals $ \g -> do + A.PointerType t as <- typeOf g + n <- getGlobalName g + return $ + A.GlobalVariable + <$> return n + <*> getLinkage g + <*> getVisibility g + <*> getDLLStorageClass g + <*> getThreadLocalMode g + <*> (liftIO $ decodeM =<< FFI.getUnnamedAddr (FFI.upCast g)) + <*> (liftIO $ decodeM =<< FFI.isGlobalConstant g) + <*> return t + <*> return as + <*> (do i <- liftIO $ FFI.getInitializer g + if i == nullPtr + then return Nothing + else Just <$> decodeM i) + <*> getSection g + <*> getCOMDATName g + <*> getAlignment g + <*> getMetadata (FFI.upCast g) + +-- This returns a nested DecodeAST to allow interleaving of different +-- decoding steps. Take a look at the call site in moduleAST for more +-- details. +decodeGlobalAliases :: Ptr FFI.Module -> DecodeAST (DecodeAST [A.G.Global]) +decodeGlobalAliases mod = do + ffiAliases <- liftIO $ FFI.getXs (FFI.getFirstAlias mod) FFI.getNextAlias + fmap sequence . forM ffiAliases $ \a -> do + n <- getGlobalName a + A.PointerType t as <- typeOf a + return $ + A.G.GlobalAlias + <$> return n + <*> getLinkage a + <*> getVisibility a + <*> getDLLStorageClass a + <*> getThreadLocalMode a + <*> (liftIO $ decodeM =<< FFI.getUnnamedAddr (FFI.upCast a)) + <*> return t + <*> return as + <*> (decodeM =<< (liftIO $ FFI.getAliasee a)) + +getMetadata :: Ptr FFI.GlobalObject -> DecodeAST [(ShortByteString, A.MDRef A.MDNode)] +getMetadata o = scopeAnyCont $ do + n <- liftIO (FFI.getNumMetadata o) + ks <- allocaArray n + ps <- allocaArray n + liftIO (FFI.getAllMetadata o ks ps) + zip <$> decodeM (n, ks) <*> decodeM (n, ps) + +setMetadata :: Ptr FFI.GlobalObject -> [(ShortByteString, A.MDRef A.MDNode)] -> EncodeAST () +setMetadata o md = + forM_ md $ \(kindName, node) -> do + kindID <- encodeM kindName + node <- encodeM node + liftIO (FFI.setMetadata o kindID node) + +-- This returns a nested DecodeAST to allow interleaving of different +-- decoding steps. Take a look at the call site in moduleAST for more +-- details. +decodeFunctions :: Ptr FFI.Module -> DecodeAST (DecodeAST [A.G.Global]) +decodeFunctions mod = do + ffiFunctions <- + liftIO $ FFI.getXs (FFI.getFirstFunction mod) FFI.getNextFunction + fmap sequence . forM ffiFunctions $ \f -> + localScope $ do + A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f + n <- getGlobalName f + AttributeList fAttrs rAttrs pAttrs <- getAttributeList f + parameters <- getParameters f pAttrs + decodeBlocks <- do + ffiBasicBlocks <- + liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock + fmap sequence . forM ffiBasicBlocks $ \b -> do + n <- getLocalName b + decodeInstructions <- getNamedInstructions b + decodeTerminator <- getBasicBlockTerminator b + return $ + A.BasicBlock + <$> return n + <*> decodeInstructions + <*> decodeTerminator + return $ + A.Function + <$> getLinkage f + <*> getVisibility f + <*> getDLLStorageClass f + <*> (liftIO $ decodeM =<< FFI.getFunctionCallingConvention f) + <*> return rAttrs + <*> return returnType + <*> return n + <*> return (parameters, isVarArg) + <*> return fAttrs + <*> getSection f + <*> getCOMDATName f + <*> getAlignment f + <*> getGC f + <*> getPrefixData f + <*> decodeBlocks + <*> getPersonalityFn f + <*> getMetadata (FFI.upCast f) + +decodeNamedMetadataDefinitions :: Ptr FFI.Module -> DecodeAST [A.Definition] +decodeNamedMetadataDefinitions mod = do + ffiNamedMetadataNodes <- + liftIO $ FFI.getXs (FFI.getFirstNamedMetadata mod) FFI.getNextNamedMetadata + forM ffiNamedMetadataNodes $ \nm -> + scopeAnyCont $ do + n <- liftIO $ FFI.getNamedMetadataNumOperands nm + os <- allocaArray n + liftIO $ FFI.getNamedMetadataOperands nm os + A.NamedMetadataDefinition + <$> (decodeM $ FFI.getNamedMetadataName nm) + <*> fmap + (map (\(A.MDRef mid) -> mid)) + (decodeM (n, os) :: DecodeAST [A.MDRef A.MDNode]) + +-- | Get an LLVM.AST.'LLVM.AST.Module' from a LLVM.'Module' - i.e. +-- raise C++ objects into an Haskell AST. +moduleAST :: Module -> IO A.Module +moduleAST m = runDecodeAST $ do + mod <- readModule m + c <- return Context `ap` liftIO (FFI.getModuleContext mod) + getMetadataKindNames c + A.Module + <$> (liftIO $ decodeM =<< FFI.getModuleIdentifier mod) + <*> (liftIO $ decodeM =<< FFI.getSourceFileName mod) + <*> (liftIO $ getDataLayout mod) + <*> (liftIO $ do + s <- decodeM =<< FFI.getTargetTriple mod + return $ if SBS.null s then Nothing else Just s) + <*> (do + globalDefinitions <- + map A.GlobalDefinition . concat <$> + -- Variables, aliases & functions can reference each other. To + -- resolve this references properly during decoding a two step + -- process is used: In the first step, the names of the + -- different definitions are stored. In the second step we can + -- then decode the definitions and look up the previously + -- stored references. + (join . fmap sequence . sequence) + [ decodeGlobalVariables mod + , decodeGlobalAliases mod + , decodeFunctions mod + ] + structDefinitions <- getStructDefinitions + inlineAsm <- decodeM =<< liftIO (FFI.moduleGetInlineAsm mod) + namedMetadata <- decodeNamedMetadataDefinitions mod + metadata <- getMetadataDefinitions + functionAttributes <- do + functionAttributes <- gets $ functionAttributeListIDs + forM functionAttributes $ \(as, gid) -> do + fAttrs <- A.FunctionAttributes <$> return gid <*> decodeM as + liftIO (FFI.disposeAttributeSet as) + pure fAttrs + comdats <- gets $ map (uncurry A.COMDAT) . Map.elems . comdats + return $ + structDefinitions ++ + inlineAsm ++ + globalDefinitions ++ + namedMetadata ++ + metadata ++ + functionAttributes ++ + comdats) diff --git a/src/LLVM/Internal/ObjectFile.hs b/src/LLVM/Internal/ObjectFile.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/ObjectFile.hs @@ -0,0 +1,37 @@ +module LLVM.Internal.ObjectFile where + +import Control.Exception (bracket) +import Control.Monad.IO.Class +import Control.Monad.AnyCont +import Foreign.Ptr +import GHC.Stack + +import LLVM.Prelude +import LLVM.Internal.Coding +import LLVM.Internal.MemoryBuffer +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.ObjectFile as FFI + +newtype ObjectFile = ObjectFile (Ptr FFI.ObjectFile) + +-- | Dispose of an 'ObjectFile'. +disposeObjectFile :: ObjectFile -> IO () +disposeObjectFile (ObjectFile obj) = FFI.disposeObjectFile obj + +-- | Create a object file which can later be linked with the +-- 'LLVM.Internal.OrcJIT.LinkingLayer'. +-- +-- Note that the file at `path` should already be a compiled object file i.e a +-- `.o` file. This does *not* compile source files. +createObjectFile :: HasCallStack => FilePath -> IO ObjectFile +createObjectFile path = runAnyContT' return $ do + -- The ownership of the object file is transfered to the object + -- file, so we need to make sure that we do not free it here. + FFI.OwnerTransfered buf <- encodeM (File path) + obj <- liftIO $ FFI.createObjectFile buf + when (obj == nullPtr) $ error "LLVMCreateObjectFile returned a null pointer." + return (ObjectFile obj) + +-- | @bracket@-style wrapper for `createObjectFile` and `disposeObjectFile`. +withObjectFile :: FilePath -> (ObjectFile -> IO a) -> IO a +withObjectFile f = bracket (createObjectFile f) disposeObjectFile diff --git a/src/LLVM/Internal/Operand.hs b/src/LLVM/Internal/Operand.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Operand.hs @@ -0,0 +1,1304 @@ +{-# LANGUAGE + DuplicateRecordFields, + DisambiguateRecordFields, + MultiParamTypeClasses, + NamedFieldPuns, + OverloadedStrings, + PatternSynonyms, + QuasiQuotes, + RecordWildCards, + ScopedTypeVariables, + TemplateHaskell + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module LLVM.Internal.Operand where + +import LLVM.Prelude + +import LLVM.Exception + +import Control.Monad.Catch +import Control.Monad.State +import Control.Monad.AnyCont +import Data.Bits +import Data.Functor.Identity +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.Constant as FFI +import qualified LLVM.Internal.FFI.InlineAssembly as FFI +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.Metadata as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Value as FFI + +import LLVM.Internal.Coding +import LLVM.Internal.Constant () +import LLVM.Internal.Context +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import LLVM.Internal.InlineAssembly () +import LLVM.Internal.Metadata (getByteStringFromFFI) + +import qualified LLVM.AST as A hiding (GlobalVariable, Module, PointerType, type') +import qualified LLVM.AST.Operand as A +import qualified LLVM.AST.Constant as A (Constant(Int, integerBits, integerValue)) + +import LLVM.Internal.FFI.LLVMCTypes (mdSubclassIdP) + +genCodingInstance [t|A.DebugEmissionKind|] ''FFI.DebugEmissionKind + [ (FFI.NoDebug, A.NoDebug) + , (FFI.FullDebug, A.FullDebug) + , (FFI.LineTablesOnly, A.LineTablesOnly) + ] + +genCodingInstance [t|A.DebugNameTableKind|] ''FFI.DebugNameTableKind + [ (FFI.NameTableKindDefault, A.NameTableKindDefault) + , (FFI.NameTableKindGNU, A.NameTableKindGNU) + , (FFI.NameTableKindNone, A.NameTableKindNone) + ] + +genCodingInstance [t|A.Encoding|] ''FFI.Encoding + [ (FFI.DwAtE_address, A.AddressEncoding) + , (FFI.DwAtE_boolean, A.BooleanEncoding) + , (FFI.DwAtE_float, A.FloatEncoding) + , (FFI.DwAtE_signed, A.SignedEncoding) + , (FFI.DwAtE_signed_char, A.SignedCharEncoding) + , (FFI.DwAtE_unsigned, A.UnsignedEncoding) + , (FFI.DwAtE_unsigned_char, A.UnsignedCharEncoding) + , (FFI.DwAtE_UTF, A.UTFEncoding) + ] + +genCodingInstance [t|A.ChecksumKind|] ''FFI.ChecksumKind + [ (FFI.ChecksumKind 1, A.MD5) + , (FFI.ChecksumKind 2, A.SHA1) + ] + +genCodingInstance [t|A.BasicTypeTag|] ''FFI.DwTag + [ (FFI.DwTag_base_type, A.BaseType) + , (FFI.DwTag_unspecified_type, A.UnspecifiedType) + ] + +genCodingInstance [t|A.DerivedTypeTag|] ''FFI.DwTag + [ (FFI.DwTag_typedef, A.Typedef) + , (FFI.DwTag_pointer_type, A.PointerType) + , (FFI.DwTag_ptr_to_member_type, A.PtrToMemberType) + , (FFI.DwTag_reference_type, A.ReferenceType) + , (FFI.DwTag_rvalue_reference_type, A.RValueReferenceType) + , (FFI.DwTag_const_type, A.ConstType) + , (FFI.DwTag_volatile_type, A.VolatileType) + , (FFI.DwTag_restrict_type, A.RestrictType) + , (FFI.DwTag_atomic_type, A.AtomicType) + , (FFI.DwTag_member, A.Member) + , (FFI.DwTag_inheritance, A.Inheritance) + , (FFI.DwTag_friend, A.Friend) + ] + +genCodingInstance [t|A.TemplateValueParameterTag|] ''FFI.DwTag + [ (FFI.DwTag_template_value_parameter, A.TemplateValueParameter) + , (FFI.DwTag_GNU_template_template_param, A.GNUTemplateTemplateParam) + , (FFI.DwTag_GNU_template_parameter_pack, A.GNUTemplateParameterPack) + ] + +genCodingInstance [t|A.Virtuality|] ''FFI.DwVirtuality + [ (FFI.DwVirtuality_none, A.NoVirtuality) + , (FFI.DwVirtuality_virtual, A.Virtual) + , (FFI.DwVirtuality_pure_virtual, A.PureVirtual) + ] + +genCodingInstance [t|A.DIMacroInfo|] ''FFI.Macinfo [ (FFI.DW_Macinfo_Define, A.Define), (FFI.DW_Macinfo_Undef, A.Undef) ] + +genCodingInstance [t|A.ImportedEntityTag|] ''FFI.DwTag + [ (FFI.DwTag_imported_module, A.ImportedModule) + , (FFI.DwTag_imported_declaration, A.ImportedDeclaration) + ] + +instance EncodeM EncodeAST ShortByteString (Ptr FFI.MDString) where + encodeM s = do + s' <- encodeM s + Context c <- gets encodeStateContext + liftIO (FFI.getMDString c s') + +instance Applicative m => EncodeM m [A.DIFlag] FFI.DIFlags where + encodeM fs = pure (FFI.DIFlags (foldl' (.|.) 0 (map encodeFlag fs))) + where + encodeFlag f = + case f of + A.Accessibility A.Private -> 1 + A.Accessibility A.Protected -> 2 + A.Accessibility A.Public -> 3 + A.FwdDecl -> 1 `shiftL` 2 + A.AppleBlock -> 1 `shiftL` 3 + A.ReservedBit4 -> 1 `shiftL` 4 + A.VirtualFlag -> 1 `shiftL` 5 + A.Artificial -> 1 `shiftL` 6 + A.Explicit -> 1 `shiftL` 7 + A.Prototyped -> 1 `shiftL` 8 + A.ObjcClassComplete -> 1 `shiftL` 9 + A.ObjectPointer -> 1 `shiftL` 10 + A.Vector -> 1 `shiftL` 11 + A.StaticMember -> 1 `shiftL` 12 + A.LValueReference -> 1 `shiftL` 13 + A.RValueReference -> 1 `shiftL` 14 + A.InheritanceFlag A.SingleInheritance -> 1 `shiftL` 16 + A.InheritanceFlag A.MultipleInheritance -> 2 `shiftL` 16 + A.InheritanceFlag A.VirtualInheritance -> 3 `shiftL` 16 + A.IntroducedVirtual -> 1 `shiftL` 18 + A.BitField -> 1 `shiftL` 19 + A.NoReturn -> 1 `shiftL` 20 + A.TypePassByValue -> 1 `shiftL` 22 + A.TypePassByReference -> 1 `shiftL` 23 + A.EnumClass -> 1 `shiftL` 24 + A.Thunk -> 1 `shiftL` 25 + A.NonTrivial -> 1 `shiftL` 26 + A.BigEndian -> 1 `shiftL` 27 + A.LittleEndian -> 1 `shiftL` 28 + A.AllCallsDescribed -> 1 `shiftL` 29 + +instance Applicative m => DecodeM m [A.DIFlag] FFI.DIFlags where + decodeM (FFI.DIFlags f) = + pure $ + accessibility ++ + inheritance ++ + mapMaybe flagSet flags + where + flagSet :: A.DIFlag -> Maybe A.DIFlag + flagSet f' + | f'' .&. f /= 0 = Just f' + | otherwise = Nothing + where Identity (FFI.DIFlags f'') = encodeM [f'] + accessibility + | testBit f 0 && testBit f 1 = [A.Accessibility A.Public] + | testBit f 0 = [A.Accessibility A.Private] + | testBit f 1 = [A.Accessibility A.Protected] + | otherwise = [] + inheritance + | testBit f 16 && testBit f 17 = [A.InheritanceFlag A.VirtualInheritance] + | testBit f 16 = [A.InheritanceFlag A.SingleInheritance] + | testBit f 17 = [A.InheritanceFlag A.MultipleInheritance] + | otherwise = [] + flags = + [ A.FwdDecl + , A.AppleBlock + , A.VirtualFlag + , A.Artificial + , A.Explicit + , A.Prototyped + , A.ObjcClassComplete + , A.ObjectPointer + , A.Vector + , A.StaticMember + , A.LValueReference + , A.RValueReference + , A.IntroducedVirtual + , A.BitField + , A.NoReturn + , A.TypePassByValue + , A.TypePassByReference + , A.EnumClass + , A.Thunk + , A.NonTrivial + , A.BigEndian + , A.LittleEndian + , A.AllCallsDescribed + ] + +instance DecodeM DecodeAST A.Operand (Ptr FFI.Value) where + decodeM v = do + c <- liftIO $ FFI.isAConstant v + if c /= nullPtr + then + return A.ConstantOperand `ap` decodeM c + else + do m <- liftIO $ FFI.isAMetadataOperand v + if m /= nullPtr + then A.MetadataOperand <$> decodeM m + else A.LocalReference + <$> (decodeM =<< liftIO (FFI.typeOf v)) + <*> getLocalName v + +instance DecodeM DecodeAST A.Metadata (Ptr FFI.Metadata) where + decodeM md = do + s <- liftIO $ FFI.isAMDString md + if s /= nullPtr + then A.MDString <$> decodeM s + else do + n <- liftIO $ FFI.isAMDNode md + if n /= nullPtr + then A.MDNode <$> decodeM n + else do + v <- liftIO $ FFI.isAMDValue md + if v /= nullPtr + then A.MDValue <$> decodeM v + else do + throwM (DecodeException "Metadata was not one of [MDString, MDValue, MDNode]") + +instance DecodeM DecodeAST (Either String A.DINode) (Ptr FFI.DINode) where + decodeM diN = do + sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast diN) + case sId of + [mdSubclassIdP|DIEnumerator|] -> + liftM Right $ A.DIEnumerator <$> decodeM (castPtr diN :: Ptr FFI.DIEnumerator) + [mdSubclassIdP|DIImportedEntity|] -> liftM Right $ A.DIImportedEntity <$> decodeM (castPtr diN :: Ptr FFI.DIImportedEntity) + [mdSubclassIdP|DIObjCProperty|] -> liftM Right $ A.DIObjCProperty <$> decodeM (castPtr diN :: Ptr FFI.DIObjCProperty) + [mdSubclassIdP|DISubrange|] -> liftM Right $ A.DISubrange <$> decodeM (castPtr diN :: Ptr FFI.DISubrange) + [mdSubclassIdP|DIBasicType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DICompositeType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DIDerivedType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DISubroutineType|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DILexicalBlock|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DILexicalBlockFile|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DIFile|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DINamespace|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DISubprogram|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DICompileUnit|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + [mdSubclassIdP|DIModule|] -> liftM Right $ A.DIScope <$> decodeM (castPtr diN :: Ptr FFI.DIScope) + + [mdSubclassIdP|DIGlobalVariable|] -> liftM Right $ A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable) + [mdSubclassIdP|DILocalVariable|] -> liftM Right $ A.DIVariable <$> decodeM (castPtr diN :: Ptr FFI.DIVariable) + + [mdSubclassIdP|DITemplateTypeParameter|] -> liftM Right $ A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter) + [mdSubclassIdP|DITemplateValueParameter|] -> liftM Right $ A.DITemplateParameter <$> decodeM (castPtr diN :: Ptr FFI.DITemplateParameter) + + [mdSubclassIdP|MDString|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDString)") + [mdSubclassIdP|ConstantAsMetadata|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (ConstantAsMetadata)") + [mdSubclassIdP|LocalAsMetadata|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (LocalAsMetadata)") + [mdSubclassIdP|DistinctMDOperandPlaceholder|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DistinctMDOperandPlaceholder)") + [mdSubclassIdP|MDTuple|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (MDTuple)") + [mdSubclassIdP|DILocation|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DILocation)") + [mdSubclassIdP|DIExpression|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIExpression)") + [mdSubclassIdP|DIGlobalVariableExpression|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIGlobalVariableExpression)") + [mdSubclassIdP|GenericDINode|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (GenericDINode)") + [mdSubclassIdP|DIMacro|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacro)") + [mdSubclassIdP|DIMacroFile|] -> liftM Left $ pure ("Lifting to Haskell not implemented for toplevel DINode kind: " <> show sId <> " (DIMacroFile)") + + _ -> throwM (DecodeException ("Unknown subclass id for DINode: " <> show sId)) + +instance EncodeM EncodeAST A.DICount (Ptr FFI.Metadata) where + encodeM count = do + case count of + A.DICountConstant i -> do + let constant = A.MDValue (A.ConstantOperand (A.Int { A.integerBits = 64, A.integerValue = toInteger i })) + encodeM constant + A.DICountVariable v -> do + encodeM (A.MDNode $ A.DINode . A.DIVariable <$> v) + +instance EncodeM EncodeAST A.DIBound (Ptr FFI.Metadata) where + encodeM bound = do + case bound of + A.DIBoundConstant i -> do + let constant = A.MDValue (A.ConstantOperand (A.Int { A.integerBits = 64, A.integerValue = toInteger i })) + encodeM constant + A.DIBoundVariable v -> do + encodeM (A.MDNode (A.DINode . A.DIVariable <$> v)) + A.DIBoundExpression e -> do + encodeM (A.MDNode (A.DIExpression <$> e)) + +instance DecodeM DecodeAST A.DICount (Ptr FFI.Metadata) where + decodeM m = do + c <- liftIO $ FFI.isAMDValue m + if c /= nullPtr + then do + (A.ConstantOperand A.Int { A.integerValue = i }) <- decodeM c + pure (A.DICountConstant (fromInteger i)) + else do + v <- decodeM =<< liftIO (FFI.isADIVariable m) + pure (A.DICountVariable v) + +instance DecodeM DecodeAST A.DIBound (Ptr FFI.Metadata) where + decodeM m = do + c <- liftIO $ FFI.isAMDValue m + if c /= nullPtr + then do + (A.ConstantOperand A.Int { A.integerValue = i }) <- decodeM c + pure (A.DIBoundConstant (fromInteger i)) + else do + v <- liftIO (FFI.isADIVariable m) + if v /= nullPtr + then do + v' <- decodeM =<< pure v + pure (A.DIBoundVariable v') + else do + e <- decodeM =<< liftIO (FFI.isADIExpression m) + pure (A.DIBoundExpression e) + +instance EncodeM EncodeAST A.DISubrange (Ptr FFI.DISubrange) where + encodeM (A.Subrange {..}) = do + Context c <- gets encodeStateContext + count' <- encodeM count + lowerBound' <- encodeM lowerBound + upperBound' <- encodeM upperBound + stride' <- encodeM stride + liftIO (FFI.getDISubrangeVariableFields c count' lowerBound' upperBound' stride') + +instance DecodeM DecodeAST A.DISubrange (Ptr FFI.DISubrange) where + decodeM r = do + count <- decodeM =<< liftIO (FFI.getDISubrangeCount r) + lowerBound <- decodeM =<< liftIO (FFI.getDISubrangeLowerBound r) + upperBound <- decodeM =<< liftIO (FFI.getDISubrangeUpperBound r) + stride <- decodeM =<< liftIO (FFI.getDISubrangeStride r) + pure (A.Subrange count lowerBound upperBound stride) + +instance EncodeM EncodeAST A.DIEnumerator (Ptr FFI.DIEnumerator) where + encodeM (A.Enumerator {..}) = do + name <- encodeM name + isUnsigned <- encodeM isUnsigned + Context c <- gets encodeStateContext + liftIO (FFI.getDIEnumerator c value isUnsigned name) + +instance DecodeM DecodeAST A.DIEnumerator (Ptr FFI.DIEnumerator) where + decodeM e = do + value <- liftIO (FFI.getDIEnumeratorValue e) + isUnsigned <- decodeM =<< liftIO (FFI.getDIEnumeratorIsUnsigned e) + name <- decodeM =<< liftIO (FFI.getDIEnumeratorName e) + pure (A.Enumerator value isUnsigned name) + +instance EncodeM EncodeAST A.DINode (Ptr FFI.DINode) where + encodeM (A.DISubrange r) = do + ptr <- encodeM r + pure (FFI.upCast (ptr :: Ptr FFI.DISubrange)) + encodeM (A.DIEnumerator e) = do + ptr <- encodeM e + pure (FFI.upCast (ptr :: Ptr FFI.DIEnumerator)) + encodeM (A.DIScope s) = do + ptr <- encodeM s + pure (FFI.upCast (ptr :: Ptr FFI.DIScope)) + encodeM (A.DIVariable v) = do + ptr <- encodeM v + pure (FFI.upCast (ptr :: Ptr FFI.DIVariable)) + encodeM (A.DITemplateParameter p) = do + ptr <- encodeM p + pure (FFI.upCast (ptr :: Ptr FFI.DITemplateParameter)) + encodeM (A.DIImportedEntity e) = do + ptr <- encodeM e + pure (FFI.upCast (ptr :: Ptr FFI.DIImportedEntity)) + encodeM (A.DIObjCProperty o) = FFI.upCast <$> (encodeM o :: EncodeAST (Ptr FFI.DIObjCProperty)) + +instance DecodeM DecodeAST A.DIScope (Ptr FFI.DIScope) where + decodeM p = do + sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast p) + case sId of + [mdSubclassIdP|DINamespace|] -> A.DINamespace <$> decodeM (castPtr p :: Ptr FFI.DINamespace) + [mdSubclassIdP|DIFile|] -> A.DIFile <$> decodeM (castPtr p :: Ptr FFI.DIFile) + [mdSubclassIdP|DILexicalBlock|] -> A.DILocalScope <$> decodeM (castPtr p :: Ptr FFI.DILocalScope) + [mdSubclassIdP|DILexicalBlockFile|] -> A.DILocalScope <$> decodeM (castPtr p :: Ptr FFI.DILocalScope) + [mdSubclassIdP|DISubprogram|] -> A.DILocalScope <$> decodeM (castPtr p :: Ptr FFI.DILocalScope) + + [mdSubclassIdP|DIBasicType|] -> A.DIType <$> decodeM (castPtr p :: Ptr FFI.DIType) + [mdSubclassIdP|DICompositeType|] -> A.DIType <$> decodeM (castPtr p :: Ptr FFI.DIType) + [mdSubclassIdP|DIDerivedType|] -> A.DIType <$> decodeM (castPtr p :: Ptr FFI.DIType) + [mdSubclassIdP|DISubroutineType|] -> A.DIType <$> decodeM (castPtr p :: Ptr FFI.DIType) + + [mdSubclassIdP|DICompileUnit|] -> A.DICompileUnit <$> decodeM (castPtr p :: Ptr FFI.DICompileUnit) + [mdSubclassIdP|DIModule|] -> A.DIModule <$> decodeM (castPtr p :: Ptr FFI.DIModule) + + _ -> throwM (DecodeException ("Unknown subclass id for DIScope: " <> show sId)) + +instance DecodeM DecodeAST A.DINamespace (Ptr FFI.DINamespace) where + decodeM p = do + scope <- decodeM =<< liftIO (FFI.getScopeScope (FFI.upCast p)) + name <- getByteStringFromFFI FFI.getScopeName (FFI.upCast p) + exported <- decodeM =<< liftIO (FFI.getNamespaceExportedSymbols (castPtr p)) + return (A.Namespace name scope exported) + +instance EncodeM EncodeAST A.DINamespace (Ptr FFI.DINamespace) where + encodeM A.Namespace {..} = do + name <- encodeM name + scope <- encodeM scope + exportSyms <- encodeM exportSymbols + Context c <- gets encodeStateContext + liftIO (FFI.getDINamespace c scope name exportSyms) + +instance DecodeM DecodeAST A.DIModule (Ptr FFI.DIModule) where + decodeM p = do + scope <- decodeM =<< liftIO (FFI.getScopeScope (FFI.upCast p)) + name <- getByteStringFromFFI FFI.getScopeName (FFI.upCast p) + let m = castPtr p :: Ptr FFI.DIModule + configurationMacros <- decodeM =<< liftIO (FFI.getDIModuleConfigurationMacros m) + includePath <- decodeM =<< liftIO (FFI.getDIModuleIncludePath m) + apiNotesFile <- decodeM =<< liftIO (FFI.getDIModuleAPINotesFile m) + lineNo <- liftIO (FFI.getDIModuleLineNo m) + pure A.Module + { A.scope = scope + , A.name = name + , A.configurationMacros = configurationMacros + , A.includePath = includePath + , A.apiNotesFile = apiNotesFile + , A.lineNo = lineNo + } + +instance EncodeM EncodeAST A.DIModule (Ptr FFI.DIModule) where + encodeM A.Module {..} = do + scope <- encodeM scope + name <- encodeM name + configurationMacros <- encodeM configurationMacros + includePath <- encodeM includePath + apiNotesFile <- encodeM apiNotesFile + Context c <- gets encodeStateContext + liftIO (FFI.getDIModule c scope name configurationMacros includePath apiNotesFile lineNo) + +instance DecodeM DecodeAST A.DICompileUnit (Ptr FFI.DICompileUnit) where + decodeM p = do + language <- decodeM =<< liftIO (FFI.getDICompileUnitLanguage p) + file <- decodeM =<< liftIO (FFI.getScopeFile (FFI.upCast p)) + producer <- decodeM =<< liftIO (FFI.getDICompileUnitProducer p) + optimized <- decodeM =<< liftIO (FFI.getDICompileUnitOptimized p) + flags <- decodeM =<< liftIO (FFI.getDICompileUnitFlags p) + runtimeVersion <- decodeM =<< liftIO (FFI.getDICompileUnitRuntimeVersion p) + splitDebugFilename <- decodeM =<< liftIO (FFI.getDICompileUnitSplitDebugFilename p) + emissionKind <- decodeM =<< liftIO (FFI.getDICompileUnitEmissionKind p) + dwoid <- decodeM =<< liftIO (FFI.getDICompileUnitDWOId p) + splitDebugInlining <- decodeM =<< liftIO (FFI.getDICompileUnitSplitDebugInlining p) + debugInfoForProfiling <- decodeM =<< liftIO (FFI.getDICompileUnitDebugInfoForProfiling p) + enums <- decodeM =<< liftIO (FFI.getDICompileUnitEnumTypes p) + retainedTypes' <- decodeM =<< liftIO (FFI.getDICompileUnitRetainedTypes p) + let toRetainedType :: A.MDRef A.DIScope -> DecodeAST (A.MDRef (Either A.DIType A.DISubprogram)) + toRetainedType (A.MDRef i) = pure (A.MDRef i) + toRetainedType (A.MDInline (A.DIType ty)) = pure (A.MDInline (Left ty)) + toRetainedType (A.MDInline (A.DILocalScope (A.DISubprogram p))) = pure (A.MDInline (Right p)) + toRetainedType (A.MDInline e) = throwM (DecodeException ("Retained type must be DISubprogram or DIType but got " <> show e)) + retainedTypes <- traverse toRetainedType retainedTypes' + globals <- decodeM =<< liftIO (FFI.getDICompileUnitGlobalVariables p) + entities <- decodeM =<< liftIO (FFI.getDICompileUnitImportedEntities p) + macros <- decodeM =<< liftIO (FFI.getDICompileUnitMacros p) + nameTableKind <- decodeM =<< liftIO (FFI.getDICompileUnitNameTableKind p) + rangesBaseAddress <- decodeM =<< liftIO (FFI.getDICompileUnitRangesBaseAddress p) + pure A.CompileUnit + { A.language = language + , A.file = file + , A.producer = producer + , A.optimized = optimized + , A.flags = flags + , A.runtimeVersion = runtimeVersion + , A.splitDebugFileName = splitDebugFilename + , A.emissionKind = emissionKind + , A.enums = enums + , A.retainedTypes = retainedTypes + , A.globals = globals + , A.imports = entities + , A.macros = macros + , A.dWOId = dwoid + , A.splitDebugInlining = splitDebugInlining + , A.debugInfoForProfiling = debugInfoForProfiling + , A.nameTableKind = nameTableKind + , A.rangesBaseAddress = rangesBaseAddress + } + +instance EncodeM EncodeAST A.DICompileUnit (Ptr FFI.DICompileUnit) where + encodeM (A.CompileUnit {..}) = do + language <- encodeM language + file <- encodeM file + producer <- encodeM producer + optimized <- encodeM optimized + flags <- encodeM flags + runtimeVersion <- encodeM runtimeVersion + debugFileName <- encodeM splitDebugFileName + emissionKind <- encodeM emissionKind + enums <- encodeM enums + retainedTypes <- encodeM (map (fmap (either A.DIType (A.DILocalScope . A.DISubprogram))) retainedTypes) + globals <- encodeM globals + imports <- encodeM imports + macros <- encodeM macros + dwoid <- encodeM dWOId + splitDebugInlining <- encodeM splitDebugInlining + debugInfoForProfiling <- encodeM debugInfoForProfiling + nameTableKind <- encodeM nameTableKind + rangesBaseAddress <- encodeM rangesBaseAddress + Context c <- gets encodeStateContext + liftIO $ FFI.getDICompileUnit + c + language file producer optimized flags + runtimeVersion debugFileName emissionKind enums retainedTypes + globals imports macros dwoid splitDebugInlining + debugInfoForProfiling nameTableKind rangesBaseAddress + +instance EncodeM EncodeAST A.DIScope (Ptr FFI.DIScope) where + encodeM (A.DIFile f) = FFI.upCast <$> (encodeM f :: EncodeAST (Ptr FFI.DIFile)) + encodeM (A.DICompileUnit cu) = FFI.upCast <$> (encodeM cu :: EncodeAST (Ptr FFI.DICompileUnit)) + encodeM (A.DIType t) = FFI.upCast <$> (encodeM t :: EncodeAST (Ptr FFI.DIType)) + encodeM (A.DILocalScope t) = FFI.upCast <$> (encodeM t :: EncodeAST (Ptr FFI.DILocalScope)) + encodeM (A.DINamespace ns) = FFI.upCast <$> (encodeM ns :: EncodeAST (Ptr FFI.DINamespace)) + encodeM (A.DIModule m) = FFI.upCast <$> (encodeM m :: EncodeAST (Ptr FFI.DIModule)) + +instance DecodeM DecodeAST A.DIFile (Ptr FFI.DIFile) where + decodeM diF = do + fname <- decodeM =<< liftIO (FFI.getFileFilename diF) + dir <- decodeM =<< liftIO (FFI.getFileDirectory diF) + mayChecksum <- decodeM =<< liftIO (FFI.getFileChecksumValue diF) + case mayChecksum of + Nothing -> pure (A.File fname dir Nothing) + Just checksum -> do + csk <- decodeM =<< liftIO (FFI.getFileChecksumKind diF) + pure (A.File fname dir (Just (A.ChecksumInfo csk checksum))) + +instance EncodeM EncodeAST A.DIFile (Ptr FFI.DIFile) where + encodeM (A.File {..}) = do + filename <- encodeM filename + directory <- encodeM directory + Context c <- gets encodeStateContext + case checksum of + Nothing -> liftIO (FFI.getDIFile c filename directory (FFI.ChecksumKind 0) nullPtr) + Just (A.ChecksumInfo {..}) -> do + checksumValue <- encodeM checksumValue + checksumKind <- encodeM checksumKind + liftIO (FFI.getDIFile c filename directory checksumKind checksumValue) + +instance EncodeM EncodeAST (Maybe A.Encoding) FFI.Encoding where + encodeM Nothing = pure (FFI.Encoding 0) + encodeM (Just e) = encodeM e + +instance DecodeM DecodeAST (Maybe A.Encoding) FFI.Encoding where + decodeM (FFI.Encoding 0) = pure Nothing + decodeM e = Just <$> decodeM e + +instance EncodeM EncodeAST A.DIType (Ptr FFI.DIType) where + encodeM (A.DIBasicType t) = FFI.upCast <$> (encodeM t :: EncodeAST (Ptr FFI.DIBasicType)) + encodeM (A.DIDerivedType t) = FFI.upCast <$> (encodeM t :: EncodeAST (Ptr FFI.DIDerivedType)) + encodeM (A.DISubroutineType t) = FFI.upCast <$> (encodeM t :: EncodeAST (Ptr FFI.DISubroutineType)) + encodeM (A.DICompositeType t) = FFI.upCast <$> (encodeM t :: EncodeAST (Ptr FFI.DICompositeType)) + +instance DecodeM DecodeAST A.DICompositeType (Ptr FFI.DICompositeType) where + decodeM diTy = do + tag <- liftIO (FFI.getTag (FFI.upCast diTy)) + size <- liftIO (FFI.getTypeSizeInBits (FFI.upCast diTy)) + align <- liftIO (FFI.getTypeAlignInBits (FFI.upCast diTy)) + elements <- liftIO (FFI.getElements diTy) + scope <- decodeM =<< liftIO (FFI.getScopeScope (FFI.upCast diTy)) + name <- decodeM =<< liftIO (FFI.getTypeName (FFI.upCast diTy)) + file <- decodeM =<< liftIO (FFI.getScopeFile (FFI.upCast diTy)) + line <- liftIO (FFI.getTypeLine (FFI.upCast diTy)) + flags <- decodeM =<< liftIO (FFI.getTypeFlags (FFI.upCast diTy)) + runtimeLang <- liftIO (FFI.getRuntimeLang diTy) + vtableHolder <- decodeM =<< liftIO (FFI.getVTableHolder diTy) + type' <- decodeM =<< liftIO (FFI.getCompositeBaseType diTy) + identifier <- decodeM =<< liftIO (FFI.getIdentifier diTy) + case tag of + FFI.DwTag_array_type -> do + subscripts <- decodeM (FFI.TupleArray elements :: FFI.TupleArray FFI.DISubrange) + pure (A.DIArrayType subscripts type' size align flags) + FFI.DwTag_enumeration_type -> do + values <- decodeM (FFI.TupleArray elements :: FFI.TupleArray FFI.DIEnumerator) + pure (A.DIEnumerationType scope name file line values type' identifier size align) + FFI.DwTag_structure_type -> do + elements <- decodeM (FFI.TupleArray elements :: FFI.TupleArray FFI.DIScope) + elements <- traverse fromCompElement elements + pure (A.DIStructureType scope name file line flags type' elements runtimeLang vtableHolder identifier size align) + FFI.DwTag_class_type -> do + elements <- decodeM (FFI.TupleArray elements :: FFI.TupleArray FFI.DIScope) + elements <- traverse fromCompElement elements + vtableHolder <- decodeM =<< liftIO (FFI.getVTableHolder diTy) + params <- decodeM =<< liftIO (FFI.getTemplateParams diTy) + pure (A.DIClassType scope name file line flags type' elements vtableHolder params identifier size align) + FFI.DwTag_union_type -> do + elements <- decodeM (FFI.TupleArray elements :: FFI.TupleArray FFI.DIScope) + elements <- traverse fromCompElement elements + pure (A.DIUnionType scope name file line flags elements runtimeLang identifier size align) + _ -> throwM (DecodeException ("Unknown tag of DICompositeType: " <> show tag)) + +fromCompElement :: A.MDRef A.DIScope -> DecodeAST (A.MDRef (Either A.DIDerivedType A.DISubprogram)) +fromCompElement (A.MDRef r) = pure (A.MDRef r) +fromCompElement (A.MDInline (A.DIType (A.DIDerivedType ty))) = pure (A.MDInline (Left ty)) +fromCompElement (A.MDInline (A.DILocalScope (A.DISubprogram p))) = pure (A.MDInline (Right p)) +fromCompElement (A.MDInline e) = throwM (DecodeException ("Elements of DIClassType, DIStructureType and DIUnionType must be DIDerivedType or DISubprogram but got " <> show e)) + +toCompElement :: A.MDRef (Either A.DIDerivedType A.DISubprogram) -> A.MDRef A.DIScope +toCompElement = fmap (either (A.DIType . A.DIDerivedType) (A.DILocalScope . A.DISubprogram)) + +instance EncodeM EncodeAST A.DICompositeType (Ptr FFI.DICompositeType) where + encodeM A.DIArrayType {..} = do + subscripts <- encodeM subscripts + elementTy <- encodeM elementTy + flags <- encodeM flags + Context c <- gets encodeStateContext + liftIO (FFI.getDIArrayType c subscripts elementTy sizeInBits alignInBits flags) + encodeM A.DIEnumerationType {..} = do + scope <- encodeM scope + name <- encodeM name + file <- encodeM file + elements <- encodeM values + underlyingType <- encodeM baseType + identifier <- encodeM identifier + Context c <- gets encodeStateContext + liftIO (FFI.getDIEnumerationType c scope name file line sizeInBits alignInBits elements underlyingType identifier) + encodeM A.DIStructureType {..} = do + scope <- encodeM scope + name <- encodeM name + file <- encodeM file + flags <- encodeM flags + derivedFrom <- encodeM derivedFrom + elements <- encodeM (map toCompElement elements) + vtableHolder <- encodeM vtableHolder + identifier <- encodeM identifier + Context c <- gets encodeStateContext + liftIO (FFI.getDIStructType c scope name file line sizeInBits alignInBits flags derivedFrom elements runtimeLang vtableHolder identifier) + encodeM A.DIUnionType {..} = do + scope <- encodeM scope + name <- encodeM name + file <- encodeM file + flags <- encodeM flags + elements <- encodeM (map toCompElement elements) + identifier <- encodeM identifier + Context c <- gets encodeStateContext + liftIO (FFI.getDIUnionType c scope name file line sizeInBits alignInBits flags elements runtimeLang identifier) + encodeM A.DIClassType {..} = do + scope <- encodeM scope + name <- encodeM name + file <- encodeM file + flags <- encodeM flags + derivedFrom <- encodeM derivedFrom + elements <- encodeM (map toCompElement elements) + vtableHolder <- encodeM vtableHolder + params <- encodeM templateParams + identifier <- encodeM identifier + Context c <- gets encodeStateContext + liftIO (FFI.getDIClassType c scope name file line sizeInBits alignInBits flags derivedFrom elements vtableHolder params identifier) + +instance DecodeM DecodeAST A.DIType (Ptr FFI.DIType) where + decodeM diTy = do + sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast diTy) + case sId of + [mdSubclassIdP|DIBasicType|] -> + A.DIBasicType <$> decodeM (castPtr diTy :: Ptr FFI.DIBasicType) + [mdSubclassIdP|DICompositeType|] -> + A.DICompositeType <$> decodeM (castPtr diTy :: Ptr FFI.DICompositeType) + [mdSubclassIdP|DIDerivedType|] -> A.DIDerivedType <$> decodeM (castPtr diTy :: Ptr FFI.DIDerivedType) + [mdSubclassIdP|DISubroutineType|] -> A.DISubroutineType <$> decodeM (castPtr diTy :: Ptr FFI.DISubroutineType) + _ -> throwM (DecodeException ("Unknown subclass id for DIType: " <> show sId)) + +instance DecodeM DecodeAST A.DIBasicType (Ptr FFI.DIBasicType) where + decodeM diTy = do + tag <- decodeM =<< liftIO (FFI.getTag (FFI.upCast diTy)) + size <- liftIO (FFI.getTypeSizeInBits (FFI.upCast diTy)) + align <- liftIO (FFI.getTypeAlignInBits (FFI.upCast diTy)) + name <- decodeM =<< liftIO (FFI.getTypeName (FFI.upCast diTy)) + encoding <- decodeM =<< liftIO (FFI.getBasicTypeEncoding diTy) + flags <- decodeM =<< liftIO (FFI.getTypeFlags (castPtr diTy :: Ptr FFI.DIType)) + pure (A.BasicType name size align encoding tag flags) + +instance EncodeM EncodeAST A.DIBasicType (Ptr FFI.DIBasicType) where + encodeM A.BasicType {..} = do + tag <- encodeM tag + name <- encodeM name + encoding <- encodeM encoding + flags <- encodeM flags + Context c <- gets encodeStateContext + liftIO (FFI.getDIBasicType c tag name sizeInBits alignInBits encoding flags) + + +instance EncodeM EncodeAST A.DISubroutineType (Ptr FFI.DISubroutineType) where + encodeM A.SubroutineType {..} = do + flags <- encodeM flags + types <- encodeM typeArray + Context c <- gets encodeStateContext + liftIO (FFI.getDISubroutineType c flags cc types) + +instance DecodeM DecodeAST A.DISubroutineType (Ptr FFI.DISubroutineType) where + decodeM p = do + flags <- decodeM =<< liftIO (FFI.getTypeFlags (FFI.upCast p)) + cc <- liftIO (FFI.getSubroutineCC p) + arr <- decodeM =<< liftIO (FFI.getSubroutineTypeArray p) + pure A.SubroutineType + { A.flags = flags + , A.cc = cc + , A.typeArray = arr + } + +instance EncodeM EncodeAST A.DIDerivedType (Ptr FFI.DIDerivedType) where + encodeM A.DerivedType {..} = do + tag <- encodeM tag + name <- encodeM name + file <- encodeM file + line <- encodeM line + scope <- encodeM scope + type' <- encodeM baseType + (addrSpace, addrSpacePresent) <- encodeM addressSpace + flags <- encodeM flags + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDIDerivedType c tag name file line scope type' sizeInBits alignInBits offsetInBits addrSpace addrSpacePresent flags) + +instance DecodeM DecodeAST A.DIDerivedType (Ptr FFI.DIDerivedType) where + decodeM diTy = do + let diTy' = FFI.upCast diTy + name <- decodeM =<< liftIO (FFI.getTypeName diTy') + file <- decodeM =<< liftIO (FFI.getScopeFile (FFI.upCast diTy)) + scope <- decodeM =<< liftIO (FFI.getScopeScope (FFI.upCast diTy)) + ty <- decodeM =<< liftIO (FFI.getDerivedBaseType diTy') + line <- liftIO (FFI.getTypeLine diTy') + size <- liftIO (FFI.getTypeSizeInBits diTy') + align <- liftIO (FFI.getTypeAlignInBits diTy') + offset <- liftIO (FFI.getTypeOffsetInBits diTy') + tag <- decodeM =<< liftIO (FFI.getTag (FFI.upCast diTy)) + flags <- decodeM =<< liftIO (FFI.getTypeFlags diTy') + addressSpace <- decodeOptional (FFI.getDerivedAddressSpace diTy') + pure A.DerivedType + { A.tag = tag + , A.name = name + , A.file = file + , A.line = line + , A.scope = scope + , A.baseType = ty + , A.sizeInBits = size + , A.alignInBits = align + , A.offsetInBits = offset + , A.addressSpace = addressSpace + , A.flags = flags + } + +instance EncodeM EncodeAST A.DIVariable (Ptr FFI.DIVariable) where + encodeM (A.DIGlobalVariable v) = do + ptr <- encodeM v + pure (FFI.upCast (ptr :: Ptr FFI.DIGlobalVariable)) + encodeM (A.DILocalVariable v) = do + ptr <- encodeM v + pure (FFI.upCast (ptr :: Ptr FFI.DILocalVariable)) + +instance DecodeM DecodeAST A.DIVariable (Ptr FFI.DIVariable) where + decodeM p = do + sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast p) + case sId of + [mdSubclassIdP|DIGlobalVariable|] -> + A.DIGlobalVariable <$> decodeM (castPtr p :: Ptr FFI.DIGlobalVariable) + [mdSubclassIdP|DILocalVariable|] -> + A.DILocalVariable <$> decodeM (castPtr p :: Ptr FFI.DILocalVariable) + _ -> throwM (DecodeException ("Unknown subclass id for DIVariable: " <> show sId)) + +instance DecodeM DecodeAST A.DIGlobalVariable (Ptr FFI.DIGlobalVariable) where + decodeM p = do + name <- decodeM =<< liftIO (FFI.getDIVariableName (FFI.upCast p)) + scope <- decodeM =<< liftIO (FFI.getDIVariableScope (FFI.upCast p)) + file <- decodeM =<< liftIO (FFI.getDIVariableFile (FFI.upCast p)) + line <- decodeM =<< liftIO (FFI.getDIVariableLine (FFI.upCast p)) + type' <- decodeM =<< liftIO (FFI.getDIVariableType (FFI.upCast p)) + align <- liftIO (FFI.getDIVariableAlignInBits (FFI.upCast p)) + linkageName <- decodeM =<< liftIO (FFI.getDIGlobalVariableLinkageName p) + local <- decodeM =<< liftIO (FFI.getDIGlobalVariableLocal p) + definition <- decodeM =<< liftIO (FFI.getDIGlobalVariableDefinition p) + decl <- decodeM =<< liftIO (FFI.getDIGlobalVariableStaticDataMemberDeclaration p) + pure A.GlobalVariable + { A.name = name + , A.scope = scope + , A.file = file + , A.line = line + , A.type' = type' + , A.linkageName = linkageName + , A.local = local + , A.definition = definition + , A.staticDataMemberDeclaration = decl + , A.templateParams = [] + , A.alignInBits = align + } + +instance EncodeM EncodeAST A.DIGlobalVariable (Ptr FFI.DIGlobalVariable) where + encodeM A.GlobalVariable {..} = do + name <- encodeM name + scope <- encodeM scope + file <- encodeM file + line <- encodeM line + type' <- encodeM type' + linkageName <- encodeM linkageName + local <- encodeM local + definition <- encodeM definition + dataMemberDeclaration <- encodeM staticDataMemberDeclaration + templateParams <- encodeM templateParams + Context c <- gets encodeStateContext + liftIO (FFI.getDIGlobalVariable c scope name linkageName file line type' local definition dataMemberDeclaration templateParams alignInBits) + +instance DecodeM DecodeAST A.DILocalVariable (Ptr FFI.DILocalVariable) where + decodeM p = do + name <- decodeM =<< liftIO (FFI.getDIVariableName (FFI.upCast p)) + scope <- decodeM =<< liftIO (FFI.getDIVariableScope (FFI.upCast p)) + file <- decodeM =<< liftIO (FFI.getDIVariableFile (FFI.upCast p)) + line <- decodeM =<< liftIO (FFI.getDIVariableLine (FFI.upCast p)) + type' <- decodeM =<< liftIO (FFI.getDIVariableType (FFI.upCast p)) + align <- liftIO (FFI.getDIVariableAlignInBits (FFI.upCast p)) + arg <- liftIO (FFI.getDILocalVariableArg p) + flags <- decodeM =<< liftIO (FFI.getDILocalVariableFlags p) + pure A.LocalVariable + { A.file = file + , A.scope = scope + , A.name = name + , A.line = line + , A.arg = arg + , A.flags = flags + , A.type' = type' + , A.alignInBits = align + } + +instance EncodeM EncodeAST A.DILocalVariable (Ptr FFI.DILocalVariable) where + encodeM A.LocalVariable {..} = do + name <- encodeM name + scope <- encodeM scope + file <- encodeM file + type' <- encodeM type' + flags <- encodeM flags + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDILocalVariable c scope name file line type' arg flags alignInBits) + +getDITemplateParameterName :: A.DITemplateParameter -> ShortByteString +getDITemplateParameterName A.DITemplateTypeParameter {..} = name +getDITemplateParameterName A.DITemplateValueParameter{..} = name + +getDITemplateParameterType :: A.DITemplateParameter -> Maybe (A.MDRef A.DIType) +getDITemplateParameterType A.DITemplateTypeParameter {..} = type' +getDITemplateParameterType A.DITemplateValueParameter{..} = type' + +instance EncodeM EncodeAST A.DITemplateParameter (Ptr FFI.DITemplateParameter) where + encodeM p = do + name' <- encodeM (getDITemplateParameterName p) :: EncodeAST (Ptr FFI.MDString) + ty <- encodeM (getDITemplateParameterType p) + Context c <- gets encodeStateContext + case p of + A.DITemplateTypeParameter {} -> + FFI.upCast <$> liftIO (FFI.getDITemplateTypeParameter c name' ty) + A.DITemplateValueParameter {..} -> do + tag <- encodeM tag + value <- encodeM value + FFI.upCast <$> liftIO (FFI.getDITemplateValueParameter c name' ty tag True value) + +instance DecodeM DecodeAST A.DITemplateParameter (Ptr FFI.DITemplateParameter) where + decodeM p = do + sId <- liftIO (FFI.getMetadataClassId (FFI.upCast p)) + name <- decodeM =<< liftIO (FFI.getDITemplateParameterName p) + ty <- decodeM =<< liftIO (FFI.getDITemplateParameterType p) + case sId of + [mdSubclassIdP|DITemplateTypeParameter|] -> + pure (A.DITemplateTypeParameter name ty) + [mdSubclassIdP|DITemplateValueParameter|] -> do + value <- decodeM =<< liftIO (FFI.getDITemplateValueParameterValue (castPtr p)) + tag <- decodeM =<< liftIO (FFI.getTag (FFI.upCast p)) + pure (A.DITemplateValueParameter name ty value tag) + _ -> throwM (DecodeException ("Unknown subclass id for DITemplateParameter: " <> show sId)) + +instance DecodeM DecodeAST A.DISubprogram (Ptr FFI.DISubprogram) where + decodeM p = do + name <- getByteStringFromFFI FFI.getScopeName (FFI.upCast p) + linkageName <- decodeM =<< liftIO (FFI.getDISubprogramLinkageName p) + file <- decodeM =<< liftIO (FFI.getScopeFile (FFI.upCast p)) + scope <- decodeM =<< liftIO (FFI.getScopeScope (FFI.upCast p)) + line <- decodeM =<< liftIO (FFI.getDISubprogramLine p) + virtuality <- decodeM =<< liftIO (FFI.getDISubprogramVirtuality p) + virtualIndex <- decodeM =<< liftIO (FFI.getDISubprogramVirtualIndex p) + scopeLine <- decodeM =<< liftIO (FFI.getDISubprogramScopeLine p) + optimized <- decodeM =<< liftIO (FFI.getDISubprogramIsOptimized p) + definition <- decodeM =<< liftIO (FFI.getDISubprogramIsDefinition p) + localToUnit <- decodeM =<< liftIO (FFI.getDISubprogramLocalToUnit p) + thisAdjustment <- liftIO (FFI.getDISubprogramThisAdjustment p) + flags <- decodeM =<< liftIO (FFI.getDISubprogramFlags p) + type' <- decodeM =<< liftIO (FFI.getDISubprogramType p) + containingType <- decodeM =<< liftIO (FFI.getDISubprogramContainingType p) + unit <- decodeM =<< liftIO (FFI.getDISubprogramUnit p) + templateParams <- decodeM =<< liftIO (FFI.getDISubprogramTemplateParams p) + retainedNodes <- decodeM =<< liftIO (FFI.getDISubprogramRetainedNodes p) + thrownTypes <- decodeM =<< liftIO (FFI.getDISubprogramThrownTypes p) + decl <- decodeM =<< liftIO (FFI.getDISubprogramDeclaration p) + pure A.Subprogram + { A.name = name + , A.linkageName = linkageName + , A.scope = scope + , A.file = file + , A.line = line + , A.type' = type' + , A.definition = definition + , A.scopeLine = scopeLine + , A.containingType = containingType + , A.virtuality = virtuality + , A.virtualityIndex = virtualIndex + , A.flags = flags + , A.optimized = optimized + , A.unit = unit + , A.templateParams = templateParams + , A.declaration = decl + , A.retainedNodes = retainedNodes + , A.thrownTypes = thrownTypes + , A.localToUnit = localToUnit + , A.thisAdjustment = thisAdjustment + } + +instance EncodeM EncodeAST A.DISubprogram (Ptr FFI.DISubprogram) where + encodeM A.Subprogram {..} = do + scope <- encodeM scope + name <- encodeM name + linkageName <- encodeM linkageName + file <- encodeM file + line <- encodeM line + type' <- encodeM type' + localToUnit <- encodeM localToUnit + definition <- encodeM definition + scopeLine <- encodeM scopeLine + containingType <- encodeM containingType + virtuality <- encodeM virtuality + virtualityIndex <- encodeM virtualityIndex + flags <- encodeM flags + optimized <- encodeM optimized + unit <- encodeM unit + templateParams <- encodeM templateParams + declaration <- encodeM declaration + retainedNodes <- encodeM retainedNodes + thrownTypes <- encodeM thrownTypes + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO + (FFI.getDISubprogram + c scope name + linkageName file line + type' localToUnit definition scopeLine + containingType virtuality virtualityIndex + thisAdjustment flags optimized + unit templateParams declaration + retainedNodes thrownTypes) + +instance DecodeM DecodeAST A.DILocalScope (Ptr FFI.DILocalScope) where + decodeM ls = do + sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast ls) + case sId of + [mdSubclassIdP|DISubprogram|] -> A.DISubprogram <$> decodeM (castPtr ls :: Ptr FFI.DISubprogram) + [mdSubclassIdP|DILexicalBlock|] -> A.DILexicalBlockBase <$> decodeM (castPtr ls :: Ptr FFI.DILexicalBlockBase) + [mdSubclassIdP|DILexicalBlockFile|] -> A.DILexicalBlockBase <$> decodeM (castPtr ls :: Ptr FFI.DILexicalBlockBase) + _ -> throwM (DecodeException ("Unknown subclass id for DILocalScope: " <> show sId)) + +instance EncodeM EncodeAST A.DILocalScope (Ptr FFI.DILocalScope) where + encodeM (A.DISubprogram sp) = do + ptr <- encodeM sp + pure (FFI.upCast (ptr :: Ptr FFI.DISubprogram)) + encodeM (A.DILexicalBlockBase b) = do + ptr <- encodeM b + pure (FFI.upCast (ptr :: Ptr FFI.DILexicalBlockBase)) + +instance DecodeM DecodeAST A.DILexicalBlockBase (Ptr FFI.DILexicalBlockBase) where + decodeM p = do + sId <- liftIO (FFI.getMetadataClassId (FFI.upCast p)) + case sId of + [mdSubclassIdP|DILexicalBlock|] -> do + scope <- decodeM =<< liftIO (FFI.getLexicalBlockScope p) + file <- decodeM =<< liftIO (FFI.getScopeFile (FFI.upCast p)) + line <- liftIO (FFI.getLexicalBlockLine p) + col <- liftIO (FFI.getLexicalBlockColumn p) + pure (A.DILexicalBlock scope file line col) + [mdSubclassIdP|DILexicalBlockFile|] -> do + scope <- decodeM =<< liftIO (FFI.getLexicalBlockScope p) + file <- decodeM =<< liftIO (FFI.getScopeFile (FFI.upCast p)) + disc <- liftIO (FFI.getLexicalBlockFileDiscriminator p) + pure (A.DILexicalBlockFile scope file disc) + _ -> throwM (DecodeException ("Unknown subclass id for DILexicalBlockBase: " <> show sId)) + +instance EncodeM EncodeAST A.DILexicalBlockBase (Ptr FFI.DILexicalBlockBase) where + encodeM A.DILexicalBlock {..} = do + scope <- encodeM scope + file <- encodeM file + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDILexicalBlock c scope file line column) + encodeM A.DILexicalBlockFile {..} = do + scope <- encodeM scope + file <- encodeM file + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDILexicalBlockFile c scope file discriminator) + +instance DecodeM DecodeAST A.CallableOperand (Ptr FFI.Value) where + decodeM v = do + ia <- liftIO $ FFI.isAInlineAsm v + if ia /= nullPtr + then Left <$> decodeM ia + else Right <$> decodeM v + +instance EncodeM EncodeAST A.Operand (Ptr FFI.Value) where + encodeM (A.ConstantOperand c) = do + c' <- (encodeM :: A.Constant -> EncodeAST (Ptr FFI.Constant)) c + let v = (FFI.upCast :: Ptr FFI.Constant -> Ptr FFI.Value) c' + return v + encodeM (A.LocalReference t n) = do + lv <- refer encodeStateLocals n $ do + lv <- do + n <- encodeM n + t <- encodeM t + v <- liftIO $ FFI.createArgument t n + return $ ForwardValue v + modify $ \s -> s { encodeStateLocals = Map.insert n lv $ encodeStateLocals s } + return lv + return $ case lv of DefinedValue v -> v; ForwardValue v -> v + encodeM (A.MetadataOperand md) = do + md' <- encodeM md + Context c <- gets encodeStateContext + liftIO $ FFI.upCast <$> FFI.metadataOperand c md' + +instance EncodeM EncodeAST A.Metadata (Ptr FFI.Metadata) where + encodeM (A.MDString s) = do + Context c <- gets encodeStateContext + s <- encodeM s + FFI.upCast <$> liftIO (FFI.getMDString c s) + encodeM (A.MDNode mdn) = (FFI.upCast :: Ptr FFI.MDNode -> Ptr FFI.Metadata) <$> encodeM mdn + encodeM (A.MDValue v) = do + v <- encodeM v + mdVal <- liftIO $ FFI.mdValue v + return $ FFI.upCast mdVal + +instance EncodeM EncodeAST A.CallableOperand (Ptr FFI.Value) where + encodeM (Right o) = encodeM o + encodeM (Left i) = (FFI.upCast :: Ptr FFI.InlineAsm -> Ptr FFI.Value) <$> encodeM i + +instance EncodeM EncodeAST A.MDNode (Ptr FFI.MDNode) where + encodeM (A.MDTuple ops) = scopeAnyCont $ do + Context c <- gets encodeStateContext + ops <- encodeM ops + FFI.upCast <$> liftIO (FFI.getMDTuple c ops) + encodeM (A.DINode n) = do + ptr <- encodeM n + pure (FFI.upCast (ptr :: Ptr FFI.DINode)) + encodeM (A.DILocation l) = FFI.upCast <$> (encodeM l :: EncodeAST (Ptr FFI.DILocation)) + encodeM (A.DIExpression e) = FFI.upCast <$> (encodeM e :: EncodeAST (Ptr FFI.DIExpression)) + encodeM (A.DIGlobalVariableExpression e) = + FFI.upCast <$> (encodeM e :: EncodeAST (Ptr FFI.DIGlobalVariableExpression)) + encodeM (A.DIMacroNode n) = FFI.upCast <$> (encodeM n :: EncodeAST (Ptr FFI.DIMacroNode)) + +instance EncodeM EncodeAST A.DILocation (Ptr FFI.DILocation) where + encodeM A.Location {..} = do + Context c <- gets encodeStateContext + scopePtr <- encodeM scope + liftIO (FFI.getDILocation c line column scopePtr) + +instance DecodeM DecodeAST A.DILocation (Ptr FFI.DILocation) where + decodeM p = do + line <- liftIO (FFI.getDILocationLine p) + col <- liftIO (FFI.getDILocationColumn p) + scope <- decodeM =<< liftIO (FFI.getDILocationScope p) + pure (A.Location line col scope) + +instance (MonadIO m, MonadState EncodeState m, MonadAnyCont IO m, EncodeM m a (Ptr a'), FFI.DescendentOf FFI.Metadata a') => EncodeM m [a] (FFI.TupleArray a') where + encodeM [] = pure (FFI.TupleArray nullPtr) + encodeM els = do + (numEls, elsPtr) <- encodeM els + Context c <- gets encodeStateContext + FFI.TupleArray <$> liftIO (FFI.getMDTuple c (numEls, castPtr (elsPtr :: Ptr (Ptr a')))) + +instance (MonadIO m, MonadAnyCont IO m, DecodeM m a (Ptr a')) => DecodeM m [a] (FFI.TupleArray a') where + decodeM (FFI.TupleArray p) + | p == nullPtr = pure [] + | otherwise = do + decodeArray FFI.getMDNodeNumOperands getOperand (FFI.upCast p) + where + getOperand md i = (castPtr <$> FFI.getMDNodeOperand md i) :: IO (Ptr a') + +encodeDWOp :: A.DWOp -> [Word64] +encodeDWOp op = + case op of + A.DW_OP_And -> [FFI.DwOp_and] + A.DW_OP_Bregx -> [FFI.DwOp_bregx] + A.DW_OP_ConstU arg -> [FFI.DwOp_constu, arg] + A.DW_OP_Deref -> [FFI.DwOp_deref] + A.DW_OP_Div -> [FFI.DwOp_div] + A.DW_OP_Dup -> [FFI.DwOp_dup] + A.DwOpFragment (A.DW_OP_LLVM_Fragment offset size) -> [FFI.DwOp_LLVM_fragment, offset, size] + A.DW_OP_Lit0 -> [FFI.DwOp_lit0] + A.DW_OP_Minus -> [FFI.DwOp_minus] + A.DW_OP_Mod -> [FFI.DwOp_mod] + A.DW_OP_Mul -> [FFI.DwOp_mul] + A.DW_OP_Not -> [FFI.DwOp_not] + A.DW_OP_Or -> [FFI.DwOp_or] + A.DW_OP_Plus -> [FFI.DwOp_plus] + A.DW_OP_PlusUConst arg -> [FFI.DwOp_plus_uconst, arg] + A.DW_OP_PushObjectAddress -> [FFI.DwOp_push_object_address] + A.DW_OP_Shl -> [FFI.DwOp_shl] + A.DW_OP_Shra -> [FFI.DwOp_shra] + A.DW_OP_Shr -> [FFI.DwOp_shr] + A.DW_OP_StackValue -> [FFI.DwOp_stack_value] + A.DW_OP_Swap -> [FFI.DwOp_swap] + A.DW_OP_XDeref -> [FFI.DwOp_xderef] + A.DW_OP_Xor -> [FFI.DwOp_xor] + +instance DecodeM DecodeAST [Maybe A.Metadata] (Ptr FFI.MDNode) where + decodeM p = decodeArray FFI.getMDNodeNumOperands FFI.getMDNodeOperand p + +instance DecodeM DecodeAST A.Operand (Ptr FFI.MDValue) where + decodeM = decodeM <=< liftIO . FFI.getMDValue + +instance DecodeM DecodeAST A.Metadata (Ptr FFI.MetadataAsVal) where + decodeM = decodeM <=< liftIO . FFI.getMetadataOperand + +decodeMDNode :: Ptr FFI.MDNode -> DecodeAST (Either String A.MDNode) +decodeMDNode p = scopeAnyCont $ do + sId <- liftIO $ FFI.getMetadataClassId p + case sId of + [mdSubclassIdP|MDTuple|] -> liftM Right $ A.MDTuple <$> decodeM p + [mdSubclassIdP|DIExpression|] -> + liftM Right $ A.DIExpression <$> decodeM (castPtr p :: Ptr FFI.DIExpression) + [mdSubclassIdP|DIGlobalVariableExpression|] -> + liftM Right $ A.DIGlobalVariableExpression <$> decodeM (castPtr p :: Ptr FFI.DIGlobalVariableExpression) + [mdSubclassIdP|DILocation|] -> liftM Right $ A.DILocation <$> decodeM (castPtr p :: Ptr FFI.DILocation) + [mdSubclassIdP|DIMacro|] -> liftM Right $ A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode) + [mdSubclassIdP|DIMacroFile|] -> liftM Right $ A.DIMacroNode <$> decodeM (castPtr p :: Ptr FFI.DIMacroNode) + _ -> do + decoded <- decodeM (castPtr p :: Ptr FFI.DINode) + case decoded of + (Right din) -> liftM Right $ pure $ A.DINode din + (Left err) -> pure $ Left err + +instance DecodeM DecodeAST A.DIMacroNode (Ptr FFI.DIMacroNode) where + decodeM p = do + sId <- liftIO $ FFI.getMetadataClassId (FFI.upCast p) + case sId of + [mdSubclassIdP|DIMacro|] -> do + let p' = castPtr p :: Ptr FFI.DIMacro + macInfo <- decodeM =<< liftIO (FFI.getDIMacroMacinfo p') + line <- liftIO (FFI.getDIMacroLine p') + name <- decodeM =<< liftIO (FFI.getDIMacroName p') + value <- decodeM =<< liftIO (FFI.getDIMacroValue p') + pure (A.DIMacro macInfo line name value) + [mdSubclassIdP|DIMacroFile|] -> do + let p' = castPtr p :: Ptr FFI.DIMacroFile + line <- liftIO (FFI.getDIMacroFileLine p') + file <- decodeM =<< liftIO (FFI.getDIMacroFileFile p') + elements <- decodeArray FFI.getDIMacroFileNumElements FFI.getDIMacroFileElement p' + pure (A.DIMacroFile line file elements) + _ -> throwM (DecodeException ("Unknown subclass id for DIMacroNode: " <> show sId)) + +instance EncodeM EncodeAST A.DIMacroNode (Ptr FFI.DIMacroNode) where + encodeM A.DIMacro {..} = do + macInfo <- encodeM info + name <- encodeM name + value <- encodeM value + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDIMacro c macInfo line name value) + encodeM A.DIMacroFile {..} = do + file <- encodeM file + elements <- encodeM elements + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDIMacroFile c line file elements) + +instance EncodeM EncodeAST A.DIExpression (Ptr FFI.DIExpression) where + encodeM A.Expression {..} = do + ops <- encodeM (concatMap encodeDWOp operands) + Context c <- gets encodeStateContext + FFI.upCast <$> liftIO (FFI.getDIExpression c ops) + +instance DecodeM DecodeAST A.DIExpression (Ptr FFI.DIExpression) where + decodeM diExpr = do + numElems <- liftIO (FFI.getDIExpressionNumElements diExpr) + let go i + | i >= numElems = pure [] + | otherwise = do + op <- FFI.getDIExpressionElement diExpr i + case op of + FFI.DwOp_LLVM_fragment -> do + expectElems "LLVM_fragment" i 2 + offset <- FFI.getDIExpressionElement diExpr (i + 1) + size <- FFI.getDIExpressionElement diExpr (i + 2) + (A.DwOpFragment (A.DW_OP_LLVM_Fragment offset size) :) <$> go (i + 3) + FFI.DwOp_stack_value -> (A.DW_OP_StackValue :) <$> go (i + 1) + FFI.DwOp_swap -> (A.DW_OP_Swap :) <$> go (i + 1) + FFI.DwOp_constu -> do + expectElems "constu" i 1 + arg <- FFI.getDIExpressionElement diExpr (i + 1) + (A.DW_OP_ConstU arg:) <$> go (i + 2) + FFI.DwOp_lit0 -> (A.DW_OP_Lit0 :) <$> go (i + 1) + FFI.DwOp_plus_uconst -> do + expectElems "uconst" i 1 + arg <- FFI.getDIExpressionElement diExpr (i + 1) + (A.DW_OP_PlusUConst arg:) <$> go (i + 2) + FFI.DwOp_plus -> (A.DW_OP_Plus :) <$> go (i + 1) + FFI.DwOp_minus -> (A.DW_OP_Minus :) <$> go (i + 1) + FFI.DwOp_mul -> (A.DW_OP_Mul :) <$> go (i + 1) + FFI.DwOp_div -> (A.DW_OP_Div :) <$> go (i + 1) + FFI.DwOp_mod -> (A.DW_OP_Mod :) <$> go (i + 1) + FFI.DwOp_not -> (A.DW_OP_Not :) <$> go (i + 1) + FFI.DwOp_or -> (A.DW_OP_Or :) <$> go (i + 1) + FFI.DwOp_xor -> (A.DW_OP_Xor :) <$> go (i + 1) + FFI.DwOp_and -> (A.DW_OP_And :) <$> go (i + 1) + FFI.DwOp_shr -> (A.DW_OP_Shr :) <$> go (i + 1) + FFI.DwOp_shra -> (A.DW_OP_Shra :) <$> go (i + 1) + FFI.DwOp_shl -> (A.DW_OP_Shl :) <$> go (i + 1) + FFI.DwOp_dup -> (A.DW_OP_Dup :) <$> go (i + 1) + FFI.DwOp_deref -> (A.DW_OP_Deref :) <$> go (i + 1) + FFI.DwOp_xderef -> (A.DW_OP_XDeref :) <$> go (i + 1) + FFI.DwOp_bregx -> (A.DW_OP_Bregx :) <$> go (i + 1) + FFI.DwOp_push_object_address -> (A.DW_OP_PushObjectAddress :) <$> go (i + 1) + _ -> throwM (DecodeException ("Unknown DW_OP " <> show op)) + expectElems name i n = + when (i + n >= numElems) + (throwM (DecodeException ("Expected " <> show n <> " elements following DW_OP_" <> + name <> " but got " <> show (numElems - i - 1)))) + liftIO (A.Expression <$> go 0) + +instance EncodeM EncodeAST A.DIGlobalVariableExpression (Ptr FFI.DIGlobalVariableExpression) where + encodeM A.GlobalVariableExpression {..} = do + var <- encodeM var + expr <- encodeM expr + Context c <- gets encodeStateContext + liftIO (FFI.getDIGlobalVariableExpression c var expr) + +instance DecodeM DecodeAST A.DIGlobalVariableExpression (Ptr FFI.DIGlobalVariableExpression) where + decodeM p = do + var <- decodeM =<< liftIO (FFI.getDIGlobalVariableExpressionVariable p) + expr <- decodeM =<< liftIO (FFI.getDIGlobalVariableExpressionExpression p) + pure (A.GlobalVariableExpression var expr) + +instance EncodeM EncodeAST A.DIImportedEntity (Ptr FFI.DIImportedEntity) where + encodeM A.ImportedEntity {..} = do + tag <- encodeM tag + scope <- encodeM scope + entity <- encodeM entity + file <- encodeM file + name <- encodeM name + Context c <- gets encodeStateContext + liftIO (FFI.getDIImportedEntity c tag scope entity file line name) + +instance DecodeM DecodeAST A.DIImportedEntity (Ptr FFI.DIImportedEntity) where + decodeM e = do + tag <- decodeM =<< liftIO (FFI.getTag (FFI.upCast e)) + scope <- decodeM =<< liftIO (FFI.getDIImportedEntityScope e) + entity :: Either String A.DINode <- decodeM =<< liftIO (FFI.getDIImportedEntityEntity e) + file <- decodeM =<< liftIO (FFI.getDIImportedEntityFile e) + name <- decodeM =<< liftIO (FFI.getDIImportedEntityName e) + line <- liftIO (FFI.getDIImportedEntityLine e) + case entity of + (Right din) -> pure (A.ImportedEntity tag name scope (Just $ A.MDInline din) file line) + (Left _) -> pure (A.ImportedEntity tag name scope Nothing file line) + +instance EncodeM EncodeAST A.DIObjCProperty (Ptr FFI.DIObjCProperty) where + encodeM A.ObjCProperty {..} = do + name <- encodeM name + file <- encodeM file + getterName <- encodeM getterName + setterName <- encodeM setterName + type' <- encodeM type' + Context c <- gets encodeStateContext + liftIO (FFI.getDIObjCProperty c name file line getterName setterName attributes type') + +instance DecodeM DecodeAST A.DIObjCProperty (Ptr FFI.DIObjCProperty) where + decodeM p = do + name <- decodeM =<< liftIO (FFI.getDIObjCPropertyName p) + file <- decodeM =<< liftIO (FFI.getDIObjCPropertyFile p) + line <- liftIO (FFI.getDIObjCPropertyLine p) + getterName <- decodeM =<< liftIO (FFI.getDIObjCPropertyGetterName p) + setterName <- decodeM =<< liftIO (FFI.getDIObjCPropertySetterName p) + attributes <- liftIO (FFI.getDIObjCPropertyAttributes p) + type' <- decodeM =<< liftIO (FFI.getDIObjCPropertyType p) + pure (A.ObjCProperty name file line getterName setterName attributes type') + +instance {-# OVERLAPS #-} DecodeM DecodeAST (A.MDRef A.MDNode) (Ptr FFI.MDNode) where + decodeM p = scopeAnyCont $ do + sId <- liftIO $ FFI.getMetadataClassId p + case sId of + [mdSubclassIdP|DIExpression|] -> A.MDInline . A.DIExpression <$> decodeM (castPtr p :: Ptr FFI.DIExpression) + _ -> A.MDRef <$> getMetadataNodeID p + +instance (DecodeM DecodeAST a (Ptr b), FFI.DescendentOf FFI.MDNode b) => DecodeM DecodeAST (A.MDRef a) (Ptr b) where + decodeM p = scopeAnyCont $ + A.MDRef <$> getMetadataNodeID (FFI.upCast p) + +instance (EncodeM EncodeAST a (Ptr b), FFI.DescendentOf FFI.MDNode b) => EncodeM EncodeAST (A.MDRef a) (Ptr b) where + encodeM (A.MDRef id) = castPtr <$> referMDNode id + encodeM (A.MDInline m) = encodeM m + +getMetadataDefinitions :: DecodeAST [A.Definition] +getMetadataDefinitions = fix $ \continue -> do + mdntd <- takeMetadataNodeToDefine + case mdntd of + Nothing -> pure [] + Just (mid, p) -> do + decoded <- decodeMDNode p + case decoded of + (Right mdn) -> + (:) + <$> (pure $ A.MetadataNodeDefinition mid mdn) + <*> continue + (Left _) -> continue diff --git a/src/LLVM/Internal/OrcJIT.hs b/src/LLVM/Internal/OrcJIT.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/OrcJIT.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +module LLVM.Internal.OrcJIT where + +import LLVM.Prelude + +import Control.Exception +import Control.Monad.AnyCont +import Control.Monad.IO.Class +import Data.Bits +import Data.IORef +import Foreign.C.Types +import Foreign.C.String +import Foreign.Ptr + +import LLVM.Internal.Coding +import LLVM.Internal.Module (Module, readModule) +import LLVM.Internal.Target (TargetMachine(..)) + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.ShortByteString as SBS +import qualified LLVM.Internal.FFI.DataLayout as FFI +import qualified LLVM.Internal.FFI.OrcJIT as FFI +import qualified LLVM.Internal.FFI.Target as FFI + +-------------------------------------------------------------------------------- +-- ExecutionSession +-------------------------------------------------------------------------------- + +data ExecutionSession = ExecutionSession { + sessionPtr :: !(Ptr FFI.ExecutionSession), + sessionCleanups :: !(IORef [IO ()]) + } + +-- | Create a new `ExecutionSession`. +createExecutionSession :: IO ExecutionSession +createExecutionSession = ExecutionSession <$> FFI.createExecutionSession <*> newIORef [] + +-- | Dispose of an `ExecutionSession`. This should be called when the +-- `ExecutionSession` is not needed anymore. +disposeExecutionSession :: ExecutionSession -> IO () +disposeExecutionSession (ExecutionSession es cleanups) = do + FFI.endSession es + sequence_ =<< readIORef cleanups + FFI.disposeExecutionSession es + +-- | `bracket`-style wrapper around `createExecutionSession` and +-- `disposeExecutionSession`. +withExecutionSession :: (ExecutionSession -> IO a) -> IO a +withExecutionSession = bracket createExecutionSession disposeExecutionSession + +-------------------------------------------------------------------------------- +-- JITSymbol +-------------------------------------------------------------------------------- + +-- | Contrary to the C++ interface, we do not store the HasError flag +-- here. Instead decoding a JITSymbol produces a sumtype based on +-- whether that flag is set or not. +data JITSymbolFlags = + JITSymbolFlags { + jitSymbolWeak :: !Bool -- ^ Is this a weak symbol? + , jitSymbolCommon :: !Bool -- ^ Is this a common symbol? + , jitSymbolAbsolute :: !Bool + -- ^ Is this an absolute symbol? This will cause LLVM to use + -- absolute relocations for the symbol even in position + -- independent code. + , jitSymbolExported :: !Bool -- ^ Is this symbol exported? + , jitSymbolCallable :: !Bool + , jitSymbolMaterializationSideEffectsOnly :: !Bool + } + deriving (Show, Eq, Ord) + +defaultJITSymbolFlags :: JITSymbolFlags +defaultJITSymbolFlags = JITSymbolFlags False False False False False False + +data JITSymbol = + JITSymbol { + jitSymbolAddress :: !WordPtr, -- ^ The address of the symbol. If + -- you’ve looked up a function, you + -- need to cast this to a 'FunPtr'. + jitSymbolFlags :: !JITSymbolFlags -- ^ The flags of this symbol. + } + deriving (Show, Eq, Ord) + +data JITSymbolError = JITSymbolError ShortByteString + deriving (Show, Eq) + +instance Monad m => EncodeM m JITSymbolFlags FFI.JITSymbolFlags where + encodeM f = return $ foldr1 (.|.) [ + if a f + then b + else 0 + | (a,b) <- [ + (jitSymbolWeak, FFI.jitSymbolFlagsWeak), + (jitSymbolCommon, FFI.jitSymbolFlagsCommon), + (jitSymbolAbsolute, FFI.jitSymbolFlagsAbsolute), + (jitSymbolExported, FFI.jitSymbolFlagsExported), + (jitSymbolCallable, FFI.jitSymbolFlagsCallable), + (jitSymbolMaterializationSideEffectsOnly, FFI.jitSymbolFlagsMaterializationSideEffectsOnly) + ] + ] + +instance Monad m => DecodeM m JITSymbolFlags FFI.JITSymbolFlags where + decodeM f = + return $ JITSymbolFlags { + jitSymbolWeak = FFI.jitSymbolFlagsWeak .&. f /= 0, + jitSymbolCommon = FFI.jitSymbolFlagsCommon .&. f /= 0, + jitSymbolAbsolute = FFI.jitSymbolFlagsAbsolute .&. f /= 0, + jitSymbolExported = FFI.jitSymbolFlagsExported .&. f /= 0, + jitSymbolCallable = FFI.jitSymbolFlagsCallable .&. f /= 0, + jitSymbolMaterializationSideEffectsOnly = FFI.jitSymbolFlagsMaterializationSideEffectsOnly .&. f /= 0 + } + +instance Monad m => EncodeM m MangledSymbol (Ptr FFI.SymbolStringPtr) where + encodeM (MangledSymbol p) = return p + +instance (Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m JITSymbol (Ptr FFI.JITEvaluatedSymbol) where + encodeM (JITSymbol addr flags) = do + flags' <- encodeM flags + anyContToM $ bracket + (FFI.createJITEvaluatedSymbol (FFI.TargetAddress $ fromIntegral addr) flags') + FFI.disposeJITEvaluatedSymbol + +instance (MonadIO m, MonadAnyCont IO m) => + DecodeM m (Either JITSymbolError JITSymbol) (Ptr FFI.ExpectedJITEvaluatedSymbol) where + decodeM expectedSym = do + errMsg <- alloca + FFI.TargetAddress addr <- liftIO $ FFI.getExpectedSymbolAddress expectedSym errMsg + rawFlags <- liftIO (FFI.getExpectedSymbolFlags expectedSym) + if addr == 0 || (rawFlags .&. FFI.jitSymbolFlagsHasError /= 0) + then do + errMsg <- decodeM errMsg + pure (Left (JITSymbolError errMsg)) + else do + flags <- decodeM rawFlags + pure (Right (JITSymbol (fromIntegral addr) flags)) + +-------------------------------------------------------------------------------- +-- JITDylib +-------------------------------------------------------------------------------- + +newtype JITDylib = JITDylib (Ptr FFI.JITDylib) + +-- | Create a new 'JITDylib' with the given name. +createJITDylib :: ExecutionSession -> ShortByteString -> IO JITDylib +createJITDylib (ExecutionSession es _) name = + SBS.useAsCString name $ fmap JITDylib . FFI.createJITDylib es + +-- NB: JITDylib unloading is WIP (at least according to some old-looking docs) + +-- | Adds a 'JITDylib' definition generator that looks up missing symbols in +-- the namespace of the current process. +addDynamicLibrarySearchGeneratorForCurrentProcess :: IRLayer l => l -> JITDylib -> IO () +addDynamicLibrarySearchGeneratorForCurrentProcess compileLayer (JITDylib dylib) = + FFI.addDynamicLibrarySearchGeneratorForCurrentProcess dylib (getDataLayout compileLayer) + +-- | Adds a 'JITDylib' definition generator that looks up missing symbols in +-- the namespace of a shared library located at the specified 'FilePath'. +addDynamicLibrarySearchGenerator :: IRLayer l => l -> JITDylib -> FilePath -> IO () +addDynamicLibrarySearchGenerator compileLayer (JITDylib dylib) s = withCString s $ \cStr -> + FFI.addDynamicLibrarySearchGenerator dylib (getDataLayout compileLayer) cStr + +defineAbsoluteSymbols :: JITDylib -> [(MangledSymbol, JITSymbol)] -> IO () +defineAbsoluteSymbols (JITDylib dylib) symList = + runAnyContT' return $ do + (nsyms, symStrPtrPtr) :: (CUInt, Ptr (Ptr FFI.SymbolStringPtr)) <- encodeM symNames + (_, symValPtrPtr) :: (CUInt, Ptr (Ptr FFI.JITEvaluatedSymbol)) <- encodeM symVals + liftIO $ FFI.defineAbsoluteSymbols dylib nsyms symStrPtrPtr symValPtrPtr + where (symNames, symVals) = unzip symList + +-- | Looks up an (unmangled) symbol name in the given 'JITDylib'. +-- +-- The symbol is expected to have been added to the 'JITDylib' by the same 'IRLayer' +-- as specified in this function. Using a different 'IRLayer' can cause the lookup +-- to fail due to differences in mangling schemes. +lookupSymbol :: IRLayer l => ExecutionSession -> l -> JITDylib -> ShortByteString -> IO (Either JITSymbolError JITSymbol) +lookupSymbol (ExecutionSession es _) irl (JITDylib dylib) name = SBS.useAsCString name $ \nameStr -> + runAnyContT' return $ do + symbol <- anyContToM $ bracket + (FFI.lookupSymbol es dylib (getMangler irl) nameStr) FFI.disposeExpectedJITEvaluatedSymbol + decodeM symbol + +-------------------------------------------------------------------------------- +-- ThreadSafeContext +-------------------------------------------------------------------------------- + +newtype ThreadSafeContext = ThreadSafeContext (Ptr FFI.ThreadSafeContext) + +-- | Create a 'ThreadSafeContext' +createThreadSafeContext :: IO ThreadSafeContext +createThreadSafeContext = ThreadSafeContext <$> FFI.createThreadSafeContext + +-- | Dispose of a 'ThreadSafeContext' +disposeThreadSafeContext :: ThreadSafeContext -> IO () +disposeThreadSafeContext (ThreadSafeContext ctx) = FFI.disposeThreadSafeContext ctx + +-- | 'bracket'-style wrapper around 'createThreadSafeContext' +-- and 'disposeThreadSafeContext'. +withThreadSafeContext :: (ThreadSafeContext -> IO a) -> IO a +withThreadSafeContext = bracket createThreadSafeContext disposeThreadSafeContext + +-------------------------------------------------------------------------------- +-- ThreadSafeModule +-------------------------------------------------------------------------------- + +newtype ThreadSafeModule = ThreadSafeModule (Ptr FFI.ThreadSafeModule) + +-- | Create a 'ThreadSafeModule' with the same content as the input 'Module'. +-- +-- The module will get cloned into a fresh LLVM context. The lifetime of the +-- new context is bound to the lifetime of the returned 'ThreadSafeModule'. +cloneAsThreadSafeModule :: Module -> IO ThreadSafeModule +cloneAsThreadSafeModule m = do + mPtr <- readModule m + ThreadSafeModule <$> FFI.cloneAsThreadSafeModule mPtr + +-- | Dispose of a 'ThreadSafeModule'. +disposeThreadSafeModule :: ThreadSafeModule -> IO () +disposeThreadSafeModule (ThreadSafeModule m) = FFI.disposeThreadSafeModule m + +-- | 'bracket'-style wrapper around 'cloneAsThreadSafeModule' +-- and 'disposeThreadSafeModule'. +withClonedThreadSafeModule :: Module -> (ThreadSafeModule -> IO a) -> IO a +withClonedThreadSafeModule m = bracket (cloneAsThreadSafeModule m) disposeThreadSafeModule + +-------------------------------------------------------------------------------- +-- ObjectLayer + RTDyldObjectLinkingLayer +-------------------------------------------------------------------------------- + +-- | A type class implemented by the different OrcJIT object layers. +-- +-- See e.g. 'RTDyldObjectLinkingLayer'. +class ObjectLayer l where + getObjectLayer :: l -> Ptr FFI.ObjectLayer + + +data RTDyldObjectLinkingLayer = RTDyldObjectLinkingLayer !(Ptr FFI.ObjectLayer) + +instance ObjectLayer RTDyldObjectLinkingLayer where + getObjectLayer (RTDyldObjectLinkingLayer ol) = ol + +-- | Create a new 'RTDyldObjectLinkingLayer'. +-- +-- The layer will get automatically disposed along with its ExecutionSession. +createRTDyldObjectLinkingLayer :: ExecutionSession -> IO RTDyldObjectLinkingLayer +createRTDyldObjectLinkingLayer (ExecutionSession es cleanups) = do + ol <- FFI.createRTDyldObjectLinkingLayer es + modifyIORef' cleanups (FFI.disposeObjectLayer ol :) + return $ RTDyldObjectLinkingLayer ol + +data ObjectLinkingLayer = ObjectLinkingLayer !(Ptr FFI.ObjectLayer) + +instance ObjectLayer ObjectLinkingLayer where + getObjectLayer (ObjectLinkingLayer ol) = ol + +createObjectLinkingLayer :: ExecutionSession -> IO ObjectLinkingLayer +createObjectLinkingLayer (ExecutionSession es cleanups) = do + ol <- FFI.createObjectLinkingLayer es + modifyIORef' cleanups (FFI.disposeObjectLayer ol :) + return $ ObjectLinkingLayer ol + +addObjectFile :: ObjectLayer l => l -> JITDylib -> FilePath -> IO () +addObjectFile ol (JITDylib dylib) path = do + withCString path $ \cStr -> + FFI.objectLayerAddObjectFile (getObjectLayer ol) dylib cStr + +-------------------------------------------------------------------------------- +-- IRLayer + IRCompileLayer +-------------------------------------------------------------------------------- + +-- | A mangled symbol name. Valid only for as long as the IRLayer that created it. +newtype MangledSymbol = MangledSymbol (Ptr FFI.SymbolStringPtr) + +-- | A type class implemented by the different OrcJIT IR layers. +-- +-- See e.g. 'IRCompileLayer'. +class IRLayer l where + getIRLayer :: l -> Ptr FFI.IRLayer + getDataLayout :: l -> Ptr FFI.DataLayout + getMangler :: l -> Ptr FFI.MangleAndInterner + +-- | Add a 'Module' to the specified 'JITDylib'. +-- +-- The specified 'IRLayer' will be responsible for compiling the symbols +-- present in the module. The module itself is consumed and __should not be used again__. +addModule :: IRLayer l => ThreadSafeModule -> JITDylib -> l -> IO () +addModule (ThreadSafeModule m) (JITDylib dylib) irl = + FFI.irLayerAddModule m dylib (getDataLayout irl) (getIRLayer irl) + +mangleSymbol :: IRLayer l => l -> ShortByteString -> IO MangledSymbol +mangleSymbol irl name = SBS.useAsCString name $ \namePtr -> + MangledSymbol <$> FFI.mangleSymbol (getMangler irl) namePtr + +disposeMangledSymbol :: MangledSymbol -> IO () +disposeMangledSymbol (MangledSymbol symbol) = FFI.disposeMangledSymbol symbol + +withMangledSymbol :: IRLayer l => l -> ShortByteString -> (MangledSymbol -> IO a) -> IO a +withMangledSymbol irl name = bracket (mangleSymbol irl name) disposeMangledSymbol + +-- | An IR layer that compiles the symbols in a module eagerly. +data IRCompileLayer = IRCompileLayer !(Ptr FFI.IRLayer) !(Ptr FFI.DataLayout) !(Ptr FFI.MangleAndInterner) + +instance IRLayer IRCompileLayer where + getIRLayer (IRCompileLayer cl _ _) = cl + getDataLayout (IRCompileLayer _ dl _) = dl + getMangler (IRCompileLayer _ _ mg) = mg + +-- | Create a new 'IRCompileLayer'. +-- +-- The layer will get automatically disposed along with its ExecutionSession. +createIRCompileLayer :: ObjectLayer l => ExecutionSession -> l -> TargetMachine -> IO IRCompileLayer +createIRCompileLayer (ExecutionSession es cleanups) ol (TargetMachine tm) = do + dl <- FFI.createTargetDataLayout tm + modifyIORef' cleanups (FFI.disposeDataLayout dl :) + mg <- FFI.createMangleAndInterner es dl + modifyIORef' cleanups (FFI.disposeMangleAndInterner mg :) + cl <- FFI.createIRCompileLayer es (getObjectLayer ol) tm + modifyIORef' cleanups (FFI.disposeIRLayer cl :) + return $ IRCompileLayer cl dl mg diff --git a/src/LLVM/Internal/PassManager.hs b/src/LLVM/Internal/PassManager.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/PassManager.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses, + CPP + #-} +module LLVM.Internal.PassManager where + +import LLVM.Prelude + +import qualified Language.Haskell.TH as TH + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.IO.Class + +import qualified Data.ByteString.Short as ByteString + +import Foreign.C (CString) +import Foreign.Ptr +import GHC.Stack + +import qualified LLVM.Internal.FFI.PassManager as FFI +import qualified LLVM.Internal.FFI.Transforms as FFI + +import LLVM.Exception +import LLVM.Internal.Module +import LLVM.Internal.Target +import LLVM.Internal.Coding +import LLVM.Transforms + +import LLVM.AST.DataLayout + +-- | +-- Note: a PassManager does substantive behind-the-scenes work, arranging for the +-- results of various analyses to be available as needed by transform passes, shared +-- as possible. +newtype PassManager = PassManager (Ptr FFI.PassManager) + +-- | There are different ways to get a 'PassManager'. This type embodies them. +data PassSetSpec + -- | a 'PassSetSpec' is a lower-level, detailed specification of a set of passes. It + -- allows fine-grained control of what passes are to be run when, and the specification + -- of passes not available through 'CuratedPassSetSpec'. + = PassSetSpec { + transforms :: [Pass], + dataLayout :: Maybe DataLayout, + targetLibraryInfo :: Maybe TargetLibraryInfo, + targetMachine :: Maybe TargetMachine + } + -- | This type is a high-level specification of a set of passes. It uses the same + -- collection of passes chosen by the LLVM team in the command line tool 'opt'. The fields + -- of this spec are much like typical compiler command-line flags - e.g. -O\, etc. + | CuratedPassSetSpec { + optLevel :: Maybe Word, + sizeLevel :: Maybe Word, + unitAtATime :: Maybe Bool, + simplifyLibCalls :: Maybe Bool, + loopVectorize :: Maybe Bool, + superwordLevelParallelismVectorize :: Maybe Bool, + useInlinerWithThreshold :: Maybe Word, + dataLayout :: Maybe DataLayout, + targetLibraryInfo :: Maybe TargetLibraryInfo, + targetMachine :: Maybe TargetMachine + } + +-- | Helper to make a curated 'PassSetSpec' +defaultCuratedPassSetSpec :: PassSetSpec +defaultCuratedPassSetSpec = CuratedPassSetSpec { + optLevel = Nothing, + sizeLevel = Nothing, + unitAtATime = Nothing, + simplifyLibCalls = Nothing, + loopVectorize = Nothing, + superwordLevelParallelismVectorize = Nothing, + useInlinerWithThreshold = Nothing, + dataLayout = Nothing, + targetLibraryInfo = Nothing, + targetMachine = Nothing +} + +-- | an empty 'PassSetSpec' +defaultPassSetSpec :: PassSetSpec +defaultPassSetSpec = PassSetSpec { + transforms = [], + dataLayout = Nothing, + targetLibraryInfo = Nothing, + targetMachine = Nothing +} + +instance (Monad m, MonadThrow m, MonadAnyCont IO m) => EncodeM m GCOVVersion CString where + encodeM (GCOVVersion cs) + | ByteString.length cs == 4 = encodeM cs + | otherwise = throwM (EncodeException "GCOVVersion should consist of exactly 4 characters") + +createPassManager :: HasCallStack => PassSetSpec -> IO (Ptr FFI.PassManager) +createPassManager pss = runAnyContT' return $ do + pm <- liftIO $ FFI.createPassManager + forM_ (targetLibraryInfo pss) $ \(TargetLibraryInfo tli) -> do + liftIO $ FFI.addTargetLibraryInfoPass pm tli + forM_ (targetMachine pss) $ \(TargetMachine tm) -> liftIO $ FFI.addAnalysisPasses tm pm + case pss of + s@CuratedPassSetSpec {} -> liftIO $ do + bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do + let handleOption g m = forM_ (m s) (g b <=< encodeM) + handleOption FFI.passManagerBuilderSetOptLevel optLevel + handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel + handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime) + handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls) + handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold + handleOption FFI.passManagerBuilderSetLoopVectorize loopVectorize + handleOption FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize superwordLevelParallelismVectorize + FFI.passManagerBuilderPopulateModulePassManager b pm + PassSetSpec ps _ _ tm' -> do + let tm = maybe nullPtr (\(TargetMachine tm) -> tm) tm' + forM_ ps $ \p -> $( + do +#if __GLASGOW_HASKELL__ < 800 + TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass +#else + TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''Pass +#endif + TH.caseE [| p |] $ flip map cons $ \con -> do + let + (n, fns) = case con of + TH.RecC n fs -> (n, [ TH.nameBase fn | (fn, _, _) <- fs ]) + TH.NormalC n [] -> (n, []) + _ -> error "pass descriptor constructors with fields need to be records" + actions = + [ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn fn) |] | fn <- fns ] + ++ [ + TH.noBindS [| + liftIO $( + foldl1 TH.appE + (map TH.dyn $ + ["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"] + ++ ["tm" | FFI.needsTargetMachine (TH.nameBase n)] + ++ fns) + ) + |] + ] + TH.match (TH.conP n $ map (TH.varP . TH.mkName) fns) (TH.normalB (TH.doE actions)) [] + ) + return pm + +-- | bracket the creation of a 'PassManager' +withPassManager :: PassSetSpec -> (PassManager -> IO a) -> IO a +withPassManager s = bracket (createPassManager s) FFI.disposePassManager . (. PassManager) + +-- | run the passes in a 'PassManager' on a 'Module', modifying the 'Module'. +runPassManager :: PassManager -> Module -> IO Bool +runPassManager (PassManager p) m = do + m' <- readModule m + toEnum . fromIntegral <$> FFI.runPassManager p m' diff --git a/src/LLVM/Internal/RMWOperation.hs b/src/LLVM/Internal/RMWOperation.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/RMWOperation.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses + #-} +module LLVM.Internal.RMWOperation where + +import LLVM.AST.RMWOperation + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Coding + +genCodingInstance [t| RMWOperation |] ''FFI.RMWOperation [ + (FFI.rmwOperationXchg, Xchg), + (FFI.rmwOperationAdd, Add), + (FFI.rmwOperationSub, Sub), + (FFI.rmwOperationAnd, And), + (FFI.rmwOperationNand, Nand), + (FFI.rmwOperationOr, Or), + (FFI.rmwOperationXor, Xor), + (FFI.rmwOperationMax, Max), + (FFI.rmwOperationMin, Min), + (FFI.rmwOperationUMax, UMax), + (FFI.rmwOperationUMin, UMin), + (FFI.rmwOperationFAdd, FAdd), + (FFI.rmwOperationFSub, FSub) + ] + diff --git a/src/LLVM/Internal/RawOStream.hs b/src/LLVM/Internal/RawOStream.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/RawOStream.hs @@ -0,0 +1,67 @@ +module LLVM.Internal.RawOStream where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.IO.Class + +import Data.IORef +import Foreign.C +import Foreign.Ptr + +import LLVM.Exception + +import qualified LLVM.Internal.FFI.RawOStream as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI + +import LLVM.Internal.Coding +import LLVM.Internal.String () + +-- May throw 'FdStreamException'. +withFileRawOStream :: + (MonadThrow m, MonadIO m, MonadAnyCont IO m) + => String + -> Bool + -> Bool + -> (Ptr FFI.RawOStream -> IO ()) + -> m () +withFileRawOStream path excl text c = + withFileRawPWriteStream path excl text (c . FFI.upCast) + +-- May throw 'FdStreamException'. +withFileRawPWriteStream :: + (MonadThrow m, MonadIO m, MonadAnyCont IO m) + => String + -> Bool + -> Bool + -> (Ptr FFI.RawPWriteStream -> IO ()) + -> m () +withFileRawPWriteStream path excl text c = do + path <- encodeM path + excl <- encodeM excl + text <- encodeM text + msgPtr <- alloca + succeeded <- decodeM =<< (liftIO $ FFI.withFileRawPWriteStream path excl text msgPtr c) + unless succeeded $ do + s <- decodeM msgPtr + throwM $ FdStreamException s + +withBufferRawOStream :: + (MonadIO m, DecodeM IO a (Ptr CChar, CSize)) + => (Ptr FFI.RawOStream -> IO ()) + -> m a +withBufferRawOStream c = withBufferRawPWriteStream (c . FFI.upCast) + +withBufferRawPWriteStream :: + (MonadIO m, DecodeM IO a (Ptr CChar, CSize)) + => (Ptr FFI.RawPWriteStream -> IO ()) + -> m a +withBufferRawPWriteStream c = liftIO $ do + resultRef <- newIORef undefined + let saveBuffer :: Ptr CChar -> CSize -> IO () + saveBuffer start size = do + r <- decodeM (start, size) + writeIORef resultRef r + FFI.withBufferRawPWriteStream saveBuffer c + readIORef resultRef diff --git a/src/LLVM/Internal/String.hs b/src/LLVM/Internal/String.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/String.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE + MultiParamTypeClasses, + UndecidableInstances + #-} +module LLVM.Internal.String where + +import LLVM.Prelude + +import Control.Arrow +import Control.Monad.AnyCont +import Control.Monad.IO.Class +import Control.Exception (finally) +import Foreign.C (CString, CChar) +import Foreign.Ptr +import Foreign.Storable (Storable) +import Foreign.Marshal.Alloc as F.M (alloca, free) + +import LLVM.Internal.FFI.LLVMCTypes + +import LLVM.Internal.Coding + +import qualified Data.ByteString as BS +import qualified LLVM.Internal.FFI.ShortByteString as SBS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.UTF8 as BSUTF8 + +newtype UTF8ByteString = UTF8ByteString { utf8Bytes :: BS.ByteString } + +instance (Monad e) => EncodeM e String UTF8ByteString where + encodeM = return . UTF8ByteString . BSUTF8.fromString + +instance (Monad d) => DecodeM d String UTF8ByteString where + decodeM = return . BSUTF8.toString . utf8Bytes + +instance (MonadAnyCont IO e) => EncodeM e String CString where + encodeM s = anyContToM (BS.unsafeUseAsCString . utf8Bytes =<< encodeM (s ++ "\0")) + +instance (MonadAnyCont IO e) => EncodeM e ByteString CString where + encodeM s = anyContToM (BS.useAsCString s) + +instance (MonadAnyCont IO e) => EncodeM e ShortByteString CString where + encodeM s = anyContToM (SBS.useAsCString s) + +instance (Integral i, MonadAnyCont IO e) => EncodeM e String (Ptr CChar, i) where + encodeM s = anyContToM ((. (. second fromIntegral)) $ BS.useAsCStringLen . utf8Bytes =<< encodeM s) + +instance (Integral i, MonadAnyCont IO e) => EncodeM e ByteString (Ptr CChar, i) where + encodeM s = + anyContToM (\cont -> BS.useAsCStringLen s (\(ptr, len) -> cont (ptr, fromIntegral len))) + +instance (Integral i, MonadAnyCont IO e) => EncodeM e ShortByteString (Ptr CChar, i) where + encodeM s = + anyContToM (\cont -> SBS.useAsCStringLen s (\(ptr, len) -> cont (ptr, fromIntegral len))) + +instance (MonadIO d) => DecodeM d String CString where + decodeM = decodeM . UTF8ByteString <=< liftIO . BS.packCString + +instance (MonadIO d) => DecodeM d ByteString CString where + decodeM = liftIO . BS.packCString + +instance (MonadIO d) => DecodeM d ShortByteString CString where + decodeM = liftIO . SBS.packCString + +instance (MonadIO d) => DecodeM d String (OwnerTransfered CString) where + decodeM (OwnerTransfered s) = liftIO $ finally (decodeM s) (free s) + +instance (MonadIO d) => DecodeM d ByteString (OwnerTransfered CString) where + decodeM (OwnerTransfered s) = liftIO $ finally (decodeM s) (free s) + +instance (MonadIO d) => DecodeM d ShortByteString (OwnerTransfered CString) where + decodeM (OwnerTransfered s) = liftIO $ finally (decodeM s) (free s) +instance (MonadIO d, DecodeM IO s (OwnerTransfered CString)) =>DecodeM d s (Ptr (OwnerTransfered CString)) where + decodeM = liftIO . decodeM <=< peek + +instance (Integral i, MonadIO d) => DecodeM d String (Ptr CChar, i) where + decodeM = decodeM . UTF8ByteString <=< liftIO . BS.packCStringLen . second fromIntegral + +instance (Integral i, MonadIO d) => DecodeM d BS.ByteString (Ptr CChar, i) where + decodeM = liftIO . BS.packCStringLen . second fromIntegral + +instance (Integral i, MonadIO d) => DecodeM d ShortByteString (Ptr CChar, i) where + decodeM = liftIO . SBS.packCStringLen . second fromIntegral + +instance (Integral i, Storable i, MonadIO d, DecodeM d s (CString, i)) => DecodeM d s (Ptr i -> IO CString) where + decodeM f = decodeM =<< (liftIO $ F.M.alloca $ \p -> (,) `liftM` f p `ap` peek p) + +instance (Monad e, EncodeM e String c) => EncodeM e (Maybe String) (NothingAsEmptyString c) where + encodeM = liftM NothingAsEmptyString . encodeM . fromMaybe "" + diff --git a/src/LLVM/Internal/TailCallKind.hs b/src/LLVM/Internal/TailCallKind.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/TailCallKind.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE + TemplateHaskell, + MultiParamTypeClasses + #-} +module LLVM.Internal.TailCallKind where + +import LLVM.Prelude + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +import LLVM.Internal.Coding +import qualified LLVM.AST as A + +genCodingInstance [t| Maybe A.TailCallKind |] ''FFI.TailCallKind [ + (FFI.tailCallKindNone, Nothing), + (FFI.tailCallKindTail, Just A.Tail), + (FFI.tailCallKindMustTail, Just A.MustTail), + (FFI.tailCallKindNoTail, Just A.NoTail) + ] diff --git a/src/LLVM/Internal/Target.hs b/src/LLVM/Internal/Target.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Target.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module LLVM.Internal.Target where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.Monad.Trans.Except + +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 +import Data.Char +import Data.Map (Map) +import Foreign.C.String +import Foreign.Ptr +import qualified Data.ByteString as ByteString +import qualified Data.Map as Map +#if __GLASGOW_HASKELL__ < 808 +import Control.Monad.Fail (MonadFail) +#endif + +import LLVM.Internal.Coding +import LLVM.Internal.String () +import LLVM.Internal.LibraryFunction +import LLVM.DataLayout +import LLVM.Exception + +import LLVM.AST.DataLayout + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import qualified LLVM.Internal.FFI.Target as FFI + +import qualified LLVM.Relocation as Reloc +import qualified LLVM.Target.Options as TO +import qualified LLVM.CodeModel as CodeModel +import qualified LLVM.CodeGenOpt as CodeGenOpt + +genCodingInstance [t| Reloc.Model |] ''FFI.RelocModel [ + (FFI.relocModelDefault, Reloc.Default), + (FFI.relocModelStatic, Reloc.Static), + (FFI.relocModelPIC, Reloc.PIC), + (FFI.relocModelDynamicNoPic, Reloc.DynamicNoPIC) + ] + +genCodingInstance [t| CodeModel.Model |] ''FFI.CodeModel [ + (FFI.codeModelDefault,CodeModel.Default), + (FFI.codeModelJITDefault, CodeModel.JITDefault), + (FFI.codeModelSmall, CodeModel.Small), + (FFI.codeModelKernel, CodeModel.Kernel), + (FFI.codeModelMedium, CodeModel.Medium), + (FFI.codeModelLarge, CodeModel.Large) + ] + +genCodingInstance [t| CodeGenOpt.Level |] ''FFI.CodeGenOptLevel [ + (FFI.codeGenOptLevelNone, CodeGenOpt.None), + (FFI.codeGenOptLevelLess, CodeGenOpt.Less), + (FFI.codeGenOptLevelDefault, CodeGenOpt.Default), + (FFI.codeGenOptLevelAggressive, CodeGenOpt.Aggressive) + ] + +genCodingInstance [t| TO.FloatABI |] ''FFI.FloatABIType [ + (FFI.floatABIDefault, TO.FloatABIDefault), + (FFI.floatABISoft, TO.FloatABISoft), + (FFI.floatABIHard, TO.FloatABIHard) + ] + +genCodingInstance [t| TO.FloatingPointOperationFusionMode |] ''FFI.FPOpFusionMode [ + (FFI.fpOpFusionModeFast, TO.FloatingPointOperationFusionFast), + (FFI.fpOpFusionModeStandard, TO.FloatingPointOperationFusionStandard), + (FFI.fpOpFusionModeStrict, TO.FloatingPointOperationFusionStrict) + ] + +genCodingInstance[t| TO.DebugCompressionType |] ''FFI.DebugCompressionType [ + (FFI.debugCompressionTypeNone, TO.CompressNone), + (FFI.debugCompressionTypeGNU, TO.CompressGNU), + (FFI.debugCompressionTypeZ, TO.CompressZ) + ] + +genCodingInstance[t| TO.ThreadModel |] ''FFI.ThreadModel [ + (FFI.threadModelPOSIX, TO.ThreadModelPOSIX), + (FFI.threadModelSingle, TO.ThreadModelSingle) + ] + +genCodingInstance[t| TO.EABIVersion |] ''FFI.EABI [ + (FFI.eabiVersionUnknown, TO.EABIVersionUnknown), + (FFI.eabiVersionDefault, TO.EABIVersionDefault), + (FFI.eabiVersionEABI4, TO.EABIVersion4), + (FFI.eabiVersionEABI5, TO.EABIVersion5), + (FFI.eabiVersionGNU, TO.EABIVersionGNU) + ] + +genCodingInstance[t| TO.DebuggerKind |] ''FFI.DebuggerKind [ + (FFI.debuggerKindDefault, TO.DebuggerDefault), + (FFI.debuggerKindGDB, TO.DebuggerGDB), + (FFI.debuggerKindLLDB, TO.DebuggerLLDB), + (FFI.debuggerKindSCE, TO.DebuggerSCE) + ] + +genCodingInstance[t| TO.FloatingPointDenormalMode |] ''FFI.FPDenormalMode [ + (FFI.fpDenormalModeIEEE, TO.FloatingPointDenormalIEEE), + (FFI.fpDenormalModePreserveSign, TO.FloatingPointDenormalPreserveSign), + (FFI.fpDenormalModePositiveZero, TO.FloatingPointDenormalPositiveZero) + ] + +genCodingInstance[t| TO.ExceptionHandling |] ''FFI.ExceptionHandling [ + (FFI.exceptionHandlingNone, TO.ExceptionHandlingNone), + (FFI.exceptionHandlingDwarfCFI, TO.ExceptionHandlingDwarfCFI), + (FFI.exceptionHandlingSjLj, TO.ExceptionHandlingSjLj), + (FFI.exceptionHandlingARM, TO.ExceptionHandlingARM), + (FFI.exceptionHandlingWinEH, TO.ExceptionHandlingWinEH) + ] + +-- | +newtype Target = Target (Ptr FFI.Target) + +-- | e.g. an instruction set extension +newtype CPUFeature = CPUFeature ByteString + deriving (Eq, Ord, Read, Show) + +instance EncodeM e ByteString es => EncodeM e (Map CPUFeature Bool) es where + encodeM = encodeM . ByteString.intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") <> f) . Map.toList + +instance (MonadFail d, DecodeM d ByteString es) => DecodeM d (Map CPUFeature Bool) es where + decodeM es = do + s <- decodeM es + let flag = do + en <- choice [char8 '-' >> return False, char8 '+' >> return True] + s <- ByteString.pack <$> many1 (notWord8 (fromIntegral (ord ','))) + return (CPUFeature s, en) + features = liftM Map.fromList (flag `sepBy` (char8 ',')) + case parseOnly (features <* endOfInput) s of + Right features -> return features + Left err -> fail ("failure to parse CPUFeature string: " <> err) + +-- | Find a 'Target' given an architecture and/or a \"triple\". +-- | +-- | Be sure to run either 'initializeAllTargets' or +-- 'initializeNativeTarget' before expecting this to succeed, +-- depending on what target(s) you want to use. May throw +-- 'LookupTargetException' if no target is found. +lookupTarget :: + Maybe ShortByteString -- ^ arch + -> ShortByteString -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu + -> IO (Target, ShortByteString) +lookupTarget arch triple = runAnyContT' return $ do + cErrorP <- alloca + cNewTripleP <- alloca + arch <- encodeM (maybe "" id arch) + triple <- encodeM triple + target <- liftIO $ FFI.lookupTarget arch triple cNewTripleP cErrorP + when (target == nullPtr) $ throwM . LookupTargetException =<< decodeM cErrorP + liftM (Target target, ) $ decodeM cNewTripleP + +-- | +newtype TargetOptions = TargetOptions (Ptr FFI.TargetOptions) + +newtype MCTargetOptions = MCTargetOptions (Ptr FFI.MCTargetOptions) + +-- | bracket creation and destruction of a 'TargetOptions' object +withTargetOptions :: (TargetOptions -> IO a) -> IO a +withTargetOptions = bracket FFI.createTargetOptions FFI.disposeTargetOptions . (. TargetOptions) + +-- | set all target options +pokeTargetOptions :: TO.Options -> TargetOptions -> IO () +pokeTargetOptions hOpts opts@(TargetOptions cOpts) = do + mapM_ (\(c, ha) -> FFI.setTargetOptionFlag cOpts c =<< encodeM (ha hOpts)) [ + (FFI.targetOptionFlagUnsafeFPMath, TO.unsafeFloatingPointMath), + (FFI.targetOptionFlagNoInfsFPMath, TO.noInfinitiesFloatingPointMath), + (FFI.targetOptionFlagNoNaNsFPMath, TO.noNaNsFloatingPointMath), + (FFI.targetOptionFlagNoTrappingFPMath, TO.noTrappingFloatingPointMath), + (FFI.targetOptionFlagNoSignedZerosFPMath, TO.noSignedZeroesFloatingPointMath), + (FFI.targetOptionFlagHonorSignDependentRoundingFPMathOption, TO.honorSignDependentRoundingFloatingPointMathOption), + (FFI.targetOptionFlagNoZerosInBSS, TO.noZerosInBSS), + (FFI.targetOptionFlagGuaranteedTailCallOpt, TO.guaranteedTailCallOptimization), + (FFI.targetOptionFlagStackSymbolOrdering, TO.stackSymbolOrdering), + (FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection), + (FFI.targetOptionFlagUseInitArray, TO.useInitArray), + (FFI.targetOptionFlagDisableIntegratedAS, TO.disableIntegratedAssembler), + (FFI.targetOptionFlagRelaxELFRelocations, TO.relaxELFRelocations), + (FFI.targetOptionFlagFunctionSections, TO.functionSections), + (FFI.targetOptionFlagDataSections, TO.dataSections), + (FFI.targetOptionFlagUniqueSectionNames, TO.uniqueSectionNames), + (FFI.targetOptionFlagTrapUnreachable, TO.trapUnreachable), + (FFI.targetOptionFlagEmulatedTLS, TO.emulatedThreadLocalStorage), + (FFI.targetOptionFlagEnableIPRA, TO.enableInterProceduralRegisterAllocation) + ] + FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts) + FFI.setFloatABIType cOpts =<< encodeM (TO.floatABIType hOpts) + FFI.setAllowFPOpFusion cOpts =<< encodeM (TO.allowFloatingPointOperationFusion hOpts) + FFI.setCompressDebugSections cOpts =<< encodeM (TO.compressDebugSections hOpts) + FFI.setThreadModel cOpts =<< encodeM (TO.threadModel hOpts) + FFI.setEABIVersion cOpts =<< encodeM (TO.eabiVersion hOpts) + FFI.setDebuggerTuning cOpts =<< encodeM (TO.debuggerTuning hOpts) + FFI.setFPDenormalMode cOpts =<< encodeM (TO.floatingPointDenormalMode hOpts) + FFI.setExceptionModel cOpts =<< encodeM (TO.exceptionModel hOpts) + pokeMachineCodeOptions (TO.machineCodeOptions hOpts) =<< machineCodeOptions opts + +pokeMachineCodeOptions :: TO.MachineCodeOptions -> MCTargetOptions -> IO () +pokeMachineCodeOptions hOpts (MCTargetOptions cOpts) = + mapM_ (\(c, ha) -> FFI.setMCTargetOptionFlag cOpts c =<< encodeM (ha hOpts)) [ + (FFI.mcTargetOptionFlagMCRelaxAll, TO.relaxAll), + (FFI.mcTargetOptionFlagMCNoExecStack, TO.noExecutableStack), + (FFI.mcTargetOptionFlagMCFatalWarnings, TO.fatalWarnings), + (FFI.mcTargetOptionFlagMCNoWarn, TO.noWarnings), + (FFI.mcTargetOptionFlagMCNoDeprecatedWarn, TO.noDeprecatedWarning), + (FFI.mcTargetOptionFlagMCSaveTempLabels, TO.saveTemporaryLabels), + (FFI.mcTargetOptionFlagMCUseDwarfDirectory, TO.useDwarfDirectory), + (FFI.mcTargetOptionFlagMCIncrementalLinkerCompatible, TO.incrementalLinkerCompatible), + (FFI.mcTargetOptionFlagShowMCEncoding, TO.showMachineCodeEncoding), + (FFI.mcTargetOptionFlagShowMCInst, TO.showMachineCodeInstructions), + (FFI.mcTargetOptionFlagAsmVerbose, TO.verboseAssembly), + (FFI.mcTargetOptionFlagPreserveAsmComments, TO.preserveComentsInAssembly) + ] + +-- | get all target options +peekTargetOptions :: TargetOptions -> IO TO.Options +peekTargetOptions opts@(TargetOptions tOpts) = do + let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts + unsafeFloatingPointMath + <- gof FFI.targetOptionFlagUnsafeFPMath + noInfinitiesFloatingPointMath + <- gof FFI.targetOptionFlagNoInfsFPMath + noNaNsFloatingPointMath + <- gof FFI.targetOptionFlagNoNaNsFPMath + noTrappingFloatingPointMath + <- gof FFI.targetOptionFlagNoTrappingFPMath + noSignedZeroesFloatingPointMath + <- gof FFI.targetOptionFlagNoSignedZerosFPMath + honorSignDependentRoundingFloatingPointMathOption + <- gof FFI.targetOptionFlagHonorSignDependentRoundingFPMathOption + noZerosInBSS + <- gof FFI.targetOptionFlagNoZerosInBSS + guaranteedTailCallOptimization + <- gof FFI.targetOptionFlagGuaranteedTailCallOpt + stackSymbolOrdering + <- gof FFI.targetOptionFlagStackSymbolOrdering + enableFastInstructionSelection + <- gof FFI.targetOptionFlagEnableFastISel + useInitArray + <- gof FFI.targetOptionFlagUseInitArray + disableIntegratedAssembler + <- gof FFI.targetOptionFlagDisableIntegratedAS + compressDebugSections <- decodeM =<< FFI.getCompressDebugSections tOpts + relaxELFRelocations + <- gof FFI.targetOptionFlagRelaxELFRelocations + functionSections + <- gof FFI.targetOptionFlagFunctionSections + dataSections + <- gof FFI.targetOptionFlagDataSections + uniqueSectionNames + <- gof FFI.targetOptionFlagUniqueSectionNames + trapUnreachable + <- gof FFI.targetOptionFlagTrapUnreachable + emulatedThreadLocalStorage + <- gof FFI.targetOptionFlagEmulatedTLS + enableInterProceduralRegisterAllocation + <- gof FFI.targetOptionFlagEnableIPRA + stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts + floatABIType <- decodeM =<< FFI.getFloatABIType tOpts + allowFloatingPointOperationFusion <- decodeM =<< FFI.getAllowFPOpFusion tOpts + threadModel <- decodeM =<< FFI.getThreadModel tOpts + eabiVersion <- decodeM =<< FFI.getEABIVersion tOpts + debuggerTuning <- decodeM =<< FFI.getDebuggerTuning tOpts + floatingPointDenormalMode <- decodeM =<< FFI.getFPDenormalMode tOpts + exceptionModel <- decodeM =<< FFI.getExceptionModel tOpts + machineCodeOptions <- peekMachineCodeOptions =<< machineCodeOptions opts + return TO.Options { .. } + +-- | get all machine code options +peekMachineCodeOptions :: MCTargetOptions -> IO TO.MachineCodeOptions +peekMachineCodeOptions (MCTargetOptions tOpts) = do + let gof = decodeM <=< FFI.getMCTargetOptionsFlag tOpts + relaxAll + <- gof FFI.mcTargetOptionFlagMCRelaxAll + noExecutableStack + <- gof FFI.mcTargetOptionFlagMCNoExecStack + fatalWarnings + <- gof FFI.mcTargetOptionFlagMCFatalWarnings + noWarnings + <- gof FFI.mcTargetOptionFlagMCNoWarn + noDeprecatedWarning + <- gof FFI.mcTargetOptionFlagMCNoDeprecatedWarn + saveTemporaryLabels + <- gof FFI.mcTargetOptionFlagMCSaveTempLabels + useDwarfDirectory + <- gof FFI.mcTargetOptionFlagMCUseDwarfDirectory + incrementalLinkerCompatible + <- gof FFI.mcTargetOptionFlagMCIncrementalLinkerCompatible + showMachineCodeEncoding + <- gof FFI.mcTargetOptionFlagShowMCEncoding + showMachineCodeInstructions + <- gof FFI.mcTargetOptionFlagShowMCInst + verboseAssembly + <- gof FFI.mcTargetOptionFlagAsmVerbose + preserveComentsInAssembly + <- gof FFI.mcTargetOptionFlagPreserveAsmComments + return TO.MachineCodeOptions { .. } + +-- | +newtype TargetMachine = TargetMachine (Ptr FFI.TargetMachine) + +-- | bracket creation and destruction of a 'TargetMachine' +withTargetMachine :: + Target + -> ShortByteString -- ^ triple + -> ByteString -- ^ cpu + -> Map CPUFeature Bool -- ^ features + -> TargetOptions + -> Reloc.Model + -> CodeModel.Model + -> CodeGenOpt.Level + -> (TargetMachine -> IO a) + -> IO a +withTargetMachine + (Target target) + triple + cpu + features + (TargetOptions targetOptions) + relocModel + codeModel + codeGenOptLevel = runAnyContT $ do + triple <- encodeM triple + cpu <- encodeM cpu + features <- encodeM features + relocModel <- encodeM relocModel + codeModel <- encodeM codeModel + codeGenOptLevel <- encodeM codeGenOptLevel + anyContToM $ bracket ( + FFI.createTargetMachine + target + triple + cpu + features + targetOptions + relocModel + codeModel + codeGenOptLevel + ) + FFI.disposeTargetMachine + . (. TargetMachine) + +targetMachineOptions :: TargetMachine -> IO TargetOptions +targetMachineOptions (TargetMachine tm) = TargetOptions <$> FFI.targetMachineOptions tm + +machineCodeOptions :: TargetOptions -> IO MCTargetOptions +machineCodeOptions (TargetOptions to) = MCTargetOptions <$> FFI.machineCodeOptions to + +-- | +newtype TargetLowering = TargetLowering (Ptr FFI.TargetLowering) + +-- | get the 'TargetLowering' of a 'TargetMachine' +getTargetLowering :: TargetMachine -> IO TargetLowering +getTargetLowering (TargetMachine _) = TargetLowering <$> error "FIXME: getTargetLowering" -- FFI.getTargetLowering tm + +-- | Initialize the native target. This function is called automatically in these Haskell bindings +-- when creating an 'LLVM.ExecutionEngine.ExecutionEngine' which will require it, and so it should +-- not be necessary to call it separately. +initializeNativeTarget :: IO () +initializeNativeTarget = do + failure <- decodeM =<< liftIO FFI.initializeNativeTarget + when failure $ fail "native target initialization failed" + +-- | the target triple corresponding to the target machine +getTargetMachineTriple :: TargetMachine -> IO ShortByteString +getTargetMachineTriple (TargetMachine m) = decodeM =<< FFI.getTargetMachineTriple m + +-- | the default target triple that LLVM has been configured to produce code for +getDefaultTargetTriple :: IO ShortByteString +getDefaultTargetTriple = decodeM =<< FFI.getDefaultTargetTriple + +-- | a target triple suitable for loading code into the current process +getProcessTargetTriple :: IO ShortByteString +getProcessTargetTriple = decodeM =<< FFI.getProcessTargetTriple + +-- | the LLVM name for the host CPU +getHostCPUName :: IO ByteString +getHostCPUName = decodeM FFI.getHostCPUName + +-- | a space-separated list of LLVM feature names supported by the host CPU +getHostCPUFeatures :: IO (Map CPUFeature Bool) +getHostCPUFeatures = + decodeM =<< FFI.getHostCPUFeatures + +-- | 'DataLayout' to use for the given 'TargetMachine' +getTargetMachineDataLayout :: TargetMachine -> IO DataLayout +getTargetMachineDataLayout (TargetMachine m) = do + dlString <- decodeM =<< FFI.getTargetMachineDataLayout m + let Right (Just dl) = runExcept . parseDataLayout BigEndian $ dlString + return dl + +-- | Initialize all targets so they can be found by 'lookupTarget' +initializeAllTargets :: IO () +initializeAllTargets = FFI.initializeAllTargets + +-- | Bracket creation and destruction of a 'TargetMachine' configured for the host. +-- +-- This function infers and fills the properties of the host machine +-- (architecture, CPU type, operating system etc.) to construct +-- a 'TargetMachine' value, but other parameters of 'TargetMachine' (the +-- code model, relocation model, and optimization level) have to be +-- provided by the user. For instance, for the JIT-compiled code that you +-- want to dynamically load you probably want to use the 'Reloc.PIC' +-- relocation model. +withHostTargetMachine + :: Reloc.Model + -> CodeModel.Model + -> CodeGenOpt.Level + -> (TargetMachine -> IO a) -> IO a +withHostTargetMachine relocModel codeModel codeGenOpt f = do + initializeAllTargets + triple <- getProcessTargetTriple + cpu <- getHostCPUName + features <- getHostCPUFeatures + (target, _) <- lookupTarget Nothing triple + withTargetOptions $ \options -> + withTargetMachine target triple cpu features options relocModel codeModel codeGenOpt f + +-- | Like 'withHostTargetMachine', but assumes the default values for the +-- relocation model, code model, and optimization level ('Reloc.Default', +-- 'CodeModel.Default', 'CodeGenOpt.Default' respectively). +-- +-- Note that the 'Reloc.Default' relocation model __is not__ suitable for +-- JIT compilation; use 'withHostTargetMachine' and 'Reloc.PIC' instead. +withHostTargetMachineDefault :: (TargetMachine -> IO a) -> IO a +withHostTargetMachineDefault f = withHostTargetMachine Reloc.Default CodeModel.Default CodeGenOpt.Default f + +-- | +newtype TargetLibraryInfo = TargetLibraryInfo (Ptr FFI.TargetLibraryInfo) + +-- | Look up a 'LibraryFunction' by its standard name +getLibraryFunction :: TargetLibraryInfo -> ShortByteString -> IO (Maybe LibraryFunction) +getLibraryFunction (TargetLibraryInfo f) name = runAnyContT' return $ do + libFuncP <- alloca :: AnyContT IO (Ptr FFI.LibFunc) + name <- (encodeM name :: AnyContT IO CString) + r <- decodeM =<< (liftIO $ FFI.getLibFunc f name libFuncP) + forM (if r then Just libFuncP else Nothing) $ decodeM <=< peek + +-- | Get a the current name to be emitted for a 'LibraryFunction' +getLibraryFunctionName :: TargetLibraryInfo -> LibraryFunction -> IO ShortByteString +getLibraryFunctionName (TargetLibraryInfo f) l = runAnyContT' return $ do + l <- encodeM l + decodeM $ FFI.libFuncGetName f l + +-- | Set the name of the function on the target platform that corresponds to funcName +setLibraryFunctionAvailableWithName :: + TargetLibraryInfo + -> LibraryFunction + -> ShortByteString -- ^ The function name to be emitted + -> IO () +setLibraryFunctionAvailableWithName (TargetLibraryInfo f) libraryFunction name = runAnyContT' return $ do + name <- encodeM name + libraryFunction <- encodeM libraryFunction + liftIO $ FFI.libFuncSetAvailableWithName f libraryFunction name + +-- | look up information about the library functions available on a given platform +withTargetLibraryInfo :: + ShortByteString -- ^ triple + -> (TargetLibraryInfo -> IO a) + -> IO a +withTargetLibraryInfo triple f = runAnyContT' return $ do + triple <- encodeM triple + liftIO $ bracket (FFI.createTargetLibraryInfo triple) FFI.disposeTargetLibraryInfo (f . TargetLibraryInfo) diff --git a/src/LLVM/Internal/Threading.hs b/src/LLVM/Internal/Threading.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Threading.hs @@ -0,0 +1,13 @@ +module LLVM.Internal.Threading ( + isMultithreaded + ) where + +import LLVM.Prelude + +import qualified LLVM.Internal.FFI.Threading as FFI + +import LLVM.Internal.Coding + +-- | Check if multithreading is enabled in LLVM +isMultithreaded :: IO Bool +isMultithreaded = FFI.isMultithreaded >>= decodeM diff --git a/src/LLVM/Internal/Type.hs b/src/LLVM/Internal/Type.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Type.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE + QuasiQuotes, + MultiParamTypeClasses + #-} +module LLVM.Internal.Type where + +import LLVM.Prelude + +import Control.Monad.AnyCont +import Control.Monad.Catch +import Control.Monad.State + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI +import LLVM.Internal.FFI.LLVMCTypes (typeKindP) +import qualified LLVM.Internal.FFI.Type as FFI +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI + +import qualified LLVM.AST as A +import qualified LLVM.AST.AddrSpace as A +import LLVM.Exception + +import LLVM.Internal.Context +import LLVM.Internal.Coding +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST + +getStructure :: Ptr FFI.Type -> DecodeAST A.Type +getStructure t = scopeAnyCont $ do + return A.StructureType + `ap` (decodeM =<< liftIO (FFI.isPackedStruct t)) + `ap` do + n <- liftIO (FFI.countStructElementTypes t) + ts <- allocaArray n + liftIO $ FFI.getStructElementTypes t ts + decodeM (n, ts) + +getStructDefinitions :: DecodeAST [A.Definition] +getStructDefinitions = do + let getStructDefinition t = do + opaque <- decodeM =<< liftIO (FFI.structIsOpaque t) + if opaque then return Nothing else Just <$> getStructure t + flip fix Set.empty $ \continue done -> do + t <- takeTypeToDefine + flip (maybe (return [])) t $ \t -> do + if t `Set.member` done + then + continue done + else + return (:) + `ap` (return A.TypeDefinition `ap` getTypeName t `ap` getStructDefinition t) + `ap` (continue $ Set.insert t done) + +isArrayType :: Ptr FFI.Type -> IO Bool +isArrayType t = do + k <- liftIO $ FFI.getTypeKind t + return $ k == FFI.typeKindArray + +instance Monad m => EncodeM m A.AddrSpace FFI.AddrSpace where + encodeM (A.AddrSpace a) = return FFI.AddrSpace `ap` encodeM a + +instance Monad m => DecodeM m A.AddrSpace FFI.AddrSpace where + decodeM (FFI.AddrSpace a) = return A.AddrSpace `ap` decodeM a + +instance EncodeM EncodeAST A.Type (Ptr FFI.Type) where + encodeM f = scopeAnyCont $ do + Context context <- gets encodeStateContext + case f of + A.IntegerType bits -> do + bits <- encodeM bits + liftIO $ FFI.intTypeInContext context bits + A.FunctionType returnTypeAST argTypeASTs isVarArg -> do + returnType <- encodeM returnTypeAST + argTypes <- encodeM argTypeASTs + isVarArg <- encodeM isVarArg + liftIO $ FFI.functionType returnType argTypes isVarArg + A.PointerType elementType addressSpace -> do + e <- encodeM elementType + a <- encodeM addressSpace + liftIO $ FFI.pointerType e a + A.VoidType -> liftIO $ FFI.voidTypeInContext context + A.FloatingPointType A.HalfFP -> liftIO $ FFI.halfTypeInContext context + A.FloatingPointType A.FloatFP -> liftIO $ FFI.floatTypeInContext context + A.FloatingPointType A.DoubleFP -> liftIO $ FFI.doubleTypeInContext context + A.FloatingPointType A.X86_FP80FP -> liftIO $ FFI.x86FP80TypeInContext context + A.FloatingPointType A.FP128FP -> liftIO $ FFI.fP128TypeInContext context + A.FloatingPointType A.PPC_FP128FP -> liftIO $ FFI.ppcFP128TypeInContext context + A.VectorType sz e -> do + e <- encodeM e + sz <- encodeM sz + liftIO $ FFI.vectorType e sz + A.ArrayType sz e -> do + e <- encodeM e + sz <- encodeM sz + liftIO $ FFI.arrayType e sz + A.StructureType packed ets -> do + ets <- encodeM ets + packed <- encodeM packed + liftIO $ FFI.structTypeInContext context ets packed + A.NamedTypeReference n -> lookupNamedType n + A.MetadataType -> liftIO $ FFI.metadataTypeInContext context + A.TokenType -> liftIO $ FFI.tokenTypeInContext context + A.LabelType -> liftIO $ FFI.labelTypeInContext context + +instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where + decodeM t = scopeAnyCont $ do + k <- liftIO $ FFI.getTypeKind t + case k of + [typeKindP|Void|] -> return A.VoidType + [typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t)) + [typeKindP|Function|] -> + return A.FunctionType + `ap` (decodeM =<< liftIO (FFI.getReturnType t)) + `ap` (do + n <- liftIO (FFI.countParamTypes t) + ts <- allocaArray n + liftIO $ FFI.getParamTypes t ts + decodeM (n, ts) + ) + `ap` (decodeM =<< liftIO (FFI.isFunctionVarArg t)) + [typeKindP|Pointer|] -> + return A.PointerType + `ap` (decodeM =<< liftIO (FFI.getElementType t)) + `ap` (decodeM =<< liftIO (FFI.getPointerAddressSpace t)) + [typeKindP|Half|] -> return $ A.FloatingPointType A.HalfFP + [typeKindP|Float|] -> return $ A.FloatingPointType A.FloatFP + [typeKindP|Double|] -> return $ A.FloatingPointType A.DoubleFP + [typeKindP|FP128|] -> return $ A.FloatingPointType A.FP128FP + [typeKindP|X86_FP80|] -> return $ A.FloatingPointType A.X86_FP80FP + [typeKindP|PPC_FP128|] -> return $ A.FloatingPointType A.PPC_FP128FP + [typeKindP|Vector|] -> + return A.VectorType + `ap` (decodeM =<< liftIO (FFI.getVectorSize t)) + `ap` (decodeM =<< liftIO (FFI.getElementType t)) + [typeKindP|Struct|] -> do + let ifM c a b = c >>= \x -> if x then a else b + ifM (decodeM =<< liftIO (FFI.structIsLiteral t)) + (getStructure t) + (saveNamedType t >> return A.NamedTypeReference `ap` getTypeName t) + [typeKindP|Metadata|] -> return A.MetadataType + [typeKindP|Array|] -> + return A.ArrayType + `ap` (decodeM =<< liftIO (FFI.getArrayLength t)) + `ap` (decodeM =<< liftIO (FFI.getElementType t)) + [typeKindP|Token|] -> return A.TokenType + [typeKindP|Label|] -> return A.LabelType + _ -> error $ "unhandled type kind " ++ show k + +createNamedType :: A.Name -> EncodeAST (Ptr FFI.Type, Maybe ShortByteString) +createNamedType n = do + Context c <- gets encodeStateContext + n <- case n of { A.Name n -> encodeM n; _ -> return nullPtr } + renamedName <- alloca + t <- liftIO $ FFI.structCreateNamed c n renamedName + p <- peek renamedName + if p == FFI.OwnerTransfered nullPtr + then pure (t, Nothing) + else do + n' <- decodeM p + pure (t, Just n') + +renameType :: A.Type -> EncodeAST A.Type +renameType A.VoidType = pure A.VoidType +renameType t@(A.IntegerType _) = pure t +renameType (A.PointerType r a) = fmap (\r' -> A.PointerType r' a) (renameType r) +renameType t@(A.FloatingPointType _) = pure t +renameType (A.FunctionType r as varArg) = + liftA2 + (\r' as' -> A.FunctionType r' as' varArg) + (renameType r) + (traverse renameType as) +renameType (A.VectorType n t) = A.VectorType n <$> renameType t +renameType (A.StructureType packed ts) = A.StructureType packed <$> traverse renameType ts +renameType (A.ArrayType n t) = A.ArrayType n <$> renameType t +renameType t@(A.NamedTypeReference n) = do + renamedTypes <- gets encodeStateRenamedTypes + case Map.lookup n renamedTypes of + Just n' -> pure (A.NamedTypeReference (A.Name n')) + Nothing -> pure t +renameType A.MetadataType = pure A.MetadataType +renameType A.LabelType = pure A.LabelType +renameType A.TokenType = pure A.TokenType + +setNamedType :: Ptr FFI.Type -> A.Type -> EncodeAST () +setNamedType t (A.StructureType packed ets) = do + ets <- encodeM ets + packed <- encodeM packed + liftIO $ FFI.structSetBody t ets packed +setNamedType _ ty = + throwM + (EncodeException + ("A type definition requires a structure type but got: " ++ show ty)) diff --git a/src/LLVM/Internal/Value.hs b/src/LLVM/Internal/Value.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Internal/Value.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE + MultiParamTypeClasses + #-} +module LLVM.Internal.Value where + +import LLVM.Prelude + +import Control.Monad.State + +import Foreign.Ptr + +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Value as FFI + +import LLVM.Internal.Coding +import LLVM.Internal.DecodeAST +import LLVM.Internal.Type () + +import qualified LLVM.AST.Type as A + +typeOf :: FFI.DescendentOf FFI.Value v => Ptr v -> DecodeAST A.Type +typeOf = decodeM <=< liftIO . FFI.typeOf . FFI.upCast + diff --git a/src/LLVM/Linking.hs b/src/LLVM/Linking.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Linking.hs @@ -0,0 +1,7 @@ +-- | Utility functions for resolving external symbols +module LLVM.Linking + ( loadLibraryPermanently + , getSymbolAddressInProcess + ) where + +import LLVM.Internal.Linking diff --git a/src/LLVM/Module.hs b/src/LLVM/Module.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Module.hs @@ -0,0 +1,31 @@ +-- | A 'Module' holds a C++ LLVM IR module. 'Module's may be converted to or from strings or Haskell ASTs, or +-- added to an 'LLVM.ExecutionEngine.ExecutionEngine' and so JIT compiled to get function pointers. +module LLVM.Module ( + Module, + File(..), + + withModuleFromAST, + createModuleFromAST, + disposeModule, + + moduleContext, + moduleAST, + + withModuleFromLLVMAssembly, + moduleLLVMAssembly, + writeLLVMAssemblyToFile, + + withModuleFromBitcode, + moduleBitcode, + writeBitcodeToFile, + + moduleTargetAssembly, + writeTargetAssemblyToFile, + + moduleObject, + writeObjectToFile, + + linkModules + ) where + +import LLVM.Internal.Module diff --git a/src/LLVM/OrcJIT.hs b/src/LLVM/OrcJIT.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/OrcJIT.hs @@ -0,0 +1,54 @@ +module LLVM.OrcJIT ( + -- * ExecutionSession + ExecutionSession, + createExecutionSession, + disposeExecutionSession, + withExecutionSession, + -- * JITDylib + JITDylib(..), + createJITDylib, + -- ** Symbol search generators + addDynamicLibrarySearchGeneratorForCurrentProcess, + addDynamicLibrarySearchGenerator, + -- ** Symbol definitions + defineAbsoluteSymbols, + -- ** Symbol lookups + lookupSymbol, + JITSymbol(..), + JITSymbolError(..), + JITSymbolFlags(..), + defaultJITSymbolFlags, + -- * Mangled symbols + mangleSymbol, + disposeMangledSymbol, + withMangledSymbol, + -- * ThreadSafeContext + ThreadSafeContext, + -- ** Lifetime management + withThreadSafeContext, + createThreadSafeContext, + disposeThreadSafeContext, + -- * ThreadSafeModule + ThreadSafeModule(..), + -- ** Lifetime management + withClonedThreadSafeModule, + cloneAsThreadSafeModule, + disposeThreadSafeModule, + -- * Object layers + ObjectLayer, + addObjectFile, + -- ** ObjectLinkingLayer + ObjectLinkingLayer, + createObjectLinkingLayer, + -- ** RTDyldObjectLinkingLayer + RTDyldObjectLinkingLayer, + createRTDyldObjectLinkingLayer, + -- * IR layers + IRLayer, + addModule, + -- ** IRCompileLayer + IRCompileLayer, + createIRCompileLayer, + ) where + +import LLVM.Internal.OrcJIT diff --git a/src/LLVM/PassManager.hs b/src/LLVM/PassManager.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/PassManager.hs @@ -0,0 +1,14 @@ +-- | A 'PassManager' holds collection of passes, to be run on 'Module's. +-- Build one with 'withPassManager': +-- +-- * using 'CuratedPassSetSpec' if you want optimization but not to play with your compiler +-- +-- * using 'PassSetSpec' if you do want to play with your compiler +module LLVM.PassManager ( + PassManager, + PassSetSpec(..), defaultPassSetSpec, defaultCuratedPassSetSpec, + withPassManager, + runPassManager + ) where + +import LLVM.Internal.PassManager diff --git a/src/LLVM/Prelude.hs b/src/LLVM/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Prelude.hs @@ -0,0 +1,68 @@ +-- | 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/src/LLVM/Relocation.hs b/src/LLVM/Relocation.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Relocation.hs @@ -0,0 +1,12 @@ +-- | Relocations, used in specifying TargetMachine +module LLVM.Relocation where + +import LLVM.Prelude + +-- | +data Model + = Default + | Static + | PIC + | DynamicNoPIC + deriving (Eq, Read, Show, Typeable, Data, Generic) diff --git a/src/LLVM/Target.hs b/src/LLVM/Target.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Target.hs @@ -0,0 +1,22 @@ +-- | A 'Target' describes that for which code may be intended. Targets are used both during actual +-- | lowering of LLVM IR to machine code and by some optimization passes which use the target to +-- | judge costs. +module LLVM.Target ( + lookupTarget, + TargetOptions, + Target, TargetMachine, TargetLowering, + CPUFeature(..), + withTargetOptions, peekTargetOptions, pokeTargetOptions, + withTargetMachine, withHostTargetMachine, withHostTargetMachineDefault, targetMachineOptions, + getTargetLowering, + getTargetMachineTriple, getDefaultTargetTriple, getProcessTargetTriple, getHostCPUName, getHostCPUFeatures, + getTargetMachineDataLayout, initializeNativeTarget, initializeAllTargets, + TargetLibraryInfo, + getLibraryFunction, + getLibraryFunctionName, + setLibraryFunctionAvailableWithName, + withTargetLibraryInfo + ) where + +import LLVM.Internal.Target + diff --git a/src/LLVM/Target/LibraryFunction.hs b/src/LLVM/Target/LibraryFunction.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Target/LibraryFunction.hs @@ -0,0 +1,7 @@ +-- | A 'LibraryFunction' identifies a function of which LLVM has particular knowledge. +module LLVM.Target.LibraryFunction ( + LibraryFunction(..) + ) where + + +import LLVM.Internal.LibraryFunction diff --git a/src/LLVM/Target/Options.hs b/src/LLVM/Target/Options.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Target/Options.hs @@ -0,0 +1,116 @@ +-- | +module LLVM.Target.Options where + +import LLVM.Prelude + +-- | +data FloatABI + = FloatABIDefault + | FloatABISoft + | FloatABIHard + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data FloatingPointOperationFusionMode + = FloatingPointOperationFusionFast + | FloatingPointOperationFusionStandard + | FloatingPointOperationFusionStrict + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data DebugCompressionType + = CompressNone -- ^ No compression + | CompressGNU -- ^ zlib-gnu style compression + | CompressZ -- ^ zlib style compression + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data ThreadModel + = ThreadModelPOSIX + | ThreadModelSingle + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data DebuggerKind + = DebuggerDefault + | DebuggerGDB + | DebuggerLLDB + | DebuggerSCE + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data EABIVersion + = EABIVersionUnknown + | EABIVersionDefault + | EABIVersion4 + | EABIVersion5 + | EABIVersionGNU + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data FloatingPointDenormalMode + = FloatingPointDenormalIEEE -- ^ IEEE 754 denormal numbers + | FloatingPointDenormalPreserveSign -- ^ The sign of a flushed-to-zero number is preserved in the sign of 0 + | FloatingPointDenormalPositiveZero -- ^ Denormals are flushed to positive zero + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | +data ExceptionHandling + = ExceptionHandlingNone -- ^ No exception support + | ExceptionHandlingDwarfCFI -- ^ DWARF-like instruction based exceptions + | ExceptionHandlingSjLj -- ^ setjmp/longjmp based exceptions + | ExceptionHandlingARM -- ^ ARM EHABI + | ExceptionHandlingWinEH -- ^ Windows Exception Handling + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +-- | The options of a 'LLVM.Target.TargetOptions' +-- +data Options = Options { + unsafeFloatingPointMath :: Bool, + noInfinitiesFloatingPointMath :: Bool, + noNaNsFloatingPointMath :: Bool, + noTrappingFloatingPointMath :: Bool, + noSignedZeroesFloatingPointMath :: Bool, + honorSignDependentRoundingFloatingPointMathOption :: Bool, + noZerosInBSS :: Bool, + guaranteedTailCallOptimization :: Bool, + stackSymbolOrdering :: Bool, + enableFastInstructionSelection :: Bool, + useInitArray :: Bool, + disableIntegratedAssembler :: Bool, + compressDebugSections :: DebugCompressionType, + relaxELFRelocations :: Bool, + functionSections :: Bool, + dataSections :: Bool, + uniqueSectionNames :: Bool, + trapUnreachable :: Bool, + emulatedThreadLocalStorage :: Bool, + enableInterProceduralRegisterAllocation :: Bool, + stackAlignmentOverride :: Word32, + floatABIType :: FloatABI, + allowFloatingPointOperationFusion :: FloatingPointOperationFusionMode, + threadModel :: ThreadModel, + eabiVersion :: EABIVersion, + debuggerTuning :: DebuggerKind, + floatingPointDenormalMode :: FloatingPointDenormalMode, + exceptionModel :: ExceptionHandling, + machineCodeOptions :: MachineCodeOptions + } + deriving (Eq, Ord, Read, Show) + +-- | +data MachineCodeOptions = MachineCodeOptions { + relaxAll :: Bool, + noExecutableStack :: Bool, + fatalWarnings :: Bool, + noWarnings :: Bool, + noDeprecatedWarning :: Bool, + saveTemporaryLabels :: Bool, + useDwarfDirectory :: Bool, + incrementalLinkerCompatible :: Bool, + showMachineCodeEncoding :: Bool, + showMachineCodeInstructions :: Bool, + verboseAssembly :: Bool, + preserveComentsInAssembly :: Bool + } + deriving (Eq, Ord, Read, Show) diff --git a/src/LLVM/Threading.hs b/src/LLVM/Threading.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Threading.hs @@ -0,0 +1,24 @@ +-- | functionality necessary when running LLVM in multiple threads at the same time. +module LLVM.Threading ( + setMultithreaded, + isMultithreaded + ) where + +import LLVM.Prelude + +import LLVM.Internal.Threading + +{-# DEPRECATED setMultithreaded "LLVM no longer features runtime control of multithreading support" #-} +-- | This function used set the multithreading mode of LLVM, but that feature no longer exists. Threading is +-- controlled only at runtime with the configure flag --enable-threads (default is YES). This function will +-- now check that the the compiled-in multithreading support (returned by 'isMultithreaded') is +-- sufficient to support the requested access, and fail if not, so as to prevent uncontrolled use of a +-- version of LLVM compiled to be capable only of singled threaded use by haskell code requesting +-- multithreading support. +setMultithreaded :: Bool -> IO () +setMultithreaded desired = do + actual <- isMultithreaded + when (desired && not actual) $ + fail $ "Multithreading support requested but not available. " ++ + "Please use an LLVM built with threading enabled" + return () diff --git a/src/LLVM/Transforms.hs b/src/LLVM/Transforms.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Transforms.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides an enumeration of the various transformation (e.g. optimization) passes +-- provided by LLVM. They can be used to create a 'LLVM.PassManager.PassManager' to, in turn, +-- run the passes on 'LLVM.Module.Module's. If you don't know what passes you want, consider +-- instead using 'LLVM.PassManager.CuratedPassSetSpec'. +module LLVM.Transforms where + +import LLVM.Prelude + +-- | +-- A few passes can make use of information in a 'LLVM.Target.TargetMachine' if one +-- is provided to 'LLVM.PassManager.createPassManager'. +-- +data Pass + -- here begin the Scalar passes + = AggressiveDeadCodeElimination + | BreakCriticalEdges + -- | can use a 'LLVM.Target.TargetMachine' + | CodeGenPrepare + | CorrelatedValuePropagation + | DeadCodeElimination + | DeadStoreElimination + | DemoteRegisterToMemory + | EarlyCommonSubexpressionElimination + | GlobalValueNumbering { noLoads :: Bool } + | InductionVariableSimplify + | InstructionCombining + -- | Instruction simplification includes constant folding + | InstructionSimplify + | JumpThreading + | LoopClosedSingleStaticAssignment + | LoopInvariantCodeMotion + | LoopDeletion + | LoopIdiom + | LoopInstructionSimplify + | LoopRotate + | LoopStrengthReduce + | LoopUnroll { loopUnrollThreshold :: Maybe Word, count :: Maybe Word, allowPartial :: Maybe Bool } + | LoopUnswitch { optimizeForSize :: Bool } + | LowerAtomic + | LowerInvoke + | LowerSwitch + | LowerExpectIntrinsic + | MemcpyOptimization + | PromoteMemoryToRegister + | Reassociate + | ScalarReplacementOfAggregates { requiresDominatorTree :: Bool } + | OldScalarReplacementOfAggregates { + oldScalarReplacementOfAggregatesThreshold :: Maybe Word, + useDominatorTree :: Bool, + structMemberThreshold :: Maybe Word, + arrayElementThreshold :: Maybe Word, + scalarLoadThreshold :: Maybe Word + } + | SparseConditionalConstantPropagation + | SimplifyLibCalls + | SimplifyControlFlowGraph + | Sinking + | TailCallElimination + + -- here begin the Interprocedural passes + | AlwaysInline { insertLifetime :: Bool } + | ArgumentPromotion + | ConstantMerge + | FunctionAttributes + | FunctionInlining { + functionInliningThreshold :: Word + } + | GlobalDeadCodeElimination + | InternalizeFunctions { exportList :: [String] } + | InterproceduralSparseConditionalConstantPropagation + | MergeFunctions + | PartialInlining + | PruneExceptionHandling + | StripDeadDebugInfo + | StripDebugDeclare + | StripNonDebugSymbols + | StripSymbols { onlyDebugInfo :: Bool } + + -- here begin the vectorization passes + | LoopVectorize { + interleaveOnlyWhenForced :: Bool, + vectorizeOnlyWhenForced :: Bool + } + | SuperwordLevelParallelismVectorize + + -- here begin the instrumentation passes + | GCOVProfiler { + emitNotes :: Bool, + emitData :: Bool, + version :: GCOVVersion, + noRedZone :: Bool, + atomic :: Bool, + filter :: String, + exclude :: String + } + | AddressSanitizer + | AddressSanitizerModule + | MemorySanitizer { + trackOrigins :: Bool, + recover :: Bool, + kernel :: Bool + } + | ThreadSanitizer + | BoundsChecking + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | Defaults for the 'LoopVectorize' pass +defaultLoopVectorize :: Pass +defaultLoopVectorize = LoopVectorize { + interleaveOnlyWhenForced = False, + vectorizeOnlyWhenForced = False + } + +-- | See . +newtype GCOVVersion = GCOVVersion ShortByteString + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | Defaults for 'GCOVProfiler'. +defaultGCOVProfiler :: Pass +defaultGCOVProfiler = GCOVProfiler { + emitNotes = True, + emitData = True, + version = GCOVVersion "402*", + noRedZone = False, + atomic = True, + LLVM.Transforms.filter = "", + exclude = "" + } + +-- | Defaults for 'AddressSanitizer'. +defaultAddressSanitizer :: Pass +defaultAddressSanitizer = AddressSanitizer + +-- | Defaults for 'AddressSanitizerModule'. +defaultAddressSanitizerModule :: Pass +defaultAddressSanitizerModule = AddressSanitizerModule + +-- | Defaults for 'MemorySanitizer'. +defaultMemorySanitizer :: Pass +defaultMemorySanitizer = MemorySanitizer { + trackOrigins = False, + recover = False, + kernel = False +} + +-- | Defaults for 'ThreadSanitizer'. +defaultThreadSanitizer :: Pass +defaultThreadSanitizer = ThreadSanitizer diff --git a/src/LLVM/Triple.hs b/src/LLVM/Triple.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Triple.hs @@ -0,0 +1,380 @@ +{-# 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 Data.ByteString.Short hiding (pack, foldr) + +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 {..} = + toShort $ ByteString.intercalate (pack "-") [ + pack (architectureToStringMap ! architecture), + pack (vendorToStringMap ! vendor), + pack (osToStringMap ! os) + ] + +parseTriple :: ShortByteString -> Except String Triple +parseTriple triple = do + let + tripleStr = 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/test/LLVM/Test/Analysis.hs b/test/LLVM/Test/Analysis.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Analysis.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Analysis where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Monad.Trans.Except + +import LLVM.Module +import LLVM.Context +import LLVM.Analysis + +import LLVM.AST as A +import LLVM.AST.Type as A.T +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import LLVM.AST.DataLayout +import qualified LLVM.AST.IntegerPredicate as IPred +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C + +import qualified LLVM.Relocation as R +import qualified LLVM.CodeModel as CM +import qualified LLVM.CodeGenOpt as CGO + +tests = testGroup "Analysis" [ + testGroup "Verifier" [ +{- + -- this test will cause an assertion if LLVM is compiled with assertions on. + testCase "Module" $ do + let ast = Module "" Nothing Nothing [ + GlobalDefinition $ Function L.External V.Default CC.C [] A.T.void (Name "foo") ([ + Parameter i32 (Name "x") [] + ],False) + [] + Nothing 0 Nothing + [ + BasicBlock (UnName 0) [ + UnName 1 := Call { + isTailCall = False, + callingConvention = CC.C, + returnAttributes = [], + function = Right (ConstantOperand (C.GlobalReference (A.T.FunctionType A.T.void [A.T.i32] False) (Name "foo"))), + arguments = [ + (ConstantOperand (C.Int 8 1), []) + ], + functionAttributes = [], + metadata = [] + } + ] ( + Do $ Ret Nothing [] + ) + ] + ] + Left s <- withContext $ \context -> withModuleFromAST context ast $ runExceptT . verify + s @?= "Call parameter type does not match function signature!\n\ + \i8 1\n\ + \ i32 call void @foo(i8 1)\n\ + \Broken module found, compilation terminated.\n\ + \Broken module found, compilation terminated.\n", +-} + + testGroup "regression" [ + testCase "load synchronization" $ do + let str = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define double @my_function2(double* %input_0) {\n\ + \foo:\n\ + \ %tmp_input_w0 = getelementptr inbounds double, double* %input_0, i64 0\n\ + \ %0 = load double, double* %tmp_input_w0, align 8\n\ + \ ret double %0\n\ + \}\n" + ast = + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = double, + G.name = Name "my_function2", + G.parameters = ([ + Parameter (ptr double) (Name "input_0") [] + ],False), + G.basicBlocks = [ + BasicBlock (Name "foo") [ + Name "tmp_input_w0" := GetElementPtr { + inBounds = True, + address = LocalReference (ptr double) (Name "input_0"), + indices = [ConstantOperand (C.Int 64 0)], + metadata = [] + }, + UnName 0 := Load { + volatile = False, + address = LocalReference (ptr double) (Name "tmp_input_w0"), + maybeAtomicity = Nothing, + alignment = 8, + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference double (UnName 0))) [] + ) + ] + } + ] + strCheck ast str + withContext $ \context -> withModuleFromAST context ast verify + ] + ] + ] diff --git a/test/LLVM/Test/Attribute.hs b/test/LLVM/Test/Attribute.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Attribute.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Attribute + ( tests + ) where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM +import LLVM.AST hiding (DIFlag(..)) +import LLVM.AST.CallingConvention (CallingConvention(C)) +import LLVM.AST.Constant (Constant (Int, GlobalReference)) +import LLVM.AST.FunctionAttribute +import LLVM.AST.Global (basicBlocks, name, returnType) +import LLVM.AST.Type (i32, ptr) +import LLVM.Context + +import Data.List +import Prelude + +moduleAst :: LLVM.AST.Module +moduleAst = + defaultModule + { moduleDefinitions = + [ GlobalDefinition + (functionDefaults + { returnType = i32 + , name = "f" + , basicBlocks = + [ BasicBlock + (UnName 0) + [] + (Do + (Ret + { returnOperand = Just (ConstantOperand (Int 32 42)) + , metadata' = [] + })) + ] + }) + , GlobalDefinition + (functionDefaults + { returnType = i32 + , name = "call_15" + , basicBlocks = + [ BasicBlock + (UnName 0) + [ "result" := + Call + { tailCallKind = Nothing + , callingConvention = C + , returnAttributes = [] + , function = + Right + (ConstantOperand + (GlobalReference + (ptr + (FunctionType + { resultType = i32 + , argumentTypes = [] + , isVarArg = False + })) + ("f"))) + , arguments = [] + , functionAttributes = [Left (GroupID 0)] + , metadata = [] + } + ] + (Do + (Ret + { returnOperand = Just (LocalReference i32 ("result")) + , metadata' = [] + })) + ] + }) + , FunctionAttributes + (GroupID 0) + [ AlwaysInline + , ArgMemOnly + , Builtin + , Cold + , Convergent + , InaccessibleMemOnly + , InaccessibleMemOrArgMemOnly + , InlineHint + , JumpTable + , MinimizeSize + , Naked + , NoBuiltin + , NoDuplicate + , NoImplicitFloat + , NoInline + , NoRecurse + , NoRedZone + , NoReturn + , NoUnwind + , NonLazyBind + , OptimizeForSize + , OptimizeNone + , ReadNone + , ReadOnly + , ReturnsTwice + , SafeStack + , SanitizeAddress + , SanitizeMemory + , SanitizeThread + , StackProtect + , StackProtectReq + , StackProtectStrong + , UWTable + , WriteOnly + , AllocSize 8 (Just 16) + , StackAlignment 8 + , StringAttribute "bar" "baz" + , StringAttribute "foo" "" + , StringAttribute "qux" "" + ] + ] + } + +moduleStr :: String +moduleStr = + unlines + [ "define i32 @f() {" + , " ret i32 42" + , "}" + , "" + , "define i32 @call_15() {" + , " %result = call i32 @f() \"foo\" \"bar\"=\"baz\" #0 alignstack(8) allocsize(8) allocsize(8, 16) alwaysinline argmemonly builtin cold convergent inaccessiblemem_or_argmemonly inaccessiblememonly inlinehint jumptable minsize naked nobuiltin noduplicate noimplicitfloat noinline nonlazybind norecurse noredzone noreturn nounwind optnone optsize readnone readonly returns_twice safestack sanitize_address sanitize_memory sanitize_thread ssp sspreq sspstrong uwtable writeonly" + , " ret i32 %result" + , "}" + , "" + , "attributes #0 = { \"qux\" }" + ] + +tests :: TestTree +tests = + testGroup "Attributes" + [ testCase "decoding of call attributes" $ do + withContext $ \ctx -> do + withModuleFromLLVMAssembly ctx moduleStr $ \m -> do + ast <- moduleAST m + ast @?= moduleAst + ] diff --git a/test/LLVM/Test/CallingConvention.hs b/test/LLVM/Test/CallingConvention.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/CallingConvention.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.CallingConvention where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Data.Maybe +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.Context +import LLVM.Module +import LLVM.AST +import LLVM.AST.Type as T +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Global as G + +import qualified Data.ByteString.Char8 as ByteString + +tests = testGroup "CallingConvention" [ + testCase name $ strCheck (defaultModule { + moduleDefinitions = [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.callingConvention = cc + } + ] + }) ("; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \declare" <> (if name == "" then "" else (" " <> ByteString.pack name)) <> " i32 @foo()\n") + | (name, cc) <- [ + ("", CC.C), + ("fastcc", CC.Fast), + ("coldcc", CC.Cold), + ("ghccc", CC.GHC), + ("cc11", CC.HiPE), + ("webkit_jscc", CC.WebKit_JS), + ("anyregcc", CC.AnyReg), + ("preserve_mostcc", CC.PreserveMost), + ("preserve_allcc", CC.PreserveAll), + ("swiftcc", CC.Swift), + ("cxx_fast_tlscc", CC.CXX_FastTLS), + ("x86_stdcallcc", CC.X86_StdCall), + ("x86_fastcallcc", CC.X86_FastCall), + ("arm_apcscc", CC.ARM_APCS), + ("arm_aapcscc", CC.ARM_AAPCS), + ("arm_aapcs_vfpcc", CC.ARM_AAPCS_VFP), + ("msp430_intrcc", CC.MSP430_INTR), + ("x86_thiscallcc", CC.X86_ThisCall), + ("ptx_kernel", CC.PTX_Kernel), + ("ptx_device", CC.PTX_Device), + ("spir_func", CC.SPIR_FUNC), + ("spir_kernel", CC.SPIR_KERNEL), + ("intel_ocl_bicc", CC.Intel_OCL_BI), + ("x86_64_sysvcc", CC.X86_64_SysV), + ("win64cc", CC.Win64), + ("x86_vectorcallcc", CC.X86_VectorCall), + ("hhvmcc", CC.HHVM), + ("hhvm_ccc", CC.HHVM_C), + ("x86_intrcc", CC.X86_Intr), + ("avr_intrcc ", CC.AVR_Intr), -- The spaces are necessary because there is a typo in LLVM’s printer + ("avr_signalcc ", CC.AVR_Signal), + ("cc86", CC.AVR_Builtin), + ("amdgpu_vs", CC.AMDGPU_VS), + ("amdgpu_hs", CC.AMDGPU_HS), + ("amdgpu_gs", CC.AMDGPU_GS), + ("amdgpu_ps", CC.AMDGPU_PS), + ("amdgpu_cs", CC.AMDGPU_CS), + ("amdgpu_kernel", CC.AMDGPU_Kernel), + ("x86_regcallcc", CC.X86_RegCall), + ("cc94", CC.MSP430_Builtin) + ] + ] diff --git a/test/LLVM/Test/Constants.hs b/test/LLVM/Test/Constants.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Constants.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Constants where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Monad +import Data.Functor +import Data.Maybe +import Data.Monoid +import Foreign.Ptr +import Data.Word + +import LLVM.Context +import LLVM.Module +import LLVM.Diagnostic +import LLVM.AST +import LLVM.AST.Type +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C +import qualified LLVM.AST.Float as F +import qualified LLVM.AST.IntegerPredicate as IPred + +tests = testGroup "Constants" [ + testCase name $ strCheck mAST mStr + | (name, type', value, str) <- [ + ( + "integer", + i32, + C.Int 32 1, + "global i32 1" + ), ( + "wide integer", + IntegerType 65, + C.Int 65 1, + "global i65 1" + ), ( + "big wide integer", + IntegerType 66, + C.Int 66 20000000000000000000, + "global i66 20000000000000000000" + ), ( + "negative wide integer", + IntegerType 65, + C.Int 65 36893488147419103231, + "global i65 -1" + ), ( + "half", + half, + C.Float (F.Half 0x1234), + "global half 0xH1234" + ), ( + "float", + float, + C.Float (F.Single 1), + "global float 1.000000e+00" + ), ( + "double", + double, + C.Float (F.Double 1), + "global double 1.000000e+00" + ), ( + "quad", + fp128, + C.Float (F.Quadruple 0x0007000600050004 0x0003000200010000), + "global fp128 0xL00030002000100000007000600050004" -- yes, this order is weird + ), ( + "quad 1.0", + fp128, + C.Float (F.Quadruple 0x3fff000000000000 0x0000000000000000), + "global fp128 0xL00000000000000003FFF000000000000" -- yes, this order is weird + ), ( + "x86_fp80", + x86_fp80, + C.Float (F.X86_FP80 0x0004 0x8003000200010000), + "global x86_fp80 0xK00048003000200010000" +{- don't know how to test this - LLVM's handling of this weird type is even weirder + ), ( + "ppc_fp128", + ppc_fp128, + C.Float (F.PPC_FP128 0x0007000600050004 0x0003000200010000), + "global ppc_fp128 0xM????????????????" +-} + ), ( + "struct", + StructureType False (replicate 2 i32), + C.Struct Nothing False (replicate 2 (C.Int 32 1)), + "global { i32, i32 } { i32 1, i32 1 }" + ), ( + "dataarray", + ArrayType 3 i32, + C.Array i32 [C.Int 32 i | i <- [1,2,1]], + "global [3 x i32] [i32 1, i32 2, i32 1]" + ), ( + "array", + ArrayType 3 (StructureType False [i32]), + C.Array (StructureType False [i32]) [C.Struct Nothing False [C.Int 32 i] | i <- [1,2,1]], + "global [3 x { i32 }] [{ i32 } { i32 1 }, { i32 } { i32 2 }, { i32 } { i32 1 }]" + ), ( + "datavector", + VectorType 3 i32, + C.Vector [C.Int 32 i | i <- [1,2,1]], + "global <3 x i32> " + ), ( + "undef", + i32, + C.Undef i32, + "global i32 undef" + ), ( + "binop/cast", + i64, + C.Add False False (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) (C.Int 64 2), + "global i64 add (i64 ptrtoint (i32* @1 to i64), i64 2)" + ), ( + "binop/cast nsw", + i64, + C.Add True False (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) (C.Int 64 2), + "global i64 add nsw (i64 ptrtoint (i32* @1 to i64), i64 2)" + ), ( + "icmp", + i1, + C.ICmp IPred.SGE (C.GlobalReference (ptr i32) (UnName 1)) (C.GlobalReference (ptr i32) (UnName 2)), + "global i1 icmp sge (i32* @1, i32* @2)" + ), ( + "getelementptr", + ptr i32, + C.GetElementPtr True (C.GlobalReference (ptr i32) (UnName 1)) [C.Int 64 27], + "global i32* getelementptr inbounds (i32, i32* @1, i64 27)" + ), ( + "selectvalue", + i32, + C.Select (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i1) + (C.Int 32 1) + (C.Int 32 2), + "global i32 select (i1 ptrtoint (i32* @1 to i1), i32 1, i32 2)" + ), ( + "extractelement", + i32, + C.ExtractElement + (C.BitCast + (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) + (VectorType 2 i32)) + (C.Int 32 1), + "global i32 extractelement (<2 x i32> bitcast (i64 ptrtoint (i32* @1 to i64) to <2 x i32>), i32 1)" + ), ( + "addrspacecast", + (PointerType i32 (AddrSpace 1)), + C.AddrSpaceCast (C.GlobalReference (ptr i32) (UnName 1)) (PointerType i32 (AddrSpace 1)), + "global i32 addrspace(1)* addrspacecast (i32* @1 to i32 addrspace(1)*)" +{- ), ( +-- This test fails since LLVM 3.2! +-- LLVM parses the extractValue instruction from a file via llvm-as properly, but it does not here. +-- Rewritten by Andrew April 2021 to match the specific example in the LLVM language reference: +-- https://llvm.org/docs/LangRef.html#extractvalue-instruction +-- Bug filed with upstream here: https://bugs.llvm.org/show_bug.cgi?id=50092 + "extractvalue", + i32, + C.ExtractValue + (C.Struct Nothing False [C.Int 32 0, C.Int 32 1]) + [0], + "global i32 extractvalue ({i32, i32} {i32 0, i32 1}, 0)" +-} + ) + ], + let mAST = Module "" "" Nothing Nothing [ + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 0, G.type' = type', G.initializer = Just value + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 1, G.type' = i32, G.initializer = Nothing + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 2, G.type' = i32, G.initializer = Nothing + } + ] + mStr = "; ModuleID = ''\nsource_filename = \"\"\n\n@0 = " <> str <> "\n\ + \@1 = external global i32\n\ + \@2 = external global i32\n" + ] diff --git a/test/LLVM/Test/DataLayout.hs b/test/LLVM/Test/DataLayout.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/DataLayout.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.DataLayout where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Monad.IO.Class +import Data.Maybe +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.Context +import LLVM.Module +import LLVM.AST +import LLVM.AST.DataLayout +import LLVM.AST.AddrSpace +import qualified LLVM.AST.Global as G +import LLVM.Internal.Coding +import LLVM.Internal.DataLayout +import LLVM.Internal.EncodeAST +import LLVM.Internal.FFI.DataLayout (getTypeAllocSize) + +m s = "; ModuleID = ''\nsource_filename = \"\"\n" <> s +t s = "target datalayout = \"" <> s <> "\"\n" +ddl = defaultDataLayout BigEndian + +tests = testGroup "DataLayout" $ + testCase "getTypeAllocSize" (withContext $ \ctx -> runEncodeAST ctx $ do + ty <- encodeM (IntegerType 8) + liftIO $ do + size <- + withFFIDataLayout + (ddl { typeLayouts = Map.singleton (IntegerAlign, 8) (AlignmentInfo 8 8) }) + (\dl -> getTypeAllocSize dl ty) + size @?= 1 + size <- + withFFIDataLayout + (ddl { typeLayouts = Map.singleton (IntegerAlign, 8) (AlignmentInfo 32 32) }) + (\dl -> getTypeAllocSize dl ty) + size @?= 4) + : + [ + testCase name $ strCheckC (Module "" "" mdl Nothing []) (m sdl) (m sdlc) + | (name, mdl, sdl, sdlc) <- [ + ("none", Nothing, "", "") + ] ++ [ + (name, Just mdl, t sdl, t (fromMaybe sdl msdlc)) + | (name, mdl, sdl, msdlc) <- [ + ("little-endian", defaultDataLayout LittleEndian, "e", Nothing), + ("big-endian", defaultDataLayout BigEndian, "E", Nothing), + ("native", ddl { nativeSizes = Just (Set.fromList [8,32]) }, "E-n8:32", Nothing), + ( + "no pref", + ddl { + pointerLayouts = + Map.singleton + (AddrSpace 0) + ( + 8, + AlignmentInfo 64 64 + ) + }, + "E-p:8:64", + Nothing + ), ( + "no pref", + ddl { + pointerLayouts = + Map.insert (AddrSpace 1) (8, AlignmentInfo 32 64) (pointerLayouts ddl) + }, + "E-p1:8:32:64", + Nothing + ), ( + "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", + Nothing + ) + ] + ] + ] diff --git a/test/LLVM/Test/ExecutionEngine.hs b/test/LLVM/Test/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/ExecutionEngine.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE + FlexibleContexts, + ForeignFunctionInterface, + OverloadedStrings + #-} +module LLVM.Test.ExecutionEngine where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Monad +import Data.Functor +import Data.Maybe + +import Foreign.Ptr +import Data.Word + +import LLVM.Context +import LLVM.Module +import LLVM.ExecutionEngine +import LLVM.AST +import LLVM.AST.Type +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import qualified LLVM.AST.IntegerPredicate as IPred + +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C + +foreign import ccall "dynamic" mkIO32Stub :: FunPtr (Word32 -> IO Word32) -> (Word32 -> IO Word32) + +testJIT :: ExecutionEngine e (FunPtr ()) => (Context -> (e -> IO ()) -> IO ()) -> Assertion +testJIT withEE = withContext $ \context -> withEE context $ \executionEngine -> do + let mAST = Module "runSomethingModule" "runSomethingModule" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "_foo", + G.parameters = ([Parameter i32 (Name "bar") []],False), + G.basicBlocks = [ + BasicBlock (UnName 0) [] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 42))) [] + ) + ] + } + ] + + s <- withModuleFromAST context mAST $ \m -> do + withModuleInEngine executionEngine m $ \em -> do + Just p <- getFunction em (Name "_foo") + (mkIO32Stub ((castFunPtr p) :: FunPtr (Word32 -> IO Word32))) 7 + s @?= 42 + +tests = testGroup "ExecutionEngine" [ + testCase "run something with MCJIT" $ testJIT (\c -> withMCJIT c Nothing Nothing Nothing Nothing) + ] diff --git a/test/LLVM/Test/FunctionAttribute.hs b/test/LLVM/Test/FunctionAttribute.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/FunctionAttribute.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module LLVM.Test.FunctionAttribute where + +import Test.Tasty +import Test.Tasty.QuickCheck hiding ( (.&.) ) + +import LLVM.Test.Support + +import LLVM.AST.FunctionAttribute +import LLVM.Internal.Coding +import LLVM.Internal.Context +import LLVM.Internal.EncodeAST +import LLVM.Internal.DecodeAST +import qualified LLVM.Internal.FFI.Attribute as FFI + +import Control.Applicative +import Data.Bits +import Data.List +import Text.Show.Pretty +import Control.Monad.IO.Class (liftIO) +import Prelude +import qualified Data.ByteString.Short as B + + +instance Arbitrary FunctionAttribute where + arbitrary = oneof + [ return AlwaysInline + , return ArgMemOnly + , return Builtin + , return Cold + , return Convergent + , return InaccessibleMemOnly + , return InaccessibleMemOrArgMemOnly + , return InlineHint + , return JumpTable + , return MinimizeSize + , return Naked + , return NoBuiltin + , return NoDuplicate + , return NoFree + , return NoImplicitFloat + , return NoInline + , return NonLazyBind + , return NoRecurse + , return NoRedZone + , return NoReturn + , return NoUnwind + , return OptimizeForSize + , return OptimizeNone + , return ReadNone + , return ReadOnly + , return ReturnsTwice + , return SafeStack + , return SanitizeAddress + , return SanitizeHWAddress + , return SanitizeMemory + , return SanitizeThread + , return Speculatable + , return StackProtect + , return StackProtectReq + , return StackProtectStrong + , return StrictFP + , return UWTable + , return WriteOnly + , StackAlignment <$> elements (map (2^) [0..8 :: Int]) + , StringAttribute <$> (B.pack <$> arbitrary) <*> (B.pack <$> arbitrary) + , suchThat (AllocSize <$> arbitrary <*> arbitrary) (/= AllocSize 0 (Just 0)) + ] + + shrink = \case + StackAlignment x -> map StackAlignment (nub [ v | u <- shrink x, let v = ceilPow2 u, v /= x ]) + StringAttribute x y -> [ StringAttribute (B.pack x') y | x' <- shrink (B.unpack x) ] + ++ [ StringAttribute x (B.pack y') | y' <- shrink (B.unpack y) ] + AllocSize x y -> [ AllocSize x' y | x' <- shrink x, not (x' == 0 && y == Just 0) ] + ++ [ AllocSize x y' | y' <- shrink y, not (x == 0 && y' == Just 0) ] + _ -> [] + + +tests :: TestTree +tests = + testGroup "FunctionAttribute" + [ testProperty "round-trip" $ \attr -> + ioProperty $ withContext $ \ctx -> do + attr' <- runEncodeAST ctx $ do + attrSet <- encodeM [attr] :: EncodeAST FFI.FunctionAttributeSet + liftIO (runDecodeAST (decodeM attrSet :: DecodeAST [FunctionAttribute])) + return $ counterexample (unlines [ "expected: " ++ ppShow [attr] + , "but got: " ++ ppShow attr' + ]) + ([attr] == attr') + ] + + +isPow2 :: (Bits a, Num a) => a -> Bool +isPow2 0 = True +isPow2 1 = False +isPow2 n = n .&. (n - 1) == 0 + +ceilPow2 :: (Bits a, Integral a) => a -> a +ceilPow2 n + | isPow2 n = n + | otherwise = + let x = logBase 2 (fromIntegral n) :: Double + y = floor x + 1 + in + 1 `shiftL` y + diff --git a/test/LLVM/Test/Global.hs b/test/LLVM/Test/Global.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Global.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Global where + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Monoid +import qualified Data.ByteString.Char8 as ByteString +import Data.ByteString.Short (fromShort) + +import LLVM.Test.Support + +import LLVM.Context +import LLVM.Module +import LLVM.AST +import LLVM.AST.Type as A.T +import qualified LLVM.AST.Global as G + +tests = testGroup "Global" [ + testGroup "Alignment" [ + testCase name $ withContext $ \context -> do + let ast = Module "" "" Nothing Nothing [ GlobalDefinition g ] + ast' <- withModuleFromAST context ast moduleAST + ast' @?= ast + | a <- [0,1], + s <- [Nothing, Just "foo"], + g <- [ + globalVariableDefaults { + G.name = UnName 0, + G.type' = i32, + G.alignment = a, + G.section = s + }, + functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.parameters = ([], False), + G.alignment = a, + G.section = s + } + ], + let + gn (G.Function {}) = "function" + gn (G.GlobalVariable {}) = "variable" + name = gn g <> ", align " <> show a <> (maybe "" ((" section " <>) . ByteString.unpack . fromShort) s) + ] + ] diff --git a/test/LLVM/Test/IRBuilder.hs b/test/LLVM/Test/IRBuilder.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/IRBuilder.hs @@ -0,0 +1,635 @@ +{-# 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/test/LLVM/Test/InlineAssembly.hs b/test/LLVM/Test/InlineAssembly.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/InlineAssembly.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.InlineAssembly where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import LLVM.Context +import LLVM.Module + +import LLVM.AST +import LLVM.AST.Type +import LLVM.AST.InlineAssembly as IA +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Constant as C +import qualified LLVM.AST.Global as G + +tests = testGroup "InlineAssembly" [ + testCase "expression" $ do + let ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ + functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []],False), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Call { + tailCallKind = Nothing, + callingConvention = CC.C, + returnAttributes = [], + function = Left $ InlineAssembly { + IA.type' = FunctionType i32 [i32] False, + assembly = "bswap $0", + constraints = "=r,r", + hasSideEffects = False, + alignStack = False, + dialect = ATTDialect + }, + arguments = [ + (LocalReference i32 (Name "x"), []) + ], + functionAttributes = [], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + } + + ] + s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define i32 @foo(i32 %x) {\n\ + \ %1 = call i32 asm \"bswap $0\", \"=r,r\"(i32 %x)\n\ + \ ret i32 %1\n\ + \}\n" + strCheck ast s, + + testCase "module" $ do + let ast = Module "" "" Nothing Nothing [ + ModuleInlineAssembly "foo", + ModuleInlineAssembly "bar", + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 0, + G.type' = i32 + } + ] + s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \module asm \"foo\"\n\ + \module asm \"bar\"\n\ + \\n\ + \@0 = external global i32\n" + strCheck ast s + ] diff --git a/test/LLVM/Test/Instructions.hs b/test/LLVM/Test/Instructions.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Instructions.hs @@ -0,0 +1,1279 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module LLVM.Test.Instructions where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (Arbitrary(..), (===), ioProperty, oneof, testProperty) + +import LLVM.Test.Support + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as ByteString +import Data.Functor +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Maybe +import Data.Monoid +import Foreign.Ptr +import Data.Word + +import LLVM.Context +import LLVM.Module +import LLVM.Diagnostic +import LLVM.AST +import LLVM.AST.Type as A.T +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import qualified LLVM.AST.IntegerPredicate as IPred +import qualified LLVM.AST.FloatingPointPredicate as FPPred +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C +import qualified LLVM.AST.RMWOperation as RMWOp + +import LLVM.Internal.Coding (decodeM, encodeM) +import qualified LLVM.Internal.FFI.LLVMCTypes as FFI + +tests = testGroup "Instructions" [ + testGroup "regular" [ + testCase name $ do + let mAST = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.parameters = ([Parameter t (UnName n) [] | (t,n) <- zip ts [0..]], False), + G.basicBlocks = [ + BasicBlock (UnName 7) [ + namedInstr + ] ( + Do $ Ret Nothing [] + ) + ] + } + ] + mStr = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0(i32 %0, float %1, i32* %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6) {\n\ + \ " <> namedInstrS <> "\n\ + \ ret void\n\ + \}\n" + strCheck mAST mStr + | let ts = [ + i32, + float, + ptr i32, + i64, + i1, + VectorType 2 i32, + StructureType False [i32, i32] + ], + let a i = LocalReference (ts !! fromIntegral i) (UnName i), + (name, namedInstr, namedInstrS :: ByteString) <- ( + [ + (name, UnName 8 := instr, "%8 = " <> instrS) + | (name, instr, instrS) <- [ + --("fneg", + -- FNeg { + -- fastMathFlags = noFastMathFlags, + -- operand0 = a 1, + -- metadata = [] + -- }, + -- "fneg float %1"), + ("add", + Add { + nsw = False, + nuw = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "add i32 %0, %0"), + ("nsw", + Add { + nsw = True, + nuw = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "add nsw i32 %0, %0"), + ("nuw", + Add { + nsw = False, + nuw = True, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "add nuw i32 %0, %0"), + ("fadd", + FAdd { + fastMathFlags = noFastMathFlags, + operand0 = a 1, + operand1 = a 1, + metadata = [] + }, + "fadd float %1, %1"), + ("sub", + Sub { + nsw = False, + nuw = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "sub i32 %0, %0"), + ("fsub", + FSub { + fastMathFlags = noFastMathFlags, + operand0 = a 1, + operand1 = a 1, + metadata = [] + }, + "fsub float %1, %1"), + ("mul", + Mul { + nsw = False, + nuw = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "mul i32 %0, %0"), + ("fmul", + FMul { + fastMathFlags = noFastMathFlags, + operand0 = a 1, + operand1 = a 1, + metadata = [] + }, + "fmul float %1, %1"), + ("udiv", + UDiv { + exact = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "udiv i32 %0, %0"), + ("exact", + UDiv { + exact = True, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "udiv exact i32 %0, %0"), + ("sdiv", + SDiv { + exact = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "sdiv i32 %0, %0"), + ("fdiv", + FDiv { + fastMathFlags = noFastMathFlags, + operand0 = a 1, + operand1 = a 1, + metadata = [] + }, + "fdiv float %1, %1"), + ("urem", + URem { + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "urem i32 %0, %0"), + ("srem", + SRem { + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "srem i32 %0, %0"), + ("frem", + FRem { + fastMathFlags = noFastMathFlags, + operand0 = a 1, + operand1 = a 1, + metadata = [] + }, + "frem float %1, %1"), + ("frem fast", + FRem { + fastMathFlags = FastMathFlags { + allowReassoc = True, + noNaNs = True, + noInfs = True, + noSignedZeros = True, + allowReciprocal = True, + allowContract = True, + approxFunc = True + }, + operand0 = a 1, + operand1 = a 1, + metadata = [] + }, + "frem fast float %1, %1"), + ("shl", + Shl { + nsw = False, + nuw = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "shl i32 %0, %0"), + ("ashr", + AShr { + exact = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "ashr i32 %0, %0"), + ("lshr", + LShr { + exact = False, + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "lshr i32 %0, %0"), + ("and", + And { + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "and i32 %0, %0"), + ("or", + Or { + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "or i32 %0, %0"), + ("xor", + Xor { + operand0 = a 0, + operand1 = a 0, + metadata = [] + }, + "xor i32 %0, %0"), + ("alloca", + Alloca { + allocatedType = i32, + numElements = Nothing, + alignment = 4, + metadata = [] + }, + "alloca i32, align 4"), + ("alloca tricky", + Alloca { + allocatedType = IntegerType 7, + numElements = Just (ConstantOperand (C.Int 32 2)), + alignment = 128, + metadata = [] + }, + "alloca i7, i32 2, align 128"), + ("load", + Load { + volatile = False, + address = a 2, + maybeAtomicity = Nothing, + alignment = 4, + metadata = [] + }, + "load i32, i32* %2, align 4"), + ("volatile", + Load { + volatile = True, + address = a 2, + maybeAtomicity = Nothing, + alignment = 4, + metadata = [] + }, + "load volatile i32, i32* %2, align 4"), + ("acquire", + Load { + volatile = False, + address = a 2, + maybeAtomicity = Just (System, Acquire), + alignment = 1, + metadata = [] + }, + "load atomic i32, i32* %2 acquire, align 1"), + ("singlethread", + Load { + volatile = False, + address = a 2, + maybeAtomicity = Just (SingleThread, Monotonic), + alignment = 1, + metadata = [] + }, + "load atomic i32, i32* %2 syncscope(\"singlethread\") monotonic, align 1"), + ("GEP", + GetElementPtr { + inBounds = False, + address = a 2, + indices = [ a 0 ], + metadata = [] + }, + "getelementptr i32, i32* %2, i32 %0"), + ("inBounds", + GetElementPtr { + inBounds = True, + address = a 2, + indices = [ a 0 ], + metadata = [] + }, + "getelementptr inbounds i32, i32* %2, i32 %0"), + ("cmpxchg", + CmpXchg { + volatile = False, + address = a 2, + expected = a 0, + replacement = a 0, + atomicity = (System, Monotonic), + failureMemoryOrdering = Monotonic, + metadata = [] + }, + "cmpxchg i32* %2, i32 %0, i32 %0 monotonic monotonic"), + ("atomicrmw", + AtomicRMW { + volatile = False, + rmwOperation = RMWOp.UMax, + address = a 2, + value = a 0, + atomicity = (System, Release), + metadata = [] + }, + "atomicrmw umax i32* %2, i32 %0 release"), + + ("trunc", + Trunc { + operand0 = a 0, + type' = i16, + metadata = [] + }, + "trunc i32 %0 to i16"), + ("zext", + ZExt { + operand0 = a 0, + type' = i64, + metadata = [] + }, + "zext i32 %0 to i64"), + ("sext", + SExt { + operand0 = a 0, + type' = i64, + metadata = [] + }, + "sext i32 %0 to i64"), + ("fptoui", + FPToUI { + operand0 = a 1, + type' = i64, + metadata = [] + }, + "fptoui float %1 to i64"), + ("fptosi", + FPToSI { + operand0 = a 1, + type' = i64, + metadata = [] + }, + "fptosi float %1 to i64"), + ("uitofp", + UIToFP { + operand0 = a 0, + type' = float, + metadata = [] + }, + "uitofp i32 %0 to float"), + ("sitofp", + SIToFP { + operand0 = a 0, + type' = float, + metadata = [] + }, + "sitofp i32 %0 to float"), + ("fptrunc", + FPTrunc { + operand0 = a 1, + type' = half, + metadata = [] + }, + "fptrunc float %1 to half"), + ("fpext", + FPExt { + operand0 = a 1, + type' = double, + metadata = [] + }, + "fpext float %1 to double"), + ("ptrtoint", + PtrToInt { + operand0 = a 2, + type' = i32, + metadata = [] + }, + "ptrtoint i32* %2 to i32"), + ("inttoptr", + IntToPtr { + operand0 = a 0, + type' = ptr i32, + metadata = [] + }, + "inttoptr i32 %0 to i32*"), + ("bitcast", + BitCast { + operand0 = a 0, + type' = float, + metadata = [] + }, + "bitcast i32 %0 to float"), + ("addrspacecast", + AddrSpaceCast { + operand0 = a 2, + type' = PointerType i32 (AddrSpace 2), + metadata = [] + }, + "addrspacecast i32* %2 to i32 addrspace(2)*"), + ("select", + Select { + condition' = a 4, + trueValue = a 0, + falseValue = a 0, + metadata = [] + }, + "select i1 %4, i32 %0, i32 %0"), + ("vaarg", + VAArg { + argList = a 2, + type' = i16, + metadata = [] + }, + "va_arg i32* %2, i16"), + ("extractelement", + ExtractElement { + vector = a 5, + index = a 0, + metadata = [] + }, + "extractelement <2 x i32> %5, i32 %0"), + ("insertelement", + InsertElement { + vector = a 5, + element = a 0, + index = a 0, + metadata = [] + }, + "insertelement <2 x i32> %5, i32 %0, i32 %0"), + ("shufflevector", + ShuffleVector { + operand0 = a 5, + operand1 = a 5, + mask = [0..1], + metadata = [] + }, + "shufflevector <2 x i32> %5, <2 x i32> %5, <2 x i32> "), + ("extractvalue", + ExtractValue { + aggregate = a 6, + indices' = [0], + metadata = [] + }, + "extractvalue { i32, i32 } %6, 0"), + ("insertvalue", + InsertValue { + aggregate = a 6, + element = a 0, + indices' = [0], + metadata = [] + }, + "insertvalue { i32, i32 } %6, i32 %0, 0") + ] ++ [ + ("landingpad-" ++ n, + LandingPad { + type' = StructureType False [ + ptr i8, + i32 + ], + cleanup = cp, + clauses = cls, + metadata = [] + }, + "landingpad { i8*, i32 }" <> s) + | (clsn,cls,clss) <- [ + ("catch", + [Catch (C.Null (ptr i8))], + "\n catch i8* null"), + ("filter", + [Filter (C.AggregateZero (ArrayType 1 (ptr i8)))], + "\n filter [1 x i8*] zeroinitializer") + ], + (cpn, cp, cps) <- [ ("-cleanup", True, "\n cleanup"), ("", False, "") ], + let s = cps <> clss + n = clsn <> cpn + ] ++ [ + ("icmp-" ++ ByteString.unpack ps, + ICmp { iPredicate = p, operand0 = a 0, operand1 = a 0, metadata = [] }, + "icmp " <> ps <> " i32 %0, %0") + | (ps, p) <- [ + ("eq", IPred.EQ), + ("ne", IPred.NE), + ("ugt", IPred.UGT), + ("uge", IPred.UGE), + ("ult", IPred.ULT), + ("ule", IPred.ULE), + ("sgt", IPred.SGT), + ("sge", IPred.SGE), + ("slt", IPred.SLT), + ("sle", IPred.SLE) + ] + ] ++ [ + ("fcmp-" ++ ByteString.unpack ps, + FCmp { fpPredicate = p, operand0 = a 1, operand1 = a 1, metadata = [] }, + "fcmp " <> ps <> " float %1, %1") + | (ps, p) <- [ + ("false", FPPred.False), + ("oeq", FPPred.OEQ), + ("ogt", FPPred.OGT), + ("oge", FPPred.OGE), + ("olt", FPPred.OLT), + ("ole", FPPred.OLE), + ("one", FPPred.ONE), + ("ord", FPPred.ORD), + ("uno", FPPred.UNO), + ("ueq", FPPred.UEQ), + ("ugt", FPPred.UGT), + ("uge", FPPred.UGE), + ("ult", FPPred.ULT), + ("ule", FPPred.ULE), + ("une", FPPred.UNE), + ("true", FPPred.True) + ] + ] + ] ++ [ + ("store", + Do $ Store { + volatile = False, + address = a 2, + value = a 0, + maybeAtomicity = Nothing, + alignment = 4, + metadata = [] + }, + "store i32 %0, i32* %2, align 4"), + ("fence", + Do $ Fence { + atomicity = (System, Acquire), + metadata = [] + }, + "fence acquire"), + ("call", + Do $ Call { + tailCallKind = Nothing, + callingConvention = CC.C, + returnAttributes = [], + function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0))), + arguments = [ (a i, []) | i <- [0..6] ], + functionAttributes = [], + metadata = [] + }, + "call void @0(i32 %0, float %1, i32* %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6)") + ] + ) + ], + testCase "GEP inBounds constant" $ do + let mAST = Module "" "" Nothing Nothing [ + GlobalDefinition $ globalVariableDefaults { + G.name = Name "fortytwo", + G.type' = i32, + G.isConstant = True, + G.initializer = Just $ C.Int 32 42 + }, + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (UnName 1) [ + UnName 2 := GetElementPtr { + inBounds = True, + address = ConstantOperand (C.GlobalReference (ptr i32) (Name "fortytwo")), + indices = [ ConstantOperand (C.Int 32 0) ], + metadata = [] + }, + UnName 3 := Load { + volatile = False, + address = LocalReference (ptr i32) (UnName 2), + maybeAtomicity = Nothing, + alignment = 1, + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 3))) [] + ) + ] + } + ] + mStr = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \@fortytwo = constant i32 42\n\ + \\n\ + \define i32 @0() {\n\ + \ %1 = getelementptr inbounds i32, i32* @fortytwo, i32 0\n\ + \ %2 = load i32, i32* %1, align 1\n\ + \ ret i32 %2\n\ + \}\n" + s <- withContext $ \context -> withModuleFromAST context mAST moduleLLVMAssembly + s @?= mStr, + + testGroup "terminators" [ + testCase name $ strCheck mAST mStr + | (name, mAST, mStr) <- [ + ( + "ret", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (UnName 0) [ + ] ( + Do $ Ret Nothing [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0() {\n\ + \ ret void\n\ + \}\n" + ), ( + "br", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (UnName 0) [] ( + Do $ Br (Name "foo") [] + ), + BasicBlock (Name "foo") [] ( + Do $ Ret Nothing [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0() {\n\ + \ br label %foo\n\ + \\n\ + \foo: ; preds = %0\n\ + \ ret void\n\ + \}\n" + ), ( + "condbr", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (Name "bar") [] ( + Do $ CondBr (ConstantOperand (C.Int 1 1)) (Name "foo") (Name "bar") [] + ), + BasicBlock (Name "foo") [] ( + Do $ Ret Nothing [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0() {\n\ + \bar:\n\ + \ br i1 true, label %foo, label %bar\n\ + \\n\ + \foo: ; preds = %bar\n\ + \ ret void\n\ + \}\n" + ), ( + "switch", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (UnName 0) [] ( + Do $ Switch { + operand0' = ConstantOperand (C.Int 16 2), + defaultDest = Name "foo", + dests = [ + (C.Int 16 0, UnName 0), + (C.Int 16 2, Name "foo"), + (C.Int 16 3, UnName 0) + ], + metadata' = [] + } + ), + BasicBlock (Name "foo") [] ( + Do $ Ret Nothing [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0() {\n\ + \ switch i16 2, label %foo [\n\ + \ i16 0, label %0\n\ + \ i16 2, label %foo\n\ + \ i16 3, label %0\n\ + \ ]\n\ + \\n\ + \foo: ; preds = %0, %0\n\ + \ ret void\n\ + \}\n" + ), ( + "indirectbr", + Module "" "" Nothing Nothing [ + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 0, + G.type' = ptr i8, + G.initializer = Just (C.BlockAddress (Name "foo") (UnName 2)) + }, + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = Name "foo", + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Load { + volatile = False, + address = ConstantOperand (C.GlobalReference (ptr (ptr i8)) (UnName 0)), + maybeAtomicity = Nothing, + alignment = 8, + metadata = [] + } + ] ( + Do $ IndirectBr { + operand0' = LocalReference (ptr i8) (UnName 1), + possibleDests = [UnName 2], + metadata' = [] + } + ), + BasicBlock (UnName 2) [] ( + Do $ Ret Nothing [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \@0 = global i8* blockaddress(@foo, %2)\n\ + \\n\ + \define void @foo() {\n\ + \ %1 = load i8*, i8** @0, align 8\n\ + \ indirectbr i8* %1, [label %2]\n\ + \\n\ + \2: ; preds = %0\n\ + \ ret void\n\ + \}\n" + ), ( + "invoke", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.personalityFunction = Just $ C.GlobalReference + (ptr (FunctionType A.T.void [i32,i16] False)) + (UnName 0) + , + G.parameters = ([ + Parameter i32 (UnName 0) [], + Parameter i16 (UnName 1) [] + ], False), + G.basicBlocks = [ + BasicBlock (UnName 2) [] ( + Do $ Invoke { + callingConvention' = CC.C, + returnAttributes' = [], + function' = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [i32, i16] False)) (UnName 0))), + arguments' = [ + (ConstantOperand (C.Int 32 4), []), + (ConstantOperand (C.Int 16 8), []) + ], + functionAttributes' = [], + returnDest = Name "foo", + exceptionDest = Name "bar", + metadata' = [] + } + ), + BasicBlock (Name "foo") [] ( + Do $ Ret Nothing [] + ), + BasicBlock (Name "bar") [ + UnName 3 := LandingPad { + type' = StructureType False [ + ptr i8, + i32 + ], + cleanup = True, + clauses = [Catch (C.Null (ptr i8))], + metadata = [] + } + ] ( + Do $ Ret Nothing [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0(i32 %0, i16 %1) personality void (i32, i16)* @0 {\n\ + \ invoke void @0(i32 4, i16 8)\n\ + \ to label %foo unwind label %bar\n\ + \\n\ + \foo: ; preds = %2\n\ + \ ret void\n\ + \\n\ + \bar: ; preds = %2\n\ + \ %3 = landingpad { i8*, i32 }\n\ + \ cleanup\n\ + \ catch i8* null\n\ + \ ret void\n\ + \}\n" + ), ( + "resume", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (UnName 0) [] ( + Do $ Resume (ConstantOperand (C.Int 32 1)) [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0() {\n\ + \ resume i32 1\n\ + \}\n" + ), ( + "unreachable", + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = UnName 0, + G.basicBlocks = [ + BasicBlock (UnName 0) [] ( + Do $ Unreachable [] + ) + ] + } + ], + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @0() {\n\ + \ unreachable\n\ + \}\n" + ), ( -- This testcase is taken from test/Feature/exception.ll in LLVM + "cleanupret0", + Module { + moduleName = "", + moduleSourceFileName = "", + moduleDataLayout = Nothing, + moduleTargetTriple = Nothing, + moduleDefinitions = [ + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "_Z3quxv" + }, + GlobalDefinition functionDefaults { + G.returnType = IntegerType {typeBits = 32}, + G.name = Name "__gxx_personality_v0", + G.parameters = ([], True) + }, + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "cleanupret0", + G.basicBlocks = [ + G.BasicBlock (Name "entry") [] ( + Do Invoke { + callingConvention' = CC.C, + returnAttributes' = [], + function' = Right ( + ConstantOperand ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, + pointerAddrSpace = AddrSpace 0 + } (Name "_Z3quxv") + ) + ), + arguments' = [], + returnDest = Name "exit", + exceptionDest = Name "pad", + metadata' = [], + functionAttributes' = [] + } + ), + G.BasicBlock + (Name "pad") + [Name "cp" := CleanupPad { parentPad = ConstantOperand C.TokenNone, args = [ConstantOperand C.Int { C.integerBits = 7, C.integerValue = 4 }], metadata = [] }] + ( + Do CleanupRet { + cleanupPad = LocalReference TokenType (Name "cp"), + unwindDest = Nothing, + metadata' = [] + } + ), + G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) + ], + G.personalityFunction = Just ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, + pointerAddrSpace = AddrSpace 0 + } (Name "__gxx_personality_v0") + ) + } + ] + }, + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \declare void @_Z3quxv()\n\ + \\n\ + \declare i32 @__gxx_personality_v0(...)\n\ + \\n\ + \define void @cleanupret0() personality i32 (...)* @__gxx_personality_v0 {\n\ + \entry:\n\ + \ invoke void @_Z3quxv()\n\ + \ to label %exit unwind label %pad\n\ + \\n\ + \pad: ; preds = %entry\n\ + \ %cp = cleanuppad within none [i7 4]\n\ + \ cleanupret from %cp unwind to caller\n\ + \\n\ + \exit: ; preds = %entry\n\ + \ ret void\n\ + \}\n" + ), ( -- This testcase is taken from test/Feature/exception.ll in LLVM + "cleanupret1", + Module { + moduleName = "", + moduleSourceFileName = "", + moduleDataLayout = Nothing, + moduleTargetTriple = Nothing, + moduleDefinitions = [ + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "_Z3quxv" + }, + GlobalDefinition functionDefaults { + G.returnType = IntegerType {typeBits = 32}, + G.name = Name "__gxx_personality_v0", + G.parameters = ([], True) + }, + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "cleanupret1", + G.basicBlocks = [ + G.BasicBlock (Name "entry") [] ( + Do Invoke { + callingConvention' = CC.C, + returnAttributes' = [], + function' = Right ( + ConstantOperand ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, + pointerAddrSpace = AddrSpace 0 + } (Name "_Z3quxv") + ) + ), + arguments' = [], + returnDest = Name "exit", + exceptionDest = Name "pad", + metadata' = [], + functionAttributes' = [] + } + ), + G.BasicBlock + (Name "cleanup") + [] + (Do CleanupRet { + cleanupPad = LocalReference TokenType (Name "cp"), + unwindDest = Nothing, + metadata' = [] + }), + G.BasicBlock + (Name "pad") + [Name "cp" := CleanupPad { parentPad = ConstantOperand C.TokenNone, args = [], metadata = [] }] + (Do Br { dest = Name "cleanup", metadata' = [] }), + G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) + ], + G.personalityFunction = Just ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, + pointerAddrSpace = AddrSpace 0 + } (Name "__gxx_personality_v0") + ) + } + ] + }, + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \declare void @_Z3quxv()\n\ + \\n\ + \declare i32 @__gxx_personality_v0(...)\n\ + \\n\ + \define void @cleanupret1() personality i32 (...)* @__gxx_personality_v0 {\n\ + \entry:\n\ + \ invoke void @_Z3quxv()\n\ + \ to label %exit unwind label %pad\n\ + \\n\ + \cleanup: ; preds = %pad\n\ + \ cleanupret from %cp unwind to caller\n\ + \\n\ + \pad: ; preds = %entry\n\ + \ %cp = cleanuppad within none []\n\ + \ br label %cleanup\n\ + \\n\ + \exit: ; preds = %entry\n\ + \ ret void\n\ + \}\n" + ), ( -- This testcase is taken from test/Feature/exception.ll in LLVM + "catchret0", + Module { + moduleName = "", + moduleSourceFileName = "", + moduleDataLayout = Nothing, + moduleTargetTriple = Nothing, + moduleDefinitions = [ + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "_Z3quxv" + }, + GlobalDefinition functionDefaults { + G.returnType = IntegerType {typeBits = 32}, + G.name = Name "__gxx_personality_v0", + G.parameters = ([], True) + }, + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "catchret0", + G.basicBlocks = [ + G.BasicBlock (Name "entry") [] ( + Do Invoke { + callingConvention' = CC.C, + returnAttributes' = [], + function' = Right ( + ConstantOperand ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, + pointerAddrSpace = AddrSpace 0 + } (Name "_Z3quxv") + ) + ), + arguments' = [], + returnDest = Name "exit", + exceptionDest = Name "pad", + metadata' = [], + functionAttributes' = [] + } + ), + G.BasicBlock (Name "pad") [] ( + Name "cs1" := CatchSwitch { + parentPad' = ConstantOperand C.TokenNone, + catchHandlers = (Name "catch" :| []), + defaultUnwindDest = Nothing, + metadata' = [] + } + ), + G.BasicBlock + (Name "catch") + [Name "cp" := CatchPad { catchSwitch = LocalReference TokenType (Name "cs1"), args = [ConstantOperand C.Int { C.integerBits = 7, C.integerValue = 4 }], metadata = [] }] ( + Do CatchRet { + catchPad = LocalReference TokenType (Name "cp"), + successor = Name "exit", + metadata' = [] + } + ), + G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) + ], + G.personalityFunction = Just ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, + pointerAddrSpace = AddrSpace 0 + } (Name "__gxx_personality_v0") + ) + } + ] + }, + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \declare void @_Z3quxv()\n\ + \\n\ + \declare i32 @__gxx_personality_v0(...)\n\ + \\n\ + \define void @catchret0() personality i32 (...)* @__gxx_personality_v0 {\n\ + \entry:\n\ + \ invoke void @_Z3quxv()\n\ + \ to label %exit unwind label %pad\n\ + \\n\ + \pad: ; preds = %entry\n\ + \ %cs1 = catchswitch within none [label %catch] unwind to caller\n\ + \\n\ + \catch: ; preds = %pad\n\ + \ %cp = catchpad within %cs1 [i7 4]\n\ + \ catchret from %cp to label %exit\n\ + \\n\ + \exit: ; preds = %catch, %entry\n\ + \ ret void\n\ + \}\n" + ), ( -- This testcase is taken from test/Feature/exception.ll in LLVM + "catchret1", + Module { + moduleName = "", + moduleSourceFileName = "", + moduleDataLayout = Nothing, + moduleTargetTriple = Nothing, + moduleDefinitions = [ + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "_Z3quxv" + }, + GlobalDefinition functionDefaults { + G.returnType = IntegerType {typeBits = 32}, + G.name = Name "__gxx_personality_v0", + G.parameters = ([], True) + }, + GlobalDefinition functionDefaults { + G.returnType = VoidType, + G.name = Name "catchret0", + G.basicBlocks = [ + G.BasicBlock (Name "entry") [] ( + Do Invoke { + callingConvention' = CC.C, + returnAttributes' = [], + function' = Right ( + ConstantOperand ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, + pointerAddrSpace = AddrSpace 0 + } (Name "_Z3quxv") + ) + ), + arguments' = [], + returnDest = Name "exit", + exceptionDest = Name "pad", + metadata' = [], + functionAttributes' = [] + } + ), + G.BasicBlock (Name "catchret") [] ( + Do CatchRet { + catchPad = LocalReference TokenType (Name "cp"), + successor = Name "exit", + metadata' = [] + } + ), + G.BasicBlock (Name "pad") [] ( + Name "cs1" := CatchSwitch { + parentPad' = ConstantOperand C.TokenNone, + catchHandlers = (Name "catch" :| []), + defaultUnwindDest = Nothing, + metadata' = [] + } + ), + G.BasicBlock + (Name "catch") + [Name "cp" := CatchPad { catchSwitch = LocalReference TokenType (Name "cs1"), args = [ConstantOperand C.Int { C.integerBits = 7, C.integerValue = 4 }], metadata = [] }] ( + Do Br { dest = (Name "catchret"), metadata' = [] } + ), + G.BasicBlock (Name "exit") [] (Do Ret { returnOperand = Nothing, metadata' = [] }) + ], + G.personalityFunction = Just ( + C.GlobalReference PointerType { + pointerReferent = FunctionType {resultType = IntegerType { typeBits = 32 }, argumentTypes = [], isVarArg = True}, + pointerAddrSpace = AddrSpace 0 + } (Name "__gxx_personality_v0") + ) + } + ] + }, + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \declare void @_Z3quxv()\n\ + \\n\ + \declare i32 @__gxx_personality_v0(...)\n\ + \\n\ + \define void @catchret0() personality i32 (...)* @__gxx_personality_v0 {\n\ + \entry:\n\ + \ invoke void @_Z3quxv()\n\ + \ to label %exit unwind label %pad\n\ + \\n\ + \catchret: ; preds = %catch\n\ + \ catchret from %cp to label %exit\n\ + \\n\ + \pad: ; preds = %entry\n\ + \ %cs1 = catchswitch within none [label %catch] unwind to caller\n\ + \\n\ + \catch: ; preds = %pad\n\ + \ %cp = catchpad within %cs1 [i7 4]\n\ + \ br label %catchret\n\ + \\n\ + \exit: ; preds = %catchret, %entry\n\ + \ ret void\n\ + \}\n" + ) + ] + ], + + testGroup "fast-math flags" [ + testProperty "roundtrip" $ \flags -> + ioProperty $ withContext $ \ctx -> do + encodedFlags <- encodeM flags :: IO FFI.FastMathFlags + decodedFlags <- decodeM encodedFlags :: IO FastMathFlags + pure (decodedFlags === flags) + ] + ] + +instance Arbitrary FastMathFlags where + arbitrary = oneof + [ pure noFastMathFlags + , FastMathFlags <$> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary <*> + arbitrary + ] diff --git a/test/LLVM/Test/Instrumentation.hs b/test/LLVM/Test/Instrumentation.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Instrumentation.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Instrumentation where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Monad.Trans.Except +import Control.Monad.Except (catchError) +import Control.Monad.IO.Class + +import Data.Functor hiding (void) +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.Module +import LLVM.Context +import LLVM.PassManager +import LLVM.Transforms +import LLVM.Target + +import LLVM.AST as A +import LLVM.AST.Type +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import LLVM.AST.DataLayout +import LLVM.Triple +import qualified LLVM.AST.IntegerPredicate as IPred +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C + +instrument :: PassSetSpec -> A.Module -> IO A.Module +instrument s m = withContext $ \context -> withModuleFromAST context m $ \mIn' -> do + withPassManager s $ \pm -> runPassManager pm mIn' + moduleAST mIn' + +ast = do + dl <- withHostTargetMachineDefault getTargetMachineDataLayout + triple <- liftIO getDefaultTargetTriple + return $ Module "" "" (Just dl) (Just triple) [ + -- This function is needed for AddressSanitizerModule + GlobalDefinition $ functionDefaults { + G.returnType = void, + G.name = Name "asan.module_ctor", + G.basicBlocks = [BasicBlock (UnName 0) [] (Do (Ret Nothing []))] + }, + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i128 (Name "x") []],False), + G.basicBlocks = [ + BasicBlock (UnName 0) [] (Do $ Br (Name "checkDone") []), + BasicBlock (Name "checkDone") [ + UnName 1 := Phi { + type' = i128, + incomingValues = [ + (LocalReference i128 (Name "x"), UnName 0), + (LocalReference i128 (Name "x'"), Name "even"), + (LocalReference i128 (Name "x''"), Name "odd") + ], + metadata = [] + }, + Name "count" := Phi { + type' = i32, + incomingValues = [ + (ConstantOperand (C.Int 32 1), UnName 0), + (LocalReference i32 (Name "count'"), Name "even"), + (LocalReference i32 (Name "count'"), Name "odd") + ], + metadata = [] + }, + Name "count'" := Add { + nsw = False, + nuw = False, + operand0 = LocalReference i32 (Name "count"), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + }, + Name "is one" := ICmp { + iPredicate = IPred.EQ, + operand0 = LocalReference i128 (UnName 1), + operand1 = ConstantOperand (C.Int 128 1), + metadata = [] + } + ] ( + Do $ CondBr (LocalReference i1 (Name "is one")) (Name "done") (Name "checkOdd") [] + ), + BasicBlock (Name "checkOdd") [ + Name "is odd" := Trunc (LocalReference i128 (UnName 1)) i1 [] + ] ( + Do $ CondBr (LocalReference i1 (Name "is odd")) (Name "odd") (Name "even") [] + ), + BasicBlock (Name "even") [ + Name "x'" := UDiv True (LocalReference i128 (UnName 1)) (ConstantOperand (C.Int 128 2)) [] + ] ( + Do $ Br (Name "checkDone") [] + ), + BasicBlock (Name "odd") [ + UnName 2 := Mul False False (LocalReference i128 (UnName 1)) (ConstantOperand (C.Int 128 3)) [], + Name "x''" := Add False False (LocalReference i128 (UnName 2)) (ConstantOperand (C.Int 128 1)) [] + ] ( + Do $ Br (Name "checkDone") [] + ), + BasicBlock (Name "done") [ + ] ( + Do $ Ret (Just (LocalReference i32 (Name "count'"))) [] + ) + ] + }, + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "main", + G.parameters = ([ + Parameter i32 (Name "argc") [], + Parameter (ptr (ptr i8)) (Name "argv") [] + ],False), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Call { + tailCallKind = Nothing, + callingConvention = CC.C, + returnAttributes = [], + function = Right + (ConstantOperand + (C.GlobalReference + (PointerType + { pointerReferent = FunctionType i32 [i128] False + , pointerAddrSpace = AddrSpace 0}) + (Name "foo"))), + arguments = [ + (ConstantOperand (C.Int 128 9491828328), []) + ], + functionAttributes = [], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + } + ] + +isMemorySanitizerSupported :: IO Bool +isMemorySanitizerSupported = do + triple <- getProcessTargetTriple + let ~(Right triple') = runExcept (parseTriple triple) + let os' = os triple' + return $ Set.member os' (Set.fromList [FreeBSD, NetBSD, Linux]) + +instrumentationPasses :: [(TestName, Pass, IO Bool)] +instrumentationPasses = [ + ("GCOVProfiler", defaultGCOVProfiler, return True), + ("AddressSanitizer", defaultAddressSanitizer, return True), + ("AddressSanitizerModule", defaultAddressSanitizerModule, return True), + ("ThreadSanitizer", defaultThreadSanitizer, return True), + ("BoundsChecking", BoundsChecking, return True), + ("MemorySanitizer", defaultMemorySanitizer, isMemorySanitizerSupported) + ] + +tests = + testGroup "Instrumentation" [ + testGroup "basic" [ + testCase n $ do + shouldTest <- checkIfShouldTest + if not shouldTest + then return () + else do + triple <- getProcessTargetTriple + withTargetLibraryInfo triple $ \tli -> do + dl <- withHostTargetMachineDefault getTargetMachineDataLayout + ast <- ast + ast' <- instrument (defaultPassSetSpec { transforms = [p], dataLayout = Just dl, targetLibraryInfo = Just tli }) ast + let names ast = [ n | GlobalDefinition d <- moduleDefinitions ast, Name n <- return (G.name d) ] + names ast' `List.intersect` names ast @?= names ast + | + (n, p, checkIfShouldTest) <- instrumentationPasses + ] + ] diff --git a/test/LLVM/Test/Linking.hs b/test/LLVM/Test/Linking.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Linking.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Linking where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Monad.Trans.Except +import Data.Functor +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.Module +import LLVM.Context +import LLVM.PassManager +import LLVM.Transforms +import LLVM.Target + +import LLVM.AST as A +import LLVM.AST.Type +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import LLVM.AST.DataLayout +import qualified LLVM.AST.IntegerPredicate as IPred +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C + +tests = testGroup "Linking" [ + testCase "basic" $ do + let + ast0 = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.linkage = L.Private, + G.returnType = i32, + G.name = Name "private0" + }, + GlobalDefinition $ functionDefaults { + G.linkage = L.External, + G.returnType = i32, + G.name = Name "external0" + } + ] + ast1 = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.linkage = L.Private, + G.returnType = i32, + G.name = Name "private1" + }, + GlobalDefinition $ functionDefaults { + G.linkage = L.External, + G.returnType = i32, + G.name = Name "external1" + } + ] + + Module { moduleDefinitions = defs } <- withContext $ \context -> + withModuleFromAST context ast0 $ \dest -> do + withModuleFromAST context ast0 $ \src -> do + linkModules dest src + moduleAST dest + [ n | GlobalDefinition g <- defs, let Name n = G.name g ] @?= [ "private0", "external0" ] + ] diff --git a/test/LLVM/Test/Metadata.hs b/test/LLVM/Test/Metadata.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Metadata.hs @@ -0,0 +1,1047 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module LLVM.Test.Metadata where + +import LLVM.Prelude + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.QuickCheck as QC + +import LLVM.Test.Support + +import Control.Monad.IO.Class +import Data.ByteString as B (readFile) +import qualified Data.ByteString.Short as BSS +import Data.Functor.Identity +import Data.Maybe (catMaybes) +import Foreign.Ptr +import Text.Show.Pretty (pPrint) + +import qualified LLVM.AST.IntegerPredicate as IP +import LLVM.AST as A hiding (GlobalVariable, PointerType) +import LLVM.AST.Operand hiding (Module) +import qualified LLVM.AST.Operand as O +import qualified LLVM.AST.Operand as A (DIFlag(..), Virtuality(..), DIInheritance(..), DIAccessibility(..)) +import LLVM.AST.Type as A.T hiding (PointerType) +import LLVM.AST.AddrSpace as A +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Constant as C +import LLVM.AST.Global as G hiding (GlobalVariable) + +import LLVM.Context +import LLVM.Module +import LLVM.Internal.Coding +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import qualified LLVM.Internal.FFI.PtrHierarchy as FFI +import qualified LLVM.Internal.FFI.Metadata as FFI + +tests = testGroup "Metadata" + [ globalMetadata + , namedMetadata + , nullMetadata + , cyclicMetadata + , metadataConstantFolding + , globalObjectMetadata + , roundtripDIBasicType + , roundtripDIDerivedType + , roundtripDISubroutineType + , roundtripDIArrayType + , roundtripDIEnumerationType + , roundtripDIStructureType + , roundtripDIClassType + , roundtripDIUnionType + , roundtripDIFile + , roundtripDINode + , roundtripDICompileUnit + , roundtripDIVariable + , roundtripDIFlags + , roundtripDISubprogram + , roundtripDILexicalBlockBase + , roundtripDITemplateParameter + , roundtripDINamespace + , roundtripDIExpression + , diFlagName + , testFile + ] + +instance Arbitrary Encoding where + arbitrary = + QC.elements + [ AddressEncoding + , BooleanEncoding + , FloatEncoding + , SignedEncoding + , SignedCharEncoding + , UnsignedEncoding + , UnsignedCharEncoding + , UTFEncoding + ] + +instance Arbitrary ChecksumInfo where + arbitrary = + oneof + [ ChecksumInfo MD5 . BSS.pack <$> QC.vector 32 + , ChecksumInfo SHA1 . BSS.pack <$> QC.vector 40 + ] + +instance Arbitrary BasicTypeTag where + arbitrary = QC.elements [BaseType, UnspecifiedType] + +instance Arbitrary DIType where + arbitrary = oneof [DIBasicType <$> arbitrary] + +instance Arbitrary DIBasicType where + arbitrary = BasicType <$> arbitrarySbs <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> genDIFlags + +genDIArrayType :: Maybe (MDRef DIType) -> Gen DICompositeType +genDIArrayType elTy = + DIArrayType <$> arbitrary <*> pure elTy <*> arbitrary <*> arbitrary <*> genDIFlags + +instance Arbitrary DIMacroInfo where + arbitrary = QC.elements [Define, Undef] + +genDIMacro :: Gen DIMacroNode +genDIMacro = + DIMacro <$> arbitrary <*> arbitrary <*> arbitrarySbs <*> arbitrarySbs + +roundtripDIArrayType :: TestTree +roundtripDIArrayType = testProperty "roundtrip DIArrayType" $ \elType -> + forAll (genDIArrayType (Just (MDRef elTyID))) $ \diArrayType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [arrayTypeID] + , MetadataNodeDefinition arrayTypeID (DINode (DIScope (DIType (DICompositeType diArrayType)))) + , MetadataNodeDefinition elTyID (DINode (DIScope (DIType elType))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where arrayTypeID = MetadataNodeID 0 + elTyID = MetadataNodeID 1 + +genDIEnumerationType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> Gen DICompositeType +genDIEnumerationType scope file baseTy = + DIEnumerationType + <$> pure scope + <*> arbitrarySbs + <*> pure file + <*> arbitrary + <*> arbitrary + <*> pure baseTy + <*> arbitrarySbs + <*> arbitrary + <*> arbitrary + +roundtripDIEnumerationType :: TestTree +roundtripDIEnumerationType = testProperty "roundtrip DIEnumerationType" $ \file baseType -> + forAll (genDIEnumerationType Nothing (Just (MDRef fileID)) (Just (MDRef baseTyID))) $ \diEnumType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [enumTypeID] + , MetadataNodeDefinition enumTypeID (DINode (DIScope (DIType (DICompositeType diEnumType)))) + , MetadataNodeDefinition fileID (DINode (DIScope (DIFile file))) + , MetadataNodeDefinition baseTyID (DINode (DIScope (DIType baseType))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where enumTypeID = MetadataNodeID 0 + fileID = MetadataNodeID 1 + baseTyID = MetadataNodeID 2 + +genDIStructureType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> [MDRef (Either DIDerivedType DISubprogram)] -> Maybe (MDRef DIType) -> Gen DICompositeType +genDIStructureType scope file derivedFrom elements vtableHolder = + DIStructureType + <$> pure scope + <*> arbitrarySbs + <*> pure file + <*> arbitrary + <*> genDIFlags + <*> pure derivedFrom + <*> pure elements + <*> arbitrary + <*> pure vtableHolder + <*> arbitrarySbs + <*> arbitrary + <*> arbitrary + +roundtripDIStructureType :: TestTree +roundtripDIStructureType = testProperty "roundtrip DIStructureType" $ + forAll (genDIStructureType Nothing Nothing Nothing [] Nothing) $ \diStructureType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [structureTypeID] + , MetadataNodeDefinition structureTypeID (DINode (DIScope (DIType (DICompositeType diStructureType)))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where structureTypeID = MetadataNodeID 0 + +genDIClassType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> [MDRef (Either DIDerivedType DISubprogram)] -> Maybe (MDRef DIType) -> [DITemplateParameter] -> Gen DICompositeType +genDIClassType scope file derivedFrom elements vtableHolder templateParams = + DIClassType + <$> pure scope + <*> arbitrarySbs + <*> pure file + <*> arbitrary + <*> genDIFlags + <*> pure derivedFrom + <*> pure elements + <*> pure vtableHolder + <*> pure templateParams + <*> arbitrarySbs + <*> arbitrary + <*> arbitrary + +roundtripDIClassType :: TestTree +roundtripDIClassType = testProperty "roundtrip DIClassType" $ + forAll (genDIClassType Nothing Nothing Nothing [] Nothing []) $ \diClassType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [classTypeID] + , MetadataNodeDefinition classTypeID (DINode (DIScope (DIType (DICompositeType diClassType)))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where classTypeID = MetadataNodeID 0 + +genDIUnionType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> [MDRef (Either DIDerivedType DISubprogram)] -> Gen DICompositeType +genDIUnionType scope file elements = + DIUnionType + <$> pure scope + <*> arbitrarySbs + <*> pure file + <*> arbitrary + <*> genDIFlags + <*> pure elements + <*> arbitrary + <*> arbitrarySbs + <*> arbitrary + <*> arbitrary + +roundtripDIUnionType :: TestTree +roundtripDIUnionType = testProperty "roundtrip DIUnionType" $ + forAll (genDIUnionType Nothing Nothing []) $ \diUnionType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [unionTypeID] + , MetadataNodeDefinition unionTypeID (DINode (DIScope (DIType (DICompositeType diUnionType)))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where unionTypeID = MetadataNodeID 0 + +instance Arbitrary DIFile where + arbitrary = + O.File <$> arbitrarySbs <*> arbitrarySbs <*> arbitrary + +instance Arbitrary DISubrange where + arbitrary = Subrange <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary DICount where + -- TODO: Also generate non-trivial DICountVariable case. + arbitrary = DICountConstant <$> arbitrary + +instance Arbitrary DIBound where + -- TODO: Also generate non-trivial DIBoundVariable, DIBoundExpression cases. + arbitrary = DIBoundConstant <$> arbitrary + +instance Arbitrary DIEnumerator where + arbitrary = Enumerator <$> arbitrary <*> arbitrary <*> arbitrarySbs + +instance Arbitrary DINode where + arbitrary = + oneof + [ DISubrange <$> arbitrary + , DIEnumerator <$> arbitrary + -- TODO: Also generate non-trivial cases. + ] + +roundtripDIBasicType :: TestTree +roundtripDIBasicType = testProperty "roundtrip DIBasicType" $ \diType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + encodedDIType <- encodeM (diType :: DIType) + decodedDIType <- liftIO (runDecodeAST (decodeM (encodedDIType :: Ptr FFI.DIType))) + pure (decodedDIType === diType) + +roundtripDIDerivedType :: TestTree +roundtripDIDerivedType = testProperty "roundtrip DIDerivedType" $ \baseType -> + forAll (QC.elements [Nothing, Just (MDRef baseTypeID)]) $ \baseType' -> + forAll (genDIDerivedType Nothing Nothing baseType') $ \diDerivedType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [derivedTypeID] + , NamedMetadataDefinition "dummy2" [baseTypeID] + , MetadataNodeDefinition derivedTypeID (DINode (DIScope (DIType (DIDerivedType diDerivedType)))) + , MetadataNodeDefinition baseTypeID (DINode (DIScope (DIType baseType))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where derivedTypeID = MetadataNodeID 0 + baseTypeID = MetadataNodeID 1 + +instance Arbitrary DerivedTypeTag where + arbitrary = + QC.elements [ Typedef, PointerType, PtrToMemberType, ReferenceType, RValueReferenceType + , ConstType, VolatileType, RestrictType, AtomicType, Member, Inheritance, Friend + ] + +genDIDerivedType :: Maybe (MDRef DIFile) -> Maybe (MDRef DIScope) -> Maybe (MDRef DIType) -> Gen DIDerivedType +genDIDerivedType file scope baseType = + DerivedType + <$> arbitrary + <*> arbitrarySbs + <*> pure file + <*> arbitrary + <*> pure scope + <*> pure baseType + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> genDIFlags + +roundtripDISubroutineType :: TestTree +roundtripDISubroutineType = testProperty "roundtrip DISubroutineType" $ \argType -> + forAll (genDISubroutineType [Nothing, Just (MDRef argTypeID)]) $ \diSubroutineType -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [subroutineTypeID] + , MetadataNodeDefinition subroutineTypeID (DINode (DIScope (DIType (DISubroutineType diSubroutineType)))) + , MetadataNodeDefinition argTypeID (DINode (DIScope (DIType argType))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where subroutineTypeID = MetadataNodeID 0 + argTypeID = MetadataNodeID 1 + +genDISubroutineType :: [Maybe (MDRef DIType)] -> Gen DISubroutineType +genDISubroutineType types = + SubroutineType + <$> genDIFlags + <*> arbitrary + <*> pure types + +roundtripDIFile :: TestTree +roundtripDIFile = testProperty "roundtrip DIFile" $ \diFile -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + encodedDIFile <- encodeM (diFile :: DIFile) + decodedDIFile <- liftIO (runDecodeAST (decodeM (encodedDIFile :: Ptr FFI.DIFile))) + pure (decodedDIFile === diFile) + +roundtripDINode :: TestTree +roundtripDINode = testProperty "roundtrip DINode" $ \diNode -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + encodedDINode <- encodeM (diNode :: DINode) + decodedDINode :: Either String DINode <- liftIO (runDecodeAST (decodeM (encodedDINode :: Ptr FFI.DINode))) + pure (decodedDINode === (Right diNode)) + +roundtripDICompileUnit :: TestTree +roundtripDICompileUnit = testProperty "roundtrip DICompileUnit" $ \diFile retainedType -> + forAll genDIMacro $ \diMacro -> + forAll (genDICompileUnit (MDRef fileID) (MDRef retainedID) (MDRef macroID)) $ \diCompileUnit -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [cuID] + , NamedMetadataDefinition "dummyMacro" [macroID] + , NamedMetadataDefinition "dummyRetained" [retainedID] + , MetadataNodeDefinition cuID (DINode (DIScope (DICompileUnit diCompileUnit))) + , MetadataNodeDefinition macroID (DIMacroNode diMacro) + , MetadataNodeDefinition retainedID (DINode (DIScope (DIType retainedType))) + , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where cuID = MetadataNodeID 0 + macroID = MetadataNodeID 1 + retainedID = MetadataNodeID 2 + fileID = MetadataNodeID 3 + +genDICompileUnit :: MDRef DIFile -> MDRef (Either DIType DISubprogram) -> MDRef DIMacroNode -> Gen DICompileUnit +genDICompileUnit file retained macro = + CompileUnit + <$> arbitrary + <*> pure file + <*> arbitrarySbs + <*> arbitrary + <*> arbitrarySbs + <*> arbitrary + <*> arbitrarySbs + <*> arbitrary + <*> pure [] + <*> listOf (pure retained) + <*> pure [] + <*> pure [] + <*> listOf (pure macro) + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary DebugEmissionKind where + arbitrary = QC.elements [NoDebug, FullDebug, LineTablesOnly] + +instance Arbitrary DebugNameTableKind where + arbitrary = QC.elements [NameTableKindDefault, NameTableKindGNU, NameTableKindNone] + +roundtripDIVariable :: TestTree +roundtripDIVariable = testProperty "roundtrip DIVariable" $ \diFile diType -> + forAll (genDIVariable Nothing (Just (MDRef fileID)) (Just (MDRef typeID))) $ \diVariable -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [varID] + , MetadataNodeDefinition varID (DINode (DIVariable diVariable)) + , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile))) + , MetadataNodeDefinition typeID (DINode (DIScope (DIType diType))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where varID = MetadataNodeID 0 + fileID = MetadataNodeID 1 + typeID = MetadataNodeID 2 + +genDIVariable :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> Gen DIVariable +genDIVariable diScope diFile diType = + case diScope of + Nothing -> DIGlobalVariable <$> globalVar + Just scope -> oneof [DILocalVariable <$> localVar scope, DIGlobalVariable <$> globalVar] + where + localVar scope = + LocalVariable + <$> arbitrarySbs + <*> pure scope + <*> pure diFile + <*> arbitrary + <*> pure diType + <*> genDIFlags + <*> arbitrary + <*> arbitrary + globalVar = + GlobalVariable + <$> arbitrarySbs + <*> pure diScope + <*> pure diFile + <*> arbitrary + <*> pure diType + <*> arbitrarySbs + <*> arbitrary + <*> arbitrary + <*> pure Nothing + <*> pure [] + <*> arbitrary + +instance Arbitrary A.DIInheritance where + arbitrary = QC.elements [A.SingleInheritance, A.MultipleInheritance, A.VirtualInheritance] + +instance Arbitrary A.DIAccessibility where + arbitrary = QC.elements [A.Public, A.Protected, A.Private] + +instance Arbitrary A.DIFlag where + arbitrary = + oneof + [ A.Accessibility <$> arbitrary + , A.InheritanceFlag <$> arbitrary + , QC.elements + [ A.FwdDecl + , A.AppleBlock + , A.VirtualFlag + , A.Artificial + , A.Explicit + , A.Prototyped + , A.ObjcClassComplete + , A.ObjectPointer + , A.Vector + , A.StaticMember + , A.LValueReference + , A.RValueReference + , A.IntroducedVirtual + , A.BitField + , A.NoReturn + , A.TypePassByValue + , A.TypePassByReference + , A.EnumClass + , A.Thunk + , A.NonTrivial + , A.BigEndian + , A.LittleEndian + , A.AllCallsDescribed + ] + ] + +roundtripDIFlags :: TestTree +roundtripDIFlags = + testProperty "roundtrip DIFlags" $ + forAll genDIFlags $ \diFlags -> + let Identity encodedFlags = encodeM diFlags + Identity decodedFlags = decodeM (encodedFlags :: FFI.DIFlags) + in decodedFlags === diFlags + +genDIFlags :: Gen [DIFlag] +genDIFlags = do + accessibility <- + QC.elements [Nothing, Just A.Public, Just A.Protected, Just A.Private] + inheritance <- + QC.elements + [ Nothing + , Just A.SingleInheritance + , Just A.MultipleInheritance + , Just A.VirtualInheritance + ] + maybeFlags <- traverse (\f -> QC.elements [Nothing, Just f]) flags + pure + (catMaybes + ((A.Accessibility <$> accessibility) : + (A.InheritanceFlag <$> inheritance) : maybeFlags)) + where + flags = + [ A.FwdDecl + , A.AppleBlock + , A.VirtualFlag + , A.Artificial + , A.Explicit + , A.Prototyped + , A.ObjcClassComplete + , A.ObjectPointer + , A.Vector + , A.StaticMember + , A.LValueReference + , A.RValueReference + , A.IntroducedVirtual + , A.BitField + , A.NoReturn + , A.TypePassByValue + , A.TypePassByReference + , A.EnumClass + , A.Thunk + , A.NonTrivial + , A.BigEndian + , A.LittleEndian + , A.AllCallsDescribed + ] + +roundtripDISubprogram :: TestTree +roundtripDISubprogram = testProperty "roundtrip DISubprogram" $ + forAll (genDISubprogram Nothing Nothing Nothing Nothing Nothing [] Nothing [] []) $ \diSubprogram -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [subprogramID] + , MetadataNodeDefinition subprogramID (DINode (DIScope (DILocalScope (DISubprogram diSubprogram)))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where subprogramID = MetadataNodeID 0 + +genDISubprogram :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DISubroutineType) -> + Maybe (MDRef DIType) -> Maybe (MDRef DICompileUnit) -> [MDRef DITemplateParameter] -> + Maybe (MDRef DISubprogram) -> + [MDRef DILocalVariable] -> [MDRef DIType] -> Gen DISubprogram +genDISubprogram scope file type' containingType unit templateParams decl vars thrownTypes = + Subprogram + <$> pure scope + <*> arbitrarySbs + <*> arbitrarySbs + <*> pure file + <*> arbitrary + <*> pure type' + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure containingType + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> genDIFlags + <*> arbitrary + <*> pure unit + <*> pure templateParams + <*> pure decl + <*> pure vars + <*> pure thrownTypes + +roundtripDILexicalBlockBase :: TestTree +roundtripDILexicalBlockBase = testProperty "roundtrip DILexicalBlockBase" $ \diFile -> + forAll (genDISubprogram Nothing Nothing Nothing Nothing Nothing [] Nothing [] []) $ \diSubprogram -> + forAll (genDILexicalBlockBase (MDRef subprogramID) (Just (MDRef fileID))) $ \block -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [blockID] + , MetadataNodeDefinition blockID (DINode (DIScope (DILocalScope (DILexicalBlockBase block)))) + , MetadataNodeDefinition subprogramID (DINode (DIScope (DILocalScope (DISubprogram diSubprogram)))) + , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where blockID = MetadataNodeID 0 + subprogramID = MetadataNodeID 1 + fileID = MetadataNodeID 2 + +genDILexicalBlockBase :: MDRef DILocalScope -> Maybe (MDRef DIFile) -> Gen DILexicalBlockBase +genDILexicalBlockBase scope file = + oneof + [ DILexicalBlock scope file <$> arbitrary <*> arbitrary + , DILexicalBlockFile scope file <$> arbitrary + ] + +instance Arbitrary Virtuality where + arbitrary = QC.elements [A.NoVirtuality, A.Virtual, A.PureVirtual] + +roundtripDITemplateParameter :: TestTree +roundtripDITemplateParameter = testProperty "roundtrip DITemplateParameter" $ \diType -> + forAll (genDITemplateParameter (MDValue (ConstantOperand (C.Int 32 1))) (MDRef tyID)) $ \param -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [paramID] + , NamedMetadataDefinition "dummyTy" [tyID] + , MetadataNodeDefinition paramID (DINode (DITemplateParameter param)) + , MetadataNodeDefinition tyID (DINode (DIScope (DIType diType))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where paramID = MetadataNodeID 0 + tyID = MetadataNodeID 1 + +instance Arbitrary TemplateValueParameterTag where + arbitrary = QC.elements [TemplateValueParameter, GNUTemplateTemplateParam, GNUTemplateParameterPack] + +genDITemplateParameter :: Metadata -> MDRef DIType -> Gen DITemplateParameter +genDITemplateParameter value ty = + oneof [ DITemplateTypeParameter <$> arbitrarySbs <*> pure (Just ty) + , DITemplateValueParameter <$> arbitrarySbs <*> pure Nothing <*> pure (Just value) <*> arbitrary + ] + +roundtripDINamespace :: TestTree +roundtripDINamespace = testProperty "roundtrip DINamespace" $ \diFile -> + forAll (genDINamespace (MDRef fileID)) $ \diNamespace -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + let mod = defaultModule + { moduleDefinitions = + [ NamedMetadataDefinition "dummy" [namespaceID] + , NamedMetadataDefinition "dummy2" [fileID] + , MetadataNodeDefinition namespaceID (DINode (DIScope (DINamespace diNamespace))) + , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile))) + ] + } + mod' <- liftIO (withModuleFromAST context mod moduleAST) + pure (mod' === mod) + where namespaceID = MetadataNodeID 0 + fileID = MetadataNodeID 1 + +genDINamespace :: MDRef DIScope -> Gen DINamespace +genDINamespace scope = Namespace <$> arbitrarySbs <*> QC.elements [Nothing, Just scope] <*> arbitrary + +diFlagName :: TestTree +diFlagName = + testProperty "LLVM and llvm-hs agree on encoding of DIFlag" $ \diFlag -> + ioProperty $ + withContext $ \context -> + runEncodeAST context $ do + encoded <- encodeM [diFlag] + flagName' <- encodeM ("DIFlag" <> flagName diFlag) + encodedByName <- liftIO (FFI.getDIFlag flagName') + pure (encoded === encodedByName) + where + flagName (A.Accessibility f) = show f + flagName (A.InheritanceFlag f) = show f + flagName A.VirtualFlag = "Virtual" + flagName f = show f + +roundtripDIExpression :: TestTree +roundtripDIExpression = testProperty "roundtrip DIExpression" $ + forAll genDIExpression $ \expr -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + encodedExpr <- encodeM expr + decodedExpr <- liftIO (runDecodeAST (decodeM (encodedExpr :: Ptr FFI.DIExpression))) + pure (decodedExpr === expr) + +genDIExpression :: Gen DIExpression +genDIExpression = Expression <$> arbitrary + +instance Arbitrary DWOp where + arbitrary = + oneof + [ DwOpFragment <$> (DW_OP_LLVM_Fragment <$> arbitrary <*> arbitrary) + , pure DW_OP_StackValue + , pure DW_OP_Swap + , pure DW_OP_Lit0 + , DW_OP_ConstU <$> arbitrary + , DW_OP_PlusUConst <$> arbitrary + , pure DW_OP_Plus + , pure DW_OP_Minus + , pure DW_OP_Mul + , pure DW_OP_Div + , pure DW_OP_Mod + , pure DW_OP_Not + , pure DW_OP_Or + , pure DW_OP_Xor + , pure DW_OP_And + , pure DW_OP_Shr + , pure DW_OP_Shra + , pure DW_OP_Shl + , pure DW_OP_Dup + , pure DW_OP_Deref + , pure DW_OP_XDeref + ] + +testFile :: TestTree +testFile = do + testGroup "file parsing and decoding" + [ testCase "test/debug_metadata_1.ll" $ do + fStr <- B.readFile "test/debug_metadata_1.ll" + withContext $ \context -> do + a <- withModuleFromLLVMAssembly' context fStr moduleAST + pure () + , testCase "test/debug_metadata_2.ll" $ do + fStr <- B.readFile "test/debug_metadata_2.ll" + withContext $ \context -> do + a <- withModuleFromLLVMAssembly' context fStr moduleAST + pure () + , testCase "test/debug_metadata_3.ll" $ do + fStr <- B.readFile "test/debug_metadata_3.ll" + withContext $ \context -> do + a <- withModuleFromLLVMAssembly' context fStr moduleAST + pure () + , testCase "test/debug_metadata_4.ll" $ do + fStr <- B.readFile "test/debug_metadata_4.ll" + withContext $ \context -> do + a <- withModuleFromLLVMAssembly' context fStr moduleAST + pure () + , testCase "test/debug_metadata_5.ll" $ do + fStr <- B.readFile "test/debug_metadata_5.ll" + withContext $ \context -> do + a <- withModuleFromLLVMAssembly' context fStr moduleAST + pure () + ] + +globalMetadata = testCase "global" $ do + let ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.basicBlocks = [ + BasicBlock (UnName 0) [ + ] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [ + ("my-metadatum", A.MDRef (MetadataNodeID 0)) + ] + ) + ] + }, + MetadataNodeDefinition (MetadataNodeID 0) (MDTuple [ Just $ MDValue $ ConstantOperand (C.Int 32 1) ]) + ] + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define i32 @foo() {\n\ + \ ret i32 0, !my-metadatum !0\n\ + \}\n\ + \\n\ + \!0 = !{i32 1}\n" + strCheck ast s + +namedMetadata = testCase "named" $ do + let ast = Module "" "" Nothing Nothing [ + NamedMetadataDefinition "my-module-metadata" [ MetadataNodeID 0 ], + MetadataNodeDefinition (MetadataNodeID 0) (MDTuple [ Just $ MDValue $ ConstantOperand (C.Int 32 1) ]) + ] + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \!my-module-metadata = !{!0}\n\ + \\n\ + \!0 = !{i32 1}\n" + strCheck ast s + +nullMetadata = testCase "null" $ do + let ast = Module "" "" Nothing Nothing [ + NamedMetadataDefinition "my-module-metadata" [ MetadataNodeID 0 ], + MetadataNodeDefinition (MetadataNodeID 0) (MDTuple [ Nothing ]) + ] + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \!my-module-metadata = !{!0}\n\ + \\n\ + \!0 = !{null}\n" + strCheck ast s + +cyclicMetadata = testGroup "cyclic" [ + testCase "metadata-only" $ do + let ast = Module "" "" Nothing Nothing [ + NamedMetadataDefinition "my-module-metadata" [MetadataNodeID 0], + MetadataNodeDefinition + (MetadataNodeID 0) + (MDTuple [Just $ MDNode (MDRef (MetadataNodeID 1))]), + MetadataNodeDefinition + (MetadataNodeID 1) + (MDTuple [Just $ MDNode (MDRef (MetadataNodeID 0))]) + ] + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \!my-module-metadata = !{!0}\n\ + \\n\ + \!0 = !{!1}\n\ + \!1 = !{!0}\n" + strCheck ast s, + + testCase "metadata-global" $ do + let ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = Name "foo", + G.basicBlocks = [ + BasicBlock (UnName 0) [ + ] ( + Do $ Ret Nothing [ ("my-metadatum", MDRef (MetadataNodeID 0)) ] + ) + ] + }, + MetadataNodeDefinition + (MetadataNodeID 0) + (MDTuple [Just $ MDValue $ ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [] False)) (Name "foo"))]) + ] + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @foo() {\n\ + \ ret void, !my-metadatum !0\n\ + \}\n\ + \\n\ + \!0 = !{void ()* @foo}\n" + strCheck ast s + ] + +metadataConstantFolding = testGroup "constant folding" [ + testCase "metadata on instructions that can be constant folded" $ + let ast = Module "" "" Nothing Nothing + [ GlobalDefinition functionDefaults + { name = "f" + , parameters = ([Parameter i32 "x" []] , False) + , returnType = i32 + , basicBlocks = + [ BasicBlock "if" + [UnName 0 := ICmp IP.EQ (ConstantOperand (C.Int 32 0)) (ConstantOperand (C.Int 32 0)) + [("foobar", MDRef (MetadataNodeID 0))] + ] + (Do (CondBr (LocalReference i1 (UnName 0)) "if.true" "if.false" [])) + , BasicBlock "if.true" [] + (Do (Ret (Just (ConstantOperand (C.Int 32 0))) [])) + , BasicBlock "if.false" [] + (Do (Ret (Just (ConstantOperand (C.Int 32 0))) [])) + ] + } + , MetadataNodeDefinition (MetadataNodeID 0) (MDTuple []) + ] + s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define i32 @f(i32 %x) {\n\ + \if:\n\ + \ %0 = icmp eq i32 0, 0, !foobar !0\n\ + \ br i1 %0, label %if.true, label %if.false\n\ + \\n\ + \if.true: ; preds = %if\n\ + \ ret i32 0\n\ + \\n\ + \if.false: ; preds = %if\n\ + \ ret i32 0\n\ + \}\n\ + \\n\ + \!0 = !{}\n" + in strCheck ast s + ] + +globalObjectMetadata = testGroup "Metadata on GlobalObject" $ + [ testCase "metadata on functions" $ do + let ast = Module "" "" Nothing Nothing + [ GlobalDefinition + functionDefaults + { G.name = "main" + , G.returnType = A.T.void + , basicBlocks = [ BasicBlock (UnName 0) [] (Do (Ret Nothing [])) ] + , G.metadata = [("dbg", MDRef (MetadataNodeID 0))] + } + , NamedMetadataDefinition "llvm.module.flags" [MetadataNodeID 1] + , NamedMetadataDefinition "llvm.dbg.cu" [MetadataNodeID 2] + , MetadataNodeDefinition (MetadataNodeID 0) $ + DINode .DIScope .DILocalScope . DISubprogram $ + Subprogram + { scope = Nothing + , name = "main" + , linkageName = "" + , file = Nothing + , line = 0 + , type' = Nothing + , localToUnit = False + , definition = True + , scopeLine = 0 + , containingType = Nothing + , virtuality = NoVirtuality + , virtualityIndex = 0 + , thisAdjustment = 0 + , flags = [] + , optimized = False + , unit = Just (MDRef (MetadataNodeID 2)) + , O.templateParams = [] + , declaration = Nothing + , retainedNodes = [] + , thrownTypes = [] + } + , MetadataNodeDefinition (MetadataNodeID 1) + (MDTuple [ Just (MDValue (ConstantOperand (C.Int 32 2))) + , Just (MDString "Debug Info Version") + , Just (MDValue (ConstantOperand (C.Int 32 3))) + ]) + , MetadataNodeDefinition (MetadataNodeID 2) $ + DINode . DIScope . DICompileUnit $ + CompileUnit + { language = 12 + , file = MDRef (MetadataNodeID 3) + , producer = "clang version 6.0.0 (tags/RELEASE_600/final)" + , optimized = True + , flags = "" + , runtimeVersion = 0 + , splitDebugFileName = "" + , emissionKind = FullDebug + , enums = [] + , retainedTypes = [] + , globals = [] + , imports = [] + , macros = [] + , dWOId = 0 + , splitDebugInlining = True + , debugInfoForProfiling = False + , nameTableKind = NameTableKindDefault + , rangesBaseAddress = False + } + , MetadataNodeDefinition (MetadataNodeID 3) $ + DINode . DIScope . DIFile $ + O.File "main.c" "/" Nothing + ] + s = + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @main() !dbg !3 {\n\ + \ ret void\n\ + \}\n\ + \\n\ + \!llvm.module.flags = !{!0}\n\ + \!llvm.dbg.cu = !{!1}\n\ + \\n\ + \!0 = !{i32 2, !\"Debug Info Version\", i32 3}\n\ + \!1 = distinct !DICompileUnit(language: DW_LANG_C99, file: !2, producer: \"clang version 6.0.0 (tags/RELEASE_600/final)\", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug)\n\ + \!2 = !DIFile(filename: \"main.c\", directory: \"/\")\n\ + \!3 = distinct !DISubprogram(name: \"main\", scope: null, spFlags: DISPFlagDefinition, unit: !1)\n" + strCheck ast s, + testCase "metadata on global variables" $ do + let ast = Module "" "" Nothing Nothing + [ GlobalDefinition + globalVariableDefaults + { G.name = "g" + , G.type' = A.T.i32 + , G.linkage = L.Common + , G.alignment = 4 + , G.initializer = Just (C.Int 32 0) + , G.metadata = [("dbg", MDRef (MetadataNodeID 0))] + } + , NamedMetadataDefinition "llvm.module.flags" [MetadataNodeID 1] + , NamedMetadataDefinition "llvm.dbg.cu" [MetadataNodeID 2] + , MetadataNodeDefinition (MetadataNodeID 0) $ + DIGlobalVariableExpression $ GlobalVariableExpression (MDRef (MetadataNodeID 3)) (MDRef (MetadataNodeID 4)) + , MetadataNodeDefinition (MetadataNodeID 1) + (MDTuple [ Just (MDValue (ConstantOperand (C.Int 32 2))) + , Just (MDString "Debug Info Version") + , Just (MDValue (ConstantOperand (C.Int 32 3))) + ]) + , MetadataNodeDefinition (MetadataNodeID 2) $ + DINode . DIScope . DICompileUnit $ + CompileUnit + { language = 12 + , file = MDRef (MetadataNodeID 5) + , producer = "clang version 6.0.0 (tags/RELEASE_600/final)" + , optimized = True + , flags = "" + , runtimeVersion = 0 + , splitDebugFileName = "" + , emissionKind = FullDebug + , enums = [] + , retainedTypes = [] + , globals = [] + , imports = [] + , macros = [] + , dWOId = 0 + , splitDebugInlining = True + , debugInfoForProfiling = False + , nameTableKind = NameTableKindDefault + , rangesBaseAddress = False + } + , MetadataNodeDefinition (MetadataNodeID 3) $ + DINode . DIVariable . DIGlobalVariable $ + GlobalVariable + { name = "g" + , scope = Nothing + , file = Nothing + , line = 0 + , type' = Just (MDRef (MetadataNodeID 6)) + , linkageName = "" + , local = False + , definition = True + , staticDataMemberDeclaration = Nothing + , templateParams = [] + , alignInBits = 0 + } + , MetadataNodeDefinition (MetadataNodeID 4) (DIExpression (Expression [])) + , MetadataNodeDefinition (MetadataNodeID 5) $ + DINode . DIScope . DIFile $ + O.File "main.c" "/" Nothing + , MetadataNodeDefinition (MetadataNodeID 6) $ + DINode . DIScope . DIType . DIBasicType $ + BasicType "" 0 0 Nothing BaseType [] + ] + s = + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \@g = common global i32 0, align 4, !dbg !0\n\ + \\n\ + \!llvm.module.flags = !{!3}\n\ + \!llvm.dbg.cu = !{!4}\n\ + \\n\ + \!0 = !DIGlobalVariableExpression(var: !1, expr: !DIExpression())\n\ + \!1 = !DIGlobalVariable(name: \"g\", scope: null, type: !2, isLocal: false, isDefinition: true)\n\ + \!2 = !DIBasicType()\n\ + \!3 = !{i32 2, !\"Debug Info Version\", i32 3}\n\ + \!4 = distinct !DICompileUnit(language: DW_LANG_C99, file: !5, producer: \"clang version 6.0.0 (tags/RELEASE_600/final)\", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug)\n\ + \!5 = !DIFile(filename: \"main.c\", directory: \"/\")\n" + strCheck ast s + ] diff --git a/test/LLVM/Test/Module.hs b/test/LLVM/Test/Module.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Module.hs @@ -0,0 +1,643 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Module where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Control.Exception +import Control.Monad.Trans.Except +import Data.Bits +import Data.Word + +import qualified Data.Map as Map + +import LLVM.Context +import LLVM.Exception +import LLVM.Module +import LLVM.Analysis +import LLVM.Diagnostic +import LLVM.Target +import LLVM.AST +import LLVM.AST.Type as T +import LLVM.AST.AddrSpace +import qualified LLVM.AST.IntegerPredicate as IPred + +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.FunctionAttribute as FA +import qualified LLVM.AST.ParameterAttribute as PA +import qualified LLVM.AST.ThreadLocalStorage as TLS +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C +import qualified LLVM.AST.COMDAT as COMDAT + +import qualified LLVM.Relocation as R +import qualified LLVM.CodeModel as CM +import qualified LLVM.CodeGenOpt as CGO + +handString = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \%0 = type { i32, %1*, %0* }\n\ + \%1 = type opaque\n\ + \\n\ + \$bob = comdat largest\n\ + \\n\ + \@0 = global i32 1\n\ + \@1 = external protected addrspace(3) global i32, section \"foo\", comdat($bob)\n\ + \@2 = unnamed_addr global i8 2\n\ + \@3 = external dllimport global %0\n\ + \@4 = external global [4294967296 x i32]\n\ + \@.argyle = thread_local global i32 0\n\ + \@5 = thread_local(localdynamic) global i32 1\n\ + \\n\ + \@three = private alias i32, i32 addrspace(3)* @1\n\ + \@two = unnamed_addr alias i32, i32 addrspace(3)* @three\n\ + \@one = thread_local(initialexec) alias i32, i32* @5\n\ + \\n\ + \define i32 @bar() prefix i32 1 {\n\ + \ %1 = musttail call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\ + \ ret i32 %1\n\ + \}\n\ + \\n\ + \define i32 @baz() prefix i32 1 {\n\ + \ %1 = notail call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\ + \ ret i32 %1\n\ + \}\n\ + \\n\ + \; Function Attrs: nounwind readnone uwtable\n\ + \define zeroext i32 @foo(i32 inreg align 16 %x, i8 signext %y) #0 {\n\ + \ %1 = mul nsw i32 %x, %x\n\ + \ br label %here\n\ + \\n\ + \here: ; preds = %0\n\ + \ %go = icmp eq i32 %1, %x\n\ + \ br i1 %go, label %there, label %elsewhere\n\ + \\n\ + \there: ; preds = %here\n\ + \ %2 = add nsw i32 %1, 3\n\ + \ br label %elsewhere\n\ + \\n\ + \elsewhere: ; preds = %there, %here\n\ + \ %r = phi i32 [ 2, %there ], [ 57, %here ]\n\ + \ ret i32 %r\n\ + \}\n\ + \\n\ + \attributes #0 = { nounwind readnone uwtable \"eep\" }\n" + +handAST = Module "" "" Nothing Nothing [ + TypeDefinition (UnName 0) ( + Just $ StructureType False [ + i32, + ptr (NamedTypeReference (UnName 1)), + ptr (NamedTypeReference (UnName 0)) + ]), + TypeDefinition (UnName 1) Nothing, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 0, + G.type' = i32, + G.initializer = Just (C.Int 32 1) + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 1, + G.visibility = V.Protected, + G.type' = i32, + G.addrSpace = AddrSpace 3, + G.section = Just "foo", + G.comdat = Just "bob" + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 2, + G.unnamedAddr = Just GlobalAddr, + G.type' = i8, + G.initializer = Just (C.Int 8 2) + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 3, + G.dllStorageClass = Just DLL.Import, + G.type' = NamedTypeReference (UnName 0) + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 4, + G.type' = ArrayType (1 `shift` 32) i32 + }, + GlobalDefinition $ globalVariableDefaults { + G.name = Name ".argyle", + G.type' = i32, + G.initializer = Just (C.Int 32 0), + G.threadLocalMode = Just TLS.GeneralDynamic + }, + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 5, + G.type' = i32, + G.threadLocalMode = Just TLS.LocalDynamic, + G.initializer = Just (C.Int 32 1) + }, + GlobalDefinition $ globalAliasDefaults { + G.name = Name "three", + G.linkage = L.Private, + G.type' = i32, + G.addrSpace = AddrSpace 3, + G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1) + }, + GlobalDefinition $ globalAliasDefaults { + G.name = Name "two", + G.unnamedAddr = Just GlobalAddr, + G.type' = i32, + G.addrSpace = AddrSpace 3, + G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (Name "three") + }, + GlobalDefinition $ globalAliasDefaults { + G.name = Name "one", + G.type' = i32, + G.aliasee = C.GlobalReference (ptr i32) (UnName 5), + G.threadLocalMode = Just TLS.InitialExec + }, + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "bar", + G.prefix = Just (C.Int 32 1), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Call { + tailCallKind = Just MustTail, + callingConvention = CC.C, + returnAttributes = [PA.ZeroExt], + function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))), + arguments = [ + (ConstantOperand (C.Int 32 1), [PA.InReg, PA.Alignment 16]), + (ConstantOperand (C.Int 8 4), [PA.SignExt]) + ], + functionAttributes = [Left (FA.GroupID 0)], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + }, + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "baz", + G.prefix = Just (C.Int 32 1), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Call { + tailCallKind = Just NoTail, + callingConvention = CC.C, + returnAttributes = [PA.ZeroExt], + function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))), + arguments = [ + (ConstantOperand (C.Int 32 1), [PA.InReg, PA.Alignment 16]), + (ConstantOperand (C.Int 8 4), [PA.SignExt]) + ], + functionAttributes = [Left (FA.GroupID 0)], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + }, + GlobalDefinition $ functionDefaults { + G.returnAttributes = [PA.ZeroExt], + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([ + Parameter i32 (Name "x") [PA.InReg, PA.Alignment 16], + Parameter i8 (Name "y") [PA.SignExt] + ], False), + G.functionAttributes = [Left (FA.GroupID 0)], + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = LocalReference i32 (Name "x"), + operand1 = LocalReference i32 (Name "x"), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + Name "go" := ICmp { + iPredicate = IPred.EQ, + operand0 = LocalReference i32 (UnName 1), + operand1 = LocalReference i32 (Name "x"), + metadata = [] + } + ] ( + Do $ CondBr { + condition = LocalReference i1 (Name "go"), + trueDest = Name "there", + falseDest = Name "elsewhere", + metadata' = [] + } + ), + BasicBlock (Name "there") [ + UnName 2 := Add { + nsw = True, + nuw = False, + operand0 = LocalReference i32 (UnName 1), + operand1 = ConstantOperand (C.Int 32 3), + metadata = [] + } + ] ( + Do $ Br (Name "elsewhere") [] + ), + BasicBlock (Name "elsewhere") [ + Name "r" := Phi { + type' = i32, + incomingValues = [ + (ConstantOperand (C.Int 32 2), Name "there"), + (ConstantOperand (C.Int 32 57), Name "here") + ], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (Name "r"))) [] + ) + ] + }, + FunctionAttributes (FA.GroupID 0) [FA.NoUnwind, FA.ReadNone, FA.UWTable, FA.StringAttribute "eep" ""], + COMDAT "bob" COMDAT.Largest + ] + +tests = testGroup "Module" [ + testGroup "withModuleFromString" [ + testCase "basic" $ withContext $ \context -> do + z <- withModuleFromLLVMAssembly' context handString (const $ return 0) + z @?= 0, + testCase "numbering" $ withContext $ \context -> do + let s = "@0 = global i32 3\ + \define i32 @1(i32 %x) {\n\ + \ %1 = mul i32 %x, %x\n\ + \ %2 = add i32 %1, 3\n\ + \ ret i32 %2\n\ + \}\n" + z <- withModuleFromLLVMAssembly' context s (const $ return 0) + z @?= 0 + ], + + testGroup "emit" [ + testCase "assemble" $ withContext $ \context -> do + let s = "define i32 @main(i32 %argc, i8** %argv) {\n\ + \ ret i32 0\n\ + \}\n" + a <- withModuleFromLLVMAssembly' context s $ \m -> do + (t, _) <- lookupTarget Nothing "x86_64-unknown-linux" + withTargetOptions $ \to -> do + withTargetMachine t "x86_64-unknown-linux" "" Map.empty to R.Default CM.Default CGO.Default $ \tm -> do + moduleTargetAssembly tm m + a @?= "\t.text\n\ + \\t.file\t\"\"\n\ + \\t.globl\tmain\n\ + \\t.p2align\t4, 0x90\n\ + \\t.type\tmain,@function\n\ + \main:\n\ + \\t.cfi_startproc\n\ + \\txorl\t%eax, %eax\n\ + \\tretq\n\ + \.Lfunc_end0:\n\ + \\t.size\tmain, .Lfunc_end0-main\n\ + \\t.cfi_endproc\n\ + \\n\ + \\t.section\t\".note.GNU-stack\",\"\",@progbits\n" + ], + + testCase "handStringIsCanonical" $ withContext $ \context -> do + s <- withModuleFromLLVMAssembly' context handString moduleLLVMAssembly + s @?= handString, + + testCase "moduleAST" $ withContext $ \context -> do + ast <- withModuleFromLLVMAssembly' context handString moduleAST + assertEqPretty ast handAST, + + testCase "withModuleFromAST" $ withContext $ \context -> do + s <- withModuleFromAST context handAST moduleLLVMAssembly + s @?= handString, + + testCase "bitcode" $ withContext $ \context -> do + bs <- withModuleFromAST context handAST moduleBitcode + s <- withModuleFromBitcode' context bs moduleLLVMAssembly + s @?= handString, + + testCase "triple" $ withContext $ \context -> do + let hAST = "; ModuleID = ''\n\ + \target triple = \"x86_64-unknown-linux\"\n" + ast <- withModuleFromLLVMAssembly' context hAST moduleAST + ast @?= defaultModule { moduleTargetTriple = Just "x86_64-unknown-linux" }, + + testGroup "regression" [ + testCase "minimal type info" $ withContext $ \context -> do + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @trouble() {\n\ + \entry:\n\ + \ ret void\n\ + \\n\ + \dead0: ; preds = %dead1\n\ + \ %x0 = add i32 %x1, %x1\n\ + \ br label %dead1\n\ + \\n\ + \dead1: ; preds = %dead0\n\ + \ %x1 = add i32 %x0, %x0\n\ + \ br label %dead0\n\ + \}\n" + ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = T.void, + G.name = Name "trouble", + G.basicBlocks = [ + BasicBlock (Name "entry") [ + ] ( + Do $ Ret Nothing [] + ), + BasicBlock (Name "dead0") [ + Name "x0" := Add { + nsw = False, + nuw = False, + operand0 = LocalReference i32 (Name "x1"), + operand1 = LocalReference i32 (Name "x1"), + metadata = [] + } + ] ( + Do $ Br (Name "dead1") [] + ), + BasicBlock (Name "dead1") [ + Name "x1" := Add { + nsw = False, + nuw = False, + operand0 = LocalReference i32 (Name "x0"), + operand1 = LocalReference i32 (Name "x0"), + metadata = [] + } + ] ( + Do $ Br (Name "dead0") [] + ) + ] + } + ] + strCheck ast s + withContext $ \context -> withModuleFromAST context ast verify, + + testCase "metadata type" $ withContext $ \context -> do + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define void @bar(metadata %0) {\n\ + \ ret void\n\ + \}\n" + ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = void, + G.name = Name "bar", + G.parameters = ([Parameter MetadataType (UnName 0) []], False), + G.basicBlocks = [ + BasicBlock (UnName 1) [] (Do $ Ret Nothing []) + ] + } + ] + strCheck ast s, + + testCase "set flag on constant expr" $ withContext $ \context -> do + let ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = ConstantOperand (C.Int 32 1), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + } + ] + t <- withModuleFromAST context ast $ \_ -> return True + t @?= True, + + testCase "Phi node finishes" $ withContext $ \context -> do + let ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = LocalReference i32 (Name "x"), + operand1 = LocalReference i32 (Name "x"), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + UnName 2 := Phi i32 [ (ConstantOperand (C.Int 32 42), UnName 0) ] [] + ] ( + Do $ Br (Name "elsewhere") [] + ), + BasicBlock (Name "elsewhere") [ + ] ( + Do $ Br (Name "there") [] + ), + BasicBlock (Name "there") [ + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + } + ] + s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define i32 @foo(i32 %x) {\n\ + \ %1 = mul nsw i32 %x, %x\n\ + \ br label %here\n\ + \\n\ + \here: ; preds = %0\n\ + \ %2 = phi i32 [ 42, %0 ]\n\ + \ br label %elsewhere\n\ + \\n\ + \elsewhere: ; preds = %here\n\ + \ br label %there\n\ + \\n\ + \there: ; preds = %elsewhere\n\ + \ ret i32 %1\n\ + \}\n" + strCheck ast s, + + testCase "switchblock" $ do + let count = 450 + start = 2 -- won't come back the same w/o start = 2 + ns = [start..count + start - 1] + vbps = zip [ ConstantOperand (C.Int 32 i) | i <- [0..] ] [ UnName n | n <- (1:ns) ] + cbps = zip [ C.Int 32 i | i <- [0..] ] [ UnName n | n <- ns ] + + withContext $ \context -> do + let ast = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.name = Name "foo", + G.returnType = i32, + G.parameters = ([Parameter i32 (UnName 0) []], False), + G.basicBlocks = [ + BasicBlock (UnName 1) [] (Do $ Switch (LocalReference i32 (UnName 0)) (Name "end") cbps []) + ] ++ [ + BasicBlock (UnName n) [] (Do $ Br (Name "end") []) | n <- ns + ] ++ [ + BasicBlock (Name "end") [ + Name "val" := Phi i32 vbps [] + ] ( + Do $ Ret (Just (LocalReference i32 (Name "val"))) [] + ) + ] + } + ] + s <- withModuleFromAST context ast moduleLLVMAssembly + m <- withModuleFromLLVMAssembly' context s moduleAST + m @?= ast, + + testCase "struct constant" $ do + let s = "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \%0 = type { i32 }\n\ + \\n\ + \@0 = constant %0 { i32 1 }, align 4\n" + ast = Module "" "" Nothing Nothing [ + TypeDefinition (UnName 0) (Just $ StructureType False [i32]), + GlobalDefinition $ globalVariableDefaults { + G.name = UnName 0, + G.isConstant = True, + G.type' = NamedTypeReference (UnName 0), + G.initializer = Just $ C.Struct (Just $ UnName 0) False [ C.Int 32 1 ], + G.alignment = 4 + } + ] + strCheck ast s + ], + + testGroup "failures" [ + testCase "bad block reference" $ withContext $ \context -> do + let badAST = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = ConstantOperand (C.Int 32 1), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + } + ] ( + Do $ Br (Name "not here") [] + ), + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 1))) [] + ) + ] + } + ] + t <- try $ withModuleFromAST context badAST $ \_ -> return True + t @?= Left (EncodeException "reference to undefined block: Name \"not here\""), + + testCase "multiple" $ withContext $ \context -> do + let badAST = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = False, + nuw = False, + operand0 = LocalReference i32 (Name "unknown"), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + }, + UnName 2 := Mul { + nsw = False, + nuw = False, + operand0 = LocalReference i32 (Name "unknown2"), + operand1 = LocalReference i32 (UnName 1), + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (UnName 2))) [] + ) + ] + } + ] + t <- try $ withModuleFromAST context badAST $ \_ -> return True + t @?= Left (EncodeException "reference to undefined local: Name \"unknown\""), + + testCase "sourceFileName" $ withContext $ \context -> do + let s = "; ModuleID = ''\n\ + \source_filename = \"filename\"\n" + ast = Module "" "filename" Nothing Nothing [] + strCheck ast s, + + testCase "badTypeDef" $ withContext $ \context -> do + let badAST = + Module "" "" Nothing Nothing + [TypeDefinition (UnName 0) (Just VoidType)] + t <- try $ withModuleFromAST context badAST $ \_ -> return () + t @?= Left (EncodeException "A type definition requires a structure type but got: VoidType"), + testCase "renamed type definitions" $ do + let modStr1 = unlines + [ "%struct = type { %struct* }" + , "define void @f(%struct*) {" + , " ret void" + , "}" + ] + modAST1 = Module "" "" Nothing Nothing + [ + ] + modStr2 = unlines + [ "%struct = type { %struct* }" + , "declare void @f(%struct*)" + , "define void @main() {" + , " call void @f(%struct* zeroinitializer)" + , " ret void" + , "}" + ] + ast1 <- withContext $ \ctx -> withModuleFromLLVMAssembly ctx modStr1 moduleAST + ast2 <- withContext $ \ctx -> withModuleFromLLVMAssembly ctx modStr2 moduleAST + (ast1', ast2') <- withContext $ \ctx -> + withModuleFromAST ctx ast1 $ \mod1 -> + withModuleFromAST ctx ast2 $ \mod2 -> + (,) <$> moduleAST mod1 <*> moduleAST mod2 + withContext $ \ctx -> do + ast1'' <- withModuleFromLLVMAssembly ctx modStr1 moduleAST + ast2'' <- withModuleFromLLVMAssembly ctx modStr2 moduleAST + -- Verify that LLVM’s automatic renaming does not produce an error + -- and that the ASTs produced by llvm-hs and LLVM itself are the same. + ast1' @?= ast1'' + ast2' @?= ast2'' + ] + ] diff --git a/test/LLVM/Test/ObjectCode.hs b/test/LLVM/Test/ObjectCode.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/ObjectCode.hs @@ -0,0 +1,33 @@ +module LLVM.Test.ObjectCode where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import qualified Data.ByteString as ByteString +import System.IO +import System.IO.Temp + +import LLVM.Context +import LLVM.Module +import LLVM.Target + +ll :: String +ll = unlines ["define i32 @main(i32 %argc, i8** %argv) {", " ret i32 0", "}"] + +tests = + testGroup + "Object code serialization" + [ testCase + "serialization to ByteString and to file" $ do + withContext $ \ctx -> + withSystemTempFile "foo" $ \objFile handle -> do + hClose handle + withHostTargetMachineDefault $ \machine -> + withModuleFromLLVMAssembly ctx ll $ \mdl -> do + obj <- moduleObject machine mdl + _ <- writeObjectToFile machine (File objFile) mdl + obj' <- ByteString.readFile objFile + obj @=? obj' + ] diff --git a/test/LLVM/Test/Optimization.hs b/test/LLVM/Test/Optimization.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Optimization.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +module LLVM.Test.Optimization where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import Data.Functor +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Map as Map + +import LLVM.Module +import LLVM.Context +import LLVM.PassManager +import qualified LLVM.Transforms as T +import LLVM.Target + +import LLVM.AST as A +import LLVM.AST.Type as A.T +import LLVM.AST.Name +import LLVM.AST.AddrSpace +import LLVM.AST.DataLayout +import qualified LLVM.AST.IntegerPredicate as IPred +import qualified LLVM.AST.Linkage as L +import qualified LLVM.AST.Visibility as V +import qualified LLVM.AST.CallingConvention as CC +import qualified LLVM.AST.Attribute as A +import qualified LLVM.AST.Global as G +import qualified LLVM.AST.Constant as C + +import qualified LLVM.Relocation as R +import qualified LLVM.CodeModel as CM +import qualified LLVM.CodeGenOpt as CGO + +import Debug.Trace + +handAST = + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.functionAttributes = [Left (A.GroupID 0)], + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = False, + nuw = False, + operand0 = ConstantOperand (C.Int 32 6), + operand1 = ConstantOperand (C.Int 32 7), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + Name "go" := ICmp { + iPredicate = IPred.EQ, + operand0 = LocalReference i32 (UnName 1), + operand1 = ConstantOperand (C.Int 32 42), + metadata = [] + } + ] ( + Do $ CondBr { + condition = LocalReference i1 (Name "go"), + trueDest = Name "take", + falseDest = Name "done", + metadata' = [] + } + ), + BasicBlock (Name "take") [ + UnName 2 := Sub { + nsw = False, + nuw = False, + operand0 = LocalReference i32 (Name "x"), + operand1 = LocalReference i32 (Name "x"), + metadata = [] + } + ] ( + Do $ Br (Name "done") [] + ), + BasicBlock (Name "done") [ + Name "r" := Phi { + type' = i32, + incomingValues = [ + (LocalReference i32 (UnName 2), Name "take"), + (ConstantOperand (C.Int 32 57), Name "here") + ], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (Name "r"))) [] + ) + ] + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] + ] + +pattern LLVMLoopIsVectorizedMetadata :: Integer -> Definition +pattern LLVMLoopIsVectorizedMetadata i <- MetadataNodeDefinition _ (MDTuple [ + Just (MDString "llvm.loop.isvectorized"), + Just (MDValue (ConstantOperand C.Int {C.integerBits = 32, C.integerValue = i})) + ]) + +isVectorized :: A.Module -> Assertion +isVectorized mod@Module { moduleDefinitions = defs } = do + let assertHasVectorTypedValues = + (@? "Module contains no vector-typed phi instructions") $ + not $ null [ i + | GlobalDefinition Function { G.basicBlocks = b } <- defs, + BasicBlock _ is _ <- b, + _ := i@Phi { type' = VectorType _ _ } <- is + ] + let assertHasVectorizedMetadata = + (@? "Module is missing 'llvm.loop.isvectorized' metadata") $ + not $ null [ 1 + | LLVMLoopIsVectorizedMetadata 1 <- defs + ] + assertHasVectorTypedValues <> assertHasVectorizedMetadata + +optimize :: PassSetSpec -> A.Module -> IO A.Module +optimize pss m = withContext $ \context -> withModuleFromAST context m $ \mIn' -> do + withPassManager pss $ \pm -> runPassManager pm mIn' + moduleAST mIn' + +tests = testGroup "Optimization" [ + testCase "curated" $ do + mOut <- optimize defaultCuratedPassSetSpec handAST + + mOut @?= Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.functionAttributes = [Left (A.GroupID 0)], + G.basicBlocks = [ + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] + ) + ] + }, + FunctionAttributes (A.GroupID 0) [A.NoRecurse, A.NoUnwind, A.ReadNone, A.UWTable, A.WillReturn] + ], + + testGroup "individual" [ + testCase "InstSimplify" $ do + let + mIn = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.functionAttributes = [Left (A.GroupID 0)], + G.basicBlocks = [ + BasicBlock (UnName 0) [] (Do $ Br (Name "here") []), + BasicBlock (Name "here") [] ( + Do $ CondBr { + condition = ConstantOperand (C.Int 1 1), + trueDest = Name "take", + falseDest = Name "done", + metadata' = [] + } + ), + BasicBlock (Name "take") [] ( + Do $ Br (Name "done") [] + ), + BasicBlock (Name "done") [ + Name "r" := Phi { + type' = i32, + incomingValues = [(ConstantOperand (C.Int 32 0), Name "take"), (ConstantOperand (C.Int 32 57), Name "here")], + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference i32 (Name "r"))) [] + ) + ] + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] + ] + mOut <- optimize defaultPassSetSpec { transforms = [T.InstructionSimplify] } handAST + mOut @?= mIn, + + testCase "SLPVectorization" $ do + let + fadd op0 op1 = + FAdd { fastMathFlags = noFastMathFlags, operand0 = op0, operand1 = op1, metadata = [] } + doubleVec = VectorType 2 double + constInt i = ConstantOperand (C.Int {C.integerBits = 32, C.integerValue = i}) + undef = ConstantOperand (C.Undef doubleVec) + extractElement vec index' = + ExtractElement { vector = vec, index = index', metadata = [] } + insertElement vec el i = + InsertElement { vector = vec, element = el, index = i, metadata = [] } + mIn = Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = doubleVec, + G.name = Name "buildVector_add_2f64", + G.parameters = ([ + Parameter doubleVec n [] + | n <- [ "a", "b" ] + ], False), + G.basicBlocks = [ + BasicBlock (UnName 0) + ["a0" := extractElement (LocalReference doubleVec "a") (constInt 0), + "a1" := extractElement (LocalReference doubleVec "a") (constInt 1), + "b0" := extractElement (LocalReference doubleVec "b") (constInt 0), + "b1" := extractElement (LocalReference doubleVec "b") (constInt 1), + "c0" := fadd (LocalReference double "a0") (LocalReference double "b0"), + "c1" := fadd (LocalReference double "a1") (LocalReference double "b1"), + "r0" := insertElement undef (LocalReference double "c0") (constInt 0), + "r1" := insertElement (LocalReference doubleVec "r0") (LocalReference double "c1") (constInt 1) + ] + (Do (Ret (Just (LocalReference doubleVec "r1")) [])) + ] + } + ] + mOut <- optimize (defaultPassSetSpec { + transforms = [ + T.SuperwordLevelParallelismVectorize, + T.InstructionCombining, + T.GlobalValueNumbering False + ] }) mIn + mOut @?= + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = doubleVec, + G.name = Name "buildVector_add_2f64", + G.parameters = ([ + Parameter doubleVec n [] + | n <- [ "a", "b" ] + ], False), + G.basicBlocks = [ + BasicBlock (UnName 0) + [UnName 1 := fadd (LocalReference doubleVec "a") (LocalReference doubleVec "b")] + (Do (Ret (Just (LocalReference doubleVec (UnName 1))) [])) + ] + } + ], + + testCase "LoopVectorize" $ do + let + mIn = + Module { + moduleName = "", + moduleSourceFileName = "", + moduleDataLayout = Just $ (defaultDataLayout BigEndian) { + typeLayouts = Map.singleton (VectorAlign, 128) (AlignmentInfo 128 128) + }, + moduleTargetTriple = Just "x86_64", + moduleDefinitions = [ + GlobalDefinition $ globalVariableDefaults { + G.name = Name "a", + G.linkage = L.Common, + G.type' = A.T.ArrayType 2048 i32, + G.initializer = Just (C.AggregateZero (A.T.ArrayType 2048 i32)) + }, + GlobalDefinition $ functionDefaults { + G.returnType = A.T.void, + G.name = Name "inc", + G.functionAttributes = [Left (A.GroupID 0)], + G.parameters = ([Parameter i32 (Name "n") []], False), + G.basicBlocks = [ + BasicBlock (UnName 0) [ + UnName 1 := ICmp IPred.SGT (LocalReference i32 (Name "n")) (ConstantOperand (C.Int 32 0)) [] + ] (Do $ CondBr (LocalReference i1 (UnName 1)) (Name ".lr.ph") (Name "._crit_edge") []), + BasicBlock (Name ".lr.ph") [ + Name "indvars.iv" := Phi i64 [ + (ConstantOperand (C.Int 64 0), UnName 0), + (LocalReference i64 (Name "indvars.iv.next"), Name ".lr.ph") + ] [], + UnName 2 := GetElementPtr True (ConstantOperand (C.GlobalReference (PointerType (A.T.ArrayType 2048 i32) (AddrSpace 0)) (Name "a"))) [ + ConstantOperand (C.Int 64 0), + LocalReference i64 (Name "indvars.iv") + ] [], + UnName 3 := Load False (LocalReference (ptr i32) (UnName 2)) Nothing 4 [], + UnName 4 := Trunc (LocalReference i64 (Name "indvars.iv")) i32 [], + UnName 5 := Add True False (LocalReference i32 (UnName 3)) (LocalReference i32 (UnName 4)) [], + Do $ Store False (LocalReference (ptr i32) (UnName 2)) (LocalReference i32 (UnName 5)) Nothing 4 [], + Name "indvars.iv.next" := Add False False (LocalReference i64 (Name "indvars.iv")) (ConstantOperand (C.Int 64 1)) [], + Name "lftr.wideiv" := Trunc (LocalReference i64 (Name "indvars.iv.next")) i32 [], + Name "exitcond" := ICmp IPred.EQ (LocalReference i32 (Name "lftr.wideiv")) (LocalReference i32 (Name "n")) [] + ] (Do $ CondBr (LocalReference i1 (Name "exitcond")) (Name "._crit_edge") (Name ".lr.ph") []), + BasicBlock (Name "._crit_edge") [ + ] (Do $ Ret Nothing []) + ] + }, + FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable, A.StackProtect] + ] + } + mOut <- do + initializeAllTargets + let triple = "x86_64" + (target, _) <- lookupTarget Nothing triple + withTargetOptions $ \targetOptions -> do + withTargetMachine target triple "" Map.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do + optimize (defaultPassSetSpec { + transforms = [ T.defaultLoopVectorize ], + dataLayout = moduleDataLayout mIn, + targetMachine = Just tm + }) mIn + isVectorized mOut, + + testCase "LowerInvoke" $ do + -- This test doesn't test much about what LowerInvoke does, just that it seems to work. + -- The pass seems to be quite deeply dependent on weakly documented presumptions about + -- how unwinding works (as is the invoke instruction) + withContext $ \context -> do + withPassManager (defaultPassSetSpec { transforms = [T.LowerInvoke] }) $ \passManager -> do + let astIn = + Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] + ) + ] + } + ] + astOut <- withModuleFromAST context astIn $ \mIn -> do + runPassManager passManager mIn + moduleAST mIn + astOut @?= Module "" "" Nothing Nothing [ + GlobalDefinition $ functionDefaults { + G.returnType = i32, + G.name = Name "foo", + G.parameters = ([Parameter i32 (Name "x") []], False), + G.basicBlocks = [ + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [] + ) + ] + } + ] + ] + ] diff --git a/test/LLVM/Test/OrcJIT.hs b/test/LLVM/Test/OrcJIT.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/OrcJIT.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} +module LLVM.Test.OrcJIT where + +import Test.Tasty +import Test.Tasty.HUnit + +import LLVM.Test.Support + +import qualified Data.Map.Strict as Map +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Int +import Data.IORef +import Data.Word +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Alloc +import System.Process (callProcess) +import System.IO.Temp (withSystemTempFile) +import System.IO + +import LLVM.Internal.PassManager +import LLVM.Internal.ObjectFile (withObjectFile) +import LLVM.PassManager +import LLVM.Context +import LLVM.Module +import LLVM.OrcJIT +import LLVM.Target +import qualified LLVM.Relocation as Reloc +import qualified LLVM.CodeModel as CodeModel +import qualified LLVM.CodeGenOpt as CodeGenOpt + +testModule :: ByteString +testModule = + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \declare i32 @testFunc()\n\ + \define i32 @main(i32, i8**) {\n\ + \ %3 = call i32 @testFunc()\n\ + \ ret i32 %3\n\ + \}\n" + +test2Module :: ByteString +test2Module = + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \\n\ + \define i32 @main() {\n\ + \ ret i32 42\n\ + \}\n" + +test3Module :: ByteString +test3Module = + "; ModuleID = ''\n\ + \source_filename = \"\"\n\ + \@data = external global i32\n\ + \\n\ + \define i32 @main() {\n\ + \ %1 = load i32, i32* @data\n\ + \ ret i32 %1\n\ + \}\n" + +withTestModule :: ByteString -> (Module -> IO a) -> IO a +withTestModule txt f = withContext $ \context -> withModuleFromLLVMAssembly' context txt f + +myTestFuncImpl :: IO Word32 +myTestFuncImpl = return 42 + +foreign import ccall "wrapper" + wrapTestFunc :: IO Word32 -> IO (FunPtr (IO Word32)) + +foreign import ccall "dynamic" + mkMain :: FunPtr (IO Word32) -> IO Word32 + +tests :: TestTree +tests = + testGroup "OrcJIT" [ + testCase "basic self-contained function" $ do + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> + withExecutionSession $ \es -> do + ol <- createRTDyldObjectLinkingLayer es + il <- createIRCompileLayer es ol tm + dylib <- createJITDylib es "testDylib" + withTestModule test2Module $ \m -> + withClonedThreadSafeModule m $ \tsm -> do + addModule tsm dylib il + Right (JITSymbol addr _) <- lookupSymbol es il dylib "main" + let mainFn = mkMain (castPtrToFunPtr $ wordPtrToPtr $ fromIntegral addr) + result <- mainFn + result @?= 42, + + testCase "basic self-contained function + ObjectLinkingLayer" $ do + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> + withExecutionSession $ \es -> do + ol <- createObjectLinkingLayer es + il <- createIRCompileLayer es ol tm + dylib <- createJITDylib es "testDylib" + withTestModule test2Module $ \m -> + withClonedThreadSafeModule m $ \tsm -> do + addModule tsm dylib il + Right (JITSymbol addr _) <- lookupSymbol es il dylib "main" + let mainFn = mkMain (castPtrToFunPtr $ wordPtrToPtr $ fromIntegral addr) + result <- mainFn + result @?= 42, + + testCase "using symbols in external shared libraries" $ + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> + withExecutionSession $ \es -> do + ol <- createRTDyldObjectLinkingLayer es + il <- createIRCompileLayer es ol tm + dylib <- createJITDylib es "testDylib" + let inputPath = "./test/main_return_38.c" + withSystemTempFile "main.o" $ \outputPath _ -> do + callProcess "gcc" ["-shared", "-fPIC", inputPath, "-o", outputPath] + addDynamicLibrarySearchGenerator il dylib outputPath + Right (JITSymbol mainFn _) <- lookupSymbol es il dylib "main" + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 38, + + testCase "run optimization passes on a JIT module" $ do + passmanagerSuccessful <- newIORef False + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> + withExecutionSession $ \es -> do + ol <- createRTDyldObjectLinkingLayer es + il <- createIRCompileLayer es ol tm + dylib <- createJITDylib es "testDylib" + withTestModule test2Module $ \m -> do + withPassManager defaultCuratedPassSetSpec { optLevel = Just 2 } $ \pm -> do + success <- runPassManager pm m + writeIORef passmanagerSuccessful success + withClonedThreadSafeModule m $ \tsm -> do + addModule tsm dylib il + Right (JITSymbol mainFn _) <- lookupSymbol es il dylib "main" + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 42 + readIORef passmanagerSuccessful @? "passmanager failed", + + testCase "defining absolute symbols" $ do + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> + withExecutionSession $ \es -> do + ol <- createRTDyldObjectLinkingLayer es + il <- createIRCompileLayer es ol tm + alloca $ \ptr -> do + poke ptr (1234 :: Int32) + dylib <- createJITDylib es "testDylib" + withMangledSymbol il "data" $ \dataSym -> do + let flags = defaultJITSymbolFlags { jitSymbolAbsolute = True } + defineAbsoluteSymbols dylib [(dataSym, JITSymbol (ptrToWordPtr ptr) flags)] + withTestModule test3Module $ \m -> do + withClonedThreadSafeModule m $ \tsm -> do + addModule tsm dylib il + Right (JITSymbol addr _) <- lookupSymbol es il dylib "main" + let mainFn = mkMain (castPtrToFunPtr $ wordPtrToPtr $ fromIntegral addr) + result <- mainFn + result @?= 1234 + + -- TODO: Make it possible to use Haskell functions as definition generators + -- and update to OrcJITv2 + {- + testCase "eager compilation" $ do + withTestModule $ \mod -> + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> + withExecutionSession $ \es -> + withObjectLinkingLayer es (\k -> fmap (\rs -> rs Map.! k) (readIORef resolvers)) $ \linkingLayer -> + withIRCompileLayer linkingLayer tm $ \compileLayer -> do + testFunc <- mangleSymbol compileLayer "testFunc" + withModuleKey es $ \k -> + withSymbolResolver es (SymbolResolver (resolver testFunc compileLayer)) $ \resolver -> do + modifyIORef' resolvers (Map.insert k resolver) + withModule compileLayer k mod $ do + mainSymbol <- mangleSymbol compileLayer "main" + Right (JITSymbol mainFn _) <- CL.findSymbol compileLayer mainSymbol True + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 42 + Right (JITSymbol mainFn _) <- CL.findSymbolIn compileLayer k mainSymbol True + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 42 + unknownSymbol <- mangleSymbol compileLayer "unknownSymbol" + unknownSymbolRes <- CL.findSymbol compileLayer unknownSymbol True + unknownSymbolRes @?= Left (JITSymbolError mempty), + -} + + -- TODO: Add IRTransformLayer and translate to OrcJITv2 + {- + testCase "lazy compilation" $ do + resolvers <- newIORef Map.empty + let getResolver k = fmap (Map.! k) (readIORef resolvers) + setResolver k r = modifyIORef' resolvers (Map.insert k r) + withTestModule $ \mod -> + withHostTargetMachine Reloc.PIC CodeModel.Default CodeGenOpt.Default $ \tm -> do + triple <- getTargetMachineTriple tm + withExecutionSession $ \es -> + withObjectLinkingLayer es getResolver $ \linkingLayer -> + withIRCompileLayer linkingLayer tm $ \baseLayer -> + withIndirectStubsManagerBuilder triple $ \stubsMgr -> + withJITCompileCallbackManager es triple Nothing $ \callbackMgr -> + withCompileOnDemandLayer es baseLayer tm getResolver setResolver (\x -> return [x]) callbackMgr stubsMgr False $ \compileLayer -> do + testFunc <- mangleSymbol compileLayer "testFunc" + withModuleKey es $ \k -> + withSymbolResolver es (SymbolResolver (resolver testFunc baseLayer)) $ \resolver -> do + setResolver k resolver + withModule compileLayer k mod $ do + mainSymbol <- mangleSymbol compileLayer "main" + Right (JITSymbol mainFn _) <- CL.findSymbol compileLayer mainSymbol True + result <- mkMain (castPtrToFunPtr (wordPtrToPtr mainFn)) + result @?= 42, + -} + + ] diff --git a/test/LLVM/Test/ParameterAttribute.hs b/test/LLVM/Test/ParameterAttribute.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/ParameterAttribute.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module LLVM.Test.ParameterAttribute where + +import Test.Tasty +import Test.Tasty.QuickCheck hiding ( (.&.) ) + +import LLVM.Test.Support + +import LLVM.AST.ParameterAttribute +import LLVM.Internal.Coding +import LLVM.Internal.Context +import LLVM.Internal.EncodeAST +import LLVM.Internal.DecodeAST +import qualified LLVM.Internal.FFI.Attribute as FFI + +import Control.Applicative +import Data.Bits +import Data.List +import Data.Word +import Text.Show.Pretty +import Control.Monad.IO.Class (liftIO) +import Prelude +import qualified Data.ByteString.Short as B + + +instance Arbitrary ParameterAttribute where + arbitrary = oneof + [ return ZeroExt + , return SignExt + , return InReg + , return SRet + , Alignment <$> elements (map (2^) [0..30 :: Int]) + , return NoAlias + , return ByVal + , return NoCapture + , return NoFree + , return Nest + , return ReadNone + , return ReadOnly + , return WriteOnly + , return ImmArg + , return InAlloca + , return NonNull + , Dereferenceable <$> suchThat arbitrary (/= 0) + , DereferenceableOrNull <$> suchThat arbitrary (/= 0) + , return Returned + , return SwiftSelf + , return SwiftError + , StringAttribute <$> arbitrarySbs <*> arbitrarySbs + ] + + +tests :: TestTree +tests = + testGroup "ParameterAttribute" + [ testProperty "round-trip" $ \attr -> + ioProperty $ withContext $ \ctx -> do + attr' <- runEncodeAST ctx $ do + attrSet <- encodeM [attr] :: EncodeAST FFI.ParameterAttributeSet + liftIO (runDecodeAST (decodeM attrSet :: DecodeAST [ParameterAttribute])) + return $ counterexample (unlines [ "expected: " ++ ppShow [attr] + , "but got: " ++ ppShow attr' + ]) + ([attr] == attr') + ] diff --git a/test/LLVM/Test/Regression.hs b/test/LLVM/Test/Regression.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Regression.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} +module LLVM.Test.Regression + ( tests + ) where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified LLVM.AST as AST +import LLVM.AST hiding (Module) +import qualified LLVM.AST.Constant as C +import LLVM.AST.Global hiding (metadata) +import LLVM.AST.Type +import LLVM.IRBuilder + +import LLVM.Context +import LLVM.Exception +import LLVM.Module + +import Data.ByteString as B (readFile) +import Control.Exception + +example1 :: AST.Module +example1 = + defaultModule + { moduleDefinitions = + [ GlobalDefinition + functionDefaults + { name = "test" + , returnType = void + , basicBlocks = + [ BasicBlock + "entry" + [ UnName 0 := Alloca i32 Nothing 0 [] + , UnName 1 := + Store + False + (LocalReference (ptr i32) (UnName 0)) + (ConstantOperand (C.Int 32 42)) + Nothing + 0 + [] + ] + (Do $ Ret Nothing []) + ] + } + ] + } + +example2 :: AST.Module +example2 = + defaultModule + { moduleDefinitions = + [ GlobalDefinition + functionDefaults + { name = "test" + , returnType = void + , basicBlocks = + [ BasicBlock + "entry" + [ UnName 0 := + Alloca (ptr $ FunctionType void [] False) Nothing 0 [] + , Do $ + Store + False + (LocalReference + (ptr $ ptr $ FunctionType void [] False) + (UnName 0)) + (ConstantOperand $ + C.GlobalReference (FunctionType void [] False) "test") + Nothing + 0 + [] + ] + (Do $ Ret Nothing []) + ] + } + ] + } + +example3 :: AST.Module +example3 = + defaultModule + { moduleDefinitions = + [ GlobalDefinition + functionDefaults + { name = "test" + , returnType = void + , basicBlocks = + [ BasicBlock + "entry" + [ UnName 0 := GetElementPtr { + inBounds = False, + address = ConstantOperand (C.Null i32), + indices = [ ConstantOperand (C.Int 32 0) ], + metadata = [] + } + ] + (Do $ Ret Nothing []) + ] + } + ] + } + +duplicateDefinitions :: AST.Module +duplicateDefinitions = + defaultModule + { moduleName = "clashingModule" + , moduleDefinitions = + [ GlobalDefinition + functionDefaults + { name = "clashy" + , returnType = i64 + , basicBlocks = + [ BasicBlock + "entry" + [ mkName "c" := + Add + False + False + (ConstantOperand (C.Int 64 1)) + (ConstantOperand (C.Int 64 2)) + [] + ] + (Do (Br "next" [])) + , BasicBlock + "next" + [ mkName "c" := + Phi i64 [(LocalReference i64 "c", "entry")] [] + ] + (Do (Ret (Just (LocalReference i64 "c")) [])) + ] + } + ] + } + +reuseAcrossFunctions :: AST.Module +reuseAcrossFunctions = + defaultModule + { moduleName = "" + , moduleDefinitions = + [ GlobalDefinition + functionDefaults + { name = "f" + , returnType = i64 + , basicBlocks = + [ BasicBlock + "entry" + [ "c" := + Add + False + False + (ConstantOperand (C.Int 64 1)) + (ConstantOperand (C.Int 64 2)) + [] + ] + (Do (Ret (Just (LocalReference i64 "c")) [])) + ] + } + , GlobalDefinition + functionDefaults + { name = "g" + , returnType = i64 + , basicBlocks = + [ BasicBlock + "entry" + [ "c" := + Add + False + False + (ConstantOperand (C.Int 64 1)) + (ConstantOperand (C.Int 64 2)) + [] + ] + (Do (Ret (Just (LocalReference i64 "c")) [])) + ] + } + ] + } + +shouldThrowEncodeException :: AST.Module -> String -> IO () +shouldThrowEncodeException ast errMsg = do + result <- try $ withContext $ \context -> do + withModuleFromAST context ast (\_ -> return ()) + case result of + Left (EncodeException actualErrMsg) -> actualErrMsg @?= errMsg + Right _ -> assertFailure ("Expected serialization to fail with: \"" ++ errMsg ++ "\"") + +shouldNotThrow :: AST.Module -> IO () +shouldNotThrow ast = do + withContext $ \context -> do + withModuleFromAST context ast (\_ -> return ()) + +emptyName :: AST.Module +emptyName = defaultModule { moduleDefinitions = defs } + where defs = execModuleBuilder emptyModuleBuilder (extern "f" [i32, i64] void) + +tests :: TestTree +tests = + testGroup + "Regression" + [ testCase + "no named voids" + (example1 `shouldThrowEncodeException` + "Instruction of type void must not have a name: UnName 1 := Store {volatile = False, address = LocalReference (PointerType {pointerReferent = IntegerType {typeBits = 32}, pointerAddrSpace = AddrSpace 0}) (UnName 0), value = ConstantOperand (Int {integerBits = 32, integerValue = 42}), maybeAtomicity = Nothing, alignment = 0, metadata = []}") + , testCase + "no implicit casts" + (example2 `shouldThrowEncodeException` + "The serialized GlobalReference Name \"test\" has type FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False} but should have type PointerType {pointerReferent = FunctionType {resultType = VoidType, argumentTypes = [], isVarArg = False}, pointerAddrSpace = AddrSpace 0}") + , testCase + "null constants must have pointer type" + (example3 `shouldThrowEncodeException` + "Null pointer constant must have pointer type but has type IntegerType {typeBits = 32}.") + , testCase + "Duplicate definitions are not allowed" + (duplicateDefinitions `shouldThrowEncodeException` + "Duplicate definition of local variable: Name \"c\".") + , testCase + "Reusing variable names across functions is allowed" + (shouldNotThrow reuseAcrossFunctions) + , testCase + "Empty names do not collide" $ do + moduleStr <- withContext $ \cxt -> withModuleFromAST cxt emptyName moduleLLVMAssembly + moduleStr @?= "; ModuleID = ''\nsource_filename = \"\"\n\ndeclare void @f(i32, i64)\n" +-- , testCase +-- "FNeg is parsed correctly" $ do +-- fStr <- B.readFile "test/fneg_test.ll" +-- withContext $ \context -> do +-- a <- withModuleFromLLVMAssembly context fStr moduleAST +-- pure () + ] diff --git a/test/LLVM/Test/Support.hs b/test/LLVM/Test/Support.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Support.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module LLVM.Test.Support where + +import LLVM.Prelude + +import Test.Tasty +import Test.Tasty.HUnit +import Test.QuickCheck + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as BSS +import Data.Functor +import Control.Monad +import Control.Monad.Trans.Except +import Text.Show.Pretty + +import LLVM.Context +import LLVM.Module +import LLVM.Diagnostic + +withModuleFromLLVMAssembly' :: Context -> ByteString -> (Module -> IO a) -> IO a +withModuleFromLLVMAssembly' c s f = withModuleFromLLVMAssembly c s f +withModuleFromBitcode' c a f = withModuleFromBitcode c ("", a) f + +assertEqPretty :: (Eq a, Show a) => a -> a -> Assertion +assertEqPretty actual expected = do + assertBool + ("expected: " ++ ppShow expected ++ "\n" ++ "but got: " ++ ppShow actual ++ "\n") + (expected == actual) + +strCheckC mAST mStr mStrCanon = withContext $ \context -> do + a <- withModuleFromLLVMAssembly' context mStr moduleAST + s <- withModuleFromAST context mAST moduleLLVMAssembly + (a,s) `assertEqPretty` (mAST, mStrCanon) + +strCheck mAST mStr = strCheckC mAST mStr mStr + +arbitrarySbs :: Gen ShortByteString +arbitrarySbs = BSS.pack <$> listOf arbitrary diff --git a/test/LLVM/Test/Target.hs b/test/LLVM/Test/Target.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Target.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE + CPP, + OverloadedStrings, + RecordWildCards, + ScopedTypeVariables + #-} +module LLVM.Test.Target where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck +import Test.QuickCheck + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.ByteString.Char8 as ByteString +import Data.Char +import Data.Map (Map) +import Data.Monoid (mempty) +import Foreign.C.String + +import qualified LLVM.CodeGenOpt as CodeGenOpt +import qualified LLVM.CodeModel as CodeModel +import LLVM.Context +import LLVM.Internal.Coding +import LLVM.Internal.DecodeAST +import LLVM.Internal.EncodeAST +import qualified LLVM.Relocation as Reloc +import LLVM.Target +import LLVM.Target.LibraryFunction +import LLVM.Target.Options + +instance Arbitrary FloatABI where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary FloatingPointOperationFusionMode where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary ThreadModel where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary EABIVersion where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary DebuggerKind where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary FloatingPointDenormalMode where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary ExceptionHandling where + arbitrary = elements [minBound .. maxBound] + +instance Arbitrary Options where + arbitrary = do + unsafeFloatingPointMath <- arbitrary + noInfinitiesFloatingPointMath <- arbitrary + noNaNsFloatingPointMath <- arbitrary + noTrappingFloatingPointMath <- arbitrary + noSignedZeroesFloatingPointMath <- arbitrary + honorSignDependentRoundingFloatingPointMathOption <- arbitrary + noZerosInBSS <- arbitrary + guaranteedTailCallOptimization <- arbitrary + stackSymbolOrdering <- arbitrary + enableFastInstructionSelection <- arbitrary + useInitArray <- arbitrary + disableIntegratedAssembler <- arbitrary + compressDebugSections <- arbitrary + relaxELFRelocations <- arbitrary + functionSections <- arbitrary + dataSections <- arbitrary + uniqueSectionNames <- arbitrary + trapUnreachable <- arbitrary + emulatedThreadLocalStorage <- arbitrary + enableInterProceduralRegisterAllocation <- arbitrary + stackAlignmentOverride <- arbitrary + floatABIType <- arbitrary + allowFloatingPointOperationFusion <- arbitrary + threadModel <- arbitrary + eabiVersion <- arbitrary + debuggerTuning <- arbitrary + floatingPointDenormalMode <- arbitrary + exceptionModel <- arbitrary + machineCodeOptions <- arbitrary + return Options { .. } + +instance Arbitrary MachineCodeOptions where + arbitrary = do + relaxAll <- arbitrary + noExecutableStack <- arbitrary + fatalWarnings <- arbitrary + noWarnings <- arbitrary + noDeprecatedWarning <- arbitrary + saveTemporaryLabels <- arbitrary + useDwarfDirectory <- arbitrary + incrementalLinkerCompatible <- arbitrary + showMachineCodeEncoding <- arbitrary + showMachineCodeInstructions <- arbitrary + verboseAssembly <- arbitrary + preserveComentsInAssembly <- arbitrary + return MachineCodeOptions { .. } + +instance Arbitrary DebugCompressionType where + arbitrary = elements [CompressNone, CompressGNU, CompressZ] + +arbitraryASCIIString :: Gen String +#if MIN_VERSION_QuickCheck(2,10,0) +arbitraryASCIIString = getASCIIString <$> arbitrary +#else +arbitraryASCIIString = arbitrary +#endif + +instance Arbitrary CPUFeature where + arbitrary = CPUFeature . ByteString.pack <$> + suchThat arbitraryASCIIString (\s -> not (null s) && all isAlphaNum s) + +tests = testGroup "Target" [ + testGroup "Options" [ + testProperty "basic" $ \options -> ioProperty $ do + withTargetOptions $ \to -> do + pokeTargetOptions options to + options' <- peekTargetOptions to + return $ options === options', + testProperty "target machine" $ \options -> ioProperty $ do + withTargetOptions $ \to -> do + pokeTargetOptions options to + let triple = "i386-linux-gnu" + cpu = "" + features = mempty + reloc = Reloc.Default + codeModel = CodeModel.Default + codeGenOpt = CodeGenOpt.Default + (target, _) <- lookupTarget Nothing triple + withTargetMachine target triple cpu features to reloc codeModel codeGenOpt $ \tm -> do + options' <- peekTargetOptions =<< targetMachineOptions tm + return $ options === options' + ], + testGroup "LibraryFunction" [ + testGroup "set-get" [ + testCase (show lf) $ do + triple <- getDefaultTargetTriple + withTargetLibraryInfo triple $ \tli -> do + setLibraryFunctionAvailableWithName tli lf "foo" + nm <- getLibraryFunctionName tli lf + nm @?= "foo" + | lf <- [minBound, maxBound] + ], + testCase "get" $ do + triple <- getDefaultTargetTriple + withTargetLibraryInfo triple $ \tli -> do + lf <- getLibraryFunction tli "printf" + lf @?= Just LF__printf + ], + testCase "Host" $ do + features <- getHostCPUFeatures + return (), + testGroup "CPUFeature" [ + testProperty "roundtrip" $ \cpuFeatures -> ioProperty $ + withContext $ \context -> runEncodeAST context $ do + encodedFeatures :: CString <- (encodeM cpuFeatures) + decodedFeatures :: Map CPUFeature Bool <- liftIO $ runDecodeAST (decodeM encodedFeatures) + return (cpuFeatures == decodedFeatures) + + ] + ] diff --git a/test/LLVM/Test/Tests.hs b/test/LLVM/Test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/Test/Tests.hs @@ -0,0 +1,54 @@ +module LLVM.Test.Tests where + +import Test.Tasty + +import qualified LLVM.Test.Analysis as Analysis +import qualified LLVM.Test.Attribute as Attribute +import qualified LLVM.Test.CallingConvention as CallingConvention +import qualified LLVM.Test.Constants as Constants +import qualified LLVM.Test.DataLayout as DataLayout +import qualified LLVM.Test.ExecutionEngine as ExecutionEngine +import qualified LLVM.Test.FunctionAttribute as FunctionAttribute +import qualified LLVM.Test.Global as Global +import qualified LLVM.Test.InlineAssembly as InlineAssembly +import qualified LLVM.Test.Instructions as Instructions +import qualified LLVM.Test.Instrumentation as Instrumentation +import qualified LLVM.Test.Linking as Linking +import qualified LLVM.Test.Metadata as Metadata +import qualified LLVM.Test.Module as Module +import qualified LLVM.Test.ObjectCode as ObjectCode +import qualified LLVM.Test.Optimization as Optimization +import qualified LLVM.Test.OrcJIT as OrcJIT +import qualified LLVM.Test.ParameterAttribute as ParameterAttribute +import qualified LLVM.Test.Target as Target +import qualified LLVM.Test.Regression as Regression +import qualified LLVM.Test.DataLayout as DataLayout +import qualified LLVM.Test.IRBuilder as IRBuilder + +tests = testGroup "llvm-hs" [ + CallingConvention.tests, + Constants.tests, + DataLayout.tests, + Attribute.tests, + FunctionAttribute.tests, + ExecutionEngine.tests, + Global.tests, + InlineAssembly.tests, + Instructions.tests, + Metadata.tests, + Module.tests, + OrcJIT.tests, + Optimization.tests, + ParameterAttribute.tests, + Target.tests, + Analysis.tests, + Linking.tests, + Instrumentation.tests, + ObjectCode.tests, + Regression.tests, + ( testGroup "llvm-hs-pure" + [ DataLayout.tests + , IRBuilder.tests + ]) + + ] diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,6 @@ +import Test.Tasty +import qualified LLVM.Test.Tests as LLVM +import LLVM.CommandLine + +main :: IO () +main = defaultMain LLVM.tests diff --git a/test/debug_metadata_1.ll b/test/debug_metadata_1.ll new file mode 100644 --- /dev/null +++ b/test/debug_metadata_1.ll @@ -0,0 +1,50 @@ +declare !foo !0 !bar !{!"baz"} !qux !{!2} void @f1() + +define void @f2() !foo !0 !bar !{!"baz"} !qux !{!2} { + ret void +} + +; --- [ Metadata definitions ] ------------------------------------------------- + +; Empty named metadata definition. +!foo = !{} + +; Plain named metadata definition. +!bar = !{!0} + +; Multiple metadata IDs. +!baz = !{!0, !1, !15} + +; !vars = !{!9, !10, !11} +; Empty metadata definition. +!0 = !{} + +; Plain metadata definition. +!1 = !{!0} + +; Multiple metadata IDs. +!2 = !{!0, !1} + +; Distinct. +!3 = distinct !{!2} + +; Nested metadata. +!4 = !{!{!{!0}}} + +; Metadata string. +!5 = !{!"foo"} + +; Metadata constant. +!6 = !{i32 42} + +; Metadata constant. +!7 = !{!{!"bar"}} + +!15 = !{ !9, !10, !8, !11} + +!8 = distinct !DISubprogram(name: "foo", scope: !9) +!9 = !DIFile(filename: "path/to/file", directory: "/path/to/dir") + +!10 = !DILexicalBlock(scope: !8, file: !9, line: 7, column: 35) + +!11 = !DINamespace(name: "Namespace", scope: !10) diff --git a/test/debug_metadata_2.ll b/test/debug_metadata_2.ll new file mode 100644 --- /dev/null +++ b/test/debug_metadata_2.ll @@ -0,0 +1,42 @@ +; ModuleID = 'test.c' +source_filename = "test.c" +target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128" +target triple = "x86_64-unknown-linux-gnu" + +; Function Attrs: noinline nounwind optnone sspstrong uwtable +define i32 @f(i32) #0 !dbg !9 { + %2 = alloca i32, align 4 + store i32 %0, i32* %2, align 4 + call void @llvm.dbg.declare(metadata i32* %2, metadata !13, metadata !14), !dbg !15 + %3 = load i32, i32* %2, align 4, !dbg !16 + ret i32 %3, !dbg !17 +} + +; Function Attrs: nounwind readnone speculatable +declare void @llvm.dbg.declare(metadata, metadata, metadata) #1 + +attributes #0 = { noinline nounwind optnone sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="true" "no-frame-pointer-elim-non-leaf" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } +attributes #1 = { nounwind readnone speculatable } + +!llvm.dbg.cu = !{!0} +!llvm.module.flags = !{!3, !4, !5, !6, !7} +!llvm.ident = !{!8} + +!0 = distinct !DICompileUnit(language: DW_LANG_C99, file: !1, producer: "clang version 5.0.1 (tags/RELEASE_501/final)", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !2) +!1 = !DIFile(filename: "test.c", directory: "/home/moritz/tmp") +!2 = !{} +!3 = !{i32 2, !"Dwarf Version", i32 4} +!4 = !{i32 2, !"Debug Info Version", i32 3} +!5 = !{i32 1, !"wchar_size", i32 4} +!6 = !{i32 7, !"PIC Level", i32 2} +!7 = !{i32 7, !"PIE Level", i32 2} +!8 = !{!"clang version 5.0.1 (tags/RELEASE_501/final)"} +!9 = distinct !DISubprogram(name: "f", scope: !1, file: !1, line: 1, type: !10, isLocal: false, isDefinition: true, scopeLine: 1, flags: DIFlagPrototyped, isOptimized: false, unit: !0, retainedNodes: !2) +!10 = !DISubroutineType(types: !11) +!11 = !{!12, !12} +!12 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed) +!13 = !DILocalVariable(name: "x", arg: 1, scope: !9, file: !1, line: 1, type: !12) +!14 = !DIExpression() +!15 = !DILocation(line: 1, column: 11, scope: !9) +!16 = !DILocation(line: 2, column: 12, scope: !9) +!17 = !DILocation(line: 2, column: 5, scope: !9) diff --git a/test/debug_metadata_3.ll b/test/debug_metadata_3.ll new file mode 100644 --- /dev/null +++ b/test/debug_metadata_3.ll @@ -0,0 +1,5759 @@ +; ModuleID = '/home/firefox/firefox/mozilla-unified/widget/LSBUtils.cpp' +source_filename = "/home/firefox/firefox/mozilla-unified/widget/LSBUtils.cpp" +target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128" +target triple = "x86_64-pc-linux-gnu" + +%class.nsTSubstring = type { %"class.mozilla::detail::nsTStringRepr" } +%"class.mozilla::detail::nsTStringRepr" = type { i8*, i32, i16, i16 } +%"class.std::vector" = type { %"struct.std::_Vector_base" } +%"struct.std::_Vector_base" = type { %"struct.std::_Vector_base, std::allocator > >::_Vector_impl" } +%"struct.std::_Vector_base, std::allocator > >::_Vector_impl" = type { %"class.std::__cxx11::basic_string"*, %"class.std::__cxx11::basic_string"*, %"class.std::__cxx11::basic_string"* } +%"class.std::__cxx11::basic_string" = type { %"struct.std::__cxx11::basic_string, std::allocator >::_Alloc_hider", i64, %union.anon } +%"struct.std::__cxx11::basic_string, std::allocator >::_Alloc_hider" = type { i8* } +%union.anon = type { i64, [8 x i8] } +%"class.std::allocator.0" = type { i8 } +%"struct.base::LaunchOptions" = type { i8, %"class.std::map", %"class.std::vector.6", %"class.mozilla::UniquePtr" } +%"class.std::map" = type { %"class.std::_Rb_tree" } +%"class.std::_Rb_tree" = type { %"struct.std::_Rb_tree, std::pair, std::__cxx11::basic_string >, std::_Select1st, std::__cxx11::basic_string > >, std::less >, std::allocator, std::__cxx11::basic_string > > >::_Rb_tree_impl" } +%"struct.std::_Rb_tree, std::pair, std::__cxx11::basic_string >, std::_Select1st, std::__cxx11::basic_string > >, std::less >, std::allocator, std::__cxx11::basic_string > > >::_Rb_tree_impl" = type { %"struct.std::_Rb_tree_key_compare", %"struct.std::_Rb_tree_header" } +%"struct.std::_Rb_tree_key_compare" = type { %"struct.std::less" } +%"struct.std::less" = type { i8 } +%"struct.std::_Rb_tree_header" = type { %"struct.std::_Rb_tree_node_base", i64 } +%"struct.std::_Rb_tree_node_base" = type { i32, %"struct.std::_Rb_tree_node_base"*, %"struct.std::_Rb_tree_node_base"*, %"struct.std::_Rb_tree_node_base"* } +%"class.std::vector.6" = type { %"struct.std::_Vector_base.7" } +%"struct.std::_Vector_base.7" = type { %"struct.std::_Vector_base, std::allocator > >::_Vector_impl" } +%"struct.std::_Vector_base, std::allocator > >::_Vector_impl" = type { %"struct.std::pair"*, %"struct.std::pair"*, %"struct.std::pair"* } +%"struct.std::pair" = type { i32, i32 } +%"class.mozilla::UniquePtr" = type { %"struct.mozilla::Pair" } +%"struct.mozilla::Pair" = type { %"struct.mozilla::detail::PairHelper" } +%"struct.mozilla::detail::PairHelper" = type { %"struct.base::LaunchOptions::ForkDelegate"* } +%"struct.base::LaunchOptions::ForkDelegate" = type { i32 (...)** } +%"class.std::allocator" = type { i8 } +%"class.std::initializer_list" = type { %"class.std::__cxx11::basic_string"*, i64 } +%"class.mozilla::DefaultDelete" = type { i8 } +%struct._IO_FILE = type { i32, i8*, i8*, i8*, i8*, i8*, i8*, i8*, i8*, i8*, i8*, i8*, %struct._IO_marker*, %struct._IO_FILE*, i32, i32, i64, i16, i8, [1 x i8], i8*, i64, %struct._IO_codecvt*, %struct._IO_wide_data*, %struct._IO_FILE*, i8*, i64, i32, [20 x i8] } +%struct._IO_marker = type opaque +%struct._IO_codecvt = type opaque +%struct._IO_wide_data = type opaque +%"class.mozilla::Scoped" = type { %struct._IO_FILE* } +%"struct.std::_Rb_tree_node" = type { %"struct.std::_Rb_tree_node_base", %"struct.__gnu_cxx::__aligned_membuf" } +%"struct.__gnu_cxx::__aligned_membuf" = type { [64 x i8] } +%"struct.std::pair.11" = type { %"class.std::__cxx11::basic_string", %"class.std::__cxx11::basic_string" } +%"class.__gnu_cxx::new_allocator" = type { i8 } +%"class.__gnu_cxx::__normal_iterator" = type { %"struct.std::pair"* } +%"class.std::move_iterator" = type { %"struct.std::pair"* } +%"class.std::allocator.8" = type { i8 } +%"class.__gnu_cxx::new_allocator.9" = type { i8 } + +$_ZN4base13LaunchOptionsD2Ev = comdat any + +$_ZNSt6vectorINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESaIS5_EED2Ev = comdat any + +$_ZN7mozilla9UniquePtrIN4base13LaunchOptions12ForkDelegateENS_13DefaultDeleteIS3_EEED2Ev = comdat any + +$_ZNSt12_Vector_baseISt4pairIiiESaIS1_EED2Ev = comdat any + +$_ZNSt8_Rb_treeINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESt4pairIKS5_S5_ESt10_Select1stIS8_ESt4lessIS5_ESaIS8_EED2Ev = comdat any + +$_ZNSt8_Rb_treeINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESt4pairIKS5_S5_ESt10_Select1stIS8_ESt4lessIS5_ESaIS8_EE8_M_eraseEPSt13_Rb_tree_nodeIS8_E = comdat any + +$_ZNSt8_Rb_treeINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESt4pairIKS5_S5_ESt10_Select1stIS8_ESt4lessIS5_ESaIS8_EE12_M_drop_nodeEPSt13_Rb_tree_nodeIS8_E = comdat any + +$_ZNSt4pairIKNSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEES5_ED2Ev = comdat any + +$_ZNSt12_Vector_baseINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESaIS5_EED2Ev = comdat any + +$_ZNSt12_Destroy_auxILb0EE9__destroyIPNSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEEEvT_S9_ = comdat any + +$_ZNSt6vectorINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESaIS5_EE19_M_range_initializeIPKS5_EEvT_SB_St20forward_iterator_tag = comdat any + +$_ZNSt12_Vector_baseINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEESaIS5_EE11_M_allocateEm = comdat any + +$_ZNSt16allocator_traitsISaINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEEE8allocateERS6_m = comdat any + +$_ZN9__gnu_cxx13new_allocatorINSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEE8allocateEmPKv = comdat any + +$_ZNSt20__uninitialized_copyILb0EE13__uninit_copyIPKNSt7__cxx1112basic_stringIcSt11char_traitsIcESaIcEEEPS7_EET0_T_SC_SB_ = comdat any + +$_ZNSt6vectorISt4pairIiiESaIS1_EE12emplace_backIJS1_EEEvDpOT_ = comdat any + +$_ZNSt6vectorISt4pairIiiESaIS1_EE17_M_realloc_insertIJS1_EEEvN9__gnu_cxx17__normal_iteratorIPS1_S3_EEDpOT_ = comdat any + +$_ZNKSt6vectorISt4pairIiiESaIS1_EE12_M_check_lenEmPKc = comdat any + +$_ZNSt12_Vector_baseISt4pairIiiESaIS1_EE11_M_allocateEm = comdat any + +$_ZNSt16allocator_traitsISaISt4pairIiiEEE8allocateERS2_m = comdat any + +$_ZN9__gnu_cxx13new_allocatorISt4pairIiiEE8allocateEmPKv = comdat any + +$_ZN7mozilla21ScopedCloseFileTraits7releaseEP8_IO_FILE = comdat any + +@.str = private unnamed_addr constant [6 x i8] c"-idrc\00", align 1 +@.str.1 = private unnamed_addr constant [2 x i8] c"r\00", align 1 +@.str.2 = private unnamed_addr constant [85 x i8] c"Distributor ID:\09%255[^\0A]\0ADescription:\09%255[^\0A]\0ARelease:\09%255[^\0A]\0ACodename:\09%255[^\0A]\0A\00", align 1 +@.str.3 = private unnamed_addr constant [21 x i8] c"/usr/bin/lsb_release\00", align 1 +@.str.5 = private unnamed_addr constant [27 x i8] c"fatal: STL threw bad_alloc\00", align 1 +@.str.6 = private unnamed_addr constant [26 x i8] c"vector::_M_realloc_insert\00", align 1 + +; Function Attrs: minsize nounwind optsize sspstrong uwtable +define hidden zeroext i1 @_ZN7mozilla6widget3lsb13GetLSBReleaseER12nsTSubstringIcES4_S4_S4_(%class.nsTSubstring* dereferenceable(16), %class.nsTSubstring* dereferenceable(16), %class.nsTSubstring* dereferenceable(16), %class.nsTSubstring* dereferenceable(16)) local_unnamed_addr #0 !dbg !2908 { + %5 = alloca [2 x i32], align 4 + %6 = alloca %"class.std::vector", align 8 + %7 = alloca [2 x %"class.std::__cxx11::basic_string"], align 8 + %8 = alloca %"class.std::allocator.0", align 1 + %9 = alloca %"class.std::allocator.0", align 1 + %10 = alloca %"struct.base::LaunchOptions", align 8 + %11 = alloca %"struct.std::pair", align 4 + %12 = alloca i32, align 4 + %13 = alloca [256 x i8], align 16 + %14 = alloca [256 x i8], align 16 + %15 = alloca [256 x i8], align 16 + %16 = alloca [256 x i8], align 16 + call void @llvm.dbg.value(metadata %class.nsTSubstring* %0, metadata !2915, metadata !DIExpression()), !dbg !3579 + call void @llvm.dbg.value(metadata %class.nsTSubstring* %1, metadata !2916, metadata !DIExpression()), !dbg !3580 + call void @llvm.dbg.value(metadata %class.nsTSubstring* %2, metadata !2917, metadata !DIExpression()), !dbg !3581 + call void @llvm.dbg.value(metadata %class.nsTSubstring* %3, metadata !2918, metadata !DIExpression()), !dbg !3582 + %17 = tail call i32 @access(i8* getelementptr inbounds ([21 x i8], [21 x i8]* @.str.3, i64 0, i64 0), i32 4) #7, !dbg !3583 + %18 = icmp eq i32 %17, 0, !dbg !3585 + br i1 %18, label %19, label %85, !dbg !3586 + +;