llvm-general 3.4.2.2 → 3.5.1.2
raw patch · 126 files changed
Files
- LICENSE +1/−1
- Setup.hs +61/−40
- llvm-general.cabal +42/−22
- src/Control/Monad/AnyCont.hs +2/−0
- src/Control/Monad/AnyCont/Class.hs +17/−7
- src/Control/Monad/Exceptable.hs +221/−0
- src/Control/Monad/Trans/AnyCont.hs +2/−1
- src/LLVM/General/CodeGenOpt.hs +1/−1
- src/LLVM/General/CodeModel.hs +1/−1
- src/LLVM/General/Diagnostic.hs +1/−1
- src/LLVM/General/Internal/Analysis.hs +6/−4
- src/LLVM/General/Internal/Atomicity.hs +18/−8
- src/LLVM/General/Internal/Attribute.hs +217/−133
- src/LLVM/General/Internal/BasicBlock.hs +2/−1
- src/LLVM/General/Internal/CallingConvention.hs +53/−13
- src/LLVM/General/Internal/Coding.hs +2/−5
- src/LLVM/General/Internal/CommandLine.hs +5/−3
- src/LLVM/General/Internal/Constant.hs +9/−6
- src/LLVM/General/Internal/Context.hs +5/−1
- src/LLVM/General/Internal/DataLayout.hs +3/−1
- src/LLVM/General/Internal/DecodeAST.hs +24/−4
- src/LLVM/General/Internal/Diagnostic.hs +2/−0
- src/LLVM/General/Internal/EncodeAST.hs +58/−32
- src/LLVM/General/Internal/ExecutionEngine.hs +9/−7
- src/LLVM/General/Internal/FFI/Analysis.hs +2/−0
- src/LLVM/General/Internal/FFI/Assembly.hs +2/−0
- src/LLVM/General/Internal/FFI/AssemblyC.cpp +1/−2
- src/LLVM/General/Internal/FFI/Attribute.h +55/−0
- src/LLVM/General/Internal/FFI/Attribute.hs +131/−0
- src/LLVM/General/Internal/FFI/AttributeC.cpp +120/−0
- src/LLVM/General/Internal/FFI/AttributeC.hpp +42/−0
- src/LLVM/General/Internal/FFI/BasicBlock.hs +2/−0
- src/LLVM/General/Internal/FFI/BinaryOperator.h +16/−0
- src/LLVM/General/Internal/FFI/BinaryOperator.hs +5/−2
- src/LLVM/General/Internal/FFI/Bitcode.hs +2/−0
- src/LLVM/General/Internal/FFI/BitcodeC.cpp +6/−4
- src/LLVM/General/Internal/FFI/Builder.hs +31/−21
- src/LLVM/General/Internal/FFI/BuilderC.cpp +24/−23
- src/LLVM/General/Internal/FFI/ByteRangeCallback.hs +2/−0
- src/LLVM/General/Internal/FFI/CallingConvention.h +35/−0
- src/LLVM/General/Internal/FFI/CallingConventionC.hpp +16/−0
- src/LLVM/General/Internal/FFI/Cleanup.hs +6/−7
- src/LLVM/General/Internal/FFI/CommandLine.hs +2/−0
- src/LLVM/General/Internal/FFI/Constant.hs +2/−3
- src/LLVM/General/Internal/FFI/ConstantC.cpp +1/−12
- src/LLVM/General/Internal/FFI/Context.hs +2/−0
- src/LLVM/General/Internal/FFI/DataLayout.hs +2/−0
- src/LLVM/General/Internal/FFI/ExecutionEngine.hs +2/−0
- src/LLVM/General/Internal/FFI/Function.h +0/−39
- src/LLVM/General/Internal/FFI/Function.hs +27/−26
- src/LLVM/General/Internal/FFI/FunctionC.cpp +32/−0
- src/LLVM/General/Internal/FFI/GlobalAlias.hs +3/−2
- src/LLVM/General/Internal/FFI/GlobalAliasC.cpp +1/−0
- src/LLVM/General/Internal/FFI/GlobalValue.h +26/−8
- src/LLVM/General/Internal/FFI/GlobalValue.hs +42/−13
- src/LLVM/General/Internal/FFI/GlobalValueC.cpp +50/−0
- src/LLVM/General/Internal/FFI/GlobalVariable.hs +3/−8
- src/LLVM/General/Internal/FFI/InlineAssembly.hs +2/−0
- src/LLVM/General/Internal/FFI/Instruction.h +29/−0
- src/LLVM/General/Internal/FFI/Instruction.hs +21/−23
- src/LLVM/General/Internal/FFI/InstructionC.cpp +62/−25
- src/LLVM/General/Internal/FFI/InstructionDefs.hsc +2/−0
- src/LLVM/General/Internal/FFI/Iterate.hs +2/−2
- src/LLVM/General/Internal/FFI/LLVMCTypes.hsc +56/−14
- src/LLVM/General/Internal/FFI/LibFunc.h +10/−1
- src/LLVM/General/Internal/FFI/MemoryBuffer.hs +3/−1
- src/LLVM/General/Internal/FFI/Metadata.hs +2/−0
- src/LLVM/General/Internal/FFI/Module.hs +8/−1
- src/LLVM/General/Internal/FFI/ModuleC.cpp +6/−2
- src/LLVM/General/Internal/FFI/PassManager.hs +8/−4
- src/LLVM/General/Internal/FFI/PassManagerC.cpp +40/−39
- src/LLVM/General/Internal/FFI/PtrHierarchy.hs +17/−4
- src/LLVM/General/Internal/FFI/RawOStream.hs +2/−1
- src/LLVM/General/Internal/FFI/RawOStreamC.cpp +4/−3
- src/LLVM/General/Internal/FFI/SMDiagnostic.hs +2/−0
- src/LLVM/General/Internal/FFI/Target.h +4/−2
- src/LLVM/General/Internal/FFI/Target.hs +3/−1
- src/LLVM/General/Internal/FFI/TargetC.cpp +14/−11
- src/LLVM/General/Internal/FFI/Threading.hs +13/−0
- src/LLVM/General/Internal/FFI/Transforms.hs +20/−17
- src/LLVM/General/Internal/FFI/Type.hs +2/−1
- src/LLVM/General/Internal/FFI/User.hs +3/−2
- src/LLVM/General/Internal/FFI/Value.h +0/−2
- src/LLVM/General/Internal/FFI/Value.hs +6/−2
- src/LLVM/General/Internal/FFI/ValueC.cpp +9/−0
- src/LLVM/General/Internal/FastMathFlags.hs +51/−0
- src/LLVM/General/Internal/Function.hs +29/−15
- src/LLVM/General/Internal/Global.hs +69/−10
- src/LLVM/General/Internal/Inject.hs +11/−0
- src/LLVM/General/Internal/InlineAssembly.hs +2/−1
- src/LLVM/General/Internal/Instruction.hs +185/−274
- src/LLVM/General/Internal/InstructionDefs.hs +2/−0
- src/LLVM/General/Internal/LibraryFunction.hsc +2/−0
- src/LLVM/General/Internal/MemoryBuffer.hs +9/−5
- src/LLVM/General/Internal/Metadata.hs +3/−1
- src/LLVM/General/Internal/Module.hs +112/−70
- src/LLVM/General/Internal/Operand.hs +18/−3
- src/LLVM/General/Internal/PassManager.hs +18/−13
- src/LLVM/General/Internal/RawOStream.hs +21/−22
- src/LLVM/General/Internal/String.hs +2/−1
- src/LLVM/General/Internal/TailCallKind.hs +18/−0
- src/LLVM/General/Internal/Target.hs +51/−33
- src/LLVM/General/Internal/Threading.hs +13/−0
- src/LLVM/General/Internal/Type.hs +14/−12
- src/LLVM/General/Internal/Value.hs +2/−0
- src/LLVM/General/Relocation.hs +1/−1
- src/LLVM/General/Target.hs +1/−1
- src/LLVM/General/Target/Options.hs +4/−3
- src/LLVM/General/Threading.hs +24/−0
- src/LLVM/General/Transforms.hs +21/−39
- test/LLVM/General/Test/Analysis.hs +13/−13
- test/LLVM/General/Test/CallingConvention.hs +57/−0
- test/LLVM/General/Test/Constants.hs +40/−35
- test/LLVM/General/Test/DataLayout.hs +87/−0
- test/LLVM/General/Test/ExecutionEngine.hs +2/−2
- test/LLVM/General/Test/Global.hs +3/−2
- test/LLVM/General/Test/InlineAssembly.hs +8/−7
- test/LLVM/General/Test/Instructions.hs +79/−64
- test/LLVM/General/Test/Instrumentation.hs +42/−28
- test/LLVM/General/Test/Linking.hs +6/−6
- test/LLVM/General/Test/Metadata.hs +9/−7
- test/LLVM/General/Test/Module.hs +177/−79
- test/LLVM/General/Test/Optimization.hs +103/−103
- test/LLVM/General/Test/Support.hs +3/−3
- test/LLVM/General/Test/Target.hs +8/−33
- test/LLVM/General/Test/Tests.hs +2/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013, Benjamin S. Scarlet+Copyright (c) 2013, Benjamin S. Scarlet and Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without
Setup.hs view
@@ -8,6 +8,7 @@ import Data.Monoid import Data.Char import Distribution.Simple+import Distribution.Simple.PreProcess import Distribution.Simple.Program import Distribution.Simple.Setup hiding (Flag) import Distribution.Simple.LocalBuildInfo@@ -22,7 +23,7 @@ -- without checking they're already defined and so causes warnings. uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] -llvmVersion = Version [3,4] []+llvmVersion = Version [3,5] [] llvmConfigNames = [ "llvm-config-" ++ (intercalate "." . map show . versionBranch $ llvmVersion),@@ -48,6 +49,22 @@ instance Monad m => ProgramSearch (v -> p -> m (Maybe b)) where programSearch checkName = \v p -> findJustBy (\n -> checkName n v p) llvmConfigNames +class OldHookable hook where+ preHookOld :: (PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()) -> hook -> hook++-- this instance is used before Cabal-1.22.0.0, when testHook took four arguments+instance OldHookable (PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()) where+ preHookOld f hook = \packageDescription localBuildInfo userHooks testFlags -> do+ f packageDescription localBuildInfo userHooks testFlags+ hook packageDescription localBuildInfo userHooks testFlags++-- this instance is used for and after Cabal-1.22.0.0, when testHook took four five arguments+instance OldHookable (Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()) where+ preHookOld f hook = \args packageDescription localBuildInfo userHooks testFlags -> do+ f packageDescription localBuildInfo userHooks testFlags+ hook args packageDescription localBuildInfo userHooks testFlags++llvmProgram :: Program llvmProgram = (simpleProgram "llvm-config") { programFindLocation = programSearch (programFindLocation . simpleProgram), programFindVersion = @@ -59,44 +76,49 @@ \v p -> findProgramVersion "--version" (svnToTag . trim) v p } -main = do- let (ldLibraryPathVar, ldLibraryPathSep) = +getLLVMConfig :: ConfigFlags -> IO (String -> IO String)+getLLVMConfig configFlags = do+ let verbosity = fromFlag $ configVerbosity configFlags+ (program, _, _) <- requireProgramVersion verbosity llvmProgram+ (withinVersion llvmVersion)+ (configPrograms configFlags)+ return $ getProgramOutput verbosity program . return++addToLdLibraryPath :: String -> IO ()+addToLdLibraryPath path = do+ let (ldLibraryPathVar, ldLibraryPathSep) = case buildOS of OSX -> ("DYLD_LIBRARY_PATH",":") _ -> ("LD_LIBRARY_PATH",":")- addToLdLibraryPath s = do- v <- try $ getEnv ldLibraryPathVar :: IO (Either SomeException String)- setEnv ldLibraryPathVar (s ++ either (const "") (ldLibraryPathSep ++) v)- getLLVMConfig configFlags = do- let verbosity = fromFlag $ configVerbosity configFlags- (program, _, _) <- requireProgramVersion verbosity llvmProgram- (withinVersion llvmVersion)- (configPrograms configFlags)- let llvmConfig :: [String] -> IO String- llvmConfig = getProgramOutput verbosity program- return llvmConfig- addLLVMToLdLibraryPath configFlags = do- llvmConfig <- getLLVMConfig configFlags- [libDir] <- liftM lines $ llvmConfig ["--libdir"]- addToLdLibraryPath libDir- - defaultMainWithHooks simpleUserHooks {+ v <- try $ getEnv ldLibraryPathVar :: IO (Either SomeException String)+ setEnv ldLibraryPathVar (path ++ either (const "") (ldLibraryPathSep ++) v)++addLLVMToLdLibraryPath :: ConfigFlags -> IO ()+addLLVMToLdLibraryPath configFlags = do+ llvmConfig <- getLLVMConfig configFlags+ [libDir] <- liftM lines $ llvmConfig "--libdir"+ addToLdLibraryPath libDir+ +main = do+ let origUserHooks = simpleUserHooks+ + defaultMainWithHooks origUserHooks { hookedPrograms = [ llvmProgram ], confHook = \(genericPackageDescription, hookedBuildInfo) configFlags -> do llvmConfig <- getLLVMConfig configFlags llvmCppFlags <- do- l <- llvmConfig ["--cppflags"]+ l <- llvmConfig "--cppflags" return $ (filter ("-D" `isPrefixOf`) $ words l) \\ (map ("-D"++) uncheckedHsFFIDefines)- includeDirs <- liftM lines $ llvmConfig ["--includedir"]- libDirs@[libDir] <- liftM lines $ llvmConfig ["--libdir"]- [llvmVersion] <- liftM lines $ llvmConfig ["--version"]+ includeDirs <- liftM lines $ llvmConfig "--includedir"+ libDirs@[libDir] <- liftM lines $ llvmConfig "--libdir"+ [llvmVersion] <- liftM lines $ llvmConfig "--version" let sharedLib = case llvmVersion of "3.2" -> "LLVM-3.2svn" x -> "LLVM-" ++ x- staticLibs <- liftM (map (fromJust . stripPrefix "-l") . words) $ llvmConfig ["--libs"]- externLibs <- liftM (mapMaybe (stripPrefix "-l") . words) $ llvmConfig ["--ldflags"]+ staticLibs <- liftM (map (fromJust . stripPrefix "-l") . words) $ llvmConfig "--libs"+ systemLibs <- liftM (map (fromJust . stripPrefix "-l") . words) $ llvmConfig "--system-libs" let genericPackageDescription' = genericPackageDescription { condLibrary = do@@ -108,8 +130,8 @@ condTreeComponents = condTreeComponents libraryCondTree ++ [ ( Var (Flag (FlagName "shared-llvm")),- CondNode (mempty { libBuildInfo = mempty { extraLibs = [sharedLib] ++ externLibs } }) [] [],- Just (CondNode (mempty { libBuildInfo = mempty { extraLibs = staticLibs ++ externLibs } }) [] [])+ CondNode (mempty { libBuildInfo = mempty { extraLibs = [sharedLib] ++ systemLibs } }) [] [],+ Just (CondNode (mempty { libBuildInfo = mempty { extraLibs = staticLibs ++ systemLibs } }) [] []) ) ] }@@ -121,18 +143,17 @@ addLLVMToLdLibraryPath configFlags' confHook simpleUserHooks (genericPackageDescription', hookedBuildInfo) configFlags', - buildHook = \packageDescription localBuildInfo userHooks buildFlags -> do- addLLVMToLdLibraryPath (configFlags localBuildInfo)- buildHook simpleUserHooks packageDescription localBuildInfo userHooks buildFlags,+ hookedPreProcessors =+ let origHookedPreprocessors = hookedPreProcessors origUserHooks+ newHsc buildInfo localBuildInfo =+ maybe ppHsc2hs id (lookup "hsc" origHookedPreprocessors) buildInfo' localBuildInfo+ where buildInfo' = buildInfo { ccOptions = ccOptions buildInfo \\ ["-std=c++11"] }+ in [("hsc", newHsc)] ++ origHookedPreprocessors, - testHook = \packageDescription localBuildInfo userHooks testFlags -> do- addLLVMToLdLibraryPath (configFlags localBuildInfo)- testHook simpleUserHooks packageDescription localBuildInfo userHooks testFlags,+ buildHook = \packageDescription localBuildInfo userHooks buildFlags -> do+ addLLVMToLdLibraryPath (configFlags localBuildInfo)+ buildHook origUserHooks packageDescription localBuildInfo userHooks buildFlags, - haddockHook = \packageDescription localBuildInfo userHooks haddockFlags -> do- let v = "GHCRTS"- oldGhcRts <- try $ getEnv v :: IO (Either SomeException String)- setEnv v (either (const id) (\o n -> o ++ " " ++ n) oldGhcRts "-K32M")- haddockHook simpleUserHooks packageDescription localBuildInfo userHooks haddockFlags- either (const (unsetEnv v)) (setEnv v) oldGhcRts+ testHook = preHookOld (\_ localBuildInfo _ _ -> addLLVMToLdLibraryPath (configFlags localBuildInfo))+ (testHook origUserHooks) }
llvm-general.cabal view
@@ -1,10 +1,12 @@ name: llvm-general-version: 3.4.2.2+version: 3.5.1.2 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net> maintainer: Benjamin S. Scarlet <fgthb0@greynode.net>-copyright: Benjamin S. Scarlet 2013+copyright: (c) 2013 Benjamin S. Scarlet and Google Inc.+homepage: http://github.com/bscarlet/llvm-general/+bug-reports: http://github.com/bscarlet/llvm-general/issues build-type: Custom stability: experimental cabal-version: >= 1.8@@ -12,15 +14,17 @@ synopsis: General purpose LLVM bindings description: llvm-general is a set of Haskell bindings for LLVM <http://llvm.org/>. Unlike other current Haskell bindings,- it uses an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>), 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.- .- For haddock, see <http://bscarlet.github.io/llvm-general/3.4.2.2/doc/html/llvm-general/index.html>.+ it uses an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>), 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. extra-source-files: src/LLVM/General/Internal/FFI/Analysis.h+ src/LLVM/General/Internal/FFI/Attribute.h+ src/LLVM/General/Internal/FFI/AttributeC.hpp+ src/LLVM/General/Internal/FFI/BinaryOperator.h+ src/LLVM/General/Internal/FFI/CallingConvention.h+ src/LLVM/General/Internal/FFI/CallingConventionC.hpp src/LLVM/General/Internal/FFI/Constant.h- src/LLVM/General/Internal/FFI/Function.h src/LLVM/General/Internal/FFI/GlobalValue.h src/LLVM/General/Internal/FFI/InlineAssembly.h src/LLVM/General/Internal/FFI/Instruction.h@@ -30,7 +34,7 @@ src/LLVM/General/Internal/FFI/Target.h src/LLVM/General/Internal/FFI/Type.h src/LLVM/General/Internal/FFI/Value.h- + source-repository head type: git location: git://github.com/bscarlet/llvm-general.git@@ -38,8 +42,8 @@ source-repository this type: git location: git://github.com/bscarlet/llvm-general.git- branch: llvm-3.4- tag: v3.4.2.2+ branch: llvm-3.5+ tag: v3.5.1.2 flag shared-llvm description: link against llvm shared rather than static library@@ -52,21 +56,24 @@ library build-tools: llvm-config ghc-options: -fwarn-unused-imports- build-depends: - base >= 4.5.0.0 && < 5,+ cc-options: -std=c++11+ build-depends:+ base >= 4.6 && < 5, utf8-string >= 0.3.7, bytestring >= 0.9.1.10,- transformers >= 0.3.0.0,- mtl >= 2.0.1.0,+ transformers >= 0.3.0.0 && < 0.5,+ transformers-compat,+ mtl >= 2.1.3, template-haskell >= 2.5.0.0, containers >= 0.4.2.1, parsec >= 3.1.3, array >= 0.4.0.0, setenv >= 0.1.0,- llvm-general-pure == 3.4.2.2+ llvm-general-pure == 3.5.1.0 extra-libraries: stdc++ hs-source-dirs: src extensions:+ NoImplicitPrelude TupleSections DeriveDataTypeable EmptyDataDecls@@ -89,10 +96,12 @@ LLVM.General.Target LLVM.General.Target.LibraryFunction LLVM.General.Target.Options+ LLVM.General.Threading LLVM.General.Transforms other-modules: Control.Monad.AnyCont+ Control.Monad.Exceptable Control.Monad.AnyCont.Class Control.Monad.Trans.AnyCont LLVM.General.Internal.Analysis@@ -109,9 +118,11 @@ LLVM.General.Internal.Diagnostic LLVM.General.Internal.EncodeAST LLVM.General.Internal.ExecutionEngine+ LLVM.General.Internal.FastMathFlags LLVM.General.Internal.FloatingPointPredicate LLVM.General.Internal.Function LLVM.General.Internal.Global+ LLVM.General.Internal.Inject LLVM.General.Internal.InlineAssembly LLVM.General.Internal.Instruction LLVM.General.Internal.InstructionDefs@@ -125,10 +136,13 @@ LLVM.General.Internal.RawOStream LLVM.General.Internal.RMWOperation LLVM.General.Internal.String+ LLVM.General.Internal.TailCallKind LLVM.General.Internal.Target+ LLVM.General.Internal.Threading LLVM.General.Internal.Type LLVM.General.Internal.Value LLVM.General.Internal.FFI.Analysis+ LLVM.General.Internal.FFI.Attribute LLVM.General.Internal.FFI.Assembly LLVM.General.Internal.FFI.BasicBlock LLVM.General.Internal.FFI.BinaryOperator@@ -158,14 +172,16 @@ LLVM.General.Internal.FFI.RawOStream LLVM.General.Internal.FFI.SMDiagnostic LLVM.General.Internal.FFI.Target+ LLVM.General.Internal.FFI.Threading LLVM.General.Internal.FFI.Transforms LLVM.General.Internal.FFI.Type LLVM.General.Internal.FFI.User LLVM.General.Internal.FFI.Value include-dirs: src- c-sources: + c-sources: src/LLVM/General/Internal/FFI/AssemblyC.cpp+ src/LLVM/General/Internal/FFI/AttributeC.cpp src/LLVM/General/Internal/FFI/BitcodeC.cpp src/LLVM/General/Internal/FFI/BuilderC.cpp src/LLVM/General/Internal/FFI/ConstantC.cpp@@ -190,17 +206,19 @@ test-suite test type: exitcode-stdio-1.0- build-depends: - base >= 3 && < 5,+ build-depends:+ base >= 4.6 && < 5, test-framework >= 0.5, test-framework-hunit >= 0.2.7, HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1,- llvm-general == 3.4.2.2,- llvm-general-pure == 3.4.2.2,+ llvm-general == 3.5.1.2,+ llvm-general-pure == 3.5.1.0, containers >= 0.4.2.1,- mtl >= 2.0.1.0+ mtl >= 2.1,+ transformers >= 0.3.0.0,+ transformers-compat hs-source-dirs: test extensions: TupleSections@@ -209,7 +227,9 @@ main-is: Test.hs other-modules: LLVM.General.Test.Analysis+ LLVM.General.Test.CallingConvention LLVM.General.Test.Constants+ LLVM.General.Test.DataLayout LLVM.General.Test.ExecutionEngine LLVM.General.Test.Global LLVM.General.Test.InlineAssembly
src/Control/Monad/AnyCont.hs view
@@ -12,6 +12,8 @@ mapAnyContT ) where +import Prelude+ import Control.Monad.Trans.AnyCont import Control.Monad.AnyCont.Class import Control.Monad.Trans.Class
src/Control/Monad/AnyCont/Class.hs view
@@ -5,11 +5,14 @@ #-} 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.Error as Error+import Control.Monad.Trans.Except as Except import Control.Monad.Trans.State as State+import Control.Monad.Exceptable as Exceptable class ScopeAnyCont m where scopeAnyCont :: m a -> m a@@ -23,8 +26,8 @@ instance Monad m => ScopeAnyCont (AnyContT m) where scopeAnyCont = lift . flip AnyCont.runAnyContT return- + instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where anyContToM x = lift $ anyContToM x @@ -32,14 +35,18 @@ scopeAnyCont = StateT . (scopeAnyCont .) . runStateT -instance (Error e, Monad m, MonadAnyCont b m) => MonadAnyCont b (ErrorT e m) where+instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (ExceptT e m) where anyContToM x = lift $ anyContToM x -instance ScopeAnyCont m => ScopeAnyCont (ErrorT e m) where- scopeAnyCont = mapErrorT scopeAnyCont+instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (Exceptable.ExceptableT e m) where+ anyContToM x = lift $ anyContToM x +instance ScopeAnyCont m => ScopeAnyCont (ExceptT e m) where+ scopeAnyCont = mapExceptT scopeAnyCont +instance ScopeAnyCont m => ScopeAnyCont (Exceptable.ExceptableT e m) where+ scopeAnyCont = Exceptable.mapExceptableT scopeAnyCont class MonadTransAnyCont b m where liftAnyCont :: (forall r . (a -> b r) -> b r) -> (forall r . (a -> m r) -> m r)@@ -50,5 +57,8 @@ 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 (ErrorT e m) where- liftAnyCont c = (\c q -> ErrorT . c $ runErrorT . q) (liftAnyCont c)+instance MonadTransAnyCont b m => MonadTransAnyCont b (ExceptT e m) where+ liftAnyCont c = (\c q -> ExceptT . c $ runExceptT . q) (liftAnyCont c)++instance MonadTransAnyCont b m => MonadTransAnyCont b (Exceptable.ExceptableT e m) where+ liftAnyCont c = (\c q -> makeExceptableT . c $ Exceptable.runExceptableT . q) (liftAnyCont c)
+ src/Control/Monad/Exceptable.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ UndecidableInstances,+ CPP+ #-}++module Control.Monad.Exceptable (+ -- * MonadError class+ MonadError(..),++ -- * The Exceptable monad+ Exceptable,+ exceptable,+ runExceptable,+ mapExceptable,+ withExceptable,+ makeExceptableT,+ -- * The ExceptT monad transformer+ ExceptableT(ExceptableT),+ unExceptableT,+ runExceptableT,+ mapExceptableT,+ withExceptableT,+ -- * Exception operations+ throwE,+ catchE,+ -- * Lifting other operations+ liftCallCC,+ liftListen,+ liftPass,+ -- * underlying ExceptT type+ Except.Except,+ Except.ExceptT,++ module Control.Monad.Fix,+ module Control.Monad.Trans,+ -- * Example 1: Custom Error Data Type+ -- $customErrorExample++ -- * Example 2: Using ExceptT Monad Transformer+ -- $ExceptTExample+ ) where++import Prelude++import qualified Control.Monad.Trans.Except as Except++import Control.Monad.Trans+import Control.Monad.Signatures+import Data.Functor.Classes+import Data.Functor.Identity++import Control.Monad.State.Class as State+import Control.Monad.Error.Class as Error++import Control.Applicative+import Control.Monad+import Control.Monad.Fix+#if __GLASGOW_HASKELL__ < 710+import Data.Foldable+import Data.Traversable (Traversable(traverse))+#endif+++{- |+Why does the Exceptable module exist? The present llvm general design+is around the use of the ExceptT transformer, first defined in transformers 0.4.++Well, the goal of this module is to allow LLVM-General to be compatible with+GHC 7.8 apis, and GHC 7.8 comes bundled with transformers 0.3. Thus LLVM-General+must be compatible with transformers 0.3 (via the use of transformers-compat)+in order to be usable in conjunction with usage of GHC as a library.++At some future point where the active "power users" base of LLVM-General+no longer needs to support GHC 7.8 heavily, removing this Module and reverting other+changes elsewhere to using ExceptT / Except will be a good idea.++A good "signpost" for reverting will be around GHC 7.12's release,+because then there will be >=2 GHC major version releases that come bundled with+Transformers >= 0.4++-}+++type Exceptable e = ExceptableT e Identity++-- | Constructor for computations in the exception monad.+-- (The inverse of 'runExcept').+except :: Either e a -> Exceptable e a+except m = makeExceptableT (Identity m)++exceptable :: Except.Except e a -> Exceptable e a+exceptable = ExceptableT++-- | Extractor for computations in the exception monad.+-- (The inverse of 'except').+runExceptable :: Exceptable e a -> Either e a+runExceptable (ExceptableT m) = runIdentity $ Except.runExceptT m++-- | Map the unwrapped computation using the given function.+--+-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@+mapExceptable :: (Either e a -> Either e' b)+ -> Exceptable e a+ -> Exceptable e' b+mapExceptable f = mapExceptableT (Identity . f . runIdentity)++-- | Transform any exceptions thrown by the computation using the given+-- function (a specialization of 'withExceptT').+withExceptable :: (e -> e') -> Exceptable e a -> Exceptable e' a+withExceptable = withExceptableT++++newtype ExceptableT e m a = ExceptableT { unExceptableT :: Except.ExceptT e m a }+ deriving (+ Eq,+ Eq1,+ Ord,+ Ord1,+ Functor,+ Foldable,+ Applicative,+ Alternative,+ Monad,+ MonadPlus,+ MonadTrans,+ MonadIO+ )++instance MonadState s m => MonadState s (ExceptableT e m) where+ get = lift get+ put = lift . put+ state = lift . state++instance Monad m => MonadError e (ExceptableT e m) where+ throwError = throwE+ catchError = catchE++instance (Traversable f) => Traversable (ExceptableT e f) where+ traverse f a =+ (ExceptableT . Except.ExceptT) <$>+ traverse (either (pure . Left) (fmap Right . f)) (runExceptableT a)+++instance (Read e, Read1 m, Read a) => Read (ExceptableT e m a) where+ readsPrec = readsData $ readsUnary1 "ExceptableT" ExceptableT++instance (Show e, Show1 m, Show a) => Show (ExceptableT e m a) where+ showsPrec d (ExceptableT m) = showsUnary1 "ExceptableT" d m++instance (Read e, Read1 m) => Read1 (ExceptableT e m) where readsPrec1 = readsPrec+instance (Show e, Show1 m) => Show1 (ExceptableT e m) where showsPrec1 = showsPrec++runExceptableT :: ExceptableT e m a -> m (Either e a)+runExceptableT = Except.runExceptT . unExceptableT++makeExceptableT :: m (Either e a) -> ExceptableT e m a+makeExceptableT = ExceptableT . Except.ExceptT+++++-- | Map the unwrapped computation using the given function.+--+-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@+mapExceptableT :: (m (Either e a) -> n (Either e' b))+ -> ExceptableT e m a+ -> ExceptableT e' n b+mapExceptableT f m = makeExceptableT $ f (runExceptableT m)++-- | Transform any exceptions thrown by the computation using the+-- given function.+withExceptableT :: (Functor m) => (e -> e') -> ExceptableT e m a -> ExceptableT e' m a+withExceptableT f = mapExceptableT $ fmap $ either (Left . f) Right+++-- | Signal an exception value @e@.+--+-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@+--+-- * @'throwE' e >>= m = 'throwE' e@+throwE :: (Monad m) => e -> ExceptableT e m a+throwE = makeExceptableT . return . Left++-- | Handle an exception.+--+-- * @'catchE' h ('lift' m) = 'lift' m@+--+-- * @'catchE' h ('throwE' e) = h e@+catchE :: (Monad m) =>+ ExceptableT e m a -- ^ the inner computation+ -> (e -> ExceptableT e' m a) -- ^ a handler for exceptions in the inner+ -- computation+ -> ExceptableT e' m a+m `catchE` h = makeExceptableT $ do+ a <- runExceptableT m+ case a of+ Left l -> runExceptableT (h l)+ Right r -> return (Right r)++-- | Lift a @callCC@ operation to the new monad.+liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptableT e m) a b+liftCallCC callCC f = makeExceptableT $+ callCC $ \ c ->+ runExceptableT (f (\ a -> makeExceptableT $ c (Right a)))++-- | Lift a @listen@ operation to the new monad.+liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptableT e m) a+liftListen listen = mapExceptableT $ \ m -> do+ (a, w) <- listen m+ return $! fmap (\ r -> (r, w)) a++-- | Lift a @pass@ operation to the new monad.+liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptableT e m) a+liftPass pass = mapExceptableT $ \ m -> pass $ do+ a <- m+ return $! case a of+ Left l -> (Left l, id)+ Right (r, f) -> (Right r, f)
src/Control/Monad/Trans/AnyCont.hs view
@@ -3,7 +3,8 @@ #-} module Control.Monad.Trans.AnyCont where -import Control.Applicative+import LLVM.General.Prelude+ import Control.Monad.Cont newtype AnyContT m a = AnyContT { unAnyContT :: forall r . ContT r m a }
src/LLVM/General/CodeGenOpt.hs view
@@ -1,7 +1,7 @@ -- | Code generation options, used in specifying TargetMachine module LLVM.General.CodeGenOpt where -import Data.Data+import LLVM.General.Prelude -- | <http://llvm.org/doxygen/namespacellvm_1_1CodeGenOpt.html> data Level
src/LLVM/General/CodeModel.hs view
@@ -1,7 +1,7 @@ -- | Relocations, used in specifying TargetMachine module LLVM.General.CodeModel where -import Data.Data+import LLVM.General.Prelude -- | <http://llvm.org/doxygen/namespacellvm_1_1CodeModel.html> data Model
src/LLVM/General/Diagnostic.hs view
@@ -5,7 +5,7 @@ diagnosticDisplay ) where -import Data.Data+import LLVM.General.Prelude -- | What kind of problem does a diagnostic describe? data DiagnosticKind
src/LLVM/General/Internal/Analysis.hs view
@@ -1,6 +1,8 @@ module LLVM.General.Internal.Analysis where -import Control.Monad.Error+import LLVM.General.Prelude++import Control.Monad.Exceptable import Control.Monad.AnyCont import qualified LLVM.General.Internal.FFI.Analysis as FFI@@ -11,9 +13,9 @@ -- | 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 -> ErrorT String IO ()-verify (Module m) = flip runAnyContT return $ do+verify :: Module -> ExceptT String IO ()+verify (Module m) = unExceptableT $ flip runAnyContT return $ do errorPtr <- alloca result <- decodeM =<< (liftIO $ FFI.verifyModule m FFI.verifierFailureActionReturnStatus errorPtr)- when result $ fail =<< decodeM errorPtr+ when result $ throwError =<< decodeM errorPtr
src/LLVM/General/Internal/Atomicity.hs view
@@ -4,14 +4,13 @@ #-} module LLVM.General.Internal.Atomicity where -import Control.Monad+import LLVM.General.Prelude import Data.Maybe import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.Coding- import qualified LLVM.General.AST as A genCodingInstance [t| Maybe A.MemoryOrdering |] ''FFI.MemoryOrdering [@@ -24,16 +23,27 @@ (FFI.memoryOrderingSequentiallyConsistent, Just A.SequentiallyConsistent) ] -instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.LLVMBool, FFI.MemoryOrdering) where+genCodingInstance [t| A.SynchronizationScope |] ''FFI.SynchronizationScope [+ (FFI.synchronizationScopeSingleThread, A.SingleThread),+ (FFI.synchronizationScopeCrossThread, A.CrossThread)+ ]++instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.SynchronizationScope, FFI.MemoryOrdering) where encodeM a =- return (,) `ap` encodeM (maybe False A.crossThread a) `ap` encodeM (liftM A.memoryOrdering a)+ return (,) `ap` encodeM (maybe A.SingleThread fst a) `ap` encodeM (liftM snd a) -instance Monad m => DecodeM m (Maybe A.Atomicity) (FFI.LLVMBool, FFI.MemoryOrdering) where- decodeM (ss, ao) = return (liftM . A.Atomicity) `ap` decodeM ss `ap` decodeM ao+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.LLVMBool, FFI.MemoryOrdering) where+instance Monad m => EncodeM m A.Atomicity (FFI.SynchronizationScope, FFI.MemoryOrdering) where encodeM = encodeM . Just -instance Monad m => DecodeM m A.Atomicity (FFI.LLVMBool, FFI.MemoryOrdering) where+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
src/LLVM/General/Internal/Attribute.hs view
@@ -1,151 +1,235 @@ {-# LANGUAGE- TemplateHaskell, MultiParamTypeClasses,- ConstraintKinds+ ConstraintKinds,+ QuasiQuotes,+ UndecidableInstances,+ RankNTypes #-} module LLVM.General.Internal.Attribute where -import Language.Haskell.TH-import Language.Haskell.TH.Quote+import LLVM.General.Prelude -import Data.Data-import Data.List (genericSplitAt)+import Control.Monad.AnyCont+import Control.Monad.Exceptable+import Control.Monad.State (gets) -import Data.Bits+import Foreign.C (CUInt)+import Foreign.Ptr+import Data.Either+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe +import qualified LLVM.General.Internal.FFI.Attribute as FFI import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import LLVM.General.Internal.FFI.LLVMCTypes (parameterAttributeKindP, functionAttributeKindP) -import qualified LLVM.General.AST.Attribute as A.A+import qualified LLVM.General.AST.ParameterAttribute as A.PA +import qualified LLVM.General.AST.FunctionAttribute as A.FA import LLVM.General.Internal.Coding+import LLVM.General.Internal.Context +import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.DecodeAST -$(do- let- -- build an instance of the Coding class for lists of some kind of attribute- genAttributeListCoding :: (Data a, Bits a) => TypeQ -> Name -> [(a, String)] -> DecsQ- genAttributeListCoding type' ctn attributeData = do- let- lowZeroes :: Bits b => b -> Int- lowZeroes b | testBit b 0 = 0- lowZeroes b = 1 + lowZeroes (shiftR b 1)- field :: Bits b => b -> (Int, Int)- field b = - let s = lowZeroes b- w = lowZeroes (complement (shiftR b s))- in - (s,w)- attributeData' = [(mkName n, b, s,w) | (b,n) <- attributeData, let (s,w) = field b ]- let m = varT . mkName $ "m"- TyConI (NewtypeD _ _ _ (NormalC ctcn _) _) <- reify ctn- let zero = [| $(conE ctcn) 0 |]- sequence [- instanceD (sequence [classP ''Monad [m]]) [t| EncodeM $(m) [$(type')] $(conT ctn) |] [- funD (mkName "encodeM") [- clause [] (normalB [| return . (- let - encodeAttribute a = $(- caseE [| a |] $ flip map attributeData' $ \(n, b, s, w) ->- let bQ = (dataToExpQ (const Nothing) b)- in- case w of- 1 -> match (conP n []) (normalB bQ) []- _ -> do - a <- newName "a"- match - (conP n [varP a])- (normalB [| ($(conE ctcn) (fromIntegral $(varE a) `shiftL` s)) .&. $(bQ) |])- []- )- in- foldl (.|.) $(zero) . map encodeAttribute- ) |]) []- ]- ],- - -- build a decoder which uses bit masking for multiple fields at once- -- to eliminate multiple absent attributes in fewer tests- instanceD (sequence [classP ''Monad [m]]) [t| DecodeM $(m) [$(type')] $(conT ctn) |] [- funD (mkName "decodeM") [- do- bits <- newName "bits"- clause [varP bits] (normalB - (let- code :: (Data a, Bits a) => [ (Name, a, Int, Int) ] -- attrs to handle- -> Int -- length (attrs), passed in to avoid recomputation- -> (a, ExpQ) -- (<bitmask for all the given attrs>, <code to decode the given attrs>)- code [(n, b, s, w)] _ = (- b, - case w of- 1 -> [| [ $(conE n) | testBit $(varE bits) s ] |]- _-> [| - [ - $(do- i' <- newName "i'"- letE - [valD (conP ctcn [varP i']) (normalB [| i |]) []]- [| $(conE n) (fromIntegral $(varE i')) |])- | let i = ($(varE bits) .&. $(dataToExpQ (const Nothing) b)) `shiftR` s, - i /= $(zero)- ]- |]- )- code attrs nAttrs =- let (nEarlyAttrs, nLateAttrs) = (nAttrs `div` 2, nAttrs - nEarlyAttrs)- (earlyAttrs, lateAttrs) = genericSplitAt nEarlyAttrs attrs- (earlyAttrBits, earlyAttrCode) = code earlyAttrs nEarlyAttrs- (lateAttrBits, lateAttrCode) = code lateAttrs nLateAttrs- attrBits = earlyAttrBits .|. lateAttrBits- in- (- attrBits, - [| - if ($(varE bits) .&. $(dataToExpQ (const Nothing) attrBits) /= $(zero)) then- ($earlyAttrCode ++ $lateAttrCode) - else- []- |]- )- in- [| return $(snd $ code attributeData' (length attributeData')) |]- )- ) []- ]- ]- ]+instance Monad m => EncodeM m A.PA.ParameterAttribute (Ptr FFI.ParameterAttrBuilder -> EncodeAST ()) where+ encodeM a = return $ \b -> liftIO $ case a of+ A.PA.Alignment v -> FFI.attrBuilderAddAlignment b v+ A.PA.Dereferenceable v -> FFI.attrBuilderAddDereferenceable b v+ _ -> FFI.attrBuilderAddParameterAttributeKind b $ case a of+ A.PA.ZeroExt -> FFI.parameterAttributeKindZExt+ A.PA.SignExt -> FFI.parameterAttributeKindSExt+ A.PA.InReg -> FFI.parameterAttributeKindInReg+ A.PA.SRet -> FFI.parameterAttributeKindStructRet+ A.PA.NoAlias -> FFI.parameterAttributeKindNoAlias+ A.PA.ByVal -> FFI.parameterAttributeKindByVal+ A.PA.NoCapture -> FFI.parameterAttributeKindNoCapture+ A.PA.Nest -> FFI.parameterAttributeKindNest+ A.PA.ReadOnly -> FFI.parameterAttributeKindReadOnly+ A.PA.ReadNone -> FFI.parameterAttributeKindReadNone+ A.PA.InAlloca -> FFI.parameterAttributeKindInAlloca+ A.PA.NonNull -> FFI.parameterAttributeKindNonNull+ A.PA.Returned -> FFI.parameterAttributeKindReturned - pi <- genAttributeListCoding [t| A.A.ParameterAttribute |] ''FFI.ParamAttr [- (FFI.paramAttrZExt, "A.A.ZeroExt"),- (FFI.paramAttrSExt, "A.A.SignExt"),- (FFI.paramAttrInReg, "A.A.InReg"),- (FFI.paramAttrStructRet, "A.A.SRet"),- (FFI.paramAttrNoAlias, "A.A.NoAlias"),- (FFI.paramAttrByVal, "A.A.ByVal"),- (FFI.paramAttrNoCapture, "A.A.NoCapture"),- (FFI.paramAttrNest, "A.A.Nest")- ]+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 -> liftIO $ case a of+ A.FA.StackAlignment v -> FFI.attrBuilderAddStackAlignment b v+ _ -> FFI.attrBuilderAddFunctionAttributeKind b $ case a of+ A.FA.NoReturn -> FFI.functionAttributeKindNoReturn+ A.FA.NoUnwind -> FFI.functionAttributeKindNoUnwind+ A.FA.ReadNone -> FFI.functionAttributeKindReadNone+ A.FA.ReadOnly -> FFI.functionAttributeKindReadOnly+ A.FA.NoInline -> FFI.functionAttributeKindNoInline+ A.FA.AlwaysInline -> FFI.functionAttributeKindAlwaysInline+ A.FA.MinimizeSize -> FFI.functionAttributeKindMinSize+ A.FA.OptimizeForSize -> FFI.functionAttributeKindOptimizeForSize+ A.FA.OptimizeNone -> FFI.functionAttributeKindOptimizeForSize + A.FA.StackProtect -> FFI.functionAttributeKindStackProtect+ A.FA.StackProtectReq -> FFI.functionAttributeKindStackProtectReq+ A.FA.StackProtectStrong -> FFI.functionAttributeKindStackProtectStrong+ A.FA.NoRedZone -> FFI.functionAttributeKindNoRedZone+ A.FA.NoImplicitFloat -> FFI.functionAttributeKindNoImplicitFloat+ A.FA.Naked -> FFI.functionAttributeKindNaked+ A.FA.InlineHint -> FFI.functionAttributeKindInlineHint+ A.FA.ReturnsTwice -> FFI.functionAttributeKindReturnsTwice+ A.FA.UWTable -> FFI.functionAttributeKindUWTable+ A.FA.NonLazyBind -> FFI.functionAttributeKindNonLazyBind+ A.FA.Builtin -> FFI.functionAttributeKindBuiltin+ A.FA.NoBuiltin -> FFI.functionAttributeKindNoBuiltin+ A.FA.Cold -> FFI.functionAttributeKindCold+ A.FA.JumpTable -> FFI.functionAttributeKindJumpTable+ A.FA.NoDuplicate -> FFI.functionAttributeKindNoDuplicate+ A.FA.SanitizeAddress -> FFI.functionAttributeKindSanitizeAddress+ A.FA.SanitizeThread -> FFI.functionAttributeKindSanitizeThread+ A.FA.SanitizeMemory -> FFI.functionAttributeKindSanitizeMemory - fi <- genAttributeListCoding [t| A.A.FunctionAttribute |] ''FFI.FunctionAttr [- (FFI.functionAttrNoReturn, "A.A.NoReturn"),- (FFI.functionAttrNoUnwind, "A.A.NoUnwind"),- (FFI.functionAttrReadNone, "A.A.ReadNone"),- (FFI.functionAttrReadOnly, "A.A.ReadOnly"),- (FFI.functionAttrNoInline, "A.A.NoInline"),- (FFI.functionAttrAlwaysInline, "A.A.AlwaysInline"),- (FFI.functionAttrOptimizeForSize, "A.A.OptimizeForSize"),- (FFI.functionAttrStackProtect, "A.A.StackProtect"),- (FFI.functionAttrStackProtectReq, "A.A.StackProtectReq"),- (FFI.functionAttrAlignment, "A.A.Alignment"),- (FFI.functionAttrNoRedZone, "A.A.NoRedZone"),- (FFI.functionAttrNoImplicitFloat, "A.A.NoImplicitFloat"),- (FFI.functionAttrNaked, "A.A.Naked"),- (FFI.functionAttrInlineHint, "A.A.InlineHint"),- (FFI.functionAttrStackAlignment, "A.A.StackAlignment"),- (FFI.functionAttrReturnsTwice, "A.A.ReturnsTwice"),- (FFI.functionAttrUWTable, "A.A.UWTable"),- (FFI.functionAttrNonLazyBind, "A.A.NonLazyBind")- ]- return (pi ++ fi)- )+instance DecodeM DecodeAST A.PA.ParameterAttribute FFI.ParameterAttribute where+ decodeM a = do+ enum <- liftIO $ FFI.parameterAttributeKindAsEnum a+ case enum of+ [parameterAttributeKindP|ZExt|] -> return A.PA.ZeroExt+ [parameterAttributeKindP|SExt|] -> return A.PA.SignExt+ [parameterAttributeKindP|InReg|] -> return A.PA.InReg+ [parameterAttributeKindP|StructRet|] -> return A.PA.SRet+ [parameterAttributeKindP|Alignment|] -> return A.PA.Alignment `ap` (liftIO $ FFI.attributeValueAsInt a)+ [parameterAttributeKindP|NoAlias|] -> return A.PA.NoAlias+ [parameterAttributeKindP|ByVal|] -> return A.PA.ByVal+ [parameterAttributeKindP|NoCapture|] -> return A.PA.NoCapture+ [parameterAttributeKindP|Nest|] -> return A.PA.Nest+ [parameterAttributeKindP|ReadOnly|] -> return A.PA.ReadOnly+ [parameterAttributeKindP|ReadNone|] -> return A.PA.ReadNone+ [parameterAttributeKindP|InAlloca|] -> return A.PA.InAlloca+ [parameterAttributeKindP|NonNull|] -> return A.PA.NonNull+ [parameterAttributeKindP|Dereferenceable|] -> return A.PA.Dereferenceable `ap` (liftIO $ FFI.attributeValueAsInt a)+ [parameterAttributeKindP|Returned|] -> return A.PA.Returned+ _ -> 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|NoReturn|] -> return A.FA.NoReturn+ [functionAttributeKindP|NoUnwind|] -> return A.FA.NoUnwind+ [functionAttributeKindP|ReadNone|] -> return A.FA.ReadNone+ [functionAttributeKindP|ReadOnly|] -> return A.FA.ReadOnly+ [functionAttributeKindP|NoInline|] -> return A.FA.NoInline+ [functionAttributeKindP|AlwaysInline|] -> return A.FA.AlwaysInline+ [functionAttributeKindP|MinSize|] -> return A.FA.MinimizeSize+ [functionAttributeKindP|OptimizeForSize|] -> return A.FA.OptimizeForSize+ [functionAttributeKindP|OptimizeNone|] -> return A.FA.OptimizeForSize + [functionAttributeKindP|StackProtect|] -> return A.FA.StackProtect+ [functionAttributeKindP|StackProtectReq|] -> return A.FA.StackProtectReq+ [functionAttributeKindP|StackProtectStrong|] -> return A.FA.StackProtectStrong+ [functionAttributeKindP|NoRedZone|] -> return A.FA.NoRedZone+ [functionAttributeKindP|NoImplicitFloat|] -> return A.FA.NoImplicitFloat+ [functionAttributeKindP|Naked|] -> return A.FA.Naked+ [functionAttributeKindP|InlineHint|] -> return A.FA.InlineHint+ [functionAttributeKindP|StackAlignment|] -> return A.FA.StackAlignment `ap` (liftIO $ FFI.attributeValueAsInt a)+ [functionAttributeKindP|ReturnsTwice|] -> return A.FA.ReturnsTwice+ [functionAttributeKindP|UWTable|] -> return A.FA.UWTable+ [functionAttributeKindP|NonLazyBind|] -> return A.FA.NonLazyBind+ [functionAttributeKindP|Builtin|] -> return A.FA.Builtin+ [functionAttributeKindP|NoBuiltin|] -> return A.FA.NoBuiltin+ [functionAttributeKindP|Cold|] -> return A.FA.Cold+ [functionAttributeKindP|JumpTable|] -> return A.FA.JumpTable+ [functionAttributeKindP|NoDuplicate|] -> return A.FA.NoDuplicate+ [functionAttributeKindP|SanitizeAddress|] -> return A.FA.SanitizeAddress+ [functionAttributeKindP|SanitizeThread|] -> return A.FA.SanitizeThread+ [functionAttributeKindP|SanitizeMemory|] -> return A.FA.SanitizeMemory+ _ -> 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 EncodeM EncodeAST a (Ptr (FFI.AttrBuilder b) -> EncodeAST ()) => EncodeM EncodeAST (FFI.Index, [a]) (FFI.AttributeSet b) where+ encodeM (index, as) = scopeAnyCont $ do+ ab <- allocaAttrBuilder+ builds <- mapM encodeM as+ forM builds ($ ab) :: EncodeAST [()]+ Context context <- gets encodeStateContext+ liftIO $ FFI.getAttributeSet context index ab++instance EncodeM EncodeAST [A.FA.FunctionAttribute] FFI.FunctionAttributeSet where+ encodeM fas = encodeM (FFI.functionIndex, fas)++instance DecodeM DecodeAST a (FFI.Attribute b) => DecodeM DecodeAST [a] (FFI.AttributeSet b) where+ decodeM as = do+ np <- alloca+ as <- liftIO $ FFI.attributeSetGetAttributes as 0 np+ n <- peek np+ decodeM (n, as)+ +data MixedAttributeSet = MixedAttributeSet {+ functionAttributes :: [Either A.FA.GroupID A.FA.FunctionAttribute],+ returnAttributes :: [A.PA.ParameterAttribute],+ parameterAttributes :: Map CUInt [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 EncodeM EncodeAST PreSlot FFI.MixedAttributeSet where+ encodeM preSlot = do+ let forget = liftM FFI.forgetAttributeType+ case preSlot of+ IndirectFunctionAttributes gid -> forget (referAttributeGroup gid)+ DirectFunctionAttributes fas -> forget (encodeM fas :: EncodeAST FFI.FunctionAttributeSet)+ ReturnAttributes as -> forget (encodeM (FFI.returnIndex, as) :: EncodeAST FFI.ParameterAttributeSet)+ ParameterAttributes i as -> forget (encodeM (fromIntegral (i + 1) :: FFI.Index, as) :: EncodeAST FFI.ParameterAttributeSet)++instance EncodeM EncodeAST MixedAttributeSet FFI.MixedAttributeSet where+ encodeM (MixedAttributeSet fAttrs rAttrs pAttrs) = do+ let directP = DirectFunctionAttributes (rights fAttrs)+ indirectPs = map IndirectFunctionAttributes (lefts fAttrs)+ returnP = ReturnAttributes rAttrs+ paramPs = [ ParameterAttributes x as | (x, as) <- Map.toList pAttrs ]+ (nAttrs, attrs) <- encodeM ([directP, returnP] ++ indirectPs ++ paramPs)+ Context context <- gets encodeStateContext+ liftIO $ FFI.mixAttributeSets context attrs nAttrs++instance DecodeM DecodeAST MixedAttributeSet FFI.MixedAttributeSet where+ decodeM mas = do+ numSlots <- if mas == nullPtr then return 0 else liftIO $ FFI.attributeSetNumSlots mas+ slotIndexes <- forM (take (fromIntegral numSlots) [0..]) $ \s -> do+ i <- liftIO $ FFI.attributeSetSlotIndex mas s+ return (i, s)+ let separate :: Ord k => k -> Map k a -> (Maybe a, Map k a)+ separate = Map.updateLookupWithKey (\_ _ -> Nothing)+ indexedSlots = Map.fromList slotIndexes+ unless (Map.size indexedSlots == length slotIndexes) $+ fail "unexpected slot index collision decoding mixed AttributeSet"+ let (functionSlot, otherSlots) = separate FFI.functionIndex (Map.fromList slotIndexes)+ functionAnnotation <- for (maybeToList functionSlot) $ \slot -> do+ a <- liftIO $ FFI.attributeSetSlotAttributes mas slot+ getAttributeGroupID a+ otherAttributeSets <- for otherSlots $ \slot -> do+ a <- liftIO $ FFI.attributeSetSlotAttributes mas slot+ decodeM (a :: FFI.ParameterAttributeSet)+ let (returnAttributeSet, shiftedParameterAttributeSets) = separate FFI.returnIndex otherAttributeSets+ return $ MixedAttributeSet {+ functionAttributes = fmap Left functionAnnotation,+ returnAttributes = join . maybeToList $ returnAttributeSet,+ parameterAttributes = Map.mapKeysMonotonic (\x -> fromIntegral x - 1) shiftedParameterAttributeSets+ }
src/LLVM/General/Internal/BasicBlock.hs view
@@ -1,6 +1,7 @@ module LLVM.General.Internal.BasicBlock where -import Control.Monad+import LLVM.General.Prelude+ import Control.Monad.Trans import Foreign.Ptr
src/LLVM/General/Internal/CallingConvention.hs view
@@ -5,27 +5,67 @@ #-} module LLVM.General.Internal.CallingConvention where +import LLVM.General.Prelude+ import LLVM.General.Internal.Coding import Foreign.C.Types (CUInt(..)) import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI-import LLVM.General.Internal.FFI.LLVMCTypes (callConvP)+import LLVM.General.Internal.FFI.LLVMCTypes (callingConventionP) import qualified LLVM.General.AST.CallingConvention as A.CC -instance Monad m => EncodeM m A.CC.CallingConvention FFI.CallConv where+instance Monad m => EncodeM m A.CC.CallingConvention FFI.CallingConvention where encodeM cc = return $ case cc of- A.CC.C -> FFI.callConvC- A.CC.Fast -> FFI.callConvFast- A.CC.Cold -> FFI.callConvCold- A.CC.GHC -> FFI.CallConv 10- A.CC.Numbered cc' -> FFI.CallConv (fromIntegral cc')+ 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.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.X86_64_Win64 -> FFI.callingConventionX86_64_Win64+ A.CC.Numbered cc' -> FFI.CallingConvention (fromIntegral cc') -instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallConv where+instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallingConvention where decodeM cc = return $ case cc of- [callConvP|C|] -> A.CC.C- [callConvP|Fast|] -> A.CC.Fast- [callConvP|Cold|] -> A.CC.Cold- FFI.CallConv (CUInt 10) -> A.CC.GHC- FFI.CallConv (CUInt ci) | ci >= 64 -> A.CC.Numbered (fromIntegral ci)+ [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|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|X86_64_Win64|] -> A.CC.X86_64_Win64+ FFI.CallingConvention (CUInt ci) | ci >= 64 -> A.CC.Numbered (fromIntegral ci)
src/LLVM/General/Internal/Coding.hs view
@@ -6,16 +6,13 @@ #-} module LLVM.General.Internal.Coding where +import LLVM.General.Prelude+ import Language.Haskell.TH import Language.Haskell.TH.Quote -import Control.Monad import Control.Monad.AnyCont import Control.Monad.IO.Class--import Data.Data (Data)-import Data.Word (Word, Word32, Word64)-import Data.Int (Int32) import Foreign.C import Foreign.Ptr
src/LLVM/General/Internal/CommandLine.hs view
@@ -1,11 +1,13 @@ module LLVM.General.Internal.CommandLine where -import qualified LLVM.General.Internal.FFI.CommandLine as FFI--import Foreign.Ptr+import LLVM.General.Prelude import Control.Monad.AnyCont import Control.Monad.IO.Class++import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.CommandLine as FFI import LLVM.General.Internal.Coding import LLVM.General.Internal.String ()
src/LLVM/General/Internal/Constant.hs view
@@ -6,15 +6,16 @@ #-} module LLVM.General.Internal.Constant where +import LLVM.General.Prelude+ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified LLVM.General.Internal.InstructionDefs as ID -import Control.Applicative-import Data.Word (Word32, Word64) import Data.Bits-import Control.Monad.State+import Control.Monad.State (get, gets, modify, evalState) import Control.Monad.AnyCont+import Control.Monad.IO.Class import qualified Data.Map as Map import Foreign.Ptr@@ -88,7 +89,7 @@ A.F.PPC_FP128 _ _ -> FFI.floatSemanticsPPCDoubleDouble nBits <- encodeM nBits liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words fpSem- A.C.GlobalReference n -> FFI.upCast <$> referGlobal n+ A.C.GlobalReference _ n -> FFI.upCast <$> referGlobal n A.C.BlockAddress f b -> do f' <- referGlobal f b' <- getBlockForAddress f b@@ -137,7 +138,9 @@ t <- decodeM ft valueSubclassId <- liftIO $ FFI.getValueSubclassId v nOps <- liftIO $ FFI.getNumOperands u- let globalRef = return A.C.GlobalReference `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v))+ 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@@ -156,7 +159,7 @@ 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 :: Word64)) 0 words)+ return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral b) 0 (words :: [Word64])) [valueSubclassIdP|ConstantFP|] -> do let A.FloatingPointType nBits fmt = t ws <- allocaWords nBits
src/LLVM/General/Internal/Context.hs view
@@ -1,6 +1,9 @@ module LLVM.General.Internal.Context where +import LLVM.General.Prelude+ import Control.Exception+import Control.Concurrent import Foreign.Ptr @@ -13,4 +16,5 @@ -- | Create a Context, run an action (to which it is provided), then destroy the Context. withContext :: (Context -> IO a) -> IO a-withContext = bracket FFI.contextCreate FFI.contextDispose . (. Context)+withContext = runBound . bracket FFI.contextCreate FFI.contextDispose . (. Context)+ where runBound = if rtsSupportsBoundThreads then runInBoundThread else id
src/LLVM/General/Internal/DataLayout.hs view
@@ -1,6 +1,8 @@ module LLVM.General.Internal.DataLayout where -import Control.Monad.Error+import LLVM.General.Prelude++import Control.Monad.Exceptable import Control.Monad.AnyCont import Control.Exception
src/LLVM/General/Internal/DecodeAST.hs view
@@ -5,13 +5,13 @@ #-} module LLVM.General.Internal.DecodeAST where -import Control.Applicative+import LLVM.General.Prelude+ import Control.Monad.State import Control.Monad.AnyCont import Foreign.Ptr import Foreign.C-import Data.Word import Data.Sequence (Seq) import qualified Data.Sequence as Seq@@ -20,12 +20,16 @@ import Data.Array (Array) import qualified Data.Array as Array +import qualified LLVM.General.Internal.FFI.Attribute as FFI+import qualified LLVM.General.Internal.FFI.GlobalValue as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.Value as FFI import qualified LLVM.General.Internal.FFI.Type as FFI import qualified LLVM.General.AST.Name as A import qualified LLVM.General.AST.Operand as A (MetadataNodeID(..))+import qualified LLVM.General.AST.Attribute as A.A+import qualified LLVM.General.AST.COMDAT as A.COMDAT import LLVM.General.Internal.Coding import LLVM.General.Internal.String ()@@ -40,7 +44,10 @@ typesToDefine :: Seq (Ptr FFI.Type), metadataNodesToDefine :: Seq (A.MetadataNodeID, Ptr FFI.MDNode), metadataNodes :: Map (Ptr FFI.MDNode) A.MetadataNodeID,- metadataKinds :: Array Word String+ metadataKinds :: Array Word String,+ parameterAttributeSets :: Map FFI.ParameterAttributeSet [A.A.ParameterAttribute],+ functionAttributeSetIDs :: Map FFI.FunctionAttributeSet A.A.GroupID,+ comdats :: Map (Ptr FFI.COMDAT) (String, A.COMDAT.SelectionKind) } initialDecode = DecodeState { globalVarNum = Map.empty,@@ -50,7 +57,10 @@ typesToDefine = Seq.empty, metadataNodesToDefine = Seq.empty, metadataNodes = Map.empty,- metadataKinds = Array.listArray (1,0) []+ metadataKinds = Array.listArray (1,0) [],+ parameterAttributeSets = Map.empty,+ functionAttributeSetIDs = Map.empty,+ comdats = Map.empty } newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a } deriving (@@ -150,3 +160,13 @@ instance DecodeM DecodeAST A.Name (Ptr FFI.BasicBlock) where decodeM = getLocalName++getAttributeGroupID :: FFI.FunctionAttributeSet -> DecodeAST A.A.GroupID+getAttributeGroupID p = do+ ids <- gets functionAttributeSetIDs+ case Map.lookup p ids of+ Just r -> return r+ Nothing -> do+ let r = A.A.GroupID (fromIntegral (Map.size ids))+ modify $ \s -> s { functionAttributeSetIDs = Map.insert p r (functionAttributeSetIDs s) }+ return r
src/LLVM/General/Internal/Diagnostic.hs view
@@ -4,6 +4,8 @@ #-} module LLVM.General.Internal.Diagnostic where +import LLVM.General.Prelude+ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.SMDiagnostic as FFI
src/LLVM/General/Internal/EncodeAST.hs view
@@ -5,9 +5,11 @@ #-} module LLVM.General.Internal.EncodeAST where +import LLVM.General.Prelude+ import Control.Exception import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Exceptable import Control.Monad.AnyCont import Foreign.Ptr@@ -16,29 +18,40 @@ import Data.Map (Map) import qualified Data.Map as Map -import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Attribute as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI+import qualified LLVM.General.Internal.FFI.GlobalValue as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Value as FFI import qualified LLVM.General.AST as A+import qualified LLVM.General.AST.Attribute as A.A import LLVM.General.Internal.Context import LLVM.General.Internal.Coding import LLVM.General.Internal.String () -data EncodeState = EncodeState { +data LocalValue+ = ForwardValue (Ptr FFI.Value)+ | DefinedValue (Ptr FFI.Value)++data EncodeState = EncodeState { encodeStateBuilder :: Ptr FFI.Builder, encodeStateContext :: Context,- encodeStateLocals :: Map A.Name (Ptr FFI.Value),+ 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)+ encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type),+ encodeStateAttributeGroups :: Map A.A.GroupID FFI.FunctionAttributeSet,+ encodeStateCOMDATs :: Map String (Ptr FFI.COMDAT) } -newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ErrorT String (StateT EncodeState IO)) a }+newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ExceptableT String (StateT EncodeState IO)) a } deriving ( Functor,+ Applicative, Monad, MonadIO, MonadState EncodeState,@@ -50,15 +63,15 @@ lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) lookupNamedType n = do t <- gets $ Map.lookup n . encodeStateNamedTypes- maybe (fail $ "reference to undefined type: " ++ show n) return t+ maybe (throwError $ "reference to undefined type: " ++ show n) return t defineType :: A.Name -> Ptr FFI.Type -> EncodeAST () defineType n t = modify $ \s -> s { encodeStateNamedTypes = Map.insert n t (encodeStateNamedTypes s) } -runEncodeAST :: Context -> EncodeAST a -> ErrorT String IO a-runEncodeAST context@(Context ctx) (EncodeAST a) = ErrorT $ +runEncodeAST :: Context -> EncodeAST a -> ExceptT String IO a+runEncodeAST context@(Context ctx) (EncodeAST a) = unExceptableT $ makeExceptableT $ bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do- let initEncodeState = EncodeState { + let initEncodeState = EncodeState { encodeStateBuilder = builder, encodeStateContext = context, encodeStateLocals = Map.empty,@@ -66,9 +79,11 @@ encodeStateAllBlocks = Map.empty, encodeStateBlocks = Map.empty, encodeStateMDNodes = Map.empty,- encodeStateNamedTypes = Map.empty+ encodeStateNamedTypes = Map.empty,+ encodeStateAttributeGroups = Map.empty,+ encodeStateCOMDATs = Map.empty }- flip evalStateT initEncodeState . runErrorT . flip runAnyContT return $ a+ flip evalStateT initEncodeState . runExceptableT . flip runAnyContT return $ a withName :: A.Name -> (CString -> IO a) -> IO a withName (A.Name n) = withCString n@@ -80,7 +95,7 @@ phase :: EncodeAST a -> EncodeAST (EncodeAST a) phase p = do- let s0 `withLocalsFrom` s1 = s0 { + let s0 `withLocalsFrom` s1 = s0 { encodeStateLocals = encodeStateLocals s1, encodeStateBlocks = encodeStateBlocks s1 }@@ -92,32 +107,43 @@ modify (`withLocalsFrom` s') return r -define :: (Ord n, FFI.DescendentOf p v) => - (EncodeState -> Map n (Ptr p))- -> (Map n (Ptr p) -> EncodeState -> EncodeState)- -> n- -> Ptr v- -> EncodeAST ()-define r w n v = modify $ \b -> w (Map.insert n (FFI.upCast v) (r b)) b- defineLocal :: FFI.DescendentOf FFI.Value v => A.Name -> Ptr v -> EncodeAST ()-defineLocal = define encodeStateLocals (\m b -> b { encodeStateLocals = m })+defineLocal n v' = do+ let v = FFI.upCast v'+ def <- gets $ Map.lookup n . encodeStateLocals+ case def of+ Just (ForwardValue dummy) -> liftIO $ FFI.replaceAllUsesWith dummy v+ _ -> return ()+ modify $ \b -> b { encodeStateLocals = Map.insert n (DefinedValue v) (encodeStateLocals b) } defineGlobal :: FFI.DescendentOf FFI.GlobalValue v => A.Name -> Ptr v -> EncodeAST ()-defineGlobal = define encodeStateGlobals (\m b -> b { encodeStateGlobals = m })+defineGlobal n v = modify $ \b -> b { encodeStateGlobals = Map.insert n (FFI.upCast v) (encodeStateGlobals b) } defineMDNode :: A.MetadataNodeID -> Ptr FFI.MDNode -> EncodeAST ()-defineMDNode = define encodeStateMDNodes (\m b -> b { encodeStateMDNodes = m })+defineMDNode n v = modify $ \b -> b { encodeStateMDNodes = Map.insert n (FFI.upCast v) (encodeStateMDNodes b) } -refer :: (Show n, Ord n) => (EncodeState -> Map n (Ptr p)) -> String -> n -> EncodeAST (Ptr p)-refer r m n = do+defineAttributeGroup :: A.A.GroupID -> FFI.FunctionAttributeSet -> EncodeAST ()+defineAttributeGroup gid attrs = modify $ \b -> b { encodeStateAttributeGroups = Map.insert gid attrs (encodeStateAttributeGroups b) }++defineCOMDAT :: String -> 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 (fail $ "reference to undefined " ++ m ++ ": " ++ show n) return mop+ maybe f return mop -referLocal = refer encodeStateLocals "local"-referGlobal = refer encodeStateGlobals "global"-referMDNode = refer encodeStateMDNodes "metadata node"+undefinedReference :: Show n => String -> n -> EncodeAST a+undefinedReference m n = throwError $ "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 = referOrThrow encodeStateGlobals "global"+referMDNode = referOrThrow encodeStateMDNodes "metadata node"+referAttributeGroup = referOrThrow encodeStateAttributeGroups "attribute group"+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),@@ -125,8 +151,8 @@ } instance EncodeM EncodeAST A.Name (Ptr FFI.BasicBlock) where- encodeM = refer encodeStateBlocks "block"+ encodeM = referOrThrow encodeStateBlocks "block" getBlockForAddress :: A.Name -> A.Name -> EncodeAST (Ptr FFI.BasicBlock)-getBlockForAddress fn n = refer encodeStateAllBlocks "blockaddress" (fn, n)+getBlockForAddress fn n = referOrThrow encodeStateAllBlocks "blockaddress" (fn, n)
src/LLVM/General/Internal/ExecutionEngine.hs view
@@ -5,13 +5,13 @@ #-} module LLVM.General.Internal.ExecutionEngine where +import LLVM.General.Prelude+ import Control.Exception-import Control.Monad import Control.Monad.IO.Class import Control.Monad.AnyCont-import Control.Monad.Error+import Control.Monad.Exceptable -import Data.Word import Data.IORef import Foreign.Ptr import Foreign.C (CUInt, CString)@@ -68,7 +68,7 @@ liftIO initializeNativeTarget outExecutionEngine <- alloca outErrorCStringPtr <- alloca- Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runErrorT+ Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runExceptableT . ExceptableT . withModuleFromAST c (A.Module "" Nothing Nothing [])) (return . Module) m r <- liftIO $ createEngine outExecutionEngine dummyModule outErrorCStringPtr@@ -86,9 +86,10 @@ -> Word -- ^ optimization level -> (JIT -> IO a) -> IO a-withJIT c opt = - withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))- . (. JIT)+withJIT c opt f = FFI.linkInJIT >> withJIT' f+ where withJIT' =+ withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))+ . (. JIT) instance ExecutionEngine JIT (FunPtr ()) where withModuleInEngine (JIT e) m f = withModuleInEngine e m (\(ExecutableModule e m) -> f (ExecutableModule (JIT e) m))@@ -116,6 +117,7 @@ -> (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
src/LLVM/General/Internal/FFI/Analysis.hs view
@@ -3,6 +3,8 @@ #-} module LLVM.General.Internal.FFI.Analysis where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Assembly.hs view
@@ -5,6 +5,8 @@ -- | Functions to read and write textual LLVM assembly module LLVM.General.Internal.FFI.Assembly where +import LLVM.General.Prelude+ import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.MemoryBuffer import LLVM.General.Internal.FFI.Module
src/LLVM/General/Internal/FFI/AssemblyC.cpp view
@@ -1,8 +1,7 @@ #define __STDC_LIMIT_MACROS #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Module.h"-#include "llvm/Assembly/Parser.h"-#include "llvm/Assembly/PrintModulePass.h"+#include "llvm/AsmParser/Parser.h" #include "llvm/Pass.h" #include "llvm/Support/SourceMgr.h" #include "llvm/Support/raw_ostream.h"
+ src/LLVM/General/Internal/FFI/Attribute.h view
@@ -0,0 +1,55 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__ATTRIBUTES__H__+#define __LLVM_GENERAL_INTERNAL_FFI__ATTRIBUTES__H__++#define LLVM_GENERAL_FOR_EACH_ATTRIBUTE_KIND(macro) \+ macro(None,F,F,F) \+ macro(Alignment,T,F,F) \+ macro(AlwaysInline,F,F,T) \+ macro(Builtin,F,F,T) \+ macro(ByVal,T,F,F) \+ macro(InAlloca,T,F,F) \+ macro(Cold,F,F,T) \+ macro(InlineHint,F,F,T) \+ macro(InReg,T,T,F) \+ 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(NoCapture,T,F,F) \+ macro(NoDuplicate,F,F,T) \+ macro(NoImplicitFloat,F,F,T) \+ macro(NoInline,F,F,T) \+ macro(NonLazyBind,F,F,T) \+ macro(NonNull,T,T,F) \+ macro(Dereferenceable,T,T,F) \+ macro(NoRedZone,F,F,T) \+ macro(NoReturn,F,F,T) \+ macro(NoUnwind,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(StackAlignment,F,F,T) \+ macro(StackProtect,F,F,T) \+ macro(StackProtectReq,F,F,T) \+ macro(StackProtectStrong,F,F,T) \+ macro(StructRet,T,F,F) \+ macro(SanitizeAddress,F,F,T) \+ macro(SanitizeThread,F,F,T) \+ macro(SanitizeMemory,F,F,T) \+ macro(UWTable,F,F,T) \+ macro(ZExt,T,T,F) \+ macro(EndAttrKinds,F,F,F)++typedef enum {+#define ENUM_CASE(x,p,r,f) LLVM_General_AttributeKind_ ## x,+LLVM_GENERAL_FOR_EACH_ATTRIBUTE_KIND(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_AttributeKind;++#endif
+ src/LLVM/General/Internal/FFI/Attribute.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE+ ForeignFunctionInterface+ #-}+module LLVM.General.Internal.FFI.Attribute where++import LLVM.General.Prelude++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.LLVMCTypes++type Index = CInt+type Slot = CUInt+type IntValue = Word64++{-+Data model:+llvm::Attribute is one function or parameter attribute++llvm::AttributeSet is a mess.+It's used to represent, at different times:+a) the set of parameter attributes on a parameter+b) the set of parameter attributes for a functions return value+c) the set of function attributes for a function+d) All of the above++It is only possible to enumerate the attributes in an attribute set+given a "slot".++Encode path:+Use AttrBuilder on the C++ side only, to implement [Attribute] -> AttributeSet+AttributeSets -> whole AttributeSet++Decode strategy:+Store maps of AttributeSetImpl (Mess | Parameter | Function),+keyed by raw pointer. Expect Parameter and Function AttributeSetImpls+to have only one slot. Use the per-slot iterators to decode them+-}++data MixedAttributeType+data FunctionAttributeType+data ParameterAttributeType+data AttributeImpl a+data AttributeSetImpl a++type Attribute a = Ptr (AttributeImpl a)+type FunctionAttribute = Attribute FunctionAttributeType+type ParameterAttribute = Attribute ParameterAttributeType++type AttributeSet a = Ptr (AttributeSetImpl a)+type MixedAttributeSet = AttributeSet MixedAttributeType+type FunctionAttributeSet = AttributeSet FunctionAttributeType+type ParameterAttributeSet = AttributeSet ParameterAttributeType++forgetAttributeType :: AttributeSet a -> AttributeSet MixedAttributeType+forgetAttributeType = castPtr++functionIndex :: Index+functionIndex = -1+returnIndex :: Index+returnIndex = 0++foreign import ccall unsafe "LLVM_General_AttributeKindAsEnum" parameterAttributeKindAsEnum ::+ ParameterAttribute -> IO ParameterAttributeKind++foreign import ccall unsafe "LLVM_General_AttributeKindAsEnum" functionAttributeKindAsEnum ::+ FunctionAttribute -> IO FunctionAttributeKind++foreign import ccall unsafe "LLVM_General_IsStringAttribute" isStringAttribute ::+ Attribute a -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_AttributeKindAsString" attributeKindAsString ::+ Attribute a -> Ptr CSize -> IO (Ptr CChar)++foreign import ccall unsafe "LLVM_General_AttributeValueAsString" attributeValueAsString ::+ Attribute a -> Ptr CSize -> IO (Ptr CChar)++foreign import ccall unsafe "LLVM_General_AttributeValueAsInt" attributeValueAsInt ::+ Attribute a -> IO Word64++foreign import ccall unsafe "LLVM_General_AttributeSetNumSlots" attributeSetNumSlots ::+ AttributeSet a -> IO Slot++foreign import ccall unsafe "LLVM_General_AttributeSetSlotIndex" attributeSetSlotIndex ::+ AttributeSet a -> Slot -> IO Index++foreign import ccall unsafe "LLVM_General_AttributeSetSlotAttributes" attributeSetSlotAttributes ::+ MixedAttributeSet -> Slot -> IO (AttributeSet a)++foreign import ccall unsafe "LLVM_General_AttributeSetGetAttributes" attributeSetGetAttributes ::+ AttributeSet a -> Slot -> Ptr CUInt -> IO (Ptr (Attribute a))++foreign import ccall unsafe "LLVM_General_GetAttributeSet" getAttributeSet ::+ Ptr Context -> Index -> Ptr (AttrBuilder a) -> IO (AttributeSet a)++foreign import ccall unsafe "LLVM_General_MixAttributeSets" mixAttributeSets ::+ Ptr Context -> Ptr MixedAttributeSet -> CUInt -> IO MixedAttributeSet++data AttrBuilder a+type FunctionAttrBuilder = AttrBuilder FunctionAttributeType+type ParameterAttrBuilder = AttrBuilder ParameterAttributeType++foreign import ccall unsafe "LLVM_General_GetAttrBuilderSize" getAttrBuilderSize ::+ CSize++foreign import ccall unsafe "LLVM_General_ConstructAttrBuilder" constructAttrBuilder ::+ Ptr Word8 -> IO (Ptr (AttrBuilder a))++foreign import ccall unsafe "LLVM_General_DestroyAttrBuilder" destroyAttrBuilder ::+ Ptr (AttrBuilder a) -> IO ()++foreign import ccall unsafe "LLVM_General_AttrBuilderAddAttributeKind" attrBuilderAddFunctionAttributeKind ::+ Ptr FunctionAttrBuilder -> FunctionAttributeKind -> IO ()++foreign import ccall unsafe "LLVM_General_AttrBuilderAddAttributeKind" attrBuilderAddParameterAttributeKind ::+ Ptr ParameterAttrBuilder -> ParameterAttributeKind -> IO ()++foreign import ccall unsafe "LLVM_General_AttrBuilderAddStringAttribute" attrBuilderAddStringAttribute ::+ Ptr FunctionAttrBuilder -> Ptr CChar -> CSize -> Ptr CChar -> CSize -> IO ()++foreign import ccall unsafe "LLVM_General_AttrBuilderAddAlignment" attrBuilderAddAlignment ::+ Ptr ParameterAttrBuilder -> Word64 -> IO ()++foreign import ccall unsafe "LLVM_General_AttrBuilderAddStackAlignment" attrBuilderAddStackAlignment ::+ Ptr FunctionAttrBuilder -> Word64 -> IO ()++foreign import ccall unsafe "LLVM_General_AttrBuilderAddDereferenceableAttr" attrBuilderAddDereferenceable ::+ Ptr ParameterAttrBuilder -> Word64 -> IO ()+
+ src/LLVM/General/Internal/FFI/AttributeC.cpp view
@@ -0,0 +1,120 @@+#define __STDC_LIMIT_MACROS+#include "llvm/IR/LLVMContext.h"+#include "LLVM/General/Internal/FFI/AttributeC.hpp"++extern "C" {++unsigned LLVM_General_AttributeSetNumSlots(const AttributeSetImpl *a) {+ return unwrap(a).getNumSlots();+}++int LLVM_General_AttributeSetSlotIndex(const AttributeSetImpl *a, unsigned slot) {+ return unwrap(a).getSlotIndex(slot);+}++const AttributeSetImpl *LLVM_General_AttributeSetSlotAttributes(const AttributeSetImpl *a, unsigned slot) {+ return wrap(unwrap(a).getSlotAttributes(slot));+}++const AttributeSetImpl *LLVM_General_GetSlotAttributeSet(+ LLVMContextRef context,+ unsigned index,+ const AttributeImpl **attributes,+ unsigned length+) {+ AttrBuilder builder;+ for (unsigned i = 0; i < length; i++) builder.addAttribute(unwrap(attributes[i]));+ return wrap(AttributeSet::get(*unwrap(context), index, builder));+}++const AttributeImpl *const *LLVM_General_AttributeSetGetAttributes(AttributeSetImpl *asi, unsigned slot, unsigned *length) {+ AttributeSet as = unwrap(asi);+ ArrayRef<Attribute>::iterator b = as.begin(slot), e = as.end(slot);+ *length = e - b;+ return reinterpret_cast<const AttributeImpl *const *>(b);+}++inline void LLVM_General_AttributeEnumMatches() {+#define CHECK(name,p,r,f) \+ static_assert( \+ unsigned(llvm::Attribute::name) == unsigned(LLVM_General_AttributeKind_ ## name), \+ "LLVM_General_AttributeKind enum out of sync w/ llvm::Attribute::AttrKind for " #name \+ );+ LLVM_GENERAL_FOR_EACH_ATTRIBUTE_KIND(CHECK)+#undef CHECK+}++unsigned LLVM_General_AttributeKindAsEnum(const AttributeImpl *a) {+ LLVM_General_AttributeEnumMatches();+ return unwrap(a).getKindAsEnum();+}++uint64_t LLVM_General_AttributeValueAsInt(const AttributeImpl *a) {+ return unwrap(a).getValueAsInt();+}++LLVMBool LLVM_General_IsStringAttribute(const AttributeImpl *a) {+ return unwrap(a).isStringAttribute();+}++const char *LLVM_General_AttributeKindAsString(const AttributeImpl *a, size_t &l) {+ const StringRef s = unwrap(a).getKindAsString();+ l = s.size();+ return s.data();+}++const char *LLVM_General_AttributeValueAsString(const AttributeImpl *a, size_t &l) {+ const StringRef s = unwrap(a).getValueAsString();+ l = s.size();+ return s.data();+}++const AttributeSetImpl *LLVM_General_GetAttributeSet(LLVMContextRef context, unsigned index, const AttrBuilder &ab) {+ return wrap(AttributeSet::get(*unwrap(context), index, ab));+}++const AttributeSetImpl *LLVM_General_MixAttributeSets(+ LLVMContextRef context, const AttributeSetImpl **as, unsigned n+) {+ return wrap(+ AttributeSet::get(+ *unwrap(context),+ ArrayRef<AttributeSet>(reinterpret_cast<const AttributeSet *>(as), n)+ )+ );+}++size_t LLVM_General_GetAttrBuilderSize() { return sizeof(AttrBuilder); }++AttrBuilder *LLVM_General_ConstructAttrBuilder(char *p) {+ return new(p) AttrBuilder();+}++void LLVM_General_DestroyAttrBuilder(AttrBuilder *a) {+ a->~AttrBuilder();+}++void LLVM_General_AttrBuilderAddAttributeKind(AttrBuilder &ab, unsigned kind) {+ LLVM_General_AttributeEnumMatches();+ ab.addAttribute(Attribute::AttrKind(kind));+}++void LLVM_General_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_General_AttrBuilderAddAlignment(AttrBuilder &ab, uint64_t v) {+ ab.addAlignmentAttr(v);+}++void LLVM_General_AttrBuilderAddStackAlignment(AttrBuilder &ab, uint64_t v) {+ ab.addStackAlignmentAttr(v);+}++void LLVM_General_AttrBuilderAddDereferenceableAttr(AttrBuilder &ab, uint64_t v) {+ ab.addDereferenceableAttr(v);+}++}
+ src/LLVM/General/Internal/FFI/AttributeC.hpp view
@@ -0,0 +1,42 @@+#ifndef __LLVM_GENERAL_ATTRIBUTE_C_HPP__+#define __LLVM_GENERAL_ATTRIBUTE_C_HPP__+#define __STDC_LIMIT_MACROS+#include "llvm/IR/Attributes.h"+#include "LLVM/General/Internal/FFI/Attribute.h"+using namespace llvm;++inline void LLVM_General_AttributeSetMatches() {+ static_assert(+ sizeof(AttributeSet) == sizeof(AttributeSetImpl *),+ "AttributeSet implementation has changed"+ );+}++inline AttributeSet unwrap(const AttributeSetImpl *asi) {+ LLVM_General_AttributeSetMatches();+ return *reinterpret_cast<const AttributeSet *>(&asi);+}++inline const AttributeSetImpl *wrap(AttributeSet as) {+ LLVM_General_AttributeSetMatches();+ return *reinterpret_cast<const AttributeSetImpl **>(&as);+}++inline void LLVM_General_AttributeMatches() {+ static_assert(+ sizeof(Attribute) == sizeof(AttributeImpl *),+ "Attribute implementation has changed"+ );+}++inline Attribute unwrap(const AttributeImpl *ai) {+ LLVM_General_AttributeMatches();+ return *reinterpret_cast<const Attribute *>(&ai);+}++inline const AttributeImpl *wrap(Attribute a) {+ LLVM_General_AttributeMatches();+ return *reinterpret_cast<const AttributeImpl **>(&a);+}++#endif
src/LLVM/General/Internal/FFI/BasicBlock.hs view
@@ -6,6 +6,8 @@ -- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html> module LLVM.General.Internal.FFI.BasicBlock where +import LLVM.General.Prelude+ import Foreign.Ptr import LLVM.General.Internal.FFI.PtrHierarchy
+ src/LLVM/General/Internal/FFI/BinaryOperator.h view
@@ -0,0 +1,16 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__BINARY_OPERATOR__H__+#define __LLVM_GENERAL_INTERNAL_FFI__BINARY_OPERATOR__H__++#define LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(macro) \+ macro(UDiv) \+ macro(SDiv) \+ macro(LShr) \+ macro(AShr)++#define LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(macro) \+ macro(Add) \+ macro(Mul) \+ macro(Shl) \+ macro(Sub) \++#endif
src/LLVM/General/Internal/FFI/BinaryOperator.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances,- OverlappingInstances+ UndecidableInstances #-} -- | FFI functions for handling the LLVM BinaryOperator class module LLVM.General.Internal.FFI.BinaryOperator where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C @@ -25,3 +26,5 @@ foreign import ccall unsafe "LLVM_General_IsExact" isExact :: Ptr Value -> IO LLVMBool +foreign import ccall unsafe "LLVM_General_GetFastMathFlags" getFastMathFlags ::+ Ptr Value -> IO FastMathFlags
src/LLVM/General/Internal/FFI/Bitcode.hs view
@@ -5,6 +5,8 @@ -- | Functions to read and write LLVM bitcode module LLVM.General.Internal.FFI.Bitcode where +import LLVM.General.Prelude+ import LLVM.General.Internal.FFI.RawOStream import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.MemoryBuffer
src/LLVM/General/Internal/FFI/BitcodeC.cpp view
@@ -1,5 +1,4 @@ #define __STDC_LIMIT_MACROS-//#include "llvm/Config/llvm-config.h" #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Module.h" #include "llvm-c/Core.h"@@ -17,9 +16,12 @@ char **error ) { std::string msg;- Module *m = ParseBitcodeFile(unwrap(mb), *unwrap(c), &msg);- if (m == 0) *error = strdup(msg.c_str());- return wrap(m);+ ErrorOr<Module *> m = parseBitcodeFile(unwrap(mb), *unwrap(c));+ if (std::error_code ec = m.getError()) {+ *error = strdup(ec.message().c_str());+ return 0;+ }+ return wrap(m.get()); } void LLVM_General_WriteBitcode(LLVMModuleRef m, raw_ostream &os) {
src/LLVM/General/Internal/FFI/Builder.hs view
@@ -7,19 +7,19 @@ -- | FFI glue for llvm::IRBuilder - llvm's IR construction state object module LLVM.General.Internal.FFI.Builder where -import qualified Language.Haskell.TH as TH--import Control.Monad--import qualified LLVM.General.AST.Instruction as A+import LLVM.General.Prelude -import LLVM.General.Internal.InstructionDefs as ID+import qualified Language.Haskell.TH as TH import Foreign.Ptr import Foreign.C +import qualified Data.List as List import qualified Data.Map as Map +import qualified LLVM.General.AST.Instruction as A+import LLVM.General.Internal.InstructionDefs as ID+ import LLVM.General.Internal.FFI.Cleanup import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.LLVMCTypes@@ -74,7 +74,7 @@ error $ "LLVM instruction def " ++ lrn ++ " not found in the AST" _ -> [] - let ats = map typeMapping [ t | t <- fieldTypes, t /= TH.ConT ''A.InstructionMetadata ]+ let ats = map typeMapping (fieldTypes List.\\ [TH.ConT ''A.InstructionMetadata, TH.ConT ''A.FastMathFlags]) cName = (if hasFlags fieldTypes then "LLVM_General_" else "LLVM") ++ "Build" ++ a rt <- case k of ID.Binary -> [[t| BinaryOperator |]]@@ -86,32 +86,41 @@ foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca :: Ptr Builder -> Ptr Type -> Ptr Value -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVM_General_BuildLoad" buildLoad ::- Ptr Builder -> Ptr Value -> CUInt -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)+foreign import ccall unsafe "LLVM_General_BuildLoad" buildLoad' ::+ Ptr Builder -> LLVMBool -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> CUInt -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVM_General_BuildStore" buildStore ::- Ptr Builder -> Ptr Value -> Ptr Value -> CUInt -> LLVMBool -> MemoryOrdering -> LLVMBool -> 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_General_BuildStore" buildStore' ::+ Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> 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 "LLVMBuildGEP" buildGetElementPtr' :: Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) foreign import ccall unsafe "LLVMBuildInBoundsGEP" buildInBoundsGetElementPtr' :: Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) -buildGetElementPtr :: Ptr Builder -> LLVMBool -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction)-buildGetElementPtr builder (LLVMBool 1) = buildInBoundsGetElementPtr' builder-buildGetElementPtr builder (LLVMBool 0) = buildGetElementPtr' builder+buildGetElementPtr :: 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 -foreign import ccall unsafe "LLVM_General_BuildFence" buildFence ::- Ptr Builder -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)+foreign import ccall unsafe "LLVM_General_BuildFence" buildFence' ::+ Ptr Builder -> MemoryOrdering -> SynchronizationScope -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVM_General_BuildAtomicCmpXchg" buildCmpXchg ::- Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)+buildFence builder (ss, mo) s = buildFence' builder mo ss s -foreign import ccall unsafe "LLVM_General_BuildAtomicRMW" buildAtomicRMW ::- Ptr Builder -> RMWOperation -> Ptr Value -> Ptr Value -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)+foreign import ccall unsafe "LLVM_General_BuildAtomicCmpXchg" buildCmpXchg' ::+ Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> MemoryOrdering -> MemoryOrdering -> SynchronizationScope -> 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_General_BuildAtomicRMW" buildAtomicRMW' ::+ Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> MemoryOrdering -> SynchronizationScope -> 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 "LLVMBuildICmp" buildICmp :: Ptr Builder -> ICmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) @@ -148,4 +157,5 @@ foreign import ccall unsafe "LLVMBuildLandingPad" buildLandingPad :: Ptr Builder -> Ptr Type -> Ptr Value -> CUInt -> CString -> IO (Ptr Instruction) -+foreign import ccall unsafe "LLVM_General_SetFastMathFlags" setFastMathFlags ::+ Ptr Builder -> FastMathFlags -> IO ()
src/LLVM/General/Internal/FFI/BuilderC.cpp view
@@ -5,6 +5,7 @@ #include "llvm-c/Core.h" #include "LLVM/General/Internal/FFI/Instruction.h"+#include "LLVM/General/Internal/FFI/BinaryOperator.h" using namespace llvm; @@ -37,15 +38,17 @@ } } +static FastMathFlags unwrap(LLVMFastMathFlags f) {+ FastMathFlags r = FastMathFlags();+#define ENUM_CASE(x,l) if (f & LLVM ## x) r.set ## x();+LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)+#undef ENUM_CASE+ return r; } -extern "C" {+} -#define LLVM_GENERAL_FOR_ALL_OVERFLOWING_BINARY_OPERATORS(macro) \- macro(Add) \- macro(Mul) \- macro(Shl) \- macro(Sub) \+extern "C" { #define ENUM_CASE(Op) \ LLVMValueRef LLVM_General_Build ## Op( \@@ -58,15 +61,9 @@ ) { \ return wrap(unwrap(b)->Create ## Op(unwrap(o0), unwrap(o1), s, nuw, nsw)); \ }-LLVM_GENERAL_FOR_ALL_OVERFLOWING_BINARY_OPERATORS(ENUM_CASE)+LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(ENUM_CASE) #undef ENUM_CASE -#define LLVM_GENERAL_FOR_ALL_POSSIBLY_EXACT_OPERATORS(macro) \- macro(AShr) \- macro(LShr) \- macro(SDiv) \- macro(UDiv) \- #define ENUM_CASE(Op) \ LLVMValueRef LLVM_General_Build ## Op( \ LLVMBuilderRef b, \@@ -77,17 +74,20 @@ ) { \ return wrap(unwrap(b)->Create ## Op(unwrap(o0), unwrap(o1), s, exact)); \ }-LLVM_GENERAL_FOR_ALL_POSSIBLY_EXACT_OPERATORS(ENUM_CASE)+LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(ENUM_CASE) #undef ENUM_CASE +void LLVM_General_SetFastMathFlags(LLVMBuilderRef b, LLVMFastMathFlags f) {+ unwrap(b)->SetFastMathFlags(unwrap(f));+} LLVMValueRef LLVM_General_BuildLoad( LLVMBuilderRef b,- LLVMValueRef p,- unsigned align, LLVMBool isVolatile,+ LLVMValueRef p, LLVMAtomicOrdering atomicOrdering, LLVMSynchronizationScope synchScope,+ unsigned align, const char *name ) { LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), align, isVolatile, name);@@ -98,12 +98,12 @@ LLVMValueRef LLVM_General_BuildStore( LLVMBuilderRef b,- LLVMValueRef v,- LLVMValueRef p,- unsigned align, LLVMBool isVolatile,+ LLVMValueRef p,+ LLVMValueRef v, LLVMAtomicOrdering atomicOrdering, LLVMSynchronizationScope synchScope,+ unsigned align, const char *name ) { StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), align, isVolatile);@@ -123,16 +123,17 @@ LLVMValueRef LLVM_General_BuildAtomicCmpXchg( LLVMBuilderRef b,+ LLVMBool v, LLVMValueRef ptr, LLVMValueRef cmp, LLVMValueRef n, - LLVMBool v,- LLVMAtomicOrdering lao,+ LLVMAtomicOrdering successOrdering,+ LLVMAtomicOrdering failureOrdering, LLVMSynchronizationScope lss, const char *name ) { AtomicCmpXchgInst *a = unwrap(b)->CreateAtomicCmpXchg(- unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(lao), unwrap(lss)+ unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(successOrdering), unwrap(failureOrdering), unwrap(lss) ); a->setVolatile(v); a->setName(name);@@ -141,10 +142,10 @@ LLVMValueRef LLVM_General_BuildAtomicRMW( LLVMBuilderRef b,+ LLVMBool v, LLVMAtomicRMWBinOp rmwOp, LLVMValueRef ptr, LLVMValueRef val, - LLVMBool v, LLVMAtomicOrdering lao, LLVMSynchronizationScope lss, const char *name
src/LLVM/General/Internal/FFI/ByteRangeCallback.hs view
@@ -3,6 +3,8 @@ #-} module LLVM.General.Internal.FFI.ByteRangeCallback where +import LLVM.General.Prelude+ import Foreign.C import Foreign.Ptr
+ src/LLVM/General/Internal/FFI/CallingConvention.h view
@@ -0,0 +1,35 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION__H__+#define __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION__H__++#define LLVM_GENERAL_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(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(X86_64_Win64, 79)++typedef enum {+#define ENUM_CASE(l,n) LLVM_General_CallingConvention_ ## l = n,+ LLVM_GENERAL_FOR_EACH_CALLING_CONVENTION(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_CallingConvention;++#endif
+ src/LLVM/General/Internal/FFI/CallingConventionC.hpp view
@@ -0,0 +1,16 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION_C_HPP__+#define __LLVM_GENERAL_INTERNAL_FFI__CALLING_CONVENTION_C_HPP__++#include "LLVM/General/Internal/FFI/CallingConvention.h"++inline void LLVM_General_CallingConventionEnumMatches() {+#define CHECK(l,n) \+ static_assert( \+ unsigned(llvm::CallingConv::l) == unsigned(LLVM_General_CallingConvention_ ## l), \+ "LLVM_General_CallingConvention enum out of sync w/ llvm::CallingConv::ID for " #l \+ );+ LLVM_GENERAL_FOR_EACH_CALLING_CONVENTION(CHECK)+#undef CHECK+}++#endif
src/LLVM/General/Internal/FFI/Cleanup.hs view
@@ -3,13 +3,11 @@ #-} module LLVM.General.Internal.FFI.Cleanup where +import LLVM.General.Prelude+ import Language.Haskell.TH-import Control.Monad import Data.Sequence as Seq-import Data.Foldable (toList) -import Data.Word-import Data.Int import Foreign.C import Foreign.Ptr @@ -21,6 +19,7 @@ import qualified LLVM.General.AST.Constant as A.C (Constant) import qualified LLVM.General.AST.Operand as A (Operand) import qualified LLVM.General.AST.Type as A (Type)+import qualified LLVM.General.AST.Instruction as A (FastMathFlags) foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ foreignDecl cName hName argTypeQs returnTypeQ = do@@ -62,10 +61,9 @@ ] ] --- | The LLVM C-API for instructions with boolean flags (e.g. nsw) is weak, so they get+-- | 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. As such it may need revision in the future (if has-a-boolean-member--- is no longer the same as needs-special-handling).+-- an instruction needs such handling. hasFlags :: [Type] -> Bool hasFlags = any (== ConT ''Bool) @@ -80,5 +78,6 @@ | 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
src/LLVM/General/Internal/FFI/CommandLine.hs view
@@ -3,6 +3,8 @@ #-} module LLVM.General.Internal.FFI.CommandLine where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Constant.hs view
@@ -3,18 +3,17 @@ ForeignFunctionInterface, MultiParamTypeClasses, UndecidableInstances,- OverlappingInstances, ViewPatterns #-} -- | FFI functions for handling the LLVM Constant class module LLVM.General.Internal.FFI.Constant where +import LLVM.General.Prelude+ import qualified Language.Haskell.TH as TH import qualified LLVM.General.Internal.InstructionDefs as ID -import Control.Monad import qualified Data.Map as Map-import Data.Word import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/ConstantC.cpp view
@@ -6,6 +6,7 @@ #include "llvm-c/Core.h" #include "LLVM/General/Internal/FFI/Value.h" #include "LLVM/General/Internal/FFI/Constant.h"+#include "LLVM/General/Internal/FFI/BinaryOperator.h" using namespace llvm; @@ -52,24 +53,12 @@ return wrap(ConstantExpr::get(opcode, unwrap<Constant>(o0), unwrap<Constant>(o1))); } -#define LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(macro) \- macro(Add) \- macro(Sub) \- macro(Mul) \- macro(Shl)- #define CASE_CODE(op) \ LLVMValueRef LLVM_General_Const ## op(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { \ return wrap(ConstantExpr::get ## op(unwrap<Constant>(o0), unwrap<Constant>(o1), nuw != 0, nsw != 0)); \ } LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(CASE_CODE) #undef CASE_CODE--#define LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(macro) \- macro(UDiv) \- macro(SDiv) \- macro(LShr) \- macro(AShr) #define CASE_CODE(op) \ LLVMValueRef LLVM_General_Const ## op(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { \
src/LLVM/General/Internal/FFI/Context.hs view
@@ -8,6 +8,8 @@ -- | This choice allows multiple threads to do independent work with LLVM safely. module LLVM.General.Internal.FFI.Context where +import LLVM.General.Prelude+ import Foreign.Ptr -- | a blind type to correspond to LLVMContext
src/LLVM/General/Internal/FFI/DataLayout.hs view
@@ -4,6 +4,8 @@ module LLVM.General.Internal.FFI.DataLayout where +import LLVM.General.Prelude+ import Foreign.C.String import Foreign.Ptr
src/LLVM/General/Internal/FFI/ExecutionEngine.hs view
@@ -4,6 +4,8 @@ module LLVM.General.Internal.FFI.ExecutionEngine where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C
− src/LLVM/General/Internal/FFI/Function.h
@@ -1,39 +0,0 @@-#ifndef __LLVM_GENERAL_INTERNAL_FFI__FUNCTION__H__-#define __LLVM_GENERAL_INTERNAL_FFI__FUNCTION__H__--#define LLVM_GENERAL_FOR_EACH_CALLCONV(macro) \- macro(C) \- macro(Fast) \- macro(Cold) \--#define LLVM_GENERAL_FOR_EACH_PARAM_ATTR(macro) \- macro(ZExt) \- macro(SExt) \- macro(InReg) \- macro(StructRet) \- macro(NoAlias) \- macro(ByVal) \- macro(NoCapture) \- macro(Nest) \--#define LLVM_GENERAL_FOR_EACH_FUNCTION_ATTR(macro) \- macro(NoReturn,Attribute) \- macro(NoUnwind,Attribute) \- macro(ReadNone,Attribute) \- macro(ReadOnly,Attribute) \- macro(NoInline,Attribute) \- macro(AlwaysInline,Attribute) \- macro(OptimizeForSize,Attribute) \- macro(StackProtect,Attribute) \- macro(StackProtectReq,Attribute) \- macro(Alignment,) \- macro(NoRedZone,Attribute) \- macro(NoImplicitFloat,Attribute) \- macro(Naked,Attribute) \- macro(InlineHint,Attribute) \- macro(StackAlignment,) \- macro(ReturnsTwice,) \- macro(UWTable,) \- macro(NonLazyBind,) \--#endif
src/LLVM/General/Internal/FFI/Function.hs view
@@ -5,58 +5,59 @@ module LLVM.General.Internal.FFI.Function where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C +import LLVM.General.Internal.FFI.Attribute import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy -foreign import ccall unsafe "LLVMGetFunctionCallConv" getFunctionCallConv ::- Ptr Function -> IO CallConv+foreign import ccall unsafe "LLVM_General_GetFunctionCallingConvention" getFunctionCallingConvention ::+ Ptr Function -> IO CallingConvention -foreign import ccall unsafe "LLVMSetFunctionCallConv" setFunctionCallConv ::- Ptr Function -> CallConv -> IO ()+foreign import ccall unsafe "LLVM_General_SetFunctionCallingConvention" setFunctionCallingConvention ::+ Ptr Function -> CallingConvention -> IO () -foreign import ccall unsafe "LLVMAddFunctionAttr" addFunctionAttr ::- Ptr Function -> FunctionAttr -> IO ()+foreign import ccall unsafe "LLVM_General_GetFunctionMixedAttributeSet" getMixedAttributeSet ::+ Ptr Function -> IO MixedAttributeSet -foreign import ccall unsafe "LLVMGetFunctionAttr" getFunctionAttr ::- Ptr Function -> IO FunctionAttr+foreign import ccall unsafe "LLVM_General_SetFunctionMixedAttributeSet" setMixedAttributeSet ::+ Ptr Function -> MixedAttributeSet -> IO () foreign import ccall unsafe "LLVMGetFirstBasicBlock" getFirstBasicBlock ::- Ptr Function -> IO (Ptr BasicBlock)+ Ptr Function -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMGetLastBasicBlock" getLastBasicBlock ::- Ptr Function -> IO (Ptr BasicBlock)+ Ptr Function -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMGetNextBasicBlock" getNextBasicBlock ::- Ptr BasicBlock -> IO (Ptr BasicBlock)+ Ptr BasicBlock -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMAppendBasicBlockInContext" appendBasicBlockInContext ::- Ptr Context -> Ptr Function -> CString -> IO (Ptr BasicBlock)+ Ptr Context -> Ptr Function -> CString -> IO (Ptr BasicBlock) foreign import ccall unsafe "LLVMCountParams" countParams ::- Ptr Function -> IO CUInt+ Ptr Function -> IO CUInt foreign import ccall unsafe "LLVMGetParams" getParams ::- Ptr Function -> Ptr (Ptr Parameter) -> IO ()--foreign import ccall unsafe "LLVMGetAttribute" getAttribute ::- Ptr Parameter -> IO ParamAttr--foreign import ccall unsafe "LLVMAddAttribute" addAttribute ::- Ptr Parameter -> ParamAttr -> IO ()--foreign import ccall unsafe "LLVM_General_GetFunctionRetAttr" getFunctionRetAttr ::- Ptr Function -> IO ParamAttr--foreign import ccall unsafe "LLVM_General_AddFunctionRetAttr" addFunctionRetAttr ::- Ptr Function -> ParamAttr -> IO ()+ 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_General_HasFunctionPrefixData" hasPrefixData ::+ Ptr Function -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_GetFunctionPrefixData" getPrefixData ::+ Ptr Function -> IO (Ptr Constant)++foreign import ccall unsafe "LLVM_General_SetFunctionPrefixData" setPrefixData ::+ Ptr Function -> Ptr Constant -> IO ()
src/LLVM/General/Internal/FFI/FunctionC.cpp view
@@ -2,8 +2,11 @@ #include "llvm/IR/LLVMContext.h" #include "llvm/IR/Attributes.h" #include "llvm/IR/Function.h"+#include "llvm/IR/Value.h" #include "llvm-c/Core.h"+#include "LLVM/General/Internal/FFI/AttributeC.hpp"+#include "LLVM/General/Internal/FFI/CallingConventionC.hpp" using namespace llvm; @@ -22,5 +25,34 @@ ); } +const AttributeSetImpl *LLVM_General_GetFunctionMixedAttributeSet(LLVMValueRef f) {+ return wrap(unwrap<Function>(f)->getAttributes());+}++void LLVM_General_SetFunctionMixedAttributeSet(LLVMValueRef f, AttributeSetImpl *asi) {+ unwrap<Function>(f)->setAttributes(unwrap(asi));+}++LLVMBool LLVM_General_HasFunctionPrefixData(LLVMValueRef f) {+ return unwrap<Function>(f)->hasPrefixData();+}++LLVMValueRef LLVM_General_GetFunctionPrefixData(LLVMValueRef f) {+ return wrap(unwrap<Function>(f)->getPrefixData());+}++void LLVM_General_SetFunctionPrefixData(LLVMValueRef f, LLVMValueRef p) {+ unwrap<Function>(f)->setPrefixData(unwrap<Constant>(p));+}++unsigned LLVM_General_GetFunctionCallingConvention(LLVMValueRef f) {+ LLVM_General_CallingConventionEnumMatches();+ return unsigned(unwrap<Function>(f)->getCallingConv());+}++void LLVM_General_SetFunctionCallingConvention(LLVMValueRef f, unsigned cc) {+ LLVM_General_CallingConventionEnumMatches();+ unwrap<Function>(f)->setCallingConv(llvm::CallingConv::ID(cc));+} }
src/LLVM/General/Internal/FFI/GlobalAlias.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances,- OverlappingInstances+ UndecidableInstances #-} -- | FFI functions for handling the LLVM GlobalAlias class module LLVM.General.Internal.FFI.GlobalAlias where++import LLVM.General.Prelude import Foreign.Ptr
src/LLVM/General/Internal/FFI/GlobalAliasC.cpp view
@@ -1,6 +1,7 @@ #define __STDC_LIMIT_MACROS #include "llvm/IR/LLVMContext.h" #include "llvm/IR/GlobalAlias.h"+#include "llvm/IR/GlobalObject.h" #include "llvm-c/Core.h"
src/LLVM/General/Internal/FFI/GlobalValue.h view
@@ -6,24 +6,42 @@ macro(AvailableExternally) \ macro(LinkOnceAny) \ macro(LinkOnceODR) \- macro(LinkOnceODRAutoHide) \ macro(WeakAny) \ macro(WeakODR) \ macro(Appending) \ macro(Internal) \ macro(Private) \- macro(DLLImport) \- macro(DLLExport) \ macro(ExternalWeak) \- macro(Ghost) \- macro(Common) \- macro(LinkerPrivate) \- macro(LinkerPrivateWeak) \-+ macro(Common) #define LLVM_GENERAL_FOR_EACH_VISIBILITY(macro) \ macro(Default) \ macro(Hidden) \ macro(Protected) \++#define LLVM_GENERAL_FOR_EACH_COMDAT_SELECTION_KIND(macro) \+ macro(Any) \+ macro(ExactMatch) \+ macro(Largest) \+ macro(NoDuplicates) \+ macro(SameSize)++typedef enum {+#define ENUM_CASE(n) LLVM_General_COMDAT_Selection_Kind_ ## n,+LLVM_GENERAL_FOR_EACH_COMDAT_SELECTION_KIND(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_COMDAT_Selection_Kind;++#define LLVM_GENERAL_FOR_EACH_DLL_STORAGE_CLASS(macro) \+ macro(Default) \+ macro(DLLImport) \+ macro(DLLExport)++#define LLVM_GENERAL_FOR_EACH_THREAD_LOCAL_MODE(macro) \+ macro(NotThreadLocal) \+ macro(GeneralDynamicTLSModel) \+ macro(LocalDynamicTLSModel) \+ macro(InitialExecTLSModel) \+ macro(LocalExecTLSModel) #endif
src/LLVM/General/Internal/FFI/GlobalValue.hs view
@@ -1,50 +1,79 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances,- OverlappingInstances+ UndecidableInstances #-} -- | FFI functions for handling the LLVM GlobalValue class module LLVM.General.Internal.FFI.GlobalValue where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.LLVMCTypes +data COMDAT+ foreign import ccall unsafe "LLVMIsAGlobalValue" isAGlobalValue ::- Ptr Value -> IO (Ptr GlobalValue)+ Ptr Value -> IO (Ptr GlobalValue) foreign import ccall unsafe "LLVMGetLinkage" getLinkage ::- Ptr GlobalValue -> IO Linkage+ Ptr GlobalValue -> IO Linkage foreign import ccall unsafe "LLVMSetLinkage" setLinkage ::- Ptr GlobalValue -> Linkage -> IO ()+ Ptr GlobalValue -> Linkage -> IO () foreign import ccall unsafe "LLVMGetSection" getSection ::- Ptr GlobalValue -> IO CString+ Ptr GlobalValue -> IO CString foreign import ccall unsafe "LLVMSetSection" setSection ::- Ptr GlobalValue -> CString -> IO ()+ Ptr GlobalValue -> CString -> IO () +foreign import ccall unsafe "LLVM_General_GetCOMDAT" getCOMDAT ::+ Ptr GlobalValue -> IO (Ptr COMDAT)++foreign import ccall unsafe "LLVM_General_SetCOMDAT" setCOMDAT ::+ Ptr GlobalObject -> Ptr COMDAT -> IO ()++foreign import ccall unsafe "LLVM_General_GetCOMDATName" getCOMDATName ::+ Ptr COMDAT -> Ptr CSize -> IO (Ptr CChar)++foreign import ccall unsafe "LLVM_General_GetCOMDATSelectionKind" getCOMDATSelectionKind ::+ Ptr COMDAT -> IO COMDATSelectionKind++foreign import ccall unsafe "LLVM_General_SetCOMDATSelectionKind" setCOMDATSelectionKind ::+ Ptr COMDAT -> COMDATSelectionKind -> IO ()+ foreign import ccall unsafe "LLVMGetVisibility" getVisibility ::- Ptr GlobalValue -> IO Visibility+ Ptr GlobalValue -> IO Visibility foreign import ccall unsafe "LLVMSetVisibility" setVisibility ::- Ptr GlobalValue -> Visibility -> IO ()+ 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+ Ptr GlobalValue -> IO CUInt foreign import ccall unsafe "LLVMSetAlignment" setAlignment ::- Ptr GlobalValue -> CUInt -> IO ()+ Ptr GlobalValue -> CUInt -> IO () foreign import ccall unsafe "LLVM_General_HasUnnamedAddr" hasUnnamedAddr ::- Ptr GlobalValue -> IO LLVMBool+ Ptr GlobalValue -> IO LLVMBool foreign import ccall unsafe "LLVM_General_SetUnnamedAddr" setUnnamedAddr ::- Ptr GlobalValue -> LLVMBool -> IO ()+ Ptr GlobalValue -> LLVMBool -> IO () +foreign import ccall unsafe "LLVM_General_GetThreadLocalMode" getThreadLocalMode ::+ Ptr GlobalValue -> IO ThreadLocalMode++foreign import ccall unsafe "LLVM_General_SetThreadLocalMode" setThreadLocalMode ::+ Ptr GlobalValue -> ThreadLocalMode -> IO ()
src/LLVM/General/Internal/FFI/GlobalValueC.cpp view
@@ -1,17 +1,67 @@ #define __STDC_LIMIT_MACROS+#include "llvm/IR/Comdat.h" #include "llvm/IR/GlobalValue.h"+#include "llvm/IR/GlobalObject.h" #include "llvm-c/Core.h"+#include "LLVM/General/Internal/FFI/GlobalValue.h" using namespace llvm; extern "C" { +const Comdat *LLVM_General_GetCOMDAT(LLVMValueRef globalVal) {+ return unwrap<GlobalValue>(globalVal)->getComdat();+}++void LLVM_General_SetCOMDAT(LLVMValueRef globalObj, Comdat *comdat) {+ return unwrap<GlobalObject>(globalObj)->setComdat(comdat);+}++const char *LLVM_General_GetCOMDATName(const Comdat &comdat, size_t &size) {+ StringRef ref = comdat.getName();+ size = ref.size();+ return ref.data();+}++inline void LLVM_General_COMDAT_Selection_Kind_Enum_Matches() {+#define ENUM_CASE(n) static_assert(unsigned(Comdat::n) == unsigned(LLVM_General_COMDAT_Selection_Kind_ ## n), \+ "COMDAT SelectionKind Enum mismatch");+ LLVM_GENERAL_FOR_EACH_COMDAT_SELECTION_KIND(ENUM_CASE)+#undef ENUM_CASE+}++unsigned LLVM_General_GetCOMDATSelectionKind(const Comdat &comdat) {+ LLVM_General_COMDAT_Selection_Kind_Enum_Matches();+ return unsigned(comdat.getSelectionKind());+}++void LLVM_General_SetCOMDATSelectionKind(Comdat &comdat, unsigned csk) {+ LLVM_General_COMDAT_Selection_Kind_Enum_Matches();+ comdat.setSelectionKind(Comdat::SelectionKind(csk));+}+ LLVMBool LLVM_General_HasUnnamedAddr(LLVMValueRef globalVal) { return unwrap<GlobalValue>(globalVal)->hasUnnamedAddr(); } void LLVM_General_SetUnnamedAddr(LLVMValueRef globalVal, LLVMBool isUnnamedAddr) { unwrap<GlobalValue>(globalVal)->setUnnamedAddr(isUnnamedAddr);+}++inline void LLVM_General_TLS_Model_Enum_Matches() {+#define ENUM_CASE(n) static_assert(unsigned(GlobalValue::n) == unsigned(LLVM ## n), "TLS Model Enum mismatch");+ LLVM_GENERAL_FOR_EACH_THREAD_LOCAL_MODE(ENUM_CASE)+#undef ENUM_CASE+}++LLVMThreadLocalMode LLVM_General_GetThreadLocalMode(LLVMValueRef globalVal) {+ LLVM_General_TLS_Model_Enum_Matches();+ return LLVMThreadLocalMode(unwrap<GlobalValue>(globalVal)->getThreadLocalMode());+}++void LLVM_General_SetThreadLocalMode(LLVMValueRef globalVal, LLVMThreadLocalMode mode) {+ LLVM_General_TLS_Model_Enum_Matches();+ unwrap<GlobalValue>(globalVal)->setThreadLocalMode(GlobalValue::ThreadLocalMode(mode)); } }
src/LLVM/General/Internal/FFI/GlobalVariable.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances,- OverlappingInstances+ UndecidableInstances #-} -- | FFI functions for handling the LLVM GlobalVariable class module LLVM.General.Internal.FFI.GlobalVariable where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C @@ -27,10 +28,4 @@ foreign import ccall unsafe "LLVMSetInitializer" setInitializer :: Ptr GlobalVariable -> Ptr Constant -> IO ()--foreign import ccall unsafe "LLVMIsThreadLocal" isThreadLocal ::- Ptr GlobalVariable -> IO LLVMBool--foreign import ccall unsafe "LLVMSetThreadLocal" setThreadLocal ::- Ptr GlobalVariable -> LLVMBool -> IO ()
src/LLVM/General/Internal/FFI/InlineAssembly.hs view
@@ -4,6 +4,8 @@ module LLVM.General.Internal.FFI.InlineAssembly where +import LLVM.General.Prelude+ import Foreign.C import Foreign.Ptr
src/LLVM/General/Internal/FFI/Instruction.h view
@@ -35,4 +35,33 @@ #undef ENUM_CASE } LLVMSynchronizationScope; +#define LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(macro) \+ macro(UnsafeAlgebra, unsafeAlgebra) \+ macro(NoNaNs, noNaNs) \+ macro(NoInfs, noInfs) \+ macro(NoSignedZeros, noSignedZeros) \+ macro(AllowReciprocal, allowReciprocal)++typedef enum {+#define ENUM_CASE(x,l) LLVM ## x ## Bit,+LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)+#undef ENUM_CASE+} LLVMFastMathFlagBit;++typedef enum {+#define ENUM_CASE(x,l) LLVM ## x = (1 << LLVM ## x ## Bit),+LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)+#undef ENUM_CASE+} LLVMFastMathFlags;++#define LLVM_GENERAL_FOR_EACH_TAIL_CALL_KIND(macro) \+ macro(None) \+ macro(Tail) \+ macro(MustTail)++typedef enum {+#define ENUM_CASE(x) LLVM_General_TailCallKind_ ## x,+LLVM_GENERAL_FOR_EACH_TAIL_CALL_KIND(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_TailCallKind; #endif
src/LLVM/General/Internal/FFI/Instruction.hs view
@@ -2,15 +2,16 @@ ForeignFunctionInterface, MultiParamTypeClasses, UndecidableInstances,- OverlappingInstances, TemplateHaskell #-} module LLVM.General.Internal.FFI.Instruction where -import Control.Monad+import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C +import LLVM.General.Internal.FFI.Attribute import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.LLVMCTypes @@ -33,33 +34,27 @@ foreign import ccall unsafe "LLVM_General_GetFCmpPredicate" getFCmpPredicate :: Ptr Instruction -> IO FCmpPredicate -foreign import ccall unsafe "LLVMGetInstructionCallConv" getInstructionCallConv ::- Ptr Instruction -> IO CallConv+foreign import ccall unsafe "LLVM_General_GetCallSiteCallingConvention" getCallSiteCallingConvention ::+ Ptr Instruction -> IO CallingConvention -foreign import ccall unsafe "LLVMSetInstructionCallConv" setInstructionCallConv ::- Ptr Instruction -> CallConv -> IO ()+foreign import ccall unsafe "LLVM_General_SetCallSiteCallingConvention" setCallSiteCallingConvention ::+ Ptr Instruction -> CallingConvention -> IO () -foreign import ccall unsafe "LLVMIsTailCall" isTailCall ::- Ptr Instruction -> IO LLVMBool+foreign import ccall unsafe "LLVM_General_GetTailCallKind" getTailCallKind ::+ Ptr Instruction -> IO TailCallKind -foreign import ccall unsafe "LLVMSetTailCall" setTailCall ::- Ptr Instruction -> LLVMBool -> IO ()+foreign import ccall unsafe "LLVM_General_SetTailCallKind" setTailCallKind ::+ Ptr Instruction -> TailCallKind -> IO () -foreign import ccall unsafe "LLVM_General_GetCallInstCalledValue" getCallInstCalledValue ::+foreign import ccall unsafe "LLVM_General_GetCallSiteCalledValue" getCallSiteCalledValue :: Ptr Instruction -> IO (Ptr Value) -foreign import ccall unsafe "LLVM_General_GetCallInstFunctionAttr" getCallInstFunctionAttr ::- Ptr Instruction -> IO FunctionAttr--foreign import ccall unsafe "LLVM_General_AddCallInstFunctionAttr" addCallInstFunctionAttr ::- Ptr Instruction -> FunctionAttr -> IO ()--foreign import ccall unsafe "LLVM_General_GetCallInstAttr" getCallInstAttr ::- Ptr Instruction -> CUInt -> IO ParamAttr--foreign import ccall unsafe "LLVM_General_AddCallInstAttr" addCallInstAttr ::- Ptr Instruction -> CUInt -> ParamAttr -> IO ()+foreign import ccall unsafe "LLVM_General_GetCallSiteAttributeSet" getCallSiteAttributeSet ::+ Ptr Instruction -> IO MixedAttributeSet +foreign import ccall unsafe "LLVM_General_SetCallSiteAttributeSet" setCallSiteAttributeSet ::+ Ptr Instruction -> MixedAttributeSet -> IO ()+ foreign import ccall unsafe "LLVMAddIncoming" addIncoming' :: Ptr Instruction -> Ptr (Ptr Value) -> Ptr (Ptr BasicBlock) -> CUInt -> IO () @@ -104,8 +99,11 @@ foreign import ccall unsafe "LLVM_General_GetAtomicOrdering" getAtomicOrdering :: Ptr Instruction -> IO MemoryOrdering +foreign import ccall unsafe "LLVM_General_GetFailureAtomicOrdering" getFailureAtomicOrdering ::+ Ptr Instruction -> IO MemoryOrdering+ foreign import ccall unsafe "LLVM_General_GetSynchronizationScope" getSynchronizationScope ::- Ptr Instruction -> IO LLVMBool+ Ptr Instruction -> IO SynchronizationScope getAtomicity i = return (,) `ap` getSynchronizationScope i `ap` getAtomicOrdering i
src/LLVM/General/Internal/FFI/InstructionC.cpp view
@@ -6,11 +6,13 @@ #include "llvm/IR/Operator.h" #include "llvm/IR/BasicBlock.h" #include "llvm/IR/Metadata.h"-#include "llvm/Support/CallSite.h"+#include "llvm/IR/CallSite.h" #include "llvm-c/Core.h" +#include "LLVM/General/Internal/FFI/AttributeC.hpp" #include "LLVM/General/Internal/FFI/Instruction.h"+#include "LLVM/General/Internal/FFI/CallingConventionC.hpp" using namespace llvm; @@ -43,8 +45,16 @@ } } +LLVMFastMathFlags wrap(FastMathFlags f) {+ unsigned r = 0;+#define ENUM_CASE(u,l) if (f.l()) r |= unsigned(LLVM ## u);+LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)+#undef ENUM_CASE+ return LLVMFastMathFlags(r); } +}+ extern "C" { unsigned LLVM_General_GetInstructionDefOpcode(LLVMValueRef val) {@@ -63,31 +73,52 @@ return unwrap<PossiblyExactOperator>(val)->isExact(); } -LLVMValueRef LLVM_General_GetCallInstCalledValue(- LLVMValueRef callInst-) {- return wrap(CallSite(unwrap<Instruction>(callInst)).getCalledValue());+LLVMFastMathFlags LLVM_General_GetFastMathFlags(LLVMValueRef val) {+ return wrap(unwrap<Instruction>(val)->getFastMathFlags()); } -LLVMAttribute LLVM_General_GetCallInstAttr(LLVMValueRef callInst, unsigned i) {- return (LLVMAttribute)CallSite(unwrap<Instruction>(callInst)).getAttributes().Raw(i);+LLVMValueRef LLVM_General_GetCallSiteCalledValue(LLVMValueRef i) {+ return wrap(CallSite(unwrap<Instruction>(i)).getCalledValue()); } -void LLVM_General_AddCallInstAttr(LLVMValueRef callInst, unsigned i, LLVMAttribute attr) {- CallSite callSite(unwrap<Instruction>(callInst));- LLVMContext &context = callSite->getContext();- AttrBuilder attrBuilder(attr);- callSite.setAttributes(callSite.getAttributes().addAttributes(context, i, AttributeSet::get(context, i, attrBuilder)));+const AttributeSetImpl *LLVM_General_GetCallSiteAttributeSet(LLVMValueRef i) {+ return wrap(CallSite(unwrap<Instruction>(i)).getAttributes()); } -LLVMAttribute LLVM_General_GetCallInstFunctionAttr(LLVMValueRef callInst) {- return LLVM_General_GetCallInstAttr(callInst, AttributeSet::FunctionIndex);+void LLVM_General_SetCallSiteAttributeSet(LLVMValueRef i, const AttributeSetImpl *asi) {+ CallSite(unwrap<Instruction>(i)).setAttributes(unwrap(asi)); } -void LLVM_General_AddCallInstFunctionAttr(LLVMValueRef callInst, LLVMAttribute attr) {- LLVM_General_AddCallInstAttr(callInst, AttributeSet::FunctionIndex, attr);+unsigned LLVM_General_GetCallSiteCallingConvention(LLVMValueRef i) {+ LLVM_General_CallingConventionEnumMatches();+ return unsigned(CallSite(unwrap<Instruction>(i)).getCallingConv()); } +void LLVM_General_SetCallSiteCallingConvention(LLVMValueRef i, unsigned cc) {+ LLVM_General_CallingConventionEnumMatches();+ CallSite(unwrap<Instruction>(i)).setCallingConv(llvm::CallingConv::ID(cc));+}++void LLVM_General_TailCallKindEnumMatches() {+#define CHECK(name) \+ static_assert( \+ unsigned(llvm::CallInst::TCK_ ## name) == unsigned(LLVM_General_TailCallKind_ ## name), \+ "LLVM_General_TailCallKind enum out of sync w/ llvm::CallInst::TailCallKind for " #name \+ );+ LLVM_GENERAL_FOR_EACH_TAIL_CALL_KIND(CHECK)+#undef CHECK+}++unsigned LLVM_General_GetTailCallKind(LLVMValueRef i) {+ LLVM_General_TailCallKindEnumMatches();+ return unwrap<CallInst>(i)->getTailCallKind();+}++void LLVM_General_SetTailCallKind(LLVMValueRef i, unsigned kind) {+ LLVM_General_TailCallKindEnumMatches();+ return unwrap<CallInst>(i)->setTailCallKind(llvm::CallInst::TailCallKind(kind));+}+ LLVMValueRef LLVM_General_GetAllocaNumElements(LLVMValueRef a) { return wrap(unwrap<AllocaInst>(a)->getArraySize()); }@@ -122,25 +153,32 @@ // ------------------------------------------------------------ -#define LLVM_GENERAL_FOR_EACH_ATOMIC_INST(macro) \- macro(Load) \- macro(Store) \- macro(Fence) \- macro(AtomicCmpXchg) \- macro(AtomicRMW)+#define LLVM_GENERAL_FOR_EACH_ATOMIC_INST(macro) \+ macro(Load,) \+ macro(Store,) \+ macro(Fence,) \+ macro(AtomicCmpXchg,Success) \+ macro(AtomicRMW,) LLVMAtomicOrdering LLVM_General_GetAtomicOrdering(LLVMValueRef i) { switch(unwrap<Instruction>(i)->getOpcode()) {-#define ENUM_CASE(n) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getOrdering());+#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->get ## s ## Ordering()); LLVM_GENERAL_FOR_EACH_ATOMIC_INST(ENUM_CASE) #undef ENUM_CASE default: return LLVMAtomicOrdering(0); } } +LLVMAtomicOrdering LLVM_General_GetFailureAtomicOrdering(LLVMValueRef i) {+ switch(unwrap<Instruction>(i)->getOpcode()) {+ case Instruction::AtomicCmpXchg: return wrap(unwrap<AtomicCmpXchgInst>(i)->getFailureOrdering());+ default: return LLVMAtomicOrdering(0);+ }+}+ LLVMSynchronizationScope LLVM_General_GetSynchronizationScope(LLVMValueRef i) { switch(unwrap<Instruction>(i)->getOpcode()) {-#define ENUM_CASE(n) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getSynchScope());+#define ENUM_CASE(n,s) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getSynchScope()); LLVM_GENERAL_FOR_EACH_ATOMIC_INST(ENUM_CASE) #undef ENUM_CASE default: return LLVMSynchronizationScope(0);@@ -237,4 +275,3 @@ } }-
src/LLVM/General/Internal/FFI/InstructionDefs.hsc view
@@ -2,6 +2,8 @@ -- so it may be accessed conveniently with Template Haskell code module LLVM.General.Internal.FFI.InstructionDefs where +import LLVM.General.Prelude+ import LLVM.General.Internal.FFI.LLVMCTypes #define FIRST_TERM_INST(num) struct inst { const char *kind; int opcode; const char *name; const char *clas; } insts[] = { { "Terminator", },
src/LLVM/General/Internal/FFI/Iterate.hs view
@@ -1,8 +1,8 @@ -- | Functions to help handle LLVM iteration patterns module LLVM.General.Internal.FFI.Iterate where -import Control.Monad-import Data.Functor+import LLVM.General.Prelude+ import Foreign.Ptr -- | retrieve a sequence of objects which form a linked list, given an action to
src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -5,17 +5,20 @@ -- Encapsulate hsc macro weirdness here, supporting higher-level tricks elsewhere. module LLVM.General.Internal.FFI.LLVMCTypes where +import LLVM.General.Prelude+ #define __STDC_LIMIT_MACROS #include "llvm-c/Core.h" #include "llvm-c/Target.h" #include "llvm-c/TargetMachine.h" #include "llvm-c/Linker.h"-#include "LLVM/General/Internal/FFI/Instruction.h"+#include "LLVM/General/Internal/FFI/Attribute.h"+#include "LLVM/General/Internal/FFI/Instruction.h" #include "LLVM/General/Internal/FFI/Value.h" #include "LLVM/General/Internal/FFI/SMDiagnostic.h" #include "LLVM/General/Internal/FFI/InlineAssembly.h" #include "LLVM/General/Internal/FFI/Target.h"-#include "LLVM/General/Internal/FFI/Function.h"+#include "LLVM/General/Internal/FFI/CallingConvention.h" #include "LLVM/General/Internal/FFI/GlobalValue.h" #include "LLVM/General/Internal/FFI/Type.h" #include "LLVM/General/Internal/FFI/Constant.h"@@ -25,7 +28,6 @@ import Language.Haskell.TH.Quote -import Data.Data import Data.Bits import Foreign.C import Foreign.Storable@@ -106,11 +108,26 @@ newtype MDKindID = MDKindID CUInt deriving (Storable) +newtype FastMathFlags = FastMathFlags CUInt+ deriving (Eq, Ord, Show, Typeable, Data, Num, Bits)+#define FMF_Rec(n,l) { #n, LLVM ## n, },+#{inject FAST_MATH_FLAG, FastMathFlags, FastMathFlags, fastMathFlags, FMF_Rec}+ newtype MemoryOrdering = MemoryOrdering CUInt deriving (Eq, Typeable, Data) #define MO_Rec(n) { #n, LLVMAtomicOrdering ## n }, #{inject ATOMIC_ORDERING, MemoryOrdering, MemoryOrdering, memoryOrdering, MO_Rec} +newtype SynchronizationScope = SynchronizationScope CUInt+ deriving (Eq, Typeable, Data)+#define SS_Rec(n) { #n, LLVM ## n ## SynchronizationScope },+#{inject SYNCRONIZATION_SCOPE, SynchronizationScope, SynchronizationScope, synchronizationScope, SS_Rec}++newtype TailCallKind = TailCallKind CUInt+ deriving (Eq, Typeable, Data)+#define TCK_Rec(n) { #n, LLVM_General_TailCallKind_ ## n },+#{inject TAIL_CALL_KIND, TailCallKind, TailCallKind, tailCallKind, TCK_Rec}+ newtype Linkage = Linkage CUInt deriving (Eq, Read, Show, Typeable, Data) #define LK_Rec(n) { #n, LLVM ## n ## Linkage },@@ -121,11 +138,26 @@ #define VIS_Rec(n) { #n, LLVM ## n ## Visibility }, #{inject VISIBILITY, Visibility, Visibility, visibility, VIS_Rec} -newtype CallConv = CallConv CUInt+newtype COMDATSelectionKind = COMDATSelectionKind CUInt deriving (Eq, Read, Show, Typeable, Data)-#define CC_Rec(n) { #n, LLVM ## n ## CallConv },-#{inject CALLCONV, CallConv, CallConv, callConv, CC_Rec}+#define CSK(n) { #n, LLVM_General_COMDAT_Selection_Kind_ ## n },+#{inject COMDAT_SELECTION_KIND, COMDATSelectionKind, COMDATSelectionKind, comdatSelectionKind, CSK} +newtype DLLStorageClass = DLLStorageClass CUInt+ deriving (Eq, Read, Show, Typeable, Data)+#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)+#define CC_Rec(l, n) { #l, LLVM_General_CallingConvention_ ## l },+#{inject CALLING_CONVENTION, CallingConvention, CallingConvention, callingConvention, CC_Rec}++newtype ThreadLocalMode = ThreadLocalMode CUInt+ deriving (Eq, Read, Show, Typeable, Data)+#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) #define VSID_Rec(n) { #n, LLVM ## n ## SubclassId },@@ -186,15 +218,25 @@ #define TK_Rec(n) { #n, LLVM ## n ## TypeKind }, #{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec} -newtype ParamAttr = ParamAttr CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num)-#define PA_Rec(n) { #n, LLVM ## n ## Attribute },-#{inject PARAM_ATTR, ParamAttr, ParamAttr, paramAttr, PA_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)+#define PAK_Rec(n,p,r,f) IF(OR(p,r))({ #n COMMA LLVM_General_AttributeKind_ ## n} COMMA)+#{inject ATTRIBUTE_KIND, ParameterAttributeKind, ParameterAttributeKind, parameterAttributeKind, PAK_Rec} -newtype FunctionAttr = FunctionAttr CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num)-#define FA_Rec(n,a) { #n, LLVM ## n ## a },-#{inject FUNCTION_ATTR, FunctionAttr, FunctionAttr, functionAttr, FA_Rec}+newtype FunctionAttributeKind = FunctionAttributeKind CUInt+ deriving (Eq, Read, Show, Typeable, Data)+#define FAK_Rec(n,p,r,f) IF(f)({ #n COMMA LLVM_General_AttributeKind_ ## n} COMMA)+#{inject ATTRIBUTE_KIND, FunctionAttributeKind, FunctionAttributeKind, functionAttributeKind, FAK_Rec} newtype FloatSemantics = FloatSemantics CUInt deriving (Eq, Read, Show, Typeable, Data)
src/LLVM/General/Internal/FFI/LibFunc.h view
@@ -26,7 +26,7 @@ macro(dunder_isoc99_sscanf) \ macro(memcpy_chk) \ macro(sincospi_stret) \- macro(sincospi_stretf) \+ macro(sincospif_stret) \ macro(sinpi) \ macro(sinpif) \ macro(sqrt_finite) \@@ -118,6 +118,12 @@ macro(floor) \ macro(floorf) \ macro(floorl) \+ macro(fmax) \+ macro(fmaxf) \+ macro(fmaxl) \+ macro(fmin) \+ macro(fminf) \+ macro(fminl) \ macro(fmod) \ macro(fmodf) \ macro(fmodl) \@@ -162,6 +168,9 @@ macro(isdigit) \ macro(labs) \ macro(lchown) \+ macro(ldexp) \+ macro(ldexpf) \+ macro(ldexpl) \ macro(llabs) \ macro(log) \ macro(log10) \
src/LLVM/General/Internal/FFI/MemoryBuffer.hs view
@@ -3,10 +3,12 @@ #-} module LLVM.General.Internal.FFI.MemoryBuffer where -import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Prelude import Foreign.Ptr import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes data MemoryBuffer
src/LLVM/General/Internal/FFI/Metadata.hs view
@@ -5,6 +5,8 @@ module LLVM.General.Internal.FFI.Metadata where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Module.hs view
@@ -3,12 +3,16 @@ #-} module LLVM.General.Internal.FFI.Module where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.GlobalValue (COMDAT) import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Type data Module @@ -48,6 +52,9 @@ foreign import ccall unsafe "LLVM_General_GetNextAlias" getNextAlias :: Ptr GlobalAlias -> IO (Ptr GlobalAlias) +foreign import ccall unsafe "LLVM_General_GetOrInsertCOMDAT" getOrInsertCOMDAT ::+ Ptr Module -> CString -> IO (Ptr COMDAT)+ foreign import ccall unsafe "LLVMGetFirstFunction" getFirstFunction :: Ptr Module -> IO (Ptr Function) @@ -64,7 +71,7 @@ Ptr Module -> Ptr Type -> CString -> CUInt -> IO (Ptr GlobalVariable) foreign import ccall unsafe "LLVM_General_JustAddAlias" justAddAlias ::- Ptr Module -> Ptr Type -> CString -> IO (Ptr GlobalAlias)+ Ptr Module -> Ptr Type -> AddrSpace -> CString -> IO (Ptr GlobalAlias) foreign import ccall unsafe "LLVMAddFunction" addFunction ::
src/LLVM/General/Internal/FFI/ModuleC.cpp view
@@ -23,8 +23,12 @@ return wrap(i); } -LLVMValueRef LLVM_General_JustAddAlias(LLVMModuleRef m, LLVMTypeRef ty, const char *name) {- return wrap(new GlobalAlias(unwrap(ty), GlobalValue::ExternalLinkage, name, 0, unwrap(m)));+Comdat *LLVM_General_GetOrInsertCOMDAT(LLVMModuleRef m, const char *name) {+ return unwrap(m)->getOrInsertComdat(name);+}++LLVMValueRef LLVM_General_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_General_GetOrAddNamedMetadata(LLVMModuleRef m, const char *name) {
src/LLVM/General/Internal/FFI/PassManager.hs view
@@ -5,11 +5,9 @@ module LLVM.General.Internal.FFI.PassManager where -import qualified Language.Haskell.TH as TH--import Control.Monad+import LLVM.General.Prelude -import Data.Word+import qualified Language.Haskell.TH as TH import Foreign.Ptr import Foreign.C@@ -129,3 +127,9 @@ foreign import ccall unsafe "LLVM_General_PassManagerBuilderSetLibraryInfo" passManagerBuilderSetLibraryInfo :: Ptr PassManagerBuilder -> Ptr TargetLibraryInfo -> IO ()++foreign import ccall unsafe "LLVM_General_PassManagerBuilderSetLoopVectorize" passManagerBuilderSetLoopVectorize ::+ Ptr PassManagerBuilder -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVM_General_PassManagerBuilderSetSuperwordLevelParallelismVectorize" passManagerBuilderSetSuperwordLevelParallelismVectorize ::+ Ptr PassManagerBuilder -> LLVMBool -> IO ()
src/LLVM/General/Internal/FFI/PassManagerC.cpp view
@@ -3,8 +3,10 @@ #include "llvm/IR/DataLayout.h" #include "llvm/Transforms/Scalar.h" #include "llvm/Transforms/IPO.h"+#include "llvm/Transforms/IPO/PassManagerBuilder.h" #include "llvm/Transforms/Vectorize.h" #include "llvm/Transforms/Instrumentation.h"+#include "llvm/CodeGen/Passes.h" #include "llvm/PassManager.h" #include "llvm-c/Target.h" #include "llvm-c/Transforms/PassManagerBuilder.h"@@ -51,10 +53,6 @@ extern "C" { -void LLVM_General_AddDataLayoutPass(LLVMPassManagerRef PM, const char *dl) {- unwrap(PM)->add(new DataLayout(dl));-}- void LLVM_General_LLVMAddAnalysisPasses(LLVMTargetMachineRef T, LLVMPassManagerRef PM) { unwrap(T)->addAnalysisPasses(*unwrap(PM)); }@@ -99,8 +97,8 @@ unwrap(PM)->add(createLoopStrengthReducePass()); } -void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM, LLVMTargetMachineRef T, LLVMBool expensiveEH) {- unwrap(PM)->add(createLowerInvokePass(unwrap(T), expensiveEH));+void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM) {+ unwrap(PM)->add(createLowerInvokePass()); } void LLVM_General_AddSROAPass(LLVMPassManagerRef PM, LLVMBool RequiresDomTree) {@@ -179,46 +177,28 @@ } void LLVM_General_AddAddressSanitizerFunctionPass(- LLVMPassManagerRef PM,- LLVMBool checkInitOrder,- LLVMBool checkUseAfterReturn,- LLVMBool checkLifetime,- char *blacklistFile,- LLVMBool zeroBaseShadow+ LLVMPassManagerRef PM ) {- unwrap(PM)->add(- createAddressSanitizerFunctionPass(- checkInitOrder,- checkUseAfterReturn,- checkLifetime,- blacklistFile,- zeroBaseShadow- )- );+ unwrap(PM)->add(createAddressSanitizerFunctionPass()); } void LLVM_General_AddAddressSanitizerModulePass(- LLVMPassManagerRef PM,- LLVMBool checkInitOrder,- const char *blacklistFile,- bool zeroBaseShadow+ LLVMPassManagerRef PM ) {- unwrap(PM)->add(createAddressSanitizerModulePass(checkInitOrder, blacklistFile, zeroBaseShadow));+ unwrap(PM)->add(createAddressSanitizerModulePass()); } void LLVM_General_AddMemorySanitizerPass( LLVMPassManagerRef PM,- LLVMBool trackOrigins,- const char *blacklistFile+ LLVMBool trackOrigins ) {- unwrap(PM)->add(createMemorySanitizerPass(trackOrigins, blacklistFile));+ unwrap(PM)->add(createMemorySanitizerPass(trackOrigins)); } void LLVM_General_AddThreadSanitizerPass(- LLVMPassManagerRef PM,- const char *blacklistFile+ LLVMPassManagerRef PM ) {- unwrap(PM)->add(createThreadSanitizerPass(blacklistFile));+ unwrap(PM)->add(createThreadSanitizerPass()); } void LLVM_General_AddBoundsCheckingPass(LLVMPassManagerRef PM) {@@ -246,14 +226,35 @@ unwrap(PM)->add(createDebugIRPass()); } -void-LLVM_General_PassManagerBuilderSetLibraryInfo(- LLVMPassManagerBuilderRef PMB,- LLVMTargetLibraryInfoRef l+void LLVM_General_AddLoopVectorizePass(+ LLVMPassManagerRef PM,+ LLVMBool noUnrolling,+ LLVMBool alwaysVectorize ) {- // The PassManager frees the TargetLibraryInfo when done,- // but we also free our ref, so give it a new copy.- unwrap(PMB)->LibraryInfo = new TargetLibraryInfo(*unwrap(l));+ unwrap(PM)->add(createLoopVectorizePass(noUnrolling, alwaysVectorize));+}++void LLVM_General_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 TargetLibraryInfo(*unwrap(l));+}++void LLVM_General_PassManagerBuilderSetLoopVectorize(+ LLVMPassManagerBuilderRef PMB,+ LLVMBool runLoopVectorization+) {+ unwrap(PMB)->LoopVectorize = runLoopVectorization;+}++void LLVM_General_PassManagerBuilderSetSuperwordLevelParallelismVectorize(+ LLVMPassManagerBuilderRef PMB,+ LLVMBool runSLPVectorization+) {+ unwrap(PMB)->SLPVectorize = runSLPVectorization; } }
src/LLVM/General/Internal/FFI/PtrHierarchy.hs view
@@ -3,11 +3,19 @@ MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances,- OverlappingInstances+ CPP #-}+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#define CPP_OVERLAPPING+#else+#define CPP_OVERLAPPING {-# OVERLAPPING #-}+#endif -- | This module defines typeclasses to represent the relationships of an object-oriented inheritance hierarchy module LLVM.General.Internal.FFI.PtrHierarchy where +import LLVM.General.Prelude+ import Foreign.Ptr -- | a class to represent safe casting of pointers to objects of descendant-classes to ancestor-classes.@@ -16,7 +24,7 @@ upCast = castPtr -- | trivial casts-instance DescendentOf a a where+instance CPP_OVERLAPPING DescendentOf a a where upCast = id -- | a class to represent direct parent-child relationships@@ -38,10 +46,15 @@ instance ChildOf Constant GlobalValue +-- | <http://llvm.org/doxygen/classllvm_1_1GlobalObject.html>+data GlobalObject++instance ChildOf GlobalValue GlobalObject+ -- | <http://llvm.org/doxygen/classllvm_1_1GlobalVariable.html> data GlobalVariable -instance ChildOf GlobalValue GlobalVariable+instance ChildOf GlobalObject GlobalVariable -- | <http://llvm.org/doxygen/classllvm_1_1GlobalAlias.html> data GlobalAlias@@ -51,7 +64,7 @@ -- | <http://llvm.org/doxygen/classllvm_1_1Function.html> data Function -instance ChildOf GlobalValue Function+instance ChildOf GlobalObject Function -- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html> data BasicBlock
src/LLVM/General/Internal/FFI/RawOStream.hs view
@@ -3,12 +3,13 @@ #-} module LLVM.General.Internal.FFI.RawOStream where -import LLVM.General.Internal.FFI.ByteRangeCallback+import LLVM.General.Prelude import Foreign.Ptr import Foreign.C import Control.Exception (bracket) +import LLVM.General.Internal.FFI.ByteRangeCallback import LLVM.General.Internal.FFI.LLVMCTypes data RawOStream
src/LLVM/General/Internal/FFI/RawOStreamC.cpp view
@@ -1,23 +1,24 @@ #define __STDC_LIMIT_MACROS #include "llvm/Support/raw_ostream.h"+#include "llvm/Support/FileSystem.h" #include "llvm-c/Core.h" using namespace llvm; using sys::fs::F_None; using sys::fs::F_Excl;-using sys::fs::F_Binary;+using sys::fs::F_Text; extern "C" { LLVMBool LLVM_General_WithFileRawOStream( const char *filename, LLVMBool excl,- LLVMBool binary,+ LLVMBool text, const char *&error, void (&callback)(raw_ostream &ostream) ) { std::string e;- raw_fd_ostream os(filename, e, (excl ? F_Excl : F_None) | (binary ? F_Binary : F_None));+ raw_fd_ostream os(filename, e, (excl ? F_Excl : F_None) | (text ? F_Text : F_None)); if (!e.empty()) { error = strdup(e.c_str()); return false;
src/LLVM/General/Internal/FFI/SMDiagnostic.hs view
@@ -4,6 +4,8 @@ -- | FFI functions for handling the LLVM SMDiagnostic class module LLVM.General.Internal.FFI.SMDiagnostic where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Target.h view
@@ -41,8 +41,10 @@ macro(DisableTailCalls) \ macro(EnableFastISel) \ macro(PositionIndependentExecutable) \- macro(EnableSegmentedStacks) \- macro(UseInitArray)+ macro(UseInitArray) \+ macro(DisableIntegratedAS) \+ macro(CompressDebugSections) \+ macro(TrapUnreachable) typedef enum { #define ENUM_CASE(n) LLVM_General_TargetOptionFlag_ ## n,
src/LLVM/General/Internal/FFI/Target.hs view
@@ -4,6 +4,8 @@ #-} module LLVM.General.Internal.FFI.Target where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C @@ -93,7 +95,7 @@ IO (OwnerTransfered CString) foreign import ccall unsafe "LLVM_General_GetHostCPUName" getHostCPUName :: - IO (OwnerTransfered CString)+ Ptr CSize -> IO CString foreign import ccall unsafe "LLVM_General_GetHostCPUFeatures" getHostCPUFeatures :: IO (OwnerTransfered CString)
src/LLVM/General/Internal/FFI/TargetC.cpp view
@@ -139,9 +139,9 @@ } LLVMTargetRef LLVM_General_LookupTarget(- const char *arch, - const char *ctriple, - const char **tripleOut, + const char *arch,+ const char *ctriple,+ const char **tripleOut, const char **cerror ) { std::string error;@@ -234,14 +234,14 @@ triple, cpu, features,- *targetOptions, + *targetOptions, unwrap(relocModel), unwrap(codeModel), unwrap(codeGenOptLevel) ) ); }- + const TargetLowering *LLVM_General_GetTargetLowering(LLVMTargetMachineRef t) { return unwrap(t)->getTargetLowering(); }@@ -254,18 +254,21 @@ return strdup(sys::getProcessTriple().c_str()); } -char *LLVM_General_GetHostCPUName() {- return strdup(sys::getHostCPUName().c_str());+const char *LLVM_General_GetHostCPUName(size_t &len) {+ StringRef r = sys::getHostCPUName();+ len = r.size();+ return r.data(); } char *LLVM_General_GetHostCPUFeatures() { StringMap<bool> featureMap; std::string features; if (sys::getHostCPUFeatures(featureMap)) {+ bool first = true; for(llvm::StringMap<bool>::const_iterator it = featureMap.begin(); it != featureMap.end(); ++it) {- if (it->second) {- features += it->first().str() + " ";- }+ if (!first) { features += ","; }+ first = false;+ features += (it->second ? "+" : "-") + it->first().str(); } } return strdup(features.c_str());@@ -337,7 +340,7 @@ return true; } PassManager passManager;- passManager.add(new DataLayout(*td));+ passManager.add(new DataLayoutPass(*td)); if (tm.addPassesToEmitFile(passManager, destf, unwrap(codeGenFileType))) { *ErrorMessage = strdup("TargetMachine can't emit a file of this type"); return true;
+ src/LLVM/General/Internal/FFI/Threading.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE+ ForeignFunctionInterface+ #-}+module LLVM.General.Internal.FFI.Threading where++import LLVM.General.Prelude++import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes++foreign import ccall unsafe "LLVMIsMultithreaded" isMultithreaded ::+ IO LLVMBool
src/LLVM/General/Internal/FFI/Transforms.hs view
@@ -1,9 +1,10 @@ -- | Code used with Template Haskell to build the FFI for transform passes. module LLVM.General.Internal.FFI.Transforms where +import LLVM.General.Prelude+ -- | does the constructor for this pass require a TargetMachine object needsTargetMachine "CodeGenPrepare" = True-needsTargetMachine "LowerInvoke" = True needsTargetMachine _ = False -- | Translate a Haskell name (used in the public Haskell interface, typically not abbreviated)@@ -33,6 +34,7 @@ "OldScalarReplacementOfAggregates" -> "ScalarReplAggregates" "SimplifyControlFlowGraph" -> "CFGSimplification" "SparseConditionalConstantPropagation" -> "SCCP"+ "SuperwordLevelParallelismVectorize" -> "SLPVectorize" h -> h patchImpls = [ "AddressSanitizer",@@ -42,31 +44,32 @@ "GlobalValueNumbering", "InternalizeFunctions", "BasicBlockVectorize",- "BlockPlacement",- "BreakCriticalEdges",- "DeadCodeElimination",- "DeadInstructionElimination",+ "BlockPlacement",+ "BreakCriticalEdges",+ "DeadCodeElimination",+ "DeadInstructionElimination", "DebugExistingIR", "DebugGeneratedIR",- "DemoteRegisterToMemory",+ "DemoteRegisterToMemory", "EdgeProfiler", "GCOVProfiler",- "LoopClosedSingleStaticAssignment",- "LoopInstructionSimplify",+ "LoopClosedSingleStaticAssignment",+ "LoopInstructionSimplify", "LoopStrengthReduce",- "LowerAtomic",- "LowerInvoke",- "LowerSwitch",+ "LoopVectorize",+ "LowerAtomic",+ "LowerInvoke",+ "LowerSwitch", "MemorySanitizer",- "MergeFunctions",+ "MergeFunctions", "OptimalEdgeProfiler", "PathProfiler",- "PartialInlining",+ "PartialInlining", "ScalarReplacementOfAggregates",- "Sinking",- "StripDeadDebugInfo",- "StripDebugDeclare",- "StripNonDebugSymbols",+ "Sinking",+ "StripDeadDebugInfo",+ "StripDebugDeclare",+ "StripNonDebugSymbols", "ThreadSanitizer" ] in
src/LLVM/General/Internal/FFI/Type.hs view
@@ -4,9 +4,10 @@ -- | Functions for handling the LLVM types module LLVM.General.Internal.FFI.Type where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C-import Data.Word import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.Context
src/LLVM/General/Internal/FFI/User.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances,- OverlappingInstances+ UndecidableInstances #-} -- | FFI functions for handling the LLVM User class module LLVM.General.Internal.FFI.User where++import LLVM.General.Prelude import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Value.h view
@@ -22,8 +22,6 @@ macro(MDNode) \ macro(MDString) \ macro(InlineAsm) \- macro(PseudoSourceValue) \- macro(FixedStackPseudoSourceValue) \ macro(Instruction) typedef enum {
src/LLVM/General/Internal/FFI/Value.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances,- OverlappingInstances+ UndecidableInstances #-} -- | FFI functions for handling the LLVM Value class module LLVM.General.Internal.FFI.Value where +import LLVM.General.Prelude+ import Foreign.Ptr import Foreign.C @@ -32,6 +33,9 @@ foreign import ccall unsafe "LLVMReplaceAllUsesWith" replaceAllUsesWith :: Ptr Value -> Ptr Value -> IO ()++foreign import ccall unsafe "LLVM_General_CreateArgument" createArgument ::+ Ptr Type -> CString -> IO (Ptr Value) foreign import ccall unsafe "LLVMDumpValue" dumpValue :: Ptr Value -> IO ()
src/LLVM/General/Internal/FFI/ValueC.cpp view
@@ -1,6 +1,8 @@ #define __STDC_LIMIT_MACROS #include "llvm-c/Core.h"+#include "llvm/IR/Type.h" #include "llvm/IR/Value.h"+#include "llvm/IR/Argument.h" #include "LLVM/General/Internal/FFI/Value.h" using namespace llvm;@@ -15,6 +17,13 @@ default: break; } return LLVMValueSubclassId(0);+}++LLVMValueRef LLVM_General_CreateArgument(+ LLVMTypeRef t,+ const char *name+) {+ return wrap(new Argument(unwrap(t), name)); } }
+ src/LLVM/General/Internal/FastMathFlags.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE + MultiParamTypeClasses+ #-}+module LLVM.General.Internal.FastMathFlags where++import LLVM.General.Prelude++import Control.Monad.Trans+import Control.Monad.AnyCont+import Control.Monad.State+import Control.Exception++import Data.Bits++import qualified LLVM.General.Internal.FFI.Builder as FFI+import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++import LLVM.General.Internal.Coding+import LLVM.General.Internal.EncodeAST++import qualified LLVM.General.AST as A++instance EncodeM IO A.FastMathFlags FFI.FastMathFlags where+ encodeM A.NoFastMathFlags = return 0+ encodeM A.UnsafeAlgebra = return FFI.fastMathFlagsUnsafeAlgebra+ encodeM f = return $ foldr1 (.|.) [ + if a f then b else 0+ | (a,b) <- [+ (A.noNaNs, FFI.fastMathFlagsNoNaNs),+ (A.noInfs, FFI.fastMathFlagsNoInfs),+ (A.noSignedZeros, FFI.fastMathFlagsNoSignedZeros),+ (A.allowReciprocal, FFI.fastMathFlagsAllowReciprocal)+ ] + ]++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 0 = return A.NoFastMathFlags+ decodeM f | FFI.fastMathFlagsUnsafeAlgebra .&. f /= 0 = return A.UnsafeAlgebra+ decodeM f = return A.FastMathFlags {+ A.noNaNs = FFI.fastMathFlagsNoNaNs .&. f /= 0,+ A.noInfs = FFI.fastMathFlagsNoInfs .&. f /= 0,+ A.noSignedZeros = FFI.fastMathFlagsNoSignedZeros .&. f /= 0,+ A.allowReciprocal = FFI.fastMathFlagsAllowReciprocal .&. f /= 0+ }+
src/LLVM/General/Internal/Function.hs view
@@ -1,11 +1,16 @@ module LLVM.General.Internal.Function where -import Control.Monad+import LLVM.General.Prelude+ import Control.Monad.Trans import Control.Monad.AnyCont -import Foreign.Ptr+import Foreign.C (CUInt)+import Foreign.Ptr +import Data.Map (Map)+import qualified Data.Map as Map+ import qualified LLVM.General.Internal.FFI.Function as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI @@ -13,34 +18,43 @@ import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Value import LLVM.General.Internal.Coding-import LLVM.General.Internal.Attribute ()+import LLVM.General.Internal.Constant ()+import LLVM.General.Internal.Attribute import qualified LLVM.General.AST as A-import qualified LLVM.General.AST.Attribute as A.A--getFunctionAttrs :: Ptr FFI.Function -> IO [A.A.FunctionAttribute]-getFunctionAttrs = decodeM <=< FFI.getFunctionAttr+import qualified LLVM.General.AST.Constant as A+import qualified LLVM.General.AST.ParameterAttribute as A.PA -setFunctionAttrs :: Ptr FFI.Function -> [A.A.FunctionAttribute] -> IO ()-setFunctionAttrs f = FFI.addFunctionAttr f <=< encodeM +getMixedAttributeSet :: Ptr FFI.Function -> DecodeAST MixedAttributeSet+getMixedAttributeSet = decodeM <=< liftIO . FFI.getMixedAttributeSet -getParameterAttrs :: Ptr FFI.Parameter -> IO [A.A.ParameterAttribute]-getParameterAttrs = decodeM <=< FFI.getAttribute+setFunctionAttributes :: Ptr FFI.Function -> MixedAttributeSet -> EncodeAST ()+setFunctionAttributes f = (liftIO . FFI.setMixedAttributeSet f) <=< encodeM -getParameters :: Ptr FFI.Function -> DecodeAST [A.Parameter]-getParameters f = scopeAnyCont $ do+getParameters :: Ptr FFI.Function -> Map CUInt [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 params $ \param -> + forM (zip params [0..]) $ \(param, i) -> return A.Parameter `ap` typeOf param `ap` getLocalName param- `ap` (liftIO $ getParameterAttrs param)+ `ap` (return $ Map.findWithDefault [] i attrs) getGC :: Ptr FFI.Function -> DecodeAST (Maybe String) getGC f = scopeAnyCont $ decodeM =<< liftIO (FFI.getGC f) setGC :: Ptr FFI.Function -> Maybe String -> 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 = maybe (return ()) (liftIO . FFI.setPrefixData f <=< encodeM)
src/LLVM/General/Internal/Global.hs view
@@ -4,12 +4,12 @@ #-} module LLVM.General.Internal.Global where -import Control.Monad.IO.Class-import Data.Functor-import Foreign.Ptr-import Control.Monad.AnyCont+import LLVM.General.Prelude -import Data.Word+import Control.Monad.State+import Control.Monad.AnyCont+import Foreign.Ptr+import qualified Data.Map as Map import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI@@ -21,6 +21,9 @@ import qualified LLVM.General.AST.Linkage as A.L import qualified LLVM.General.AST.Visibility as A.V+import qualified LLVM.General.AST.COMDAT as A.COMDAT+import qualified LLVM.General.AST.DLL as A.DLL+import qualified LLVM.General.AST.ThreadLocalStorage as A.TLS genCodingInstance [t| A.L.Linkage |] ''FFI.Linkage [ (FFI.linkageExternal, A.L.External),@@ -32,12 +35,8 @@ (FFI.linkageAppending, A.L.Appending), (FFI.linkageInternal, A.L.Internal), (FFI.linkagePrivate, A.L.Private),- (FFI.linkageDLLImport, A.L.DLLImport),- (FFI.linkageDLLExport, A.L.DLLExport), (FFI.linkageExternalWeak, A.L.ExternWeak),- (FFI.linkageCommon, A.L.Common),- (FFI.linkageLinkerPrivate, A.L.LinkerPrivate),- (FFI.linkageLinkerPrivateWeak, A.L.LinkerPrivateWeak)+ (FFI.linkageCommon, A.L.Common) ] getLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.L.Linkage@@ -58,6 +57,18 @@ 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 String) getSection g = liftIO $ do s <- decodeM =<< FFI.getSection (FFI.upCast g)@@ -68,8 +79,56 @@ s <- encodeM (maybe "" id 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 (String, A.COMDAT.SelectionKind) (Ptr FFI.COMDAT) where+ decodeM c = return (,)+ `ap` (decodeM $ FFI.getCOMDATName c)+ `ap` (decodeM =<< liftIO (FFI.getCOMDATSelectionKind c))++getCOMDATName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe String)+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 String -> 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+
+ src/LLVM/General/Internal/Inject.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.General.Internal.Inject where++import LLVM.General.Prelude++class Inject a b where+ inject :: a -> b++instance Inject a a where+ inject = id+
src/LLVM/General/Internal/InlineAssembly.hs view
@@ -4,7 +4,8 @@ #-} module LLVM.General.Internal.InlineAssembly where -import Control.Monad+import LLVM.General.Prelude+ import Control.Monad.IO.Class import Foreign.C
src/LLVM/General/Internal/Instruction.hs view
@@ -1,21 +1,22 @@-{-# LANGUAGE +{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ ViewPatterns #-} module LLVM.General.Internal.Instruction where +import LLVM.General.Prelude+ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified LLVM.General.Internal.InstructionDefs as ID import LLVM.General.Internal.InstructionDefs (instrP) -import Data.Functor-import Control.Monad-import Control.Monad.Trans+import Control.Monad.Exceptable import Control.Monad.AnyCont-import Control.Monad.State+import Control.Monad.State (gets) import Foreign.Ptr @@ -32,21 +33,24 @@ import qualified LLVM.General.Internal.FFI.BasicBlock as FFI import LLVM.General.Internal.Atomicity ()-import LLVM.General.Internal.Attribute ()+import LLVM.General.Internal.Attribute import LLVM.General.Internal.CallingConvention () import LLVM.General.Internal.Coding import LLVM.General.Internal.DecodeAST import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.FastMathFlags () import LLVM.General.Internal.Metadata () import LLVM.General.Internal.Operand () import LLVM.General.Internal.RMWOperation ()+import LLVM.General.Internal.TailCallKind () import LLVM.General.Internal.Type import LLVM.General.Internal.Value import qualified LLVM.General.AST as A import qualified LLVM.General.AST.Constant as A.C -callInstAttr i j = liftIO $ decodeM =<< FFI.getCallInstAttr i j+callInstAttributeSet :: Ptr FFI.Instruction -> DecodeAST MixedAttributeSet+callInstAttributeSet = decodeM <=< liftIO . FFI.getCallSiteAttributeSet meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata meta i = do@@ -119,20 +123,21 @@ A.metadata' = md } [instrP|Invoke|] -> do- cc <- decodeM =<< liftIO (FFI.getInstructionCallConv i)- rAttrs <- callInstAttr i 0- fv <- liftIO $ FFI.getCallInstCalledValue i+ cc <- decodeM =<< liftIO (FFI.getCallSiteCallingConvention i)+ attrs <- callInstAttributeSet i+ fv <- liftIO $ FFI.getCallSiteCalledValue i f <- decodeM fv- args <- forM [1..nOps-3] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j- fAttrs <- decodeM =<< liftIO (FFI.getCallInstFunctionAttr i)+ args <- forM [1..nOps-3] $ \j -> do+ let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes attrs)+ return (, pAttrs) `ap` op (j-1) rd <- successor (nOps - 2) ed <- successor (nOps - 1) return A.Invoke { A.callingConvention' = cc,- A.returnAttributes' = rAttrs,+ A.returnAttributes' = returnAttributes attrs, A.function' = f, A.arguments' = args,- A.functionAttributes' = fAttrs,+ A.functionAttributes' = functionAttributes attrs, A.returnDest = rd, A.exceptionDest = ed, A.metadata' = md@@ -202,13 +207,10 @@ let (argvs, argAttrs) = unzip args (n, argvs) <- encodeM argvs i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s- forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do- attrs <- encodeM attrs- liftIO $ FFI.addCallInstAttr i j attrs- fAttrs <- encodeM fAttrs- liftIO $ FFI.addCallInstFunctionAttr i fAttrs+ attrs <- encodeM $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs))+ liftIO $ FFI.setCallSiteAttributeSet i attrs cc <- encodeM cc- liftIO $ FFI.setInstructionCallConv i cc+ liftIO $ FFI.setCallSiteCallingConvention i cc return $ FFI.upCast i A.Resume { A.operand0' = op0@@ -237,6 +239,7 @@ 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 $(@@ -246,6 +249,7 @@ "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 |])@@ -265,20 +269,23 @@ "metadata" -> ([], [| meta i |]) "iPredicate" -> ([], [| decodeM =<< liftIO (FFI.getICmpPredicate i) |]) "fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |])- "isTailCall" -> ([], [| decodeM =<< liftIO (FFI.isTailCall i) |])- "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getInstructionCallConv i) |])- "returnAttributes" -> ([], [| callInstAttr i 0 |])- "f" -> ([], [| liftIO $ FFI.getCallInstCalledValue i |])+ "tailCallKind" -> ([], [| decodeM =<< liftIO (FFI.getTailCallKind i) |])+ "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getCallSiteCallingConvention i) |])+ "attrs" -> ([], [| callInstAttributeSet i |])+ "returnAttributes" -> (["attrs"], [| return $ returnAttributes $(TH.dyn "attrs") |])+ "f" -> ([], [| liftIO $ FFI.getCallSiteCalledValue i |]) "function" -> (["f"], [| decodeM $(TH.dyn "f") |])- "arguments" -> ([], [| forM [1..nOps-1] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j |])+ "arguments" -> ([], [| forM [1..nOps-1] $ \j -> do+ let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes $(TH.dyn "attrs"))+ p <- op (j-1)+ return (p, pAttrs) |]) "clauses" -> ([], [| forM [1..nOps-1] $ \j -> do v <- liftIO $ FFI.getOperand (FFI.upCast i) j c <- decodeM =<< (liftIO $ FFI.isAConstant v) t <- typeOf v return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |])- "functionAttributes" ->- ([], [| decodeM =<< liftIO (FFI.getCallInstFunctionAttr i) |])+ "functionAttributes" -> (["attrs"], [| return $ functionAttributes $(TH.dyn "attrs") |]) "type'" -> ([], [| return t |]) "incomingValues" -> ([], [| do@@ -300,6 +307,7 @@ "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@@ -339,253 +347,156 @@ 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.Call {- A.isTailCall = tc,- 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- forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do- attrs <- encodeM attrs- liftIO $ FFI.addCallInstAttr i j attrs- fAttrs <- encodeM fAttrs- liftIO $ FFI.addCallInstFunctionAttr i fAttrs- when tc $ do- tc <- encodeM tc- liftIO $ FFI.setTailCall i tc- cc <- encodeM cc- liftIO $ FFI.setInstructionCallConv i cc- return' i- 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.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- mask' <- encodeM mask- i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' 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.personalityFunction = pf,- A.cleanup = cl, - A.clauses = cs- } -> do- t' <- encodeM t- pf' <- encodeM pf- i <- liftIO $ FFI.buildLandingPad builder t' pf' (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 $ fail $ "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 $ fail $ "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' <- maybe (return nullPtr) encodeM n- i <- liftIO $ FFI.buildAlloca builder alt' n' s- unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment)- return' i- A.Load {- A.volatile = vol,- A.address = a,- A.alignment = al,- A.maybeAtomicity = mat- } -> do- a' <- encodeM a- al <- encodeM al- vol <- encodeM vol- (ss, mo) <- encodeM mat- i <- liftIO $ FFI.buildLoad builder a' al vol mo ss s- return' i- A.Store { - A.volatile = vol, - A.address = a, - A.value = v, - A.maybeAtomicity = mat, - A.alignment = al- } -> do- a' <- encodeM a- v' <- encodeM v- al <- encodeM al- vol <- encodeM vol- (ss, mo) <- encodeM mat- i <- liftIO $ FFI.buildStore builder v' a' al vol mo ss s- return' i- A.GetElementPtr { A.address = a, A.indices = is, A.inBounds = ib } -> do- a' <- encodeM a- (n, is') <- encodeM is- ib <- encodeM ib - i <- liftIO $ FFI.buildGetElementPtr builder ib a' is' n s- return' i- A.Fence { A.atomicity = at } -> do- (ss, mo) <- encodeM at- i <- liftIO $ FFI.buildFence builder mo ss s- return' i- A.CmpXchg { - A.volatile = vol, - A.address = a, A.expected = e, A.replacement = r,- A.atomicity = at- } -> do- a' <- encodeM a- e' <- encodeM e- r' <- encodeM r- vol <- encodeM vol- (ss, mo) <- encodeM at- i <- liftIO $ FFI.buildCmpXchg builder a' e' r' vol mo ss s- return' i- A.AtomicRMW {- A.volatile = vol,- A.rmwOperation = rmwOp,- A.address = a,- A.value = v,- A.atomicity = at- } -> do- a' <- encodeM a- v' <- encodeM v- rmwOp <- encodeM rmwOp- vol <- encodeM vol- (ss, mo) <- encodeM at- i <- liftIO $ FFI.buildAtomicRMW builder rmwOp a' v' vol mo ss s- return' i- o -> $(- let- fieldData :: String -> [Either TH.ExpQ TH.ExpQ]- fieldData s = case s of- "operand0" -> [Left [| encodeM $(TH.dyn s) |] ]- "operand1" -> [Left [| encodeM $(TH.dyn s) |] ]- "type'" -> [Left [| encodeM $(TH.dyn s) |] ]- "nsw" -> [Left [| encodeM $(TH.dyn s) |] ]- "nuw" -> [Left [| encodeM $(TH.dyn s) |] ]- "exact" -> [Left [| encodeM $(TH.dyn s) |] ]- "metadata" -> [Right [| return () |] ]- _ -> error $ "unhandled instruction field " ++ show s- in- TH.caseE [| o |] [- TH.match - (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])- (TH.normalB (TH.doE handlerBody))- []- |- (name, ID.InstructionDef { ID.instructionKind = k }) <- Map.toList ID.instructionDefs,- k `List.elem` [ID.Binary, ID.Cast],- let- TH.RecC fullName fields = findInstrFields name- (fieldNames, _, _) = unzip3 fields- cTorFields = [- (s, binding)- | f <- fieldNames,- let s = TH.nameBase f,- Left binding <- fieldData s- ]- handlerBody = (- [ TH.bindS (TH.varP (TH.mkName s)) binding | (s, binding) <- cTorFields ]- ++ [- TH.bindS - (TH.varP (TH.mkName "i"))- [| liftIO $ $(foldl1 TH.appE . map TH.dyn $ [ - "FFI.build" ++ name,- "builder"- ] ++ [- s | (s, _) <- cTorFields, s /= "metadata"- ] ++ [- "s"- ] ) |]-- ] ++ [- TH.noBindS action- | f <- fieldNames,- let s = TH.nameBase f,- Right action <- fieldData s- ] ++ [- TH.noBindS [| return' $(TH.dyn "i") |]- ]- )- ]- )+ (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.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 $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs))+ liftIO $ FFI.setCallSiteAttributeSet i attrs + tck <- encodeM tck+ liftIO $ FFI.setTailCallKind i tck+ cc <- encodeM cc+ liftIO $ FFI.setCallSiteCallingConvention i cc+ return' i+ 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.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+ mask' <- encodeM mask+ i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' 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.personalityFunction = pf,+ A.cleanup = cl, + A.clauses = cs+ } -> do+ t' <- encodeM t+ pf' <- encodeM pf+ i <- liftIO $ FFI.buildLandingPad builder t' pf' (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 $ throwError $ "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 $ throwError $ "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+ o -> $(TH.caseE [| o |] [+ TH.match + (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])+ (TH.normalB (TH.doE handlerBody))+ []+ |+ (name, ID.instructionKind -> k) <- Map.toList ID.instructionDefs,+ case (k, name) of+ (ID.Binary, _) -> True+ (ID.Cast, _) -> True+ (ID.Memory, "Alloca") -> False+ (ID.Memory, _) -> True+ _ -> False,+ let+ TH.RecC fullName (unzip3 -> (fieldNames, _, _)) = findInstrFields name+ encodeMFields = map TH.nameBase fieldNames List.\\ [ "metadata" ]+ 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") |]+ ])+ ]+ ) - |]- ) setMD inst (A.metadata o) return (inst, act) |]
src/LLVM/General/Internal/InstructionDefs.hs view
@@ -12,6 +12,8 @@ outerJoin ) where +import LLVM.General.Prelude+ import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH
src/LLVM/General/Internal/LibraryFunction.hsc view
@@ -3,6 +3,8 @@ #-} module LLVM.General.Internal.LibraryFunction where +import LLVM.General.Prelude+ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.Coding
src/LLVM/General/Internal/MemoryBuffer.hs view
@@ -4,16 +4,18 @@ #-} module LLVM.General.Internal.MemoryBuffer where +import LLVM.General.Prelude+ import Control.Exception-import Control.Monad+import Control.Monad.Exceptable import Control.Monad.AnyCont-import Control.Monad.IO.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Foreign.Ptr import LLVM.General.Internal.Coding import LLVM.General.Internal.String+import LLVM.General.Internal.Inject import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.MemoryBuffer as FFI @@ -21,7 +23,7 @@ = Bytes { name :: String, content :: BS.ByteString } | File { pathName :: String } -instance (Monad e, MonadIO e, MonadAnyCont IO e) => EncodeM e Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where+instance (Inject String e, MonadError e m, Monad 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@@ -34,10 +36,12 @@ mbPtr <- alloca msgPtr <- alloca result <- decodeM =<< (liftIO $ FFI.createMemoryBufferWithContentsOfFile pathName mbPtr msgPtr)- when result $ fail =<< decodeM msgPtr+ when result $ do+ msg <- decodeM msgPtr+ throwError (inject (msg :: String)) peek mbPtr -instance (Monad e, MonadIO e, MonadAnyCont IO e) => EncodeM e Specification (Ptr FFI.MemoryBuffer) where+instance (Inject String e, MonadError e m, Monad 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
src/LLVM/General/Internal/Metadata.hs view
@@ -3,7 +3,9 @@ #-} module LLVM.General.Internal.Metadata where -import Control.Monad.State+import LLVM.General.Prelude++import Control.Monad.State hiding (mapM, forM) import Control.Monad.AnyCont import Foreign.Ptr
src/LLVM/General/Internal/Module.hs view
@@ -7,17 +7,20 @@ -- | This Haskell module is for/of functions for handling LLVM modules. module LLVM.General.Internal.Module where +import LLVM.General.Prelude+ import Control.Monad.Trans-import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Trans.Except (runExcept)+import Control.Monad.State (gets)+import Control.Monad.Exceptable import Control.Monad.AnyCont-import Control.Applicative import Control.Exception import Foreign.Ptr import Foreign.C import Data.IORef import qualified Data.ByteString as BS+import qualified Data.Map as Map import qualified LLVM.General.Internal.FFI.Assembly as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI@@ -36,7 +39,8 @@ import qualified LLVM.General.Internal.FFI.Target as FFI import qualified LLVM.General.Internal.FFI.Value as FFI -import LLVM.General.Internal.BasicBlock+import LLVM.General.Internal.Attribute+import LLVM.General.Internal.BasicBlock import LLVM.General.Internal.Coding import LLVM.General.Internal.Context import LLVM.General.Internal.DecodeAST@@ -44,8 +48,9 @@ import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Function import LLVM.General.Internal.Global+import LLVM.General.Internal.Inject import LLVM.General.Internal.Instruction ()-import qualified LLVM.General.Internal.MemoryBuffer as MB +import qualified LLVM.General.Internal.MemoryBuffer as MB import LLVM.General.Internal.Metadata import LLVM.General.Internal.Operand import LLVM.General.Internal.RawOStream@@ -69,8 +74,8 @@ newtype File = File FilePath deriving (Eq, Ord, Read, Show) -instance Error (Either String Diagnostic) where- strMsg = Left+instance Inject String (Either String Diagnostic) where+ inject = Left genCodingInstance [t| Bool |] ''FFI.LinkerMode [ (FFI.linkerModeDestroySource, False),@@ -81,19 +86,20 @@ -- 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).-linkModules :: +linkModules :: Bool -- ^ True to leave the right module unmodified, False to cannibalize it (for efficiency's sake). -> Module -- ^ The module into which to link -> Module -- ^ The module to link into the other (and cannibalize or not)- -> ErrorT String IO ()-linkModules preserveRight (Module m) (Module m') = flip runAnyContT return $ do+ -> ExceptT String IO ()+linkModules preserveRight (Module m) (Module m') = unExceptableT $ flip runAnyContT return $ do preserveRight <- encodeM preserveRight msgPtr <- alloca result <- decodeM =<< (liftIO $ FFI.linkModules m m' preserveRight msgPtr)- when result $ fail =<< decodeM msgPtr+ when result $ throwError =<< decodeM msgPtr class LLVMAssemblyInput s where- llvmAssemblyMemoryBuffer :: (MonadIO e, MonadAnyCont IO e) => s -> e (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer))+ llvmAssemblyMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)+ => s -> m (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) instance LLVMAssemblyInput (String, String) where llvmAssemblyMemoryBuffer (id, s) = do@@ -107,8 +113,9 @@ llvmAssemblyMemoryBuffer (File p) = encodeM (MB.File p) -- | parse 'Module' from LLVM assembly-withModuleFromLLVMAssembly :: LLVMAssemblyInput s => Context -> s -> (Module -> IO a) -> ErrorT (Either String Diagnostic) IO a-withModuleFromLLVMAssembly (Context c) s f = flip runAnyContT return $ do+withModuleFromLLVMAssembly :: LLVMAssemblyInput s+ => Context -> s -> (Module -> IO a) -> ExceptT (Either String Diagnostic) IO a+withModuleFromLLVMAssembly (Context c) s f = unExceptableT $ flip runAnyContT return $ do mb <- llvmAssemblyMemoryBuffer s smDiag <- anyContToM withSMDiagnostic m <- anyContToM $ bracket (FFI.parseLLVMAssembly c mb smDiag) FFI.disposeModule@@ -128,12 +135,13 @@ return s -- | write LLVM assembly for a 'Module' to a file-writeLLVMAssemblyToFile :: File -> Module -> ErrorT String IO ()-writeLLVMAssemblyToFile (File path) (Module m) = flip runAnyContT return $ do- withFileRawOStream path False False $ liftIO . FFI.writeLLVMAssembly m+writeLLVMAssemblyToFile :: File -> Module -> ExceptT String IO ()+writeLLVMAssemblyToFile (File path) (Module m) = unExceptableT $ flip runAnyContT return $ do+ withFileRawOStream path False True $ liftIO . FFI.writeLLVMAssembly m class BitcodeInput b where- bitcodeMemoryBuffer :: (MonadIO e, MonadAnyCont IO e) => b -> e (Ptr FFI.MemoryBuffer)+ bitcodeMemoryBuffer :: (Inject String e, MonadError e 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)@@ -142,51 +150,53 @@ bitcodeMemoryBuffer (File p) = encodeM (MB.File p) -- | parse 'Module' from LLVM bitcode-withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ErrorT String IO a-withModuleFromBitcode (Context c) b f = flip runAnyContT return $ do+withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ExceptT String IO a+withModuleFromBitcode (Context c) b f = unExceptableT $ flip runAnyContT return $ do mb <- bitcodeMemoryBuffer b msgPtr <- alloca m <- anyContToM $ bracket (FFI.parseBitcode c mb msgPtr) FFI.disposeModule- when (m == nullPtr) $ fail =<< decodeM msgPtr+ when (m == nullPtr) $ throwError =<< decodeM msgPtr liftIO $ f (Module m) -- | generate LLVM bitcode from a 'Module' moduleBitcode :: Module -> IO BS.ByteString-moduleBitcode (Module m) = withBufferRawOStream (liftIO . FFI.writeBitcode m)+moduleBitcode (Module m) = do+ r <- runExceptableT $ withBufferRawOStream (liftIO . FFI.writeBitcode m)+ either fail return r -- | write LLVM bitcode from a 'Module' into a file-writeBitcodeToFile :: File -> Module -> ErrorT String IO ()-writeBitcodeToFile (File path) (Module m) = flip runAnyContT return $ do- withFileRawOStream path False True $ liftIO . FFI.writeBitcode m+writeBitcodeToFile :: File -> Module -> ExceptT String IO ()+writeBitcodeToFile (File path) (Module m) = unExceptableT $ flip runAnyContT return $ do+ withFileRawOStream path False False $ liftIO . FFI.writeBitcode m -targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ErrorT String IO ()-targetMachineEmit fileType (TargetMachine tm) (Module m) os = flip runAnyContT return $ do+targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ExceptT String IO ()+targetMachineEmit fileType (TargetMachine tm) (Module m) os = unExceptableT $ flip runAnyContT return $ do msgPtr <- alloca r <- decodeM =<< (liftIO $ FFI.targetMachineEmit tm m fileType msgPtr os)- when r $ fail =<< decodeM msgPtr+ when r $ throwError =<< decodeM msgPtr -emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ErrorT String IO ()-emitToFile fileType tm (File path) m = flip runAnyContT return $ do- withFileRawOStream path False True $ targetMachineEmit fileType tm m+emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ExceptT String IO ()+emitToFile fileType tm (File path) m = unExceptableT$ flip runAnyContT return $ do+ withFileRawOStream path False False $ targetMachineEmit fileType tm m -emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ErrorT String IO BS.ByteString-emitToByteString fileType tm m = flip runAnyContT return $ do+emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ExceptT String IO BS.ByteString+emitToByteString fileType tm m = unExceptableT $ flip runAnyContT return $ do withBufferRawOStream $ targetMachineEmit fileType tm m -- | write target-specific assembly directly into a file-writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ErrorT String IO ()+writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ExceptT String IO () writeTargetAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly -- | produce target-specific assembly as a 'String'-moduleTargetAssembly :: TargetMachine -> Module -> ErrorT String IO String+moduleTargetAssembly :: TargetMachine -> Module -> ExceptT String IO String moduleTargetAssembly tm m = decodeM . UTF8ByteString =<< emitToByteString FFI.codeGenFileTypeAssembly tm m -- | produce target-specific object code as a 'ByteString'-moduleObject :: TargetMachine -> Module -> ErrorT String IO BS.ByteString+moduleObject :: TargetMachine -> Module -> ExceptT String IO BS.ByteString moduleObject = emitToByteString FFI.codeGenFileTypeObject -- | write target-specific object code directly into a file-writeObjectToFile :: TargetMachine -> File -> Module -> ErrorT String IO ()+writeObjectToFile :: TargetMachine -> File -> Module -> ExceptT String IO () writeObjectToFile = emitToFile FFI.codeGenFileTypeObject setTargetTriple :: Ptr FFI.Module -> String -> EncodeAST ()@@ -205,13 +215,13 @@ liftIO $ FFI.setDataLayout m s getDataLayout :: Ptr FFI.Module -> IO (Maybe A.DataLayout)-getDataLayout m = parseDataLayout <$> (decodeM =<< FFI.getDataLayout m)--type P a = a -> a+getDataLayout m = do+ dlString <- decodeM =<< FFI.getDataLayout m+ either fail return . runExcept . parseDataLayout A.BigEndian $ dlString -- | Build an LLVM.General.'Module' from a LLVM.General.AST.'LLVM.General.AST.Module' - i.e. -- lower an AST from Haskell into C++ objects.-withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> ErrorT String IO a+withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> ExceptT String IO a withModuleFromAST context@(Context c) (A.Module moduleId dataLayout triple definitions) f = runEncodeAST context $ do moduleId <- encodeM moduleId m <- anyContToM $ bracket (FFI.moduleCreateWithNameInContext moduleId c) FFI.disposeModule@@ -226,8 +236,16 @@ defineType n t' return $ do maybe (return ()) (setNamedType t') t- return . return . return $ return ()+ return . return . return . return $ () + A.COMDAT n csk -> do+ n' <- encodeM n+ csk <- encodeM csk+ cd <- liftIO $ FFI.getOrInsertCOMDAT m n'+ liftIO $ FFI.setCOMDATSelectionKind cd csk+ defineCOMDAT n cd+ return . return . return . return . return $ ()+ A.MetadataNodeDefinition i os -> return . return $ do t <- liftIO $ FFI.createTemporaryMDNodeInContext c defineMDNode i t@@ -248,19 +266,23 @@ A.ModuleInlineAssembly s -> do s <- encodeM s liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s)- return . return . return . return $ return ()+ 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 m typ gName + g' <- liftIO $ withName n $ \gName ->+ FFI.addGlobalInAddressSpace m typ gName (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g)) defineGlobal n g'+ setThreadLocalMode g' (A.G.threadLocalMode g) liftIO $ do- tl <- encodeM (A.G.isThreadLocal g)- FFI.setThreadLocal g' tl hua <- encodeM (A.G.hasUnnamedAddr g) FFI.setUnnamedAddr (FFI.upCast g') hua ic <- encodeM (A.G.isConstant g)@@ -268,25 +290,32 @@ return $ do maybe (return ()) ((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) return (FFI.upCast g') (a@A.G.GlobalAlias { A.G.name = n }) -> do- typ <- encodeM (A.G.type' a)- a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ name+ let A.PointerType typ as = A.G.type' a+ typ <- encodeM typ+ as <- encodeM as+ a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ as name defineGlobal n a'+ liftIO $ do+ hua <- encodeM (A.G.hasUnnamedAddr 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 blocks) -> do- typ <- encodeM $ A.FunctionType resultType (map (\(A.Parameter t _ _) -> t) args) isVarArgs+ (A.Function _ _ _ cc rAttrs resultType fName (args, isVarArgs) attrs _ _ _ gc prefix blocks) -> do+ typ <- encodeM $ A.FunctionType resultType [t | A.Parameter t _ _ <- args] isVarArgs f <- liftIO . withName fName $ \fName -> FFI.addFunction m fName typ defineGlobal fName f cc <- encodeM cc- liftIO $ FFI.setFunctionCallConv f cc- rAttrs <- encodeM rAttrs- liftIO $ FFI.addFunctionRetAttr f rAttrs- liftIO $ setFunctionAttrs f attrs+ liftIO $ FFI.setFunctionCallingConvention f cc+ setFunctionAttributes f (MixedAttributeSet attrs rAttrs (Map.fromList $ zip [0..] [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 forM blocks $ \(A.BasicBlock bName _ _) -> do@@ -297,15 +326,10 @@ ps <- allocaArray nParams liftIO $ FFI.getParams f ps params <- peekArray nParams ps- forM (zip args params) $ \(A.Parameter _ n attrs, p) -> do+ forM (zip args params) $ \(A.Parameter _ n _, p) -> do defineLocal n p n <- encodeM n liftIO $ FFI.setValueName (FFI.upCast p) n- unless (null attrs) $- do attrs <- encodeM attrs- liftIO $ FFI.addAttribute p attrs- return ()- return () finishInstrs <- forM blocks $ \(A.BasicBlock bName namedInstrs term) -> do b <- encodeM bName (do@@ -315,14 +339,17 @@ (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 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 () - liftIO $ f (Module m) + liftIO $ f (Module m) -- | Get an LLVM.General.AST.'LLVM.General.AST.Module' from a LLVM.General.'Module' - i.e. -- raise C++ objects into an Haskell AST.@@ -330,7 +357,7 @@ moduleAST (Module mod) = runDecodeAST $ do c <- return Context `ap` liftIO (FFI.getModuleContext mod) getMetadataKindNames c- return A.Module + return A.Module `ap` (liftIO $ decodeM =<< FFI.getModuleIdentifier mod) `ap` (liftIO $ getDataLayout mod) `ap` (liftIO $ do@@ -348,7 +375,8 @@ `ap` return n `ap` getLinkage g `ap` getVisibility g- `ap` (liftIO $ decodeM =<< FFI.isThreadLocal g)+ `ap` getDLLStorageClass g+ `ap` getThreadLocalMode g `ap` return as `ap` (liftIO $ decodeM =<< FFI.hasUnnamedAddr (FFI.upCast g)) `ap` (liftIO $ decodeM =<< FFI.isGlobalConstant g)@@ -357,6 +385,7 @@ i <- liftIO $ FFI.getInitializer g if i == nullPtr then return Nothing else Just <$> decodeM i) `ap` getSection g+ `ap` getCOMDATName g `ap` getAlignment g, do@@ -367,6 +396,9 @@ `ap` return n `ap` getLinkage a `ap` getVisibility a+ `ap` getDLLStorageClass a+ `ap` getThreadLocalMode a+ `ap` (liftIO $ decodeM =<< FFI.hasUnnamedAddr (FFI.upCast a)) `ap` typeOf a `ap` (decodeM =<< (liftIO $ FFI.getAliasee a)), @@ -375,7 +407,8 @@ liftM sequence . forM ffiFunctions $ \f -> localScope $ do A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f n <- getGlobalName f- parameters <- getParameters f+ MixedAttributeSet fAttrs rAttrs pAttrs <- getMixedAttributeSet f+ parameters <- getParameters f pAttrs decodeBlocks <- do ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock liftM sequence . forM ffiBasicBlocks $ \b -> do@@ -386,15 +419,18 @@ return $ return A.Function `ap` getLinkage f `ap` getVisibility f- `ap` (liftIO $ decodeM =<< FFI.getFunctionCallConv f)- `ap` (liftIO $ decodeM =<< FFI.getFunctionRetAttr f)+ `ap` getDLLStorageClass f+ `ap` (liftIO $ decodeM =<< FFI.getFunctionCallingConvention f)+ `ap` return rAttrs `ap` return returnType `ap` return n `ap` return (parameters, isVarArg)- `ap` (liftIO $ getFunctionAttrs f)+ `ap` return fAttrs `ap` getSection f+ `ap` getCOMDATName f `ap` getAlignment f `ap` getGC f+ `ap` getPrefixData f `ap` decodeBlocks ] @@ -411,8 +447,14 @@ return A.NamedMetadataDefinition `ap` (decodeM $ FFI.getNamedMetadataName nm) `ap` liftM (map (\(A.MetadataNodeReference mid) -> mid)) (decodeM (n, os))- + mds <- getMetadataDefinitions - return $ tds ++ ias ++ gs ++ nmds ++ mds+ ags <- do+ ags <- gets $ Map.toList . functionAttributeSetIDs+ forM ags $ \(as, gid) -> return A.FunctionAttributes `ap` return gid `ap` decodeM as++ cds <- gets $ map (uncurry A.COMDAT) . Map.elems . comdats++ return $ tds ++ ias ++ gs ++ nmds ++ mds ++ ags ++ cds )
src/LLVM/General/Internal/Operand.hs view
@@ -3,9 +3,11 @@ #-} module LLVM.General.Internal.Operand where -import Data.Functor+import LLVM.General.Prelude+ import Control.Monad.State import Control.Monad.AnyCont+import qualified Data.Map as Map import Foreign.Ptr @@ -13,6 +15,7 @@ import qualified LLVM.General.Internal.FFI.InlineAssembly as FFI import qualified LLVM.General.Internal.FFI.Metadata as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Value as FFI import LLVM.General.Internal.Coding import LLVM.General.Internal.Constant ()@@ -41,7 +44,9 @@ if mdn /= nullPtr then return A.MetadataNodeOperand `ap` decodeM mdn else- return A.LocalReference `ap` getLocalName v+ return A.LocalReference + `ap` (decodeM =<< (liftIO $ FFI.typeOf v))+ `ap` getLocalName v instance DecodeM DecodeAST A.CallableOperand (Ptr FFI.Value) where decodeM v = do@@ -52,7 +57,17 @@ instance EncodeM EncodeAST A.Operand (Ptr FFI.Value) where encodeM (A.ConstantOperand c) = (FFI.upCast :: Ptr FFI.Constant -> Ptr FFI.Value) <$> encodeM c- encodeM (A.LocalReference n) = referLocal n+ 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.MetadataStringOperand s) = do Context c <- gets encodeStateContext s <- encodeM s
src/LLVM/General/Internal/PassManager.hs view
@@ -4,17 +4,15 @@ #-} module LLVM.General.Internal.PassManager where +import LLVM.General.Prelude+ import qualified Language.Haskell.TH as TH import Control.Exception-import Control.Monad hiding (forM_) import Control.Monad.IO.Class-import Control.Applicative import Control.Monad.AnyCont -import Data.Word-import Data.Foldable (forM_) import Foreign.C (CString) import Foreign.Ptr @@ -54,8 +52,12 @@ sizeLevel :: Maybe Word, unitAtATime :: Maybe Bool, simplifyLibCalls :: Maybe Bool,+ loopVectorize :: Maybe Bool,+ superwordLevelParallelismVectorize :: Maybe Bool, useInlinerWithThreshold :: Maybe Word,- curatedTargetLibraryInfo :: Maybe TargetLibraryInfo+ dataLayout :: Maybe DataLayout,+ targetLibraryInfo :: Maybe TargetLibraryInfo,+ targetMachine :: Maybe TargetMachine } -- | Helper to make a curated 'PassSetSpec'@@ -64,8 +66,12 @@ sizeLevel = Nothing, unitAtATime = Nothing, simplifyLibCalls = Nothing,+ loopVectorize = Nothing,+ superwordLevelParallelismVectorize = Nothing, useInlinerWithThreshold = Nothing,- curatedTargetLibraryInfo = Nothing+ dataLayout = Nothing,+ targetLibraryInfo = Nothing,+ targetMachine = Nothing } -- | an empty 'PassSetSpec'@@ -82,6 +88,10 @@ createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager) createPassManager pss = flip runAnyContT return $ do pm <- liftIO $ FFI.createPassManager+ forM_ (dataLayout pss) $ \dl -> liftIO $ withFFIDataLayout dl $ FFI.addDataLayoutPass pm + 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@@ -91,16 +101,11 @@ handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime) handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls) handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold- case (curatedTargetLibraryInfo s) of- (Just (TargetLibraryInfo tl)) -> FFI.passManagerBuilderSetLibraryInfo b tl- Nothing -> return ()+ handleOption FFI.passManagerBuilderSetLoopVectorize loopVectorize+ handleOption FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize superwordLevelParallelismVectorize FFI.passManagerBuilderPopulateModulePassManager b pm PassSetSpec ps dl tli tm' -> do let tm = maybe nullPtr (\(TargetMachine tm) -> tm) tm'- forM_ tli $ \(TargetLibraryInfo tli) -> do- liftIO $ FFI.addTargetLibraryInfoPass pm tli- forM_ dl $ \dl -> liftIO $ withFFIDataLayout dl $ FFI.addDataLayoutPass pm - forM_ tm' $ \(TargetMachine tm) -> liftIO $ FFI.addAnalysisPasses tm pm forM_ ps $ \p -> $( do TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass
src/LLVM/General/Internal/RawOStream.hs view
@@ -1,7 +1,8 @@ module LLVM.General.Internal.RawOStream where -import Control.Monad-import Control.Monad.Error+import LLVM.General.Prelude++import Control.Monad.Exceptable import Control.Monad.AnyCont import Data.IORef@@ -11,36 +12,34 @@ import qualified LLVM.General.Internal.FFI.RawOStream as FFI import LLVM.General.Internal.Coding+import LLVM.General.Internal.Inject import LLVM.General.Internal.String () -withFileRawOStream :: - (MonadAnyCont IO m, MonadIO m) +withFileRawOStream ::+ (Inject String e, MonadError e m, MonadAnyCont IO m, MonadIO m) => String -> Bool -> Bool- -> (Ptr FFI.RawOStream -> ErrorT String IO ())+ -> (Ptr FFI.RawOStream -> ExceptT String IO ()) -> m ()-withFileRawOStream path excl binary c = do+withFileRawOStream path excl text c = do path <- encodeM path excl <- encodeM excl- binary <- encodeM binary- outputRef <- liftIO $ newIORef Nothing+ text <- encodeM text msgPtr <- alloca errorRef <- liftIO $ newIORef undefined- failed <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl binary msgPtr $ \os -> do- r <- runErrorT (c os)- writeIORef errorRef r)- when failed $ fail =<< decodeM msgPtr+ succeeded <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl text msgPtr $ \os -> do+ r <- runExceptableT (ExceptableT $ c os)+ writeIORef errorRef r)+ unless succeeded $ do+ s <- decodeM msgPtr+ throwError $ inject (s :: String) e <- liftIO $ readIORef errorRef- case e of- Left e -> fail e- _ -> do- Just r <- liftIO $ readIORef outputRef- return r+ either (throwError . inject) return e -withBufferRawOStream :: - (MonadIO m, DecodeM IO a (Ptr CChar, CSize))- => (Ptr FFI.RawOStream -> ErrorT String IO ())+withBufferRawOStream ::+ (Inject String e, MonadError e m, MonadIO m, DecodeM IO a (Ptr CChar, CSize))+ => (Ptr FFI.RawOStream -> ExceptT String IO ()) -> m a withBufferRawOStream c = do resultRef <- liftIO $ newIORef Nothing@@ -50,12 +49,12 @@ r <- decodeM (start, size) writeIORef resultRef (Just r) saveError os = do- r <- runErrorT (c os)+ r <- runExceptableT (ExceptableT $ c os) writeIORef errorRef r liftIO $ FFI.withBufferRawOStream saveBuffer saveError e <- liftIO $ readIORef errorRef case e of- Left e -> fail e+ Left e -> throwError $ inject e _ -> do Just r <- liftIO $ readIORef resultRef return r
src/LLVM/General/Internal/String.hs view
@@ -4,8 +4,9 @@ #-} module LLVM.General.Internal.String where +import LLVM.General.Prelude+ import Control.Arrow-import Control.Monad import Control.Monad.AnyCont import Control.Monad.IO.Class import Control.Exception (finally)
+ src/LLVM/General/Internal/TailCallKind.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE+ TemplateHaskell,+ MultiParamTypeClasses+ #-}+module LLVM.General.Internal.TailCallKind where++import LLVM.General.Prelude++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++import LLVM.General.Internal.Coding+import qualified LLVM.General.AST as A++genCodingInstance [t| Maybe A.TailCallKind |] ''FFI.TailCallKind [+ (FFI.tailCallKindNone, Nothing),+ (FFI.tailCallKindTail, Just A.Tail),+ (FFI.tailCallKindMustTail, Just A.MustTail)+ ]
src/LLVM/General/Internal/Target.hs view
@@ -6,19 +6,20 @@ #-} module LLVM.General.Internal.Target where -import Control.Monad hiding (forM)-import Control.Monad.Error hiding (forM)+import LLVM.General.Prelude++import Control.Monad.Trans.Except (runExcept)+import Control.Monad.Exceptable import Control.Exception-import Data.Functor-import Data.Traversable (forM) import Control.Monad.AnyCont-import Data.Maybe import Foreign.Ptr import Data.List (intercalate)-import Data.Set (Set)-import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map +import Text.ParserCombinators.Parsec hiding (many)+ import LLVM.General.Internal.Coding import LLVM.General.Internal.String () import LLVM.General.Internal.LibraryFunction@@ -76,26 +77,35 @@ newtype CPUFeature = CPUFeature String deriving (Eq, Ord, Read, Show) -instance EncodeM e String es => EncodeM e (Set CPUFeature) es where- encodeM = encodeM . intercalate " " . map (\(CPUFeature f) -> f) . Set.toList--instance (Monad d, DecodeM d String es) => DecodeM d (Set CPUFeature) es where- decodeM = liftM (Set.fromList . map CPUFeature . words) . decodeM+instance EncodeM e String es => EncodeM e (Map CPUFeature Bool) es where+ encodeM = encodeM . intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") ++ f) . Map.toList +instance (Monad d, DecodeM d String es) => DecodeM d (Map CPUFeature Bool) es where+ decodeM es = do+ s <- decodeM es+ let flag = do+ en <- choice [char '-' >> return False, char '+' >> return True]+ s <- many1 (noneOf ",")+ return (CPUFeature s, en)+ features = liftM Map.fromList (flag `sepBy` (char ','))+ case parse (do f <- features; eof; return f) "CPU Feature string" (s :: String) of+ Right features -> return features+ Left _ -> fail "failure to parse CPUFeature string"+ -- | Find a 'Target' given an architecture and/or a \"triple\". -- | <http://llvm.org/doxygen/structllvm_1_1TargetRegistry.html#a3105b45e546c9cc3cf78d0f2ec18ad89> -- | Be sure to run either 'initializeAllTargets' or 'initializeNativeTarget' before expecting this to succeed, depending on what target(s) you want to use.-lookupTarget :: +lookupTarget :: Maybe String -- ^ arch -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu- -> ErrorT String IO (Target, String)-lookupTarget arch triple = flip runAnyContT return $ do+ -> ExceptT String IO (Target, String)+lookupTarget arch triple = unExceptableT $ flip 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) $ fail =<< decodeM cErrorP+ when (target == nullPtr) $ throwError =<< decodeM cErrorP liftM (Target target, ) $ decodeM cNewTripleP -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>@@ -124,8 +134,10 @@ (FFI.targetOptionFlagDisableTailCalls, TO.disableTailCalls), (FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection), (FFI.targetOptionFlagPositionIndependentExecutable, TO.positionIndependentExecutable),- (FFI.targetOptionFlagEnableSegmentedStacks, TO.enableSegmentedStacks),- (FFI.targetOptionFlagUseInitArray, TO.useInitArray)+ (FFI.targetOptionFlagUseInitArray, TO.useInitArray),+ (FFI.targetOptionFlagDisableIntegratedAS, TO.disableIntegratedAssembler),+ (FFI.targetOptionFlagCompressDebugSections, TO.compressDebugSections),+ (FFI.targetOptionFlagTrapUnreachable, TO.trapUnreachable) ] FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts) flip runAnyContT return $ do@@ -133,11 +145,11 @@ liftIO $ FFI.setTrapFuncName cOpts n FFI.setFloatABIType cOpts =<< encodeM (TO.floatABIType hOpts) FFI.setAllowFPOpFusion cOpts =<< encodeM (TO.allowFloatingPointOperationFusion hOpts)- + -- | get all target options peekTargetOptions :: TargetOptions -> IO TO.Options peekTargetOptions (TargetOptions tOpts) = do- let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts + let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts printMachineCode <- gof FFI.targetOptionFlagPrintMachineCode noFramePointerElimination@@ -168,10 +180,14 @@ <- gof FFI.targetOptionFlagEnableFastISel positionIndependentExecutable <- gof FFI.targetOptionFlagPositionIndependentExecutable- enableSegmentedStacks- <- gof FFI.targetOptionFlagEnableSegmentedStacks useInitArray <- gof FFI.targetOptionFlagUseInitArray+ disableIntegratedAssembler+ <- gof FFI.targetOptionFlagDisableIntegratedAS+ compressDebugSections+ <- gof FFI.targetOptionFlagCompressDebugSections+ trapUnreachable+ <- gof FFI.targetOptionFlagTrapUnreachable stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts trapFunctionName <- decodeM =<< FFI.getTrapFuncName tOpts floatABIType <- decodeM =<< FFI.getFloatABIType tOpts@@ -182,11 +198,11 @@ newtype TargetMachine = TargetMachine (Ptr FFI.TargetMachine) -- | bracket creation and destruction of a 'TargetMachine'-withTargetMachine :: +withTargetMachine :: Target -> String -- ^ triple -> String -- ^ cpu- -> Set CPUFeature -- ^ features+ -> Map CPUFeature Bool -- ^ features -> TargetOptions -> Reloc.Model -> CodeModel.Model@@ -247,26 +263,28 @@ -- | the LLVM name for the host CPU getHostCPUName :: IO String-getHostCPUName = decodeM =<< FFI.getHostCPUName+getHostCPUName = decodeM FFI.getHostCPUName -- | a space-separated list of LLVM feature names supported by the host CPU-getHostCPUFeatures :: IO (Set CPUFeature)+getHostCPUFeatures :: IO (Map CPUFeature Bool) getHostCPUFeatures = decodeM =<< FFI.getHostCPUFeatures- + -- | 'DataLayout' to use for the given 'TargetMachine' getTargetMachineDataLayout :: TargetMachine -> IO DataLayout-getTargetMachineDataLayout (TargetMachine m) =- fromMaybe (error "parseDataLayout failed") . parseDataLayout <$> (decodeM =<< (FFI.getTargetMachineDataLayout m))+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-withDefaultTargetMachine :: (TargetMachine -> IO a) -> ErrorT String IO a-withDefaultTargetMachine f = do+withHostTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a+withHostTargetMachine f = do liftIO $ initializeAllTargets- triple <- liftIO $ getDefaultTargetTriple+ triple <- liftIO $ getProcessTargetTriple cpu <- liftIO $ getHostCPUName features <- liftIO $ getHostCPUFeatures (target, _) <- lookupTarget Nothing triple@@ -302,7 +320,7 @@ liftIO $ FFI.libFuncSetAvailableWithName f libraryFunction name -- | look up information about the library functions available on a given platform-withTargetLibraryInfo :: +withTargetLibraryInfo :: String -- ^ triple -> (TargetLibraryInfo -> IO a) -> IO a
+ src/LLVM/General/Internal/Threading.hs view
@@ -0,0 +1,13 @@+module LLVM.General.Internal.Threading (+ isMultithreaded+ ) where++import LLVM.General.Prelude++import qualified LLVM.General.Internal.FFI.Threading as FFI++import LLVM.General.Internal.Coding++-- | Check if multithreading is enabled in LLVM+isMultithreaded :: IO Bool+isMultithreaded = FFI.isMultithreaded >>= decodeM
src/LLVM/General/Internal/Type.hs view
@@ -4,9 +4,11 @@ #-} module LLVM.General.Internal.Type where -import Control.Applicative+import LLVM.General.Prelude+ import Control.Monad.State import Control.Monad.AnyCont+import Control.Monad.Exceptable import qualified Data.Set as Set @@ -27,7 +29,7 @@ getStructure :: Ptr FFI.Type -> DecodeAST A.Type getStructure t = scopeAnyCont $ do- return A.StructureType + return A.StructureType `ap` (decodeM =<< liftIO (FFI.isPackedStruct t)) `ap` do n <- liftIO (FFI.countStructElementTypes t)@@ -55,7 +57,7 @@ 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 @@ -85,7 +87,7 @@ A.FloatingPointType 80 A.DoubleExtended -> liftIO $ FFI.x86FP80TypeInContext context A.FloatingPointType 128 A.IEEE -> liftIO $ FFI.fP128TypeInContext context A.FloatingPointType 128 A.PairOfFloats -> liftIO $ FFI.ppcFP128TypeInContext context- A.FloatingPointType _ _ -> fail $ "unsupported floating point type: " ++ show f+ A.FloatingPointType _ _ -> throwError $ "unsupported floating point type: " ++ show f A.VectorType sz e -> do e <- encodeM e sz <- encodeM sz@@ -107,7 +109,7 @@ case k of [typeKindP|Void|] -> return A.VoidType [typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))- [typeKindP|Function|] -> + [typeKindP|Function|] -> return A.FunctionType `ap` (decodeM =<< liftIO (FFI.getReturnType t)) `ap` (do@@ -127,17 +129,17 @@ [typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE [typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended [typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats- [typeKindP|Vector|] -> + [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)) + ifM (decodeM =<< liftIO (FFI.structIsLiteral t)) (getStructure t) (saveNamedType t >> return A.NamedTypeReference `ap` getTypeName t)-- [typeKindP|Array|] -> + [typeKindP|Metadata|] -> return A.MetadataType+ [typeKindP|Array|] -> return A.ArrayType `ap` (decodeM =<< liftIO (FFI.getArrayLength t)) `ap` (decodeM =<< liftIO (FFI.getElementType t))@@ -148,13 +150,13 @@ Context c <- gets encodeStateContext n <- case n of { A.Name n -> encodeM n; _ -> return nullPtr } liftIO $ FFI.structCreateNamed c n- + 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 - - ++
src/LLVM/General/Internal/Value.hs view
@@ -3,6 +3,8 @@ #-} module LLVM.General.Internal.Value where +import LLVM.General.Prelude+ import Control.Monad.State import Foreign.Ptr
src/LLVM/General/Relocation.hs view
@@ -1,7 +1,7 @@ -- | Relocations, used in specifying TargetMachine module LLVM.General.Relocation where -import Data.Data+import LLVM.General.Prelude -- | <http://llvm.org/doxygen/namespacellvm_1_1Reloc.html> data Model
src/LLVM/General/Target.hs view
@@ -7,7 +7,7 @@ Target, TargetMachine, TargetLowering, CPUFeature(..), withTargetOptions, peekTargetOptions, pokeTargetOptions,- withTargetMachine, withDefaultTargetMachine,+ withTargetMachine, withHostTargetMachine, getTargetLowering, getDefaultTargetTriple, getProcessTargetTriple, getHostCPUName, getHostCPUFeatures, getTargetMachineDataLayout, initializeNativeTarget, initializeAllTargets,
src/LLVM/General/Target/Options.hs view
@@ -1,8 +1,7 @@ -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html> module LLVM.General.Target.Options where -import Data.Data-import Data.Word+import LLVM.General.Prelude -- | <http://llvm.org/doxygen/namespacellvm_1_1FloatABI.html#aea077c52d84934aabf9445cef9eab2e2> data FloatABI@@ -36,8 +35,10 @@ disableTailCalls :: Bool, enableFastInstructionSelection :: Bool, positionIndependentExecutable :: Bool,- enableSegmentedStacks :: Bool, useInitArray :: Bool,+ disableIntegratedAssembler :: Bool,+ compressDebugSections :: Bool,+ trapUnreachable :: Bool, stackAlignmentOverride :: Word32, trapFunctionName :: String, floatABIType :: FloatABI,
+ src/LLVM/General/Threading.hs view
@@ -0,0 +1,24 @@+-- | functionality necessary when running LLVM in multiple threads at the same time.+module LLVM.General.Threading (+ setMultithreaded,+ isMultithreaded+ ) where++import LLVM.General.Prelude++import LLVM.General.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 ()
src/LLVM/General/Transforms.hs view
@@ -4,8 +4,7 @@ -- instead using 'LLVM.General.PassManager.CuratedPassSetSpec'. module LLVM.General.Transforms where -import Data.Data-import Data.Word+import LLVM.General.Prelude -- | <http://llvm.org/docs/Passes.html#transform-passes> -- A few passes can make use of information in a 'LLVM.General.Target.TargetMachine' if one@@ -38,8 +37,7 @@ | LoopUnroll { loopUnrollThreshold :: Maybe Word, count :: Maybe Word, allowPartial :: Maybe Bool } | LoopUnswitch { optimizeForSize :: Bool } | LowerAtomic- -- | can use a 'LLVM.General.Target.TargetMachine'- | LowerInvoke { useExpensiveExceptionHandlingSupport :: Bool } + | LowerInvoke | LowerSwitch | LowerExpectIntrinsic | MemcpyOptimization@@ -104,7 +102,11 @@ noMemoryOperationBoost :: Bool, fastDependencyAnalysis :: Bool }- | LoopVectorize+ | LoopVectorize {+ noUnrolling :: Bool,+ alwaysVectorize :: Bool+ }+ | SuperwordLevelParallelismVectorize -- here begin the instrumentation passes | GCOVProfiler {@@ -115,25 +117,12 @@ noRedZone :: Bool, functionNamesInData :: Bool }- | AddressSanitizer {- checkInitOrder :: Bool,- checkUseAfterReturn :: Bool,- checkLifetime :: Bool,- blackListFile :: Maybe FilePath,- zeroBaseShadow :: Bool- }- | AddressSanitizerModule {- checkInitOrder :: Bool,- blackListFile :: Maybe FilePath,- zeroBaseShadow :: Bool- }+ | AddressSanitizer+ | AddressSanitizerModule | MemorySanitizer {- trackOrigins :: Bool,- blackListFile :: Maybe FilePath- }- | ThreadSanitizer {- blackListFile :: Maybe FilePath+ trackOrigins :: Bool }+ | ThreadSanitizer | BoundsChecking | DebugGeneratedIR { hideDebugIntrinsics :: Bool,@@ -144,6 +133,12 @@ | DebugExistingIR deriving (Eq, Ord, Read, Show, Typeable, Data) +-- | Defaults for the 'LoopVectorize' pass+defaultLoopVectorize = LoopVectorize {+ noUnrolling = False,+ alwaysVectorize = True+ }+ -- | Defaults for the 'BasicBlockVectorize' pass - copied from the C++ code to keep these defaults -- constant. (The C++ defaults are modifiable through global objects used for command-line processing, -- in a design apparently oblivious to uses of LLVM besides the standard command-line tools).@@ -188,31 +183,18 @@ } -- | Defaults for 'AddressSanitizer'.-defaultAddressSanitizer = AddressSanitizer {- checkInitOrder = True,- checkUseAfterReturn = False,- checkLifetime = False,- blackListFile = Nothing,- zeroBaseShadow = False-}+defaultAddressSanitizer = AddressSanitizer -- | Defaults for 'AddressSanitizerModule'.-defaultAddressSanitizerModule = AddressSanitizerModule {- checkInitOrder = True,- blackListFile = Nothing,- zeroBaseShadow = False-}+defaultAddressSanitizerModule = AddressSanitizerModule -- | Defaults for 'MemorySanitizer'. defaultMemorySanitizer = MemorySanitizer {- trackOrigins = False,- blackListFile = Nothing+ trackOrigins = False } -- | Defaults for 'ThreadSanitizer'.-defaultThreadSanitizer = ThreadSanitizer {- blackListFile = Nothing-}+defaultThreadSanitizer = ThreadSanitizer -- | Defaults for 'DebugGeneratedIR'. defaultDebugGeneratedIR = DebugGeneratedIR {
test/LLVM/General/Test/Analysis.hs view
@@ -6,14 +6,14 @@ import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Trans.Except import LLVM.General.Module import LLVM.General.Context import LLVM.General.Analysis import LLVM.General.AST as A-import LLVM.General.AST.Type+import LLVM.General.AST.Type as A.T import LLVM.General.AST.Name import LLVM.General.AST.AddrSpace import LLVM.General.AST.DataLayout@@ -35,18 +35,18 @@ -- this test will cause an assertion if LLVM is compiled with assertions on. testCase "Module" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([- Parameter (IntegerType 32) (Name "x") []+ GlobalDefinition $ Function L.External V.Default CC.C [] A.T.void (Name "foo") ([+ Parameter i32 (Name "x") [] ],False) [] - Nothing 0 + Nothing 0 Nothing [ BasicBlock (UnName 0) [ UnName 1 := Call { isTailCall = False, callingConvention = CC.C, returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+ function = Right (ConstantOperand (C.GlobalReference (A.T.FunctionType A.T.void [A.T.i32] False) (Name "foo"))), arguments = [ (ConstantOperand (C.Int 8 1), []) ],@@ -58,7 +58,7 @@ ) ] ]- Left s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify+ 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\@@ -79,34 +79,34 @@ ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = FloatingPointType 64 IEEE,+ G.returnType = double, G.name = Name "my_function2", G.parameters = ([- Parameter (PointerType (FloatingPointType 64 IEEE) (AddrSpace 0)) (Name "input_0") []+ Parameter (ptr double) (Name "input_0") [] ],False), G.basicBlocks = [ BasicBlock (Name "foo") [ Name "tmp_input_w0" := GetElementPtr { inBounds = True,- address = LocalReference (Name "input_0"),+ address = LocalReference (ptr double) (Name "input_0"), indices = [ConstantOperand (C.Int 64 0)], metadata = [] }, UnName 0 := Load { volatile = False,- address = LocalReference (Name "tmp_input_w0"),+ address = LocalReference (ptr double) (Name "tmp_input_w0"), maybeAtomicity = Nothing, alignment = 8, metadata = [] } ] (- Do $ Ret (Just (LocalReference (UnName 0))) []+ Do $ Ret (Just (LocalReference double (UnName 0))) [] ) ] } ] strCheck ast str- s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify+ s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify s @?= Right () ] ]
+ test/LLVM/General/Test/CallingConvention.hs view
@@ -0,0 +1,57 @@+module LLVM.General.Test.CallingConvention where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Map as Map++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.AST+import LLVM.General.AST.Type as T+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Global as G++tests = testGroup "CallingConvention" [+ testCase name $ strCheck (defaultModule {+ moduleDefinitions = [+ GlobalDefinition $ functionDefaults {+ G.returnType = i32,+ G.name = Name "foo",+ G.callingConvention = cc+ }+ ]+ }) ("; ModuleID = '<string>'\n\+ \\n\+ \declare" ++ (if name == "" then "" else (" " ++ name)) ++ " i32 @foo()\n")+ | (name, cc) <- [+ ("", CC.C),+ ("fastcc", CC.Fast),+ ("coldcc", CC.Cold),+ ("cc10", CC.GHC),+ ("cc11", CC.HiPE),+ ("webkit_jscc", CC.WebKit_JS),+ ("anyregcc", CC.AnyReg),+ ("preserve_mostcc", CC.PreserveMost),+ ("preserve_allcc", CC.PreserveAll),+ ("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),+ ("x86_64_win64cc", CC.X86_64_Win64)+ ]+ ]
test/LLVM/General/Test/Constants.hs view
@@ -33,7 +33,7 @@ | (name, type', value, str) <- [ ( "integer",- IntegerType 32,+ i32, C.Int 32 1, "global i32 1" ), (@@ -53,111 +53,116 @@ "global i65 -1" ), ( "half",- FloatingPointType 16 IEEE,+ half, C.Float (F.Half 0x1234), "global half 0xH1234" ), ( "float",- FloatingPointType 32 IEEE,+ float, C.Float (F.Single 1), "global float 1.000000e+00" ), ( "double",- FloatingPointType 64 IEEE,+ double, C.Float (F.Double 1), "global double 1.000000e+00" ), ( "quad",- FloatingPointType 128 IEEE,+ fp128, C.Float (F.Quadruple 0x0007000600050004 0x0003000200010000), "global fp128 0xL00030002000100000007000600050004" -- yes, this order is weird ), ( "quad 1.0",- FloatingPointType 128 IEEE,+ fp128, C.Float (F.Quadruple 0x3fff000000000000 0x0000000000000000), "global fp128 0xL00000000000000003FFF000000000000" -- yes, this order is weird ), ( "x86_fp80",- FloatingPointType 80 DoubleExtended,+ x86_fp80, C.Float (F.X86_FP80 0x0004 0x0003000200010000), "global x86_fp80 0xK00040003000200010000" {- don't know how to test this - LLVM's handling of this weird type is even weirder ), ( "ppc_fp128",- FloatingPointType 128 PairOfFloats,+ ppc_fp128, C.Float (F.PPC_FP128 0x0007000600050004 0x0003000200010000), "global ppc_fp128 0xM????????????????" -} ), ( "struct",- StructureType False (replicate 2 (IntegerType 32)),+ 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 (IntegerType 32),- C.Array (IntegerType 32) [C.Int 32 i | i <- [1,2,1]],+ 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 [IntegerType 32]),- C.Array (StructureType False [IntegerType 32]) [C.Struct Nothing False [C.Int 32 i] | i <- [1,2,1]],+ 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 (IntegerType 32),+ VectorType 3 i32, C.Vector [C.Int 32 i | i <- [1,2,1]], "global <3 x i32> <i32 1, i32 2, i32 1>" ), ( "undef",- IntegerType 32,- C.Undef (IntegerType 32),+ i32,+ C.Undef i32, "global i32 undef" ), ( "binop/cast",- IntegerType 64,- C.Add False False (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2),+ 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",- IntegerType 64,- C.Add True False (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2),+ 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",- IntegerType 1,- C.ICmp IPred.SGE (C.GlobalReference (UnName 1)) (C.GlobalReference (UnName 2)),+ 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",- PointerType (IntegerType 32) (AddrSpace 0),- C.GetElementPtr True (C.GlobalReference (UnName 1)) [C.Int 64 27],+ ptr i32,+ C.GetElementPtr True (C.GlobalReference (ptr i32) (UnName 1)) [C.Int 64 27], "global i32* getelementptr inbounds (i32* @1, i64 27)" ), ( "selectvalue",- IntegerType 32,- C.Select (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 1)) + 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",- IntegerType 32,+ i32, C.ExtractElement (C.BitCast- (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64))- (VectorType 2 (IntegerType 32)))+ (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 made llvm abort as of llvm-3.2. Now, as a new feature in llvm-3.4, it makes it report a fatal error! "extractvalue",- IntegerType 8,+ i8, C.ExtractValue- (C.Select (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 1)) - (C.Array (IntegerType 8) [C.Int 8 0])- (C.Array (IntegerType 8) [C.Int 8 1]))+ (C.Select (C.PtrToInt (C.GlobalReference (p i32) (UnName 1)) i1) + (C.Array i8 [C.Int 8 0])+ (C.Array i8 [C.Int 8 1])) [0], "global i8 extractvalue ([1 x i8] select (i1 ptrtoint (i32* @1 to i1), [1 x i8] [ i8 1 ], [1 x i8] [ i8 2 ]), 0)" -}@@ -168,10 +173,10 @@ G.name = UnName 0, G.type' = type', G.initializer = Just value }, GlobalDefinition $ globalVariableDefaults {- G.name = UnName 1, G.type' = IntegerType 32, G.initializer = Nothing + G.name = UnName 1, G.type' = i32, G.initializer = Nothing }, GlobalDefinition $ globalVariableDefaults {- G.name = UnName 2, G.type' = IntegerType 32, G.initializer = Nothing + G.name = UnName 2, G.type' = i32, G.initializer = Nothing } ] mStr = "; ModuleID = '<string>'\n\n@0 = " ++ str ++ "\n\
+ test/LLVM/General/Test/DataLayout.hs view
@@ -0,0 +1,87 @@+module LLVM.General.Test.DataLayout where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Map as Map++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.AST+import LLVM.General.AST.DataLayout+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.Global as G++m s = "; ModuleID = '<string>'\n" ++ s+t s = "target datalayout = \"" ++ s ++ "\"\n"+ddl = defaultDataLayout BigEndian++tests = testGroup "DataLayout" [+ testCase name $ strCheckC (Module "<string>" 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 {+ abiAlignment = 64,+ preferredAlignment = Nothing+ }+ )+ },+ "E-p:8:64",+ Nothing+ ), (+ "no pref",+ ddl {+ pointerLayouts = + Map.insert (AddrSpace 1) (8, AlignmentInfo 32 (Just 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 {abiAlignment = 8, preferredAlignment = Just 16}))+ ],+ typeLayouts = Map.fromList [+ ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}),+ ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}),+ ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 256}),+ ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}),+ ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}),+ ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}),+ ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256}),+ ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}),+ ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}),+ ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256})+ ] `Map.union` typeLayouts ddl, + aggregateLayout = AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 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-f32:32:256-f64:64:256-v64:64:256-v128:128:256-a:0:256-f80:128:256-n8:16:32:64-S128",+ Just "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-f32:32:256-f64:64:256-v64:64:256-v128:128:256-a:0:256-f80:128:256-n8:16:32:64-S128"+ )+ ]+ ]+ ]
test/LLVM/General/Test/ExecutionEngine.hs view
@@ -38,9 +38,9 @@ testJIT withEE = withContext $ \context -> withEE context $ \executionEngine -> do let mAST = Module "runSomethingModule" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "_foo",- G.parameters = ([Parameter (IntegerType 32) (Name "bar") []],False),+ G.parameters = ([Parameter i32 (Name "bar") []],False), G.basicBlocks = [ BasicBlock (UnName 0) [] ( Do $ Ret (Just (ConstantOperand (C.Int 32 42))) []
test/LLVM/General/Test/Global.hs view
@@ -9,6 +9,7 @@ import LLVM.General.Context import LLVM.General.Module import LLVM.General.AST+import LLVM.General.AST.Type as A.T import qualified LLVM.General.AST.Global as G tests = testGroup "Global" [@@ -22,12 +23,12 @@ g <- [ globalVariableDefaults { G.name = UnName 0,- G.type' = IntegerType 32,+ G.type' = i32, G.alignment = a, G.section = s }, functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.parameters = ([], False), G.alignment = a,
test/LLVM/General/Test/InlineAssembly.hs view
@@ -10,6 +10,7 @@ import LLVM.General.Module import LLVM.General.AST+import LLVM.General.AST.Type import LLVM.General.AST.InlineAssembly as IA import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V@@ -22,17 +23,17 @@ let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []],False),+ G.parameters = ([Parameter i32 (Name "x") []],False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call {- isTailCall = False,+ tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [], function = Left $ InlineAssembly {- IA.type' = FunctionType (IntegerType 32) [IntegerType 32] False,+ IA.type' = FunctionType i32 [i32] False, assembly = "bswap $0", constraints = "=r,r", hasSideEffects = False,@@ -40,13 +41,13 @@ dialect = ATTDialect }, arguments = [- (LocalReference (Name "x"), [])+ (LocalReference i32 (Name "x"), []) ], functionAttributes = [], metadata = [] } ] (- Do $ Ret (Just (LocalReference (UnName 1))) []+ Do $ Ret (Just (LocalReference i32 (UnName 1))) [] ) ] }@@ -66,7 +67,7 @@ ModuleInlineAssembly "bar", GlobalDefinition $ globalVariableDefaults { G.name = UnName 0,- G.type' = IntegerType 32+ G.type' = i32 } ] s = "; ModuleID = '<string>'\n\
test/LLVM/General/Test/Instructions.hs view
@@ -16,7 +16,7 @@ import LLVM.General.Module import LLVM.General.Diagnostic import LLVM.General.AST-import LLVM.General.AST.Type+import LLVM.General.AST.Type as A.T import LLVM.General.AST.Name import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred@@ -34,17 +34,9 @@ testCase name $ do let mAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0,- G.parameters = ([- Parameter (IntegerType 32) (UnName 0) [],- Parameter (FloatingPointType 32 IEEE) (UnName 1) [],- Parameter (PointerType (IntegerType 32) (AddrSpace 0)) (UnName 2) [],- Parameter (IntegerType 64) (UnName 3) [],- Parameter (IntegerType 1) (UnName 4) [],- Parameter (VectorType 2 (IntegerType 32)) (UnName 5) [],- Parameter (StructureType False [IntegerType 32, IntegerType 32]) (UnName 6) []- ], False),+ G.parameters = ([Parameter t (UnName n) [] | (t,n) <- zip ts [0..]], False), G.basicBlocks = [ BasicBlock (UnName 7) [ namedInstr@@ -61,7 +53,16 @@ \ ret void\n\ \}\n" strCheck mAST mStr- | let a = LocalReference . UnName,+ | 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) <- ( [ (name, UnName 8 := instr, "%8 = " ++ instrS)@@ -95,6 +96,7 @@ "add nuw i32 %0, %0"), ("fadd", FAdd {+ fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -111,6 +113,7 @@ "sub i32 %0, %0"), ("fsub", FSub {+ fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -127,6 +130,7 @@ "mul i32 %0, %0"), ("fmul", FMul {+ fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -158,6 +162,7 @@ "sdiv i32 %0, %0"), ("fdiv", FDiv {+ fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -179,11 +184,20 @@ "srem i32 %0, %0"), ("frem", FRem {+ fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] }, "frem float %1, %1"),+ ("frem fast",+ FRem {+ fastMathFlags = UnsafeAlgebra,+ operand0 = a 1,+ operand1 = a 1,+ metadata = [] + },+ "frem fast float %1, %1"), ("shl", Shl { nsw = False,@@ -232,7 +246,7 @@ "xor i32 %0, %0"), ("alloca", Alloca {- allocatedType = IntegerType 32,+ allocatedType = i32, numElements = Nothing, alignment = 0, metadata = [] @@ -268,7 +282,7 @@ Load { volatile = False, address = a 2,- maybeAtomicity = Just (Atomicity { crossThread = True, memoryOrdering = Acquire }),+ maybeAtomicity = Just (CrossThread, Acquire), alignment = 1, metadata = [] },@@ -277,7 +291,7 @@ Load { volatile = False, address = a 2,- maybeAtomicity = Just (Atomicity { crossThread = False, memoryOrdering = Monotonic }),+ maybeAtomicity = Just (SingleThread, Monotonic), alignment = 1, metadata = [] },@@ -304,17 +318,18 @@ address = a 2, expected = a 0, replacement = a 0,- atomicity = Atomicity { crossThread = True, memoryOrdering = Monotonic },+ atomicity = (CrossThread, Monotonic),+ failureMemoryOrdering = Monotonic, metadata = [] },- "cmpxchg i32* %2, i32 %0, i32 %0 monotonic"),+ "cmpxchg i32* %2, i32 %0, i32 %0 monotonic monotonic"), ("atomicrmw", AtomicRMW { volatile = False, rmwOperation = RMWOp.UMax, address = a 2, value = a 0,- atomicity = Atomicity { crossThread = True, memoryOrdering = Release },+ atomicity = (CrossThread, Release), metadata = [] }, "atomicrmw umax i32* %2, i32 %0 release"),@@ -322,91 +337,91 @@ ("trunc", Trunc { operand0 = a 0,- type' = IntegerType 16,+ type' = i16, metadata = [] }, "trunc i32 %0 to i16"), ("zext", ZExt { operand0 = a 0,- type' = IntegerType 64,+ type' = i64, metadata = [] }, "zext i32 %0 to i64"), ("sext", SExt { operand0 = a 0,- type' = IntegerType 64,+ type' = i64, metadata = [] }, "sext i32 %0 to i64"), ("fptoui", FPToUI { operand0 = a 1,- type' = IntegerType 64,+ type' = i64, metadata = [] }, "fptoui float %1 to i64"), ("fptosi", FPToSI { operand0 = a 1,- type' = IntegerType 64,+ type' = i64, metadata = [] }, "fptosi float %1 to i64"), ("uitofp", UIToFP { operand0 = a 0,- type' = FloatingPointType 32 IEEE,+ type' = float, metadata = [] }, "uitofp i32 %0 to float"), ("sitofp", SIToFP { operand0 = a 0,- type' = FloatingPointType 32 IEEE,+ type' = float, metadata = [] }, "sitofp i32 %0 to float"), ("fptrunc", FPTrunc { operand0 = a 1,- type' = FloatingPointType 16 IEEE,+ type' = half, metadata = [] }, "fptrunc float %1 to half"), ("fpext", FPExt { operand0 = a 1,- type' = FloatingPointType 64 IEEE,+ type' = double, metadata = [] }, "fpext float %1 to double"), ("ptrtoint", PtrToInt { operand0 = a 2,- type' = IntegerType 32,+ type' = i32, metadata = [] }, "ptrtoint i32* %2 to i32"), ("inttoptr", IntToPtr { operand0 = a 0,- type' = PointerType (IntegerType 32) (AddrSpace 0),+ type' = ptr i32, metadata = [] }, "inttoptr i32 %0 to i32*"), ("bitcast", BitCast { operand0 = a 0,- type' = FloatingPointType 32 IEEE,+ type' = float, metadata = [] }, "bitcast i32 %0 to float"), ("addrspacecast", AddrSpaceCast { operand0 = a 2,- type' = PointerType (IntegerType 32) (AddrSpace 2),+ type' = PointerType i32 (AddrSpace 2), metadata = [] }, "addrspacecast i32* %2 to i32 addrspace(2)*"),@@ -421,7 +436,7 @@ ("vaarg", VAArg { argList = a 2,- type' = IntegerType 16,+ type' = i16, metadata = [] }, "va_arg i32* %2, i16"),@@ -467,10 +482,10 @@ ("landingpad-" ++ n, LandingPad { type' = StructureType False [ - PointerType (IntegerType 8) (AddrSpace 0),- IntegerType 32+ ptr i8,+ i32 ],- personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)),+ personalityFunction = ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0)), cleanup = cp, clauses = cls, metadata = []@@ -478,10 +493,10 @@ "landingpad { i8*, i32 } personality void (i32, float, i32*, i64, i1, <2 x i32>, { i32, i32 })* @0" ++ s) | (clsn,cls,clss) <- [ ("catch",- [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))],+ [Catch (C.Null (ptr i8))], "\n catch i8* null"), ("filter",- [Filter (C.Null (ArrayType 1 (PointerType (IntegerType 8) (AddrSpace 0))))],+ [Filter (C.Null (ArrayType 1 (ptr i8)))], "\n filter [1 x i8*] zeroinitializer") ], (cpn, cp, cps) <- [ ("-cleanup", True, "\n cleanup"), ("", False, "") ],@@ -539,17 +554,17 @@ "store i32 %0, i32* %2"), ("fence", Do $ Fence {- atomicity = Atomicity { crossThread = True, memoryOrdering = Acquire },+ atomicity = (CrossThread, Acquire), metadata = [] }, "fence acquire"), ("call", Do $ Call {- isTailCall = False,+ tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (UnName 0))),- arguments = [ (LocalReference (UnName i), []) | i <- [0..6] ],+ function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0))),+ arguments = [ (a i, []) | i <- [0..6] ], functionAttributes = [], metadata = [] },@@ -561,30 +576,30 @@ let mAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ globalVariableDefaults { G.name = Name "fortytwo",- G.type' = IntegerType 32,+ G.type' = i32, G.isConstant = True, G.initializer = Just $ C.Int 32 42 }, GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 1) [ UnName 2 := GetElementPtr { inBounds = True,- address = ConstantOperand (C.GlobalReference (Name "fortytwo")),+ address = ConstantOperand (C.GlobalReference (ptr i32) (Name "fortytwo")), indices = [ ConstantOperand (C.Int 32 0) ], metadata = [] }, UnName 3 := Load { volatile = False,- address = LocalReference (UnName 2),+ address = LocalReference (ptr i32) (UnName 2), maybeAtomicity = Nothing, alignment = 1, metadata = [] } ] (- Do $ Ret (Just (LocalReference (UnName 3))) []+ Do $ Ret (Just (LocalReference i32 (UnName 3))) [] ) ] }@@ -607,7 +622,7 @@ "ret", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [@@ -626,7 +641,7 @@ "br", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (@@ -650,7 +665,7 @@ "condbr", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.basicBlocks = [ BasicBlock (Name "bar") [] (@@ -675,7 +690,7 @@ "switch", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (@@ -714,24 +729,24 @@ Module "<string>" Nothing Nothing [ GlobalDefinition $ globalVariableDefaults { G.name = UnName 0,- G.type' = PointerType (IntegerType 8) (AddrSpace 0),+ G.type' = ptr i8, G.initializer = Just (C.BlockAddress (Name "foo") (UnName 2)) }, GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Load { volatile = False,- address = ConstantOperand (C.GlobalReference (UnName 0)),+ address = ConstantOperand (C.GlobalReference (ptr (ptr i8)) (UnName 0)), maybeAtomicity = Nothing, alignment = 0, metadata = [] } ] ( Do $ IndirectBr {- operand0' = LocalReference (UnName 1),+ operand0' = LocalReference (ptr i8) (UnName 1), possibleDests = [UnName 2], metadata' = [] }@@ -758,18 +773,18 @@ "invoke", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.parameters = ([- Parameter (IntegerType 32) (UnName 0) [],- Parameter (IntegerType 16) (UnName 1) []+ 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 (UnName 0))),+ 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), [])@@ -786,12 +801,12 @@ BasicBlock (Name "bar") [ UnName 3 := LandingPad { type' = StructureType False [ - PointerType (IntegerType 8) (AddrSpace 0),- IntegerType 32+ ptr i8,+ i32 ],- personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)),+ personalityFunction = ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [i32, i16] False)) (UnName 0)), cleanup = True,- clauses = [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))],+ clauses = [Catch (C.Null (ptr i8))], metadata = [] } ] (@@ -819,7 +834,7 @@ "resume", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (@@ -837,7 +852,7 @@ "unreachable", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (
test/LLVM/General/Test/Instrumentation.hs view
@@ -6,7 +6,8 @@ import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Trans.Except + import Data.Functor import qualified Data.List as List import qualified Data.Set as Set@@ -37,74 +38,85 @@ moduleAST mIn' ast = do- dl <- withDefaultTargetMachine getTargetMachineDataLayout+ dl <- withHostTargetMachine getTargetMachineDataLayout return $ Module "<string>" (Just dl) Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 128) (Name "x") []],False),+ G.parameters = ([Parameter i128 (Name "x") []],False), G.basicBlocks = [ BasicBlock (UnName 0) [] (Do $ Br (Name "checkDone") []), BasicBlock (Name "checkDone") [ UnName 1 := Phi {- type' = IntegerType 128,+ type' = i128, incomingValues = [- (LocalReference (Name "x"), UnName 0),- (LocalReference (Name "x'"), Name "even"),- (LocalReference (Name "x''"), Name "odd")+ (LocalReference i128 (Name "x"), UnName 0),+ (LocalReference i128 (Name "x'"), Name "even"),+ (LocalReference i128 (Name "x''"), Name "odd") ], metadata = [] }, Name "count" := Phi {- type' = IntegerType 32,+ type' = i32, incomingValues = [ (ConstantOperand (C.Int 32 1), UnName 0),- (LocalReference (Name "count'"), Name "even"),- (LocalReference (Name "count'"), Name "odd")+ (LocalReference i32 (Name "count'"), Name "even"),+ (LocalReference i32 (Name "count'"), Name "odd") ], metadata = [] },- Name "count'" := Add False False (LocalReference (Name "count")) (ConstantOperand (C.Int 32 1)) [],- Name "is one" := ICmp IPred.EQ (LocalReference (UnName 1)) (ConstantOperand (C.Int 128 1)) []+ 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 (Name "is one")) (Name "done") (Name "checkOdd") []+ Do $ CondBr (LocalReference i1 (Name "is one")) (Name "done") (Name "checkOdd") [] ), BasicBlock (Name "checkOdd") [- Name "is odd" := Trunc (LocalReference (UnName 1)) (IntegerType 1) []+ Name "is odd" := Trunc (LocalReference i128 (UnName 1)) i1 [] ] (- Do $ CondBr (LocalReference (Name "is odd")) (Name "odd") (Name "even") []+ Do $ CondBr (LocalReference i1 (Name "is odd")) (Name "odd") (Name "even") [] ), BasicBlock (Name "even") [- Name "x'" := UDiv True (LocalReference (UnName 1)) (ConstantOperand (C.Int 128 2)) []+ 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 (UnName 1)) (ConstantOperand (C.Int 128 3)) [],- Name "x''" := Add False False (LocalReference (UnName 2)) (ConstantOperand (C.Int 128 1)) []+ 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 (Name "count'"))) []+ Do $ Ret (Just (LocalReference i32 (Name "count'"))) [] ) ] }, GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "main", G.parameters = ([- Parameter (IntegerType 32) (Name "argc") [],- Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []+ Parameter i32 (Name "argc") [],+ Parameter (ptr (ptr i8)) (Name "argv") [] ],False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call {- isTailCall = False,+ tailCallKind = Nothing, callingConvention = CC.C, returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+ function = Right (ConstantOperand (C.GlobalReference (FunctionType i32 [i32, ptr (ptr i8)] False) (Name "foo"))), arguments = [ (ConstantOperand (C.Int 128 9491828328), []) ],@@ -112,7 +124,7 @@ metadata = [] } ] (- Do $ Ret (Just (LocalReference (UnName 1))) []+ Do $ Ret (Just (LocalReference i32 (UnName 1))) [] ) ] }@@ -123,15 +135,17 @@ testCase n $ do triple <- getProcessTargetTriple withTargetLibraryInfo triple $ \tli -> do- Right dl <- runErrorT $ withDefaultTargetMachine getTargetMachineDataLayout- Right ast <- runErrorT ast+ Right dl <- runExceptT $ withHostTargetMachine getTargetMachineDataLayout+ Right ast <- runExceptT 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) <- [ ("GCOVProfiler", defaultGCOVProfiler),+{- ("AddressSanitizer", defaultAddressSanitizer), ("AddressSanitizerModule", defaultAddressSanitizerModule),+-} ("MemorySanitizer", defaultMemorySanitizer), ("ThreadSanitizer", defaultThreadSanitizer), ("BoundsChecking", BoundsChecking),
test/LLVM/General/Test/Linking.hs view
@@ -6,7 +6,7 @@ import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Trans.Except import Data.Functor import qualified Data.Set as Set import qualified Data.Map as Map@@ -36,24 +36,24 @@ ast0 = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.linkage = L.Private,- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "private0" }, GlobalDefinition $ functionDefaults { G.linkage = L.External,- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "external0" } ] ast1 = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.linkage = L.Private,- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "private1" }, GlobalDefinition $ functionDefaults { G.linkage = L.External,- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "external1" } ] @@ -61,7 +61,7 @@ Module { moduleDefinitions = defs } <- withContext $ \context -> withModuleFromAST' context ast0 $ \m0 -> withModuleFromAST' context ast1 $ \m1 -> do- runErrorT $ linkModules False m0 m1+ runExceptT $ linkModules False m0 m1 moduleAST m0 [ n | GlobalDefinition g <- defs, let Name n = G.name g ] @?= [ "private0", "external0", "external1" ] ]
test/LLVM/General/Test/Metadata.hs view
@@ -7,6 +7,8 @@ import LLVM.General.Test.Support import LLVM.General.AST as A+import LLVM.General.AST.Type as A.T+import LLVM.General.AST.AddrSpace as A import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V import qualified LLVM.General.AST.CallingConvention as CC@@ -16,15 +18,15 @@ tests = testGroup "Metadata" [ testCase "local" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = IntegerType 32 },+ GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = i32 }, GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Load { volatile = False,- address = ConstantOperand (C.GlobalReference (UnName 0)),+ address = ConstantOperand (C.GlobalReference (ptr i32) (UnName 0)), maybeAtomicity = Nothing, A.alignment = 0, metadata = []@@ -34,7 +36,7 @@ ( "my-metadatum", MetadataNode [- Just $ LocalReference (UnName 1),+ Just $ LocalReference i32 (UnName 1), Just $ MetadataStringOperand "super hyper", Nothing ]@@ -57,7 +59,7 @@ testCase "global" $ do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [@@ -125,7 +127,7 @@ testCase "metadata-global" $ do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = VoidType,+ G.returnType = A.T.void, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [@@ -135,7 +137,7 @@ ] }, MetadataNodeDefinition (MetadataNodeID 0) [- Just $ ConstantOperand (C.GlobalReference (Name "foo"))+ Just $ ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [] False)) (Name "foo")) ] ] let s = "; ModuleID = '<string>'\n\
test/LLVM/General/Test/Module.hs view
@@ -6,27 +6,32 @@ import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Trans.Except import Data.Bits import Data.Word-import Data.Functor -import qualified Data.Set as Set+import qualified Data.Map as Map import LLVM.General.Context import LLVM.General.Module+import LLVM.General.Analysis import LLVM.General.Diagnostic import LLVM.General.Target import LLVM.General.AST+import LLVM.General.AST.Type as T import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.DLL as DLL import qualified LLVM.General.AST.CallingConvention as CC-import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.FunctionAttribute as FA+import qualified LLVM.General.AST.ParameterAttribute as PA+import qualified LLVM.General.AST.ThreadLocalStorage as TLS import qualified LLVM.General.AST.Global as G import qualified LLVM.General.AST.Constant as C+import qualified LLVM.General.AST.COMDAT as COMDAT import qualified LLVM.General.Relocation as R import qualified LLVM.General.CodeModel as CM@@ -37,23 +42,27 @@ \%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\"\n\+ \@1 = external protected addrspace(3) global i32, section \"foo\", comdat $bob\n\ \@2 = unnamed_addr global i8 2\n\- \@3 = external global %0\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 = alias private i32 addrspace(3)* @1\n\- \@two = alias i32 addrspace(3)* @three\n\+ \@two = unnamed_addr alias i32 addrspace(3)* @three\n\+ \@one = thread_local(initialexec) alias i32* @5\n\ \\n\- \define i32 @bar() {\n\- \ %1 = call zeroext i32 @foo(i32 inreg 1, i8 signext 4) #0\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\ \; Function Attrs: nounwind readnone uwtable\n\- \define zeroext i32 @foo(i32 inreg %x, i8 signext %y) #0 {\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\@@ -70,97 +79,113 @@ \ ret i32 %r\n\ \}\n\ \\n\- \attributes #0 = { nounwind readnone uwtable }\n"+ \attributes #0 = { nounwind readnone uwtable \"eep\" }\n" handAST = Module "<string>" Nothing Nothing [ TypeDefinition (UnName 0) ( Just $ StructureType False [- IntegerType 32,- PointerType (NamedTypeReference (UnName 1)) (AddrSpace 0),- PointerType (NamedTypeReference (UnName 0)) (AddrSpace 0)+ i32,+ ptr (NamedTypeReference (UnName 1)),+ ptr (NamedTypeReference (UnName 0)) ]), TypeDefinition (UnName 1) Nothing, GlobalDefinition $ globalVariableDefaults { G.name = UnName 0,- G.type' = IntegerType 32,+ G.type' = i32, G.initializer = Just (C.Int 32 1) }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 1, G.visibility = V.Protected,- G.type' = IntegerType 32,+ G.type' = i32, G.addrSpace = AddrSpace 3,- G.section = Just "foo"+ G.section = Just "foo",+ G.comdat = Just "bob" }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 2, G.hasUnnamedAddr = True,- G.type' = IntegerType 8,+ 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) (IntegerType 32)+ G.type' = ArrayType (1 `shift` 32) i32 }, GlobalDefinition $ globalVariableDefaults { G.name = Name ".argyle",- G.type' = IntegerType 32,+ G.type' = i32, G.initializer = Just (C.Int 32 0),- G.isThreadLocal = True+ 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' = PointerType (IntegerType 32) (AddrSpace 3),- G.aliasee = C.GlobalReference (UnName 1)+ G.name = Name "three",+ G.linkage = L.Private,+ G.type' = PointerType i32 (AddrSpace 3),+ G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1) }, GlobalDefinition $ globalAliasDefaults { G.name = Name "two",- G.type' = PointerType (IntegerType 32) (AddrSpace 3),- G.aliasee = C.GlobalReference (Name "three")+ G.hasUnnamedAddr = True,+ G.type' = PointerType i32 (AddrSpace 3),+ G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (Name "three") },+ GlobalDefinition $ globalAliasDefaults {+ G.name = Name "one",+ G.type' = ptr i32,+ G.aliasee = C.GlobalReference (ptr i32) (UnName 5),+ G.threadLocalMode = Just TLS.InitialExec+ }, GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "bar",+ G.prefix = Just (C.Int 32 1), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call {- isTailCall = False,+ tailCallKind = Just MustTail, callingConvention = CC.C,- returnAttributes = [A.ZeroExt],- function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+ returnAttributes = [PA.ZeroExt],+ function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))), arguments = [- (ConstantOperand (C.Int 32 1), [A.InReg]),- (ConstantOperand (C.Int 8 4), [A.SignExt])+ (ConstantOperand (C.Int 32 1), [PA.InReg, PA.Alignment 16]),+ (ConstantOperand (C.Int 8 4), [PA.SignExt]) ],- functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],+ functionAttributes = [Left (FA.GroupID 0)], metadata = [] } ] (- Do $ Ret (Just (LocalReference (UnName 1))) []+ Do $ Ret (Just (LocalReference i32 (UnName 1))) [] ) ] }, GlobalDefinition $ functionDefaults {- G.returnAttributes = [A.ZeroExt],- G.returnType = IntegerType 32,+ G.returnAttributes = [PA.ZeroExt],+ G.returnType = i32, G.name = Name "foo", G.parameters = ([- Parameter (IntegerType 32) (Name "x") [A.InReg],- Parameter (IntegerType 8) (Name "y") [A.SignExt]+ Parameter i32 (Name "x") [PA.InReg, PA.Alignment 16],+ Parameter i8 (Name "y") [PA.SignExt] ], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],+ G.functionAttributes = [Left (FA.GroupID 0)], G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { nsw = True, nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),+ operand0 = LocalReference i32 (Name "x"),+ operand1 = LocalReference i32 (Name "x"), metadata = [] } ] (@@ -169,13 +194,13 @@ BasicBlock (Name "here") [ Name "go" := ICmp { iPredicate = IPred.EQ,- operand0 = LocalReference (UnName 1),- operand1 = LocalReference (Name "x"),+ operand0 = LocalReference i32 (UnName 1),+ operand1 = LocalReference i32 (Name "x"), metadata = [] } ] ( Do $ CondBr {- condition = LocalReference (Name "go"),+ condition = LocalReference i1 (Name "go"), trueDest = Name "there", falseDest = Name "elsewhere", metadata' = []@@ -185,7 +210,7 @@ UnName 2 := Add { nsw = True, nuw = False,- operand0 = LocalReference (UnName 1),+ operand0 = LocalReference i32 (UnName 1), operand1 = ConstantOperand (C.Int 32 3), metadata = [] }@@ -194,7 +219,7 @@ ), BasicBlock (Name "elsewhere") [ Name "r" := Phi {- type' = IntegerType 32,+ type' = i32, incomingValues = [ (ConstantOperand (C.Int 32 2), Name "there"), (ConstantOperand (C.Int 32 57), Name "here")@@ -202,11 +227,13 @@ metadata = [] } ] (- Do $ Ret (Just (LocalReference (Name "r"))) []+ 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" [@@ -232,17 +259,17 @@ a <- withModuleFromLLVMAssembly' context s $ \m -> do (t, _) <- failInIO $ lookupTarget Nothing "x86_64-unknown-linux" withTargetOptions $ \to -> do- withTargetMachine t "" "" Set.empty to R.Default CM.Default CGO.Default $ \tm -> do+ withTargetMachine t "x86_64-unknown-linux" "" Map.empty to R.Default CM.Default CGO.Default $ \tm -> do failInIO $ moduleTargetAssembly tm m- a @?= "\t.file\t\"<string>\"\n\- \\t.text\n\+ a @?= "\t.text\n\+ \\t.file\t\"<string>\"\n\ \\t.globl\tmain\n\ \\t.align\t16, 0x90\n\ \\t.type\tmain,@function\n\ \main:\n\ \\t.cfi_startproc\n\ \\txorl\t%eax, %eax\n\- \\tret\n\+ \\tretq\n\ \.Ltmp0:\n\ \\t.size\tmain, .Ltmp0-main\n\ \\t.cfi_endproc\n\@@ -275,12 +302,83 @@ ast @?= defaultModule { moduleTargetTriple = Just "x86_64-unknown-linux" }, testGroup "regression" [+ testCase "minimal type info" $ withContext $ \context -> do+ let s = "; ModuleID = '<string>'\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 "<string>" 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+ s' <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify+ s' @?= Right (),++ testCase "metadata type" $ withContext $ \context -> do+ let s = "; ModuleID = '<string>'\n\+ \\n\+ \define void @bar(metadata) {\n\+ \ ret void\n\+ \}\n"+ ast = Module "<string>" 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 "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),+ G.parameters = ([Parameter i32 (Name "x") []], False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul {@@ -295,7 +393,7 @@ ), BasicBlock (Name "here") [ ] (- Do $ Ret (Just (LocalReference (UnName 1))) []+ Do $ Ret (Just (LocalReference i32 (UnName 1))) [] ) ] }@@ -306,23 +404,23 @@ testCase "Phi node finishes" $ withContext $ \context -> do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),+ G.parameters = ([Parameter i32 (Name "x") []], False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { nsw = True, nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),+ operand0 = LocalReference i32 (Name "x"),+ operand1 = LocalReference i32 (Name "x"), metadata = [] } ] ( Do $ Br (Name "here") [] ), BasicBlock (Name "here") [- UnName 2 := Phi (IntegerType 32) [ (ConstantOperand (C.Int 32 42), UnName 0) ] []+ UnName 2 := Phi i32 [ (ConstantOperand (C.Int 32 42), UnName 0) ] [] ] ( Do $ Br (Name "elsewhere") [] ),@@ -332,7 +430,7 @@ ), BasicBlock (Name "there") [ ] (- Do $ Ret (Just (LocalReference (UnName 1))) []+ Do $ Ret (Just (LocalReference i32 (UnName 1))) [] ) ] }@@ -366,17 +464,17 @@ let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.name = Name "foo",- G.returnType = IntegerType 32,- G.parameters = ([Parameter (IntegerType 32) (UnName 0) []], False),+ G.returnType = i32,+ G.parameters = ([Parameter i32 (UnName 0) []], False), G.basicBlocks = [- BasicBlock (UnName 1) [] (Do $ Switch (LocalReference $ UnName 0) (Name "end") cbps [])+ 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 (IntegerType 32) vbps []+ Name "val" := Phi i32 vbps [] ] (- Do $ Ret (Just (LocalReference (Name "val"))) []+ Do $ Ret (Just (LocalReference i32 (Name "val"))) [] ) ] }@@ -392,7 +490,7 @@ \\n\ \@0 = constant %0 { i32 1 }, align 4\n" ast = Module "<string>" Nothing Nothing [- TypeDefinition (UnName 0) (Just $ StructureType False [IntegerType 32]),+ TypeDefinition (UnName 0) (Just $ StructureType False [i32]), GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.isConstant = True,@@ -408,9 +506,9 @@ testCase "bad block reference" $ withContext $ \context -> do let badAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),+ G.parameters = ([Parameter i32 (Name "x") []], False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul {@@ -425,42 +523,42 @@ ), BasicBlock (Name "here") [ ] (- Do $ Ret (Just (LocalReference (UnName 1))) []+ Do $ Ret (Just (LocalReference i32 (UnName 1))) [] ) ] } ]- t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True+ t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True t @?= Left "reference to undefined block: Name \"not here\"", testCase "multiple" $ withContext $ \context -> do let badAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { nsw = False, nuw = False,- operand0 = LocalReference (Name "unknown"),+ operand0 = LocalReference i32 (Name "unknown"), operand1 = ConstantOperand (C.Int 32 1), metadata = [] }, UnName 2 := Mul { nsw = False, nuw = False,- operand0 = LocalReference (Name "unknown2"),- operand1 = LocalReference (UnName 1),+ operand0 = LocalReference i32 (Name "unknown2"),+ operand1 = LocalReference i32 (UnName 1), metadata = [] } ] (- Do $ Ret (Just (LocalReference (UnName 2))) []+ Do $ Ret (Just (LocalReference i32 (UnName 2))) [] ) ] } ]- t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True+ t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True t @?= Left "reference to undefined local: Name \"unknown\"" ] ]
test/LLVM/General/Test/Optimization.hs view
@@ -13,11 +13,11 @@ import LLVM.General.Module import LLVM.General.Context import LLVM.General.PassManager-import LLVM.General.Transforms+import qualified LLVM.General.Transforms as T import LLVM.General.Target import LLVM.General.AST as A-import LLVM.General.AST.Type+import LLVM.General.AST.Type as A.T import LLVM.General.AST.Name import LLVM.General.AST.AddrSpace import LLVM.General.AST.DataLayout@@ -36,10 +36,10 @@ handAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], + G.parameters = ([Parameter i32 (Name "x") []], False),+ G.functionAttributes = [Left (A.GroupID 0)], G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul {@@ -55,13 +55,13 @@ BasicBlock (Name "here") [ Name "go" := ICmp { iPredicate = IPred.EQ,- operand0 = LocalReference (UnName 1),+ operand0 = LocalReference i32 (UnName 1), operand1 = ConstantOperand (C.Int 32 42), metadata = [] } ] ( Do $ CondBr {- condition = LocalReference (Name "go"),+ condition = LocalReference i1 (Name "go"), trueDest = Name "take", falseDest = Name "done", metadata' = []@@ -71,8 +71,8 @@ UnName 2 := Sub { nsw = False, nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),+ operand0 = LocalReference i32 (Name "x"),+ operand1 = LocalReference i32 (Name "x"), metadata = [] } ] (@@ -80,18 +80,19 @@ ), BasicBlock (Name "done") [ Name "r" := Phi {- type' = IntegerType 32,+ type' = i32, incomingValues = [- (LocalReference (UnName 2), Name "take"),+ (LocalReference i32 (UnName 2), Name "take"), (ConstantOperand (C.Int 32 57), Name "here") ], metadata = [] } ] (- Do $ Ret (Just (LocalReference (Name "r"))) []+ Do $ Ret (Just (LocalReference i32 (Name "r"))) [] ) ]- }+ },+ FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] ] isVectory :: A.Module -> Assertion@@ -113,29 +114,30 @@ mOut @?= Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],+ 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.NoUnwind, A.ReadNone, A.UWTable] ], testGroup "individual" [ testCase "ConstantPropagation" $ do- mOut <- optimize defaultPassSetSpec { transforms = [ConstantPropagation] } handAST+ mOut <- optimize defaultPassSetSpec { transforms = [T.ConstantPropagation] } handAST mOut @?= Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,+ G.returnType = i32, G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],+ 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") [] (@@ -150,8 +152,8 @@ UnName 1 := Sub { nsw = False, nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),+ operand0 = LocalReference i32 (Name "x"),+ operand1 = LocalReference i32 (Name "x"), metadata = [] } ] (@@ -159,46 +161,47 @@ ), BasicBlock (Name "done") [ Name "r" := Phi {- type' = IntegerType 32,- incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")],+ type' = i32,+ incomingValues = [(LocalReference i32 (UnName 1), Name "take"),(ConstantOperand (C.Int 32 57), Name "here")], metadata = [] } ] (- Do $ Ret (Just (LocalReference (Name "r"))) []+ Do $ Ret (Just (LocalReference i32 (Name "r"))) [] ) ]- }+ },+ FunctionAttributes (A.GroupID 0) [A.NoUnwind, A.ReadNone, A.UWTable] ], testCase "BasicBlockVectorization" $ do let mIn = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = FloatingPointType 64 IEEE,+ G.returnType = double, G.name = Name "foo", G.parameters = ([- Parameter (FloatingPointType 64 IEEE) (Name (l ++ n)) []+ Parameter double (Name (l ++ n)) [] | l <- [ "a", "b" ], n <- ["1", "2"] ], False), G.basicBlocks = [ BasicBlock (UnName 0) ([- Name (l ++ n) := op (LocalReference (Name (o1 ++ n))) (LocalReference (Name (o2 ++ n))) []+ Name (l ++ n) := op NoFastMathFlags (LocalReference double (Name (o1 ++ n))) (LocalReference double (Name (o2 ++ n))) [] | (l, op, o1, o2) <- [ ("x", FSub, "a", "b"), ("y", FMul, "x", "a"), ("z", FAdd, "y", "b")], n <- ["1", "2"] ] ++ [- Name "r" := FMul (LocalReference (Name "z1")) (LocalReference (Name "z2")) []- ]) (Do $ Ret (Just (LocalReference (Name "r"))) [])+ Name "r" := FMul NoFastMathFlags (LocalReference double (Name "z1")) (LocalReference double (Name "z2")) []+ ]) (Do $ Ret (Just (LocalReference double (Name "r"))) []) ] } ] mOut <- optimize (defaultPassSetSpec { transforms = [- defaultVectorizeBasicBlocks { requiredChainDepth = 3 },- InstructionCombining, - GlobalValueNumbering False+ T.defaultVectorizeBasicBlocks { T.requiredChainDepth = 3 },+ T.InstructionCombining, + T.GlobalValueNumbering False ] }) mIn isVectory mOut, @@ -207,51 +210,57 @@ mIn = Module { moduleName = "<string>",- moduleDataLayout = Just $ defaultDataLayout { + moduleDataLayout = Just $ (defaultDataLayout BigEndian) { typeLayouts = Map.singleton (VectorAlign, 128) (AlignmentInfo 128 Nothing) }, 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.Null (A.T.ArrayType 2048 i32))+ }, GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = Name "foo",- G.parameters = ([Parameter (PointerType (IntegerType 32) (AddrSpace 0)) (Name "x") []], False),+ 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) [] (Do $ Br (UnName 1) []),- BasicBlock (UnName 1) [- Name "i.0" := Phi (IntegerType 32) [ - (ConstantOperand (C.Int 32 0), UnName 0),- (LocalReference (UnName 8), UnName 7)- ] [],- Name ".0" := Phi (PointerType (IntegerType 32) (AddrSpace 0)) [ - (LocalReference (Name "x"), UnName 0),- (LocalReference (UnName 4), UnName 7)+ 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 := ICmp IPred.SLT (LocalReference (Name "i.0")) (ConstantOperand (C.Int 32 2048)) []- ] (Do $ CondBr (LocalReference (UnName 2)) (UnName 3) (UnName 9) []),- BasicBlock (UnName 3) [- UnName 4 := GetElementPtr True (LocalReference (Name ".0")) [ - ConstantOperand (C.Int 32 1)+ UnName 2 := GetElementPtr True (ConstantOperand (C.GlobalReference (A.T.ArrayType 2048 i32) (Name "a"))) [ + ConstantOperand (C.Int 64 0),+ (LocalReference i64 (Name "indvars.iv")) ] [],- UnName 5 := Load False (LocalReference (Name ".0")) Nothing 4 [],- UnName 6 := Add True False (LocalReference (UnName 5)) (ConstantOperand (C.Int 32 1)) [],- Do $ Store False (LocalReference (Name ".0")) (LocalReference (UnName 6)) Nothing 4 [] - ] (Do $ Br (UnName 7) []),- BasicBlock (UnName 7) [- UnName 8 := Add True False (LocalReference (Name "i.0")) (ConstantOperand (C.Int 32 1)) []- ] (Do $ Br (UnName 1) []),- BasicBlock (UnName 9) [] (Do $ Ret Nothing [])+ 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 let triple = "x86_64" (target, _) <- failInIO $ lookupTarget Nothing triple withTargetOptions $ \targetOptions -> do- withTargetMachine target triple "" Set.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do+ withTargetMachine target triple "" Map.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do optimize (defaultPassSetSpec { - transforms = [ LoopVectorize ],+ transforms = [ T.defaultLoopVectorize ], dataLayout = moduleDataLayout mIn, targetMachine = Just tm }) mIn@@ -262,45 +271,36 @@ -- The pass seems to be quite deeply dependent on weakly documented presumptions about -- how unwinding works (as is the invoke instruction) withContext $ \context -> do- let triple = "x86_64-apple-darwin"- (target, _) <- failInIO $ lookupTarget Nothing triple- withTargetOptions $ \targetOptions -> do- withTargetMachine target triple "" Set.empty targetOptions- R.Default CM.Default CGO.Default $ \tm -> do- withPassManager (defaultPassSetSpec { transforms = [LowerInvoke False], targetMachine = Just tm}) $ \passManager -> do- let astIn = - Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (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 "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.basicBlocks = [- BasicBlock (Name "here") [- ] (- Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []- )- ]- },- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = Name "abort"- }+ withPassManager (defaultPassSetSpec { transforms = [T.LowerInvoke] }) $ \passManager -> do+ let astIn = + Module "<string>" 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 "<string>" 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))) []+ )+ ]+ }+ ] ] ]
test/LLVM/General/Test/Support.hs view
@@ -6,7 +6,7 @@ import Data.Functor import Control.Monad-import Control.Monad.Error+import Control.Monad.Trans.Except import LLVM.General.Context import LLVM.General.Module@@ -16,8 +16,8 @@ class FailInIO f where errorToString :: f -> String -failInIO :: FailInIO f => ErrorT f IO a -> IO a-failInIO = either (fail . errorToString) return <=< runErrorT+failInIO :: FailInIO f => ExceptT f IO a -> IO a+failInIO = either (fail . errorToString) return <=< runExceptT instance FailInIO String where errorToString = id
test/LLVM/General/Test/Target.hs view
@@ -39,8 +39,10 @@ disableTailCalls <- arbitrary enableFastInstructionSelection <- arbitrary positionIndependentExecutable <- arbitrary- enableSegmentedStacks <- arbitrary useInitArray <- arbitrary+ disableIntegratedAssembler <- arbitrary+ compressDebugSections <- arbitrary+ trapUnreachable <- arbitrary stackAlignmentOverride <- arbitrary trapFunctionName <- elements [ "foo", "bar", "baz" ] floatABIType <- arbitrary@@ -49,37 +51,7 @@ tests = testGroup "Target" [ testGroup "Options" [- testGroup "regressions" [- testCase "hurm" $ do- withTargetOptions $ \to -> do- let o = Options {- printMachineCode = True,- noFramePointerElimination = False,- lessPreciseFloatingPointMultiplyAddOption = True,- unsafeFloatingPointMath = True,- noInfinitiesFloatingPointMath = True,- noNaNsFloatingPointMath = False,- honorSignDependentRoundingFloatingPointMathOption = True,- useSoftFloat = True,- noZerosInBSS = False,- jITEmitDebugInfo = True,- jITEmitDebugInfoToDisk = False,- guaranteedTailCallOptimization = False,- disableTailCalls = False,- enableFastInstructionSelection = True,- positionIndependentExecutable = True,- enableSegmentedStacks = False,- useInitArray = True,- stackAlignmentOverride = 9432851444,- trapFunctionName = "baz",- floatABIType = FloatABISoft,- allowFloatingPointOperationFusion = FloatingPointOperationFusionStrict- }- pokeTargetOptions o to- o' <- peekTargetOptions to- o' @?= o- ],- testProperty "basic" $ \options -> morallyDubiousIOProperty $ do+ testProperty "basic" $ \options -> ioProperty $ do withTargetOptions $ \to -> do pokeTargetOptions options to options' <- peekTargetOptions to@@ -100,5 +72,8 @@ withTargetLibraryInfo triple $ \tli -> do lf <- getLibraryFunction tli "printf" lf @?= Just LF__printf- ]+ ],+ testCase "Host" $ do+ features <- getHostCPUFeatures+ return () ]
test/LLVM/General/Test/Tests.hs view
@@ -2,6 +2,7 @@ import Test.Framework +import qualified LLVM.General.Test.CallingConvention as CallingConvention import qualified LLVM.General.Test.Constants as Constants import qualified LLVM.General.Test.DataLayout as DataLayout import qualified LLVM.General.Test.ExecutionEngine as ExecutionEngine@@ -17,6 +18,7 @@ import qualified LLVM.General.Test.Instrumentation as Instrumentation tests = testGroup "llvm-general" [+ CallingConvention.tests, Constants.tests, DataLayout.tests, ExecutionEngine.tests,