llvm-general 3.2.8.2 → 3.3.0.0
raw patch · 126 files changed
+2989/−2724 lines, 126 filesdep +textdep −llvm-general-puredep −utf8-stringdep ~arraydep ~basedep ~containerssetup-changed
Dependencies added: text
Dependencies removed: llvm-general-pure, utf8-string
Dependency ranges changed: array, base, containers, llvm-general
Files
- Setup.hs +27/−76
- llvm-general.cabal +39/−52
- src/Control/Monad/AnyCont.hs +4/−3
- src/Control/Monad/AnyCont/Class.hs +17/−32
- src/Control/Monad/Phased.hs +36/−0
- src/Control/Monad/Phased/Class.hs +46/−0
- src/Control/Monad/Trans/Phased.hs +33/−0
- src/LLVM/General/AST.hs +53/−0
- src/LLVM/General/AST/AddrSpace.hs +8/−0
- src/LLVM/General/AST/Attribute.hs +38/−0
- src/LLVM/General/AST/CallingConvention.hs +13/−0
- src/LLVM/General/AST/Constant.hs +218/−0
- src/LLVM/General/AST/DataLayout.hs +51/−0
- src/LLVM/General/AST/Float.hs +19/−0
- src/LLVM/General/AST/FloatingPointPredicate.hs +30/−0
- src/LLVM/General/AST/Global.hs +109/−0
- src/LLVM/General/AST/InlineAssembly.hs +30/−0
- src/LLVM/General/AST/Instruction.hs +389/−0
- src/LLVM/General/AST/IntegerPredicate.hs +24/−0
- src/LLVM/General/AST/Linkage.hs +27/−0
- src/LLVM/General/AST/Name.hs +31/−0
- src/LLVM/General/AST/Operand.hs +33/−0
- src/LLVM/General/AST/RMWOperation.hs +25/−0
- src/LLVM/General/AST/Type.hs +40/−0
- src/LLVM/General/AST/Visibility.hs +11/−0
- src/LLVM/General/Analysis.hs +0/−8
- src/LLVM/General/CodeGenOpt.hs +3/−0
- src/LLVM/General/CodeModel.hs +3/−0
- src/LLVM/General/Diagnostic.hs +3/−0
- src/LLVM/General/ExecutionEngine.hs +4/−3
- src/LLVM/General/Internal/Analysis.hs +0/−19
- src/LLVM/General/Internal/Atomicity.hs +4/−2
- src/LLVM/General/Internal/Attribute.hs +2/−1
- src/LLVM/General/Internal/BasicBlock.hs +4/−3
- src/LLVM/General/Internal/CallingConvention.hs +7/−8
- src/LLVM/General/Internal/Coding.hs +21/−25
- src/LLVM/General/Internal/Constant.hs +31/−29
- src/LLVM/General/Internal/DataLayout.hs +80/−13
- src/LLVM/General/Internal/DecodeAST.hs +24/−5
- src/LLVM/General/Internal/Diagnostic.hs +7/−5
- src/LLVM/General/Internal/EncodeAST.hs +34/−20
- src/LLVM/General/Internal/ExecutionEngine.hs +35/−61
- src/LLVM/General/Internal/FFI/Analysis.h +0/−11
- src/LLVM/General/Internal/FFI/Analysis.hs +0/−13
- src/LLVM/General/Internal/FFI/Assembly.hs +1/−2
- src/LLVM/General/Internal/FFI/AssemblyC.cpp +2/−1
- src/LLVM/General/Internal/FFI/BasicBlock.hs +1/−0
- src/LLVM/General/Internal/FFI/BinaryOperator.hs +11/−3
- src/LLVM/General/Internal/FFI/Builder.hs +32/−31
- src/LLVM/General/Internal/FFI/BuilderC.cpp +8/−8
- src/LLVM/General/Internal/FFI/Cleanup.hs +8/−19
- src/LLVM/General/Internal/FFI/Constant.h +20/−0
- src/LLVM/General/Internal/FFI/Constant.hs +20/−16
- src/LLVM/General/Internal/FFI/ConstantC.cpp +20/−30
- src/LLVM/General/Internal/FFI/Context.hs +2/−1
- src/LLVM/General/Internal/FFI/DataLayout.hs +0/−24
- src/LLVM/General/Internal/FFI/ExecutionEngine.hs +8/−20
- src/LLVM/General/Internal/FFI/Function.hs +2/−4
- src/LLVM/General/Internal/FFI/FunctionC.cpp +5/−4
- src/LLVM/General/Internal/FFI/GlobalAlias.hs +3/−0
- src/LLVM/General/Internal/FFI/GlobalAliasC.cpp +2/−2
- src/LLVM/General/Internal/FFI/GlobalValue.hs +3/−0
- src/LLVM/General/Internal/FFI/GlobalValueC.cpp +1/−1
- src/LLVM/General/Internal/FFI/GlobalVariable.hs +3/−0
- src/LLVM/General/Internal/FFI/InlineAssembly.hs +1/−0
- src/LLVM/General/Internal/FFI/InlineAssemblyC.cpp +2/−1
- src/LLVM/General/Internal/FFI/Instruction.h +9/−19
- src/LLVM/General/Internal/FFI/Instruction.hs +8/−1
- src/LLVM/General/Internal/FFI/InstructionC.cpp +21/−14
- src/LLVM/General/Internal/FFI/InstructionDefs.hsc +4/−1
- src/LLVM/General/Internal/FFI/LLVMCTypes.hsc +11/−30
- src/LLVM/General/Internal/FFI/MetadataC.cpp +3/−3
- src/LLVM/General/Internal/FFI/Module.h +0/−8
- src/LLVM/General/Internal/FFI/Module.hs +6/−13
- src/LLVM/General/Internal/FFI/ModuleC.cpp +3/−18
- src/LLVM/General/Internal/FFI/PassManager.hs +20/−45
- src/LLVM/General/Internal/FFI/PassManagerC.cpp +4/−52
- src/LLVM/General/Internal/FFI/PtrHierarchy.hs +3/−9
- src/LLVM/General/Internal/FFI/SMDiagnostic.hs +6/−4
- src/LLVM/General/Internal/FFI/SMDiagnosticC.cpp +15/−4
- src/LLVM/General/Internal/FFI/Target.h +0/−4
- src/LLVM/General/Internal/FFI/Target.hs +16/−40
- src/LLVM/General/Internal/FFI/TargetC.cpp +17/−56
- src/LLVM/General/Internal/FFI/Transforms.hs +1/−14
- src/LLVM/General/Internal/FFI/Type.hs +8/−9
- src/LLVM/General/Internal/FFI/TypeC.cpp +3/−4
- src/LLVM/General/Internal/FFI/User.hs +3/−0
- src/LLVM/General/Internal/FFI/Value.hs +5/−0
- src/LLVM/General/Internal/FFI/ValueC.cpp +1/−1
- src/LLVM/General/Internal/FloatingPointPredicate.hs +4/−2
- src/LLVM/General/Internal/Function.hs +0/−6
- src/LLVM/General/Internal/Global.hs +5/−3
- src/LLVM/General/Internal/InlineAssembly.hs +3/−2
- src/LLVM/General/Internal/Instruction.hs +75/−82
- src/LLVM/General/Internal/InstructionDefs.hs +7/−8
- src/LLVM/General/Internal/IntegerPredicate.hs +4/−2
- src/LLVM/General/Internal/Metadata.hs +2/−1
- src/LLVM/General/Internal/Module.hs +140/−204
- src/LLVM/General/Internal/Operand.hs +3/−2
- src/LLVM/General/Internal/PassManager.hs +72/−93
- src/LLVM/General/Internal/RMWOperation.hs +4/−2
- src/LLVM/General/Internal/String.hs +10/−30
- src/LLVM/General/Internal/Target.hs +23/−86
- src/LLVM/General/Internal/Type.hs +14/−16
- src/LLVM/General/Internal/Value.hs +2/−0
- src/LLVM/General/Module.hs +2/−8
- src/LLVM/General/PassManager.hs +9/−4
- src/LLVM/General/Relocation.hs +3/−0
- src/LLVM/General/Target.hs +2/−8
- src/LLVM/General/Target/Options.hs +3/−0
- src/LLVM/General/Transforms.hs +32/−61
- test/LLVM/General/Test/Analysis.hs +0/−113
- test/LLVM/General/Test/Constants.hs +1/−11
- test/LLVM/General/Test/DataLayout.hs +29/−0
- test/LLVM/General/Test/ExecutionEngine.hs +17/−25
- test/LLVM/General/Test/Global.hs +1/−3
- test/LLVM/General/Test/InlineAssembly.hs +3/−6
- test/LLVM/General/Test/Instructions.hs +132/−205
- test/LLVM/General/Test/Instrumentation.hs +0/−141
- test/LLVM/General/Test/Linking.hs +0/−67
- test/LLVM/General/Test/Metadata.hs +54/−67
- test/LLVM/General/Test/Module.hs +127/−256
- test/LLVM/General/Test/Optimization.hs +257/−269
- test/LLVM/General/Test/Support.hs +12/−29
- test/LLVM/General/Test/Tests.hs +2/−7
- test/Test.hs +0/−0
Setup.hs view
@@ -1,63 +1,25 @@-{-# LANGUAGE FlexibleInstances #-}-import Control.Exception (SomeException, try) import Control.Monad-import Data.Monoid-import Data.Maybe-import Data.List (isPrefixOf, (\\), intercalate, stripPrefix)+import Data.List (isPrefixOf, (\\)) import Data.Map (Map) import qualified Data.Map as Map-import Data.Char+import Data.Monoid import Distribution.Simple import Distribution.Simple.Program-import Distribution.Simple.Setup hiding (Flag)+import Distribution.Simple.Setup import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription-import Distribution.Version import System.Environment import System.SetEnv import Distribution.System ++ -- define these selectively in C files (where _not_ using HsFFI.h), -- rather than universally in the ccOptions, because HsFFI.h currently defines them -- without checking they're already defined and so causes warnings. uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] -llvmVersion = Version [3,2] []--llvmConfigNames = [- "llvm-config-" ++ (intercalate "." . map show . versionBranch $ llvmVersion),- "llvm-config"- ]--findJustBy :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)-findJustBy f (x:xs) = do- x' <- f x- case x' of- Nothing -> findJustBy f xs- j -> return j-findJustBy _ [] = return Nothing--class ProgramSearch a where- programSearch :: (String -> a) -> a---- this instance is used before Cabal-1.18.0, when programFindLocation took one argument-instance Monad m => ProgramSearch (v -> m (Maybe b)) where- programSearch checkName = \v -> findJustBy (\n -> checkName n v) llvmConfigNames---- this instance is used for and after Cabal-1.18.0, when programFindLocation took two arguments-instance Monad m => ProgramSearch (v -> p -> m (Maybe b)) where- programSearch checkName = \v p -> findJustBy (\n -> checkName n v p) llvmConfigNames--llvmProgram = (simpleProgram "llvm-config") {- programFindLocation = programSearch (programFindLocation . simpleProgram),- programFindVersion = - let- stripSuffix suf str = let r = reverse in liftM r (stripPrefix (r suf) (r str))- svnToTag v = maybe v (++"-svn") (stripSuffix "svn" v)- trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse- in- \v p -> findProgramVersion "--version" (svnToTag . trim) v p- }+llvmProgram = simpleProgram "llvm-config" main = do let (ldLibraryPathVar, ldLibraryPathSep) = @@ -65,15 +27,17 @@ 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)+ v <- lookupEnv ldLibraryPathVar+ setEnv ldLibraryPathVar (s ++ maybe "" (ldLibraryPathSep ++) v) getLLVMConfig configFlags = do let verbosity = fromFlag $ configVerbosity configFlags- (program, _, _) <- requireProgramVersion verbosity llvmProgram- (withinVersion llvmVersion)- (configPrograms configFlags)+ -- preconfigure the configuration-generating program "llvm-config"+ programDb <- configureProgram verbosity llvmProgram+ . userSpecifyPaths (configProgramPaths configFlags)+ . userSpecifyArgss (configProgramArgs configFlags)+ $ configPrograms configFlags let llvmConfig :: [String] -> IO String- llvmConfig = getProgramOutput verbosity program+ llvmConfig = getDbProgramOutput verbosity llvmProgram programDb return llvmConfig addLLVMToLdLibraryPath configFlags = do llvmConfig <- getLLVMConfig configFlags@@ -82,7 +46,6 @@ defaultMainWithHooks simpleUserHooks { hookedPrograms = [ llvmProgram ],- confHook = \(genericPackageDescription, hookedBuildInfo) configFlags -> do llvmConfig <- getLLVMConfig configFlags @@ -92,26 +55,22 @@ 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"]+ let libraryVersion = + case llvmVersion of+ "3.2" -> "3.2svn"+ "3.3" -> "3.3"+ x -> error $ "llvm version " ++ x ++ " not yet supported by llvm-general" let genericPackageDescription' = genericPackageDescription { condLibrary = do libraryCondTree <- condLibrary genericPackageDescription return libraryCondTree {- condTreeData = condTreeData libraryCondTree <> mempty {- libBuildInfo = mempty { ccOptions = llvmCppFlags }- },- condTreeComponents = condTreeComponents libraryCondTree ++ [- (- Var (Flag (FlagName "shared-llvm")),- CondNode (mempty { libBuildInfo = mempty { extraLibs = [sharedLib] ++ externLibs } }) [] [],- Just (CondNode (mempty { libBuildInfo = mempty { extraLibs = staticLibs ++ externLibs } }) [] [])- )- ] + condTreeData = condTreeData libraryCondTree <> mempty { + libBuildInfo = mempty {+ ccOptions = llvmCppFlags,+ extraLibs = ["LLVM-" ++ libraryVersion]+ }+ } } } configFlags' = configFlags {@@ -120,19 +79,11 @@ } addLLVMToLdLibraryPath configFlags' confHook simpleUserHooks (genericPackageDescription', hookedBuildInfo) configFlags',- buildHook = \packageDescription localBuildInfo userHooks buildFlags -> do addLLVMToLdLibraryPath (configFlags localBuildInfo) buildHook simpleUserHooks packageDescription localBuildInfo userHooks buildFlags,- testHook = \packageDescription localBuildInfo userHooks testFlags -> do addLLVMToLdLibraryPath (configFlags localBuildInfo)- testHook simpleUserHooks packageDescription localBuildInfo userHooks testFlags,-- 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 simpleUserHooks packageDescription localBuildInfo userHooks testFlags }+
llvm-general.cabal view
@@ -1,5 +1,5 @@ name: llvm-general-version: 3.2.8.2+version: 3.3.0.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net>@@ -15,19 +15,16 @@ 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.2.8.2/doc/html/llvm-general/index.html>. extra-source-files:- src/LLVM/General/Internal/FFI/Analysis.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- src/LLVM/General/Internal/FFI/Module.h+ src/LLVM/General/Internal/FFI/Value.h src/LLVM/General/Internal/FFI/SMDiagnostic.h+ src/LLVM/General/Internal/FFI/InlineAssembly.h src/LLVM/General/Internal/FFI/Target.h+ src/LLVM/General/Internal/FFI/Function.h+ src/LLVM/General/Internal/FFI/GlobalValue.h src/LLVM/General/Internal/FFI/Type.h- src/LLVM/General/Internal/FFI/Value.h+ src/LLVM/General/Internal/FFI/Constant.h source-repository head type: git@@ -36,45 +33,45 @@ source-repository this type: git location: git://github.com/bscarlet/llvm-general.git- branch: llvm-3.2- tag: v3.2.8.2--flag shared-llvm- description: link against llvm shared rather than static library- default: False--flag debug- description: compile C(++) shims with debug info for ease of troubleshooting- default: False+ branch: llvm-3.3+ tag: v3.3.0.0 library build-tools: llvm-config ghc-options: -fwarn-unused-imports build-depends: - base >= 4.5.0.0 && < 5,- utf8-string >= 0.3.7,+ base >= 3 && < 5,+ text >= 0.11.2.1, bytestring >= 0.9.1.10, transformers >= 0.3.0.0, mtl >= 2.0.1.0, template-haskell >= 2.5.0.0,- containers >= 0.4.2.1,+ containers >= 0.5.0.0, parsec >= 3.1.3,- array >= 0.4.0.0,- setenv >= 0.1.0,- llvm-general-pure == 3.2.8.2+ array >= 0.4.0.1,+ setenv >= 0.1.0 extra-libraries: stdc++ hs-source-dirs: src- extensions:- TupleSections- DeriveDataTypeable- EmptyDataDecls- FlexibleContexts- FlexibleInstances- StandaloneDeriving- ConstraintKinds exposed-modules: LLVM.General- LLVM.General.Analysis+ LLVM.General.AST+ LLVM.General.AST.AddrSpace+ LLVM.General.AST.InlineAssembly+ LLVM.General.AST.Attribute+ LLVM.General.AST.CallingConvention+ LLVM.General.AST.Constant+ LLVM.General.AST.DataLayout+ LLVM.General.AST.Float+ LLVM.General.AST.FloatingPointPredicate+ LLVM.General.AST.Global+ LLVM.General.AST.Instruction+ LLVM.General.AST.IntegerPredicate+ LLVM.General.AST.Linkage+ LLVM.General.AST.Name+ LLVM.General.AST.Operand+ LLVM.General.AST.RMWOperation+ LLVM.General.AST.Type+ LLVM.General.AST.Visibility LLVM.General.CodeGenOpt LLVM.General.CodeModel LLVM.General.CommandLine@@ -89,10 +86,12 @@ LLVM.General.Transforms other-modules:+ Control.Monad.Phased+ Control.Monad.Phased.Class+ Control.Monad.Trans.Phased Control.Monad.AnyCont Control.Monad.AnyCont.Class Control.Monad.Trans.AnyCont- LLVM.General.Internal.Analysis LLVM.General.Internal.Atomicity LLVM.General.Internal.Attribute LLVM.General.Internal.BasicBlock@@ -122,7 +121,6 @@ LLVM.General.Internal.Target LLVM.General.Internal.Type LLVM.General.Internal.Value- LLVM.General.Internal.FFI.Analysis LLVM.General.Internal.FFI.Assembly LLVM.General.Internal.FFI.BasicBlock LLVM.General.Internal.FFI.BinaryOperator@@ -131,7 +129,6 @@ LLVM.General.Internal.FFI.CommandLine LLVM.General.Internal.FFI.Constant LLVM.General.Internal.FFI.Context- LLVM.General.Internal.FFI.DataLayout LLVM.General.Internal.FFI.ExecutionEngine LLVM.General.Internal.FFI.Function LLVM.General.Internal.FFI.GlobalAlias@@ -157,8 +154,8 @@ c-sources: src/LLVM/General/Internal/FFI/AssemblyC.cpp src/LLVM/General/Internal/FFI/BuilderC.cpp- src/LLVM/General/Internal/FFI/CommandLineC.cpp src/LLVM/General/Internal/FFI/ConstantC.cpp+ src/LLVM/General/Internal/FFI/CommandLineC.cpp src/LLVM/General/Internal/FFI/FunctionC.cpp src/LLVM/General/Internal/FFI/GlobalAliasC.cpp src/LLVM/General/Internal/FFI/GlobalValueC.cpp@@ -172,9 +169,6 @@ src/LLVM/General/Internal/FFI/TypeC.cpp src/LLVM/General/Internal/FFI/ValueC.cpp - if flag(debug)- cc-options: -g- test-suite test type: exitcode-stdio-1.0 build-depends: @@ -184,28 +178,21 @@ HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1,- llvm-general == 3.2.8.2,- llvm-general-pure == 3.2.8.2,- containers >= 0.4.2.1,- mtl >= 2.0.1.0+ llvm-general >= 0.1,+ containers >= 0.5.0.0 hs-source-dirs: test- extensions:- TupleSections- FlexibleInstances- FlexibleContexts main-is: Test.hs other-modules:- LLVM.General.Test.Analysis LLVM.General.Test.Constants+ LLVM.General.Test.DataLayout LLVM.General.Test.ExecutionEngine LLVM.General.Test.Global LLVM.General.Test.InlineAssembly LLVM.General.Test.Instructions- LLVM.General.Test.Instrumentation- LLVM.General.Test.Linking LLVM.General.Test.Metadata LLVM.General.Test.Module LLVM.General.Test.Optimization LLVM.General.Test.Support LLVM.General.Test.Target LLVM.General.Test.Tests+
src/Control/Monad/AnyCont.hs view
@@ -1,15 +1,16 @@ {-# LANGUAGE+ FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} module Control.Monad.AnyCont ( MonadAnyCont(..),- ScopeAnyCont(..), AnyContT(..),- MonadTransAnyCont(..), runAnyContT, withAnyContT,- mapAnyContT+ mapAnyContT,+ anyContIOToM,+ anyContT ) where import Control.Monad.Trans.AnyCont
src/Control/Monad/AnyCont/Class.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE RankNTypes, MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances, UndecidableInstances #-} module Control.Monad.AnyCont.Class where@@ -10,45 +12,28 @@ import qualified Control.Monad.Trans.AnyCont as AnyCont import Control.Monad.Trans.Error as Error import Control.Monad.Trans.State as State--class ScopeAnyCont m where- scopeAnyCont :: m a -> m a+import Control.Monad.Trans.Phased as Phased+import Control.Monad.IO.Class -class MonadAnyCont b m where+class MonadAnyCont b m | m -> b where anyContToM :: (forall r . (a -> b r) -> b r) -> m a---instance MonadTransAnyCont b m => MonadAnyCont b (AnyContT m) where- anyContToM c = AnyCont.anyContT (liftAnyCont c)+ scopeAnyCont :: m a -> m a -instance Monad m => ScopeAnyCont (AnyContT m) where+instance Monad m => MonadAnyCont m (AnyContT m) where+ anyContToM = AnyCont.anyContT scopeAnyCont = lift . flip AnyCont.runAnyContT return --instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where- anyContToM x = lift $ anyContToM x--instance ScopeAnyCont m => ScopeAnyCont (StateT s m) where- scopeAnyCont = StateT . (scopeAnyCont .) . runStateT-- instance (Error e, Monad m, MonadAnyCont b m) => MonadAnyCont b (ErrorT e m) where- anyContToM x = lift $ anyContToM x--instance ScopeAnyCont m => ScopeAnyCont (ErrorT e m) where+ anyContToM = lift . anyContToM scopeAnyCont = mapErrorT scopeAnyCont ----class MonadTransAnyCont b m where- liftAnyCont :: (forall r . (a -> b r) -> b r) -> (forall r . (a -> m r) -> m r)--instance MonadTransAnyCont b b where- liftAnyCont c = c+instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (PhasedT m) where+ anyContToM = lift . anyContToM+ scopeAnyCont = mapPhasedT scopeAnyCont -instance MonadTransAnyCont b m => MonadTransAnyCont b (StateT s m) where- liftAnyCont c = (\c q -> StateT $ \s -> c $ ($ s) . runStateT . q) (liftAnyCont c)+instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where+ anyContToM = lift . anyContToM+ scopeAnyCont = StateT . (scopeAnyCont .) . runStateT -instance MonadTransAnyCont b m => MonadTransAnyCont b (ErrorT e m) where- liftAnyCont c = (\c q -> ErrorT . c $ runErrorT . q) (liftAnyCont c)+anyContIOToM :: MonadIO m => (forall r . (a -> IO r) -> IO r) -> AnyContT m a+anyContIOToM ioac = AnyCont.anyContT (\c -> liftIO (ioac return) >>= c)
+ src/Control/Monad/Phased.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE+ FlexibleInstances,+ MultiParamTypeClasses,+ UndecidableInstances+ #-}+module Control.Monad.Phased (+ MonadPhased(..),+ PhasedT(..),+ runPhasedT,+ forInterleavedM,+ iap,+ defer,+ runInterleaved,+ mapPhasedT+ ) where++import Control.Monad+import Control.Monad.Trans.Phased++import Control.Monad.Trans.Class+import Control.Monad.State.Class+import Control.Monad.Reader.Class+import Control.Monad.Error.Class+import Control.Monad.Phased.Class++instance MonadState s m => MonadState s (PhasedT m) where+ state = lift . state++instance MonadReader r m => MonadReader r (PhasedT m) where+ ask = lift ask+ local f = PhasedT . local f . liftM (either (Left . local f) Right) . unPhasedT++instance (MonadError e m) => MonadError e (PhasedT m) where+ throwError = lift . throwError+ catchError pa ph = mapPhasedT (`catchError` (unPhasedT . ph)) pa+
+ src/Control/Monad/Phased/Class.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE+ MultiParamTypeClasses,+ UndecidableInstances,+ FlexibleInstances,+ TupleSections+ #-}+module Control.Monad.Phased.Class where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Phased+import Control.Monad.Trans.AnyCont++class Monad m => MonadPhased m where+ later :: m a -> m a+ interleavePhasesWith :: (a -> b -> c) -> m a -> m b -> m c+ mergePhases :: m a -> m a++iap :: MonadPhased m => m (a -> b) -> m a -> m b+iap = interleavePhasesWith ($)++runInterleaved :: (MonadPhased m) => [m a] -> m [a]+runInterleaved = foldr (interleavePhasesWith (:)) (return [])++forInterleavedM x = runInterleaved . flip map x++defer :: MonadPhased m => m ()+defer = later (return ())++instance Monad m => MonadPhased (PhasedT m) where+ later = PhasedT . return . Left+ interleavePhasesWith p (PhasedT mx) (PhasedT my) = PhasedT $ do+ x <- mx+ y <- my+ return $ case (x,y) of+ (Right a, Right b) -> Right (p a b)+ _ -> Left $ interleavePhasesWith p (stall x) (stall y)+ where stall = either id return+ mergePhases = lift . runPhasedT++instance MonadPhased m => MonadPhased (AnyContT m) where+ later = lift . later . flip runAnyContT return+ interleavePhasesWith p mx my = + anyContT $ (>>=) $ interleavePhasesWith p (runAnyContT mx return) (runAnyContT my return)+ mergePhases ma = anyContT (mergePhases (runAnyContT ma return) >>= )++
+ src/Control/Monad/Trans/Phased.hs view
@@ -0,0 +1,33 @@+module Control.Monad.Trans.Phased where++import Control.Monad+import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.IO.Class++newtype PhasedT m a = PhasedT { unPhasedT :: m (Either (PhasedT m a) a) }++instance Functor m => Functor (PhasedT m) where+ fmap f = PhasedT . fmap (either (Left . fmap f) (Right . f)) . unPhasedT++instance (Functor m, Monad m) => Applicative (PhasedT m) where+ pure = return+ (<*>) = ap++instance Monad m => Monad (PhasedT m) where+ k >>= f = PhasedT $ unPhasedT k >>= either (return . Left . (>>= f)) (unPhasedT . f)+ return = PhasedT . return . Right+ fail = PhasedT . fail++instance MonadTrans PhasedT where+ lift = PhasedT . liftM Right++runPhasedT :: Monad m => PhasedT m a -> m a+runPhasedT = either runPhasedT return <=< unPhasedT++instance MonadIO m => MonadIO (PhasedT m) where+ liftIO = PhasedT . liftM Right . liftIO++mapPhasedT :: Monad n => (m (Either (PhasedT m a) a) -> n (Either (PhasedT m a) b)) -> PhasedT m a -> PhasedT n b+mapPhasedT f (PhasedT x) = PhasedT $ return (either (Left . (mapPhasedT f)) Right) `ap` f x+
+ src/LLVM/General/AST.hs view
@@ -0,0 +1,53 @@+-- | This module and descendants define AST data types to represent LLVM code.+-- Note that these types are designed for fidelity rather than convenience - if the truth+-- of what LLVM supports is less than pretty, so be it.+module LLVM.General.AST (+ Module(..), defaultModule,+ Definition(..),+ Global(GlobalVariable, GlobalAlias, Function), + globalVariableDefaults,+ globalAliasDefaults,+ functionDefaults,+ Parameter(..),+ BasicBlock(..),+ module LLVM.General.AST.Instruction,+ module LLVM.General.AST.Name,+ module LLVM.General.AST.Operand,+ module LLVM.General.AST.Type+ ) where++import LLVM.General.AST.Name+import LLVM.General.AST.Type+import LLVM.General.AST.Global+import LLVM.General.AST.Operand+import LLVM.General.AST.Instruction+import LLVM.General.AST.DataLayout++-- | Any thing which can be at the top level of a 'Module'+data Definition + = GlobalDefinition Global+ | TypeDefinition Name (Maybe Type)+ | MetadataNodeDefinition MetadataNodeID [Operand]+ | NamedMetadataDefinition String [MetadataNodeID]+ | ModuleInlineAssembly String+ deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#modulestructure>+data Module = + Module {+ moduleName :: String,+ -- | a 'DataLayout', if specified, must match that of the eventual code generator+ moduleDataLayout :: Maybe DataLayout, + moduleTargetTriple :: Maybe String,+ moduleDefinitions :: [Definition]+ } + deriving (Eq, Read, Show)++-- | helper for making 'Module's+defaultModule = + Module {+ moduleName = "<string>",+ moduleDataLayout = Nothing,+ moduleTargetTriple = Nothing,+ moduleDefinitions = []+ }
+ src/LLVM/General/AST/AddrSpace.hs view
@@ -0,0 +1,8 @@+-- | Pointers exist in Address Spaces +module LLVM.General.AST.AddrSpace where++import Data.Word++-- | See <http://llvm.org/docs/LangRef.html#pointer-type>+data AddrSpace = AddrSpace Word32+ deriving (Eq, Ord, Read, Show)
+ src/LLVM/General/AST/Attribute.hs view
@@ -0,0 +1,38 @@+-- | Module to allow importing 'Attribute' distinctly qualified.+module LLVM.General.AST.Attribute where++import Data.Word++-- | <http://llvm.org/docs/LangRef.html#parameter-attributes>+data ParameterAttribute+ = ZeroExt+ | SignExt+ | InReg+ | SRet+ | NoAlias+ | ByVal+ | NoCapture+ | Nest+ deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#function-attributes>+data FunctionAttribute+ = NoReturn+ | NoUnwind+ | ReadNone+ | ReadOnly+ | NoInline+ | AlwaysInline+ | OptimizeForSize+ | StackProtect+ | StackProtectReq+ | Alignment Word32+ | NoRedZone+ | NoImplicitFloat+ | Naked+ | InlineHint+ | StackAlignment Word32+ | ReturnsTwice+ | UWTable+ | NonLazyBind+ deriving (Eq, Read, Show)
+ src/LLVM/General/AST/CallingConvention.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-}+-- | Module to allow importing 'CallingConvention' distinctly qualified.+module LLVM.General.AST.CallingConvention where++import Data.Data+import Data.Word++-- | <http://llvm.org/docs/LangRef.html#callingconv>+data CallingConvention = C | Fast | Cold | GHC | Numbered Word32+ deriving (Eq, Read, Show, Typeable, Data)+
+ src/LLVM/General/AST/Constant.hs view
@@ -0,0 +1,218 @@+-- | A representation of LLVM constants+module LLVM.General.AST.Constant where++import Data.Word (Word32)+import Data.Bits ((.|.), (.&.), complement, testBit, shiftL)++import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate)+import LLVM.General.AST.IntegerPredicate (IntegerPredicate)+import qualified LLVM.General.AST.Float as F++{- |+<http://llvm.org/docs/LangRef.html#constants>++N.B. - <http://llvm.org/docs/LangRef.html#constant-expressions>++Although constant expressions and instructions have many similarites, there are important+differences - so they're represented using different types in this AST. At the cost of making it+harder to move an code back and forth between being constant and not, this approach embeds more of+the rules of what IR is legal into the Haskell types.+-} +data Constant+ = Int { integerBits :: Word32, integerValue :: Integer }+ | Float { floatValue :: F.SomeFloat }+ | Null { constantType :: Type }+ | Struct { isPacked :: Bool, memberValues :: [ Constant ] }+ | Array { memberType :: Type, memberValues :: [ Constant ] }+ | Vector { memberValues :: [ Constant ] }+ | Undef { constantType :: Type }+ | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name }+ | GlobalReference Name + | Add { + operand0 :: Constant,+ operand1 :: Constant+ }+ | FAdd {+ operand0 :: Constant,+ operand1 :: Constant+ }+ | Sub {+ operand0 :: Constant,+ operand1 :: Constant+ }+ | FSub { + operand0 :: Constant, + operand1 :: Constant+ }+ | Mul { + operand0 :: Constant, + operand1 :: Constant+ }+ | FMul { + operand0 :: Constant, + operand1 :: Constant+ }+ | UDiv { + operand0 :: Constant, + operand1 :: Constant+ }+ | SDiv { + operand0 :: Constant, + operand1 :: Constant+ }+ | FDiv { + operand0 :: Constant, + operand1 :: Constant+ }+ | URem { + operand0 :: Constant, + operand1 :: Constant+ }+ | SRem { + operand0 :: Constant, + operand1 :: Constant+ }+ | FRem { + operand0 :: Constant, + operand1 :: Constant+ }+ | Shl { + operand0 :: Constant, + operand1 :: Constant+ }+ | LShr { + operand0 :: Constant, + operand1 :: Constant+ }+ | AShr { + operand0 :: Constant, + operand1 :: Constant+ }+ | And { + operand0 :: Constant, + operand1 :: Constant+ }+ | Or { + operand0 :: Constant, + operand1 :: Constant+ }+ | Xor { + operand0 :: Constant, + operand1 :: Constant+ }+ | GetElementPtr { + inBounds :: Bool,+ address :: Constant,+ indices :: [Constant]+ }+ | Trunc { + operand0 :: Constant,+ type' :: Type+ }+ | ZExt {+ operand0 :: Constant,+ type' :: Type+ }+ | SExt {+ operand0 :: Constant,+ type' :: Type+ }+ | FPToUI {+ operand0 :: Constant,+ type' :: Type+ }+ | FPToSI {+ operand0 :: Constant,+ type' :: Type+ }+ | UIToFP {+ operand0 :: Constant,+ type' :: Type+ }+ | SIToFP {+ operand0 :: Constant,+ type' :: Type+ }+ | FPTrunc {+ operand0 :: Constant,+ type' :: Type+ }+ | FPExt {+ operand0 :: Constant,+ type' :: Type+ }+ | PtrToInt {+ operand0 :: Constant,+ type' :: Type+ }+ | IntToPtr {+ operand0 :: Constant,+ type' :: Type+ }+ | BitCast {+ operand0 :: Constant,+ type' :: Type+ }+ | ICmp {+ iPredicate :: IntegerPredicate,+ operand0 :: Constant,+ operand1 :: Constant+ }+ | FCmp {+ fpPredicate :: FloatingPointPredicate,+ operand0 :: Constant,+ operand1 :: Constant+ }+ | Select { + condition' :: Constant,+ trueValue :: Constant,+ falseValue :: Constant+ }+ | ExtractElement { + vector :: Constant,+ index :: Constant+ }+ | InsertElement { + vector :: Constant,+ element :: Constant,+ index :: Constant+ }+ | ShuffleVector { + operand0 :: Constant,+ operand1 :: Constant,+ mask :: Constant+ }+ | ExtractValue { + aggregate :: Constant,+ indices' :: [Word32]+ }+ | InsertValue { + aggregate :: Constant,+ element :: Constant,+ indices' :: [Word32]+ }+ deriving (Eq, Ord, Read, Show)+++-- | Since LLVM types don't include signedness, there's ambiguity in interpreting+-- an constant as an Integer. The LLVM assembly printer prints integers as signed, but+-- cheats for 1-bit integers and prints them as 'true' or 'false'. That way it circuments the+-- otherwise awkward fact that a twos complement 1-bit number only has the values -1 and 0.+signedIntegerValue :: Constant -> Integer+signedIntegerValue (Int nBits' bits) =+ let nBits = fromIntegral nBits'+ in+ if bits `testBit` (nBits - 1) then bits .|. (-1 `shiftL` nBits) else bits++-- | This library's conversion from LLVM C++ objects will always produce integer constants+-- as unsigned, so this function in many cases is not necessary. However, nothing's to keep+-- stop direct construction of an 'Int' with a negative 'integerValue'. There's nothing in principle+-- wrong with such a value - it has perfectly good low order bits like any integer, and will be used+-- as such, likely producing the intended result if lowered to C++. If, however one wishes to interpret+-- an 'Int' of unknown provenance as unsigned, then this function will serve.+unsignedIntegerValue :: Constant -> Integer+unsignedIntegerValue (Int nBits bits) =+ bits .&. (complement (-1 `shiftL` (fromIntegral nBits)))+
+ src/LLVM/General/AST/DataLayout.hs view
@@ -0,0 +1,51 @@+-- | <http://llvm.org/docs/LangRef.html#data-layout>+module LLVM.General.AST.DataLayout where++import Data.Word++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)++import LLVM.General.AST.AddrSpace++-- | Little Endian is the one true way :-). Sadly, we must support the infidels.+data Endianness = LittleEndian | BigEndian+ deriving (Eq, Ord, Read, Show)++-- | An AlignmentInfo describes how a given type must and would best be aligned+data AlignmentInfo = AlignmentInfo {+ abiAlignment :: Word32,+ preferredAlignment :: Word32+ }+ deriving (Eq, Ord, Read, Show)++-- | A type of type for which 'AlignmentInfo' may be specified+data AlignType+ = IntegerAlign+ | VectorAlign+ | FloatAlign+ | AggregateAlign+ | StackAlign+ deriving (Eq, Ord, Read, Show)++-- | a description of the various data layout properties which may be used during+-- optimization+data DataLayout = DataLayout {+ endianness :: Maybe Endianness,+ stackAlignment :: Maybe Word32,+ pointerLayouts :: Map AddrSpace (Word32, AlignmentInfo),+ typeLayouts :: Map (AlignType, Word32) AlignmentInfo,+ nativeSizes :: Maybe (Set Word32)+ }+ deriving (Eq, Ord, Read, Show)++-- | a 'DataLayout' which specifies nothing+defaultDataLayout = DataLayout {+ endianness = Nothing,+ stackAlignment = Nothing,+ pointerLayouts = Map.empty,+ typeLayouts = Map.empty,+ nativeSizes = Nothing+ }+
+ src/LLVM/General/AST/Float.hs view
@@ -0,0 +1,19 @@+-- | This module provides a sub-namespace for a type to support the various sizes of floating point+-- numbers LLVM supports. It is most definitely intended to be imported qualified.+module LLVM.General.AST.Float where++import Prelude as P+import Data.Word (Word16, Word64)++-- | A type summing up the various float types.+-- N.B. Note that in the constructors with multiple fields, the lower significance bits are on the right+-- - e.g. Quadruple highbits lowbits+data SomeFloat+ = Half Word16 + | Single Float+ | Double P.Double+ | Quadruple Word64 Word64+ | X86_FP80 Word16 Word64+ | PPC_FP128 Word64 Word64+ deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/AST/FloatingPointPredicate.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE+ DeriveDataTypeable + #-} +-- | Predicates for the 'LLVM.General.AST.Instruction.FCmp' instruction+module LLVM.General.AST.FloatingPointPredicate where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#fcmp-instruction>+data FloatingPointPredicate+ = False+ | OEQ+ | OGT+ | OGE+ | OLT+ | OLE+ | ONE+ | ORD+ | UNO+ | UEQ+ | UGT+ | UGE+ | ULT+ | ULE+ | UNE+ | True+ deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Global.hs view
@@ -0,0 +1,109 @@+-- | 'Global's - top-level values in 'Module's - and supporting structures.+module LLVM.General.AST.Global where++import Data.Word++import LLVM.General.AST.Name+import LLVM.General.AST.Type+import LLVM.General.AST.Constant (Constant)+import LLVM.General.AST.AddrSpace+import LLVM.General.AST.Instruction (Named, Instruction, Terminator)+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalValue.html>+data Global+ -- | <http://llvm.org/docs/LangRef.html#global-variables>+ = GlobalVariable {+ name :: Name,+ linkage :: L.Linkage,+ visibility :: V.Visibility,+ isThreadLocal :: Bool,+ addrSpace :: AddrSpace,+ hasUnnamedAddr :: Bool,+ isConstant :: Bool,+ type' :: Type,+ initializer :: Maybe Constant,+ section :: Maybe String,+ alignment :: Word32+ }+ -- | <http://llvm.org/docs/LangRef.html#aliases>+ | GlobalAlias {+ name :: Name,+ linkage :: L.Linkage,+ visibility :: V.Visibility,+ type' :: Type,+ aliasee :: Constant+ }+ -- | <http://llvm.org/docs/LangRef.html#functions>+ | Function {+ linkage :: L.Linkage,+ visibility :: V.Visibility,+ callingConvention :: CC.CallingConvention,+ returnAttributes :: [A.ParameterAttribute],+ returnType :: Type,+ name :: Name,+ parameters :: ([Parameter],Bool),+ functionAttributes :: [A.FunctionAttribute],+ section :: Maybe String,+ alignment :: Word32,+ basicBlocks :: [BasicBlock]+ }+ deriving (Eq, Read, Show)++-- | 'Parameter's for 'Function's+data Parameter = Parameter Type Name [A.ParameterAttribute]+ deriving (Eq, Read, Show)++-- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html>+-- LLVM code in a function is a sequence of 'BasicBlock's each with a label,+-- some instructions, and a terminator.+data BasicBlock = BasicBlock Name [Named Instruction] (Named Terminator)+ deriving (Eq, Read, Show)++-- | helper for making 'GlobalVariable's+globalVariableDefaults :: Global+globalVariableDefaults = + GlobalVariable {+ name = undefined,+ linkage = L.External,+ visibility = V.Default,+ isThreadLocal = False,+ addrSpace = AddrSpace 0,+ hasUnnamedAddr = False,+ isConstant = False,+ type' = undefined,+ initializer = Nothing,+ section = Nothing,+ alignment = 0+ }++-- | helper for making 'GlobalAlias's+globalAliasDefaults :: Global+globalAliasDefaults =+ GlobalAlias {+ name = undefined,+ linkage = L.External,+ visibility = V.Default,+ type' = undefined,+ aliasee = undefined+ }++-- | helper for making 'Function's+functionDefaults :: Global+functionDefaults = + Function {+ linkage = L.External,+ visibility = V.Default,+ callingConvention = CC.C,+ returnAttributes = [],+ returnType = undefined,+ name = undefined,+ parameters = undefined,+ functionAttributes = [],+ section = Nothing,+ alignment = 0,+ basicBlocks = []+ }
+ src/LLVM/General/AST/InlineAssembly.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-}+-- | A representation of an LLVM inline assembly+module LLVM.General.AST.InlineAssembly where++import Data.Data++import LLVM.General.AST.Type++-- | the dialect of assembly used in an inline assembly string+-- <http://en.wikipedia.org/wiki/X86_assembly_language#Syntax>+data Dialect+ = ATTDialect+ | IntelDialect+ deriving (Eq, Read, Show, Typeable, Data)++-- | <http://llvm.org/docs/LangRef.html#inline-assembler-expressions>+-- to be used through 'LLVM.General.AST.Operand.CallableOperand' with a+-- 'LLVM.General.AST.Instruction.Call' instruction+data InlineAssembly+ = InlineAssembly {+ type' :: Type,+ assembly :: String,+ constraints :: String,+ hasSideEffects :: Bool,+ alignStack :: Bool,+ dialect :: Dialect+ }+ deriving (Eq, Read, Show)
+ src/LLVM/General/AST/Instruction.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-}+-- | LLVM instructions +-- <http://llvm.org/docs/LangRef.html#instruction-reference>+module LLVM.General.AST.Instruction where++import Data.Data+import Data.Word++import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.Constant+import LLVM.General.AST.Operand+import LLVM.General.AST.IntegerPredicate (IntegerPredicate)+import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate)+import LLVM.General.AST.RMWOperation (RMWOperation)+import LLVM.General.AST.CallingConvention (CallingConvention)+import LLVM.General.AST.Attribute (ParameterAttribute, FunctionAttribute)++-- | <http://llvm.org/docs/LangRef.html#metadata-nodes-and-metadata-strings>+-- Metadata can be attached to an instruction+type InstructionMetadata = [(String, MetadataNode)]++-- | <http://llvm.org/docs/LangRef.html#terminators>+data Terminator + = Ret { + returnOperand :: Maybe Operand,+ metadata' :: InstructionMetadata+ }+ | CondBr { + condition :: Operand, + trueDest :: Name, + falseDest :: Name,+ metadata' :: InstructionMetadata+ }+ | Br { + dest :: Name,+ metadata' :: InstructionMetadata+ }+ | Switch {+ operand0' :: Operand,+ defaultDest :: Name,+ dests :: [(Constant, Name)],+ metadata' :: InstructionMetadata+ }+ | IndirectBr {+ operand0' :: Operand,+ possibleDests :: [Name],+ metadata' :: InstructionMetadata+ }+ | Invoke {+ callingConvention' :: CallingConvention,+ returnAttributes' :: [ParameterAttribute],+ function' :: CallableOperand,+ arguments' :: [(Operand, [ParameterAttribute])],+ functionAttributes' :: [FunctionAttribute],+ returnDest :: Name,+ exceptionDest :: Name,+ metadata' :: InstructionMetadata+ }+ | Resume {+ operand0' :: Operand,+ metadata' :: InstructionMetadata+ }+ | Unreachable {+ metadata' :: InstructionMetadata+ }+ deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#atomic-memory-ordering-constraints>+-- <http://llvm.org/docs/Atomics.html>+data MemoryOrdering+ = Unordered+ | Monotonic+ | Acquire+ | Release+ | AcquireRelease+ | SequentiallyConsistent+ deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction+data Atomicity = Atomicity { + crossThread :: Bool, -- ^ <http://llvm.org/docs/LangRef.html#singlethread>+ memoryOrdering :: MemoryOrdering+ }+ deriving (Eq, Ord, Read, Show)++-- | For the redoubtably complex 'LandingPad' instruction+data LandingPadClause+ = Catch Constant+ | Filter Constant+ deriving (Eq, Ord, Read, Show)++-- | non-terminator instructions:+-- <http://llvm.org/docs/LangRef.html#binaryops>+-- <http://llvm.org/docs/LangRef.html#bitwiseops>+-- <http://llvm.org/docs/LangRef.html#memoryops>+-- <http://llvm.org/docs/LangRef.html#otherops>+data Instruction+ = Add { + nsw :: Bool,+ nuw :: Bool,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FAdd {+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | Sub {+ nsw :: Bool,+ nuw :: Bool,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FSub { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Mul { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata + }+ | FMul { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | UDiv { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | SDiv { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | FDiv { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | URem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | SRem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | FRem { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Shl { + nsw :: Bool, + nuw :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | LShr { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | AShr { + exact :: Bool, + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | And { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Or { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Xor { + operand0 :: Operand, + operand1 :: Operand, + metadata :: InstructionMetadata+ }+ | Alloca { + allocatedType :: Type,+ numElements :: Maybe Operand,+ alignment :: Word32,+ metadata :: InstructionMetadata+ }+ | Load {+ volatile :: Bool, + address :: Operand,+ maybeAtomicity :: Maybe Atomicity,+ alignment :: Word32,+ metadata :: InstructionMetadata+ }+ | Store {+ volatile :: Bool, + address :: Operand,+ value :: Operand,+ maybeAtomicity :: Maybe Atomicity,+ alignment :: Word32,+ metadata :: InstructionMetadata+ }+ | GetElementPtr { + inBounds :: Bool,+ address :: Operand,+ indices :: [Operand],+ metadata :: InstructionMetadata+ }+ | Fence { + atomicity :: Atomicity,+ metadata :: InstructionMetadata + }+ | CmpXchg { + volatile :: Bool,+ address :: Operand,+ expected :: Operand,+ replacement :: Operand,+ atomicity :: Atomicity,+ metadata :: InstructionMetadata + }+ | AtomicRMW { + volatile :: Bool,+ rmwOperation :: RMWOperation,+ address :: Operand,+ value :: Operand,+ atomicity :: Atomicity,+ metadata :: InstructionMetadata + }+ | Trunc { + operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata + }+ | ZExt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata + }+ | SExt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPToUI {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPToSI {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | UIToFP {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | SIToFP {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPTrunc {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | FPExt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | PtrToInt {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | IntToPtr {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | BitCast {+ operand0 :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata+ }+ | ICmp {+ iPredicate :: IntegerPredicate,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | FCmp {+ fpPredicate :: FloatingPointPredicate,+ operand0 :: Operand,+ operand1 :: Operand,+ metadata :: InstructionMetadata+ }+ | Phi {+ type' :: Type,+ incomingValues :: [ (Operand, Name) ],+ metadata :: InstructionMetadata+ } + | Call {+ isTailCall :: Bool,+ callingConvention :: CallingConvention,+ returnAttributes :: [ParameterAttribute],+ function :: CallableOperand,+ arguments :: [(Operand, [ParameterAttribute])],+ functionAttributes :: [FunctionAttribute],+ metadata :: InstructionMetadata+ }+ | Select { + condition' :: Operand,+ trueValue :: Operand,+ falseValue :: Operand,+ metadata :: InstructionMetadata+ }+ | VAArg { + argList :: Operand,+ type' :: Type,+ metadata :: InstructionMetadata + }+ | ExtractElement { + vector :: Operand,+ index :: Operand,+ metadata :: InstructionMetadata + }+ | InsertElement { + vector :: Operand,+ element :: Operand,+ index :: Operand,+ metadata :: InstructionMetadata+ }+ | ShuffleVector { + operand0 :: Operand,+ operand1 :: Operand,+ mask :: Constant,+ metadata :: InstructionMetadata+ }+ | ExtractValue { + aggregate :: Operand,+ indices' :: [Word32],+ metadata :: InstructionMetadata+ }+ | InsertValue { + aggregate :: Operand,+ element :: Operand,+ indices' :: [Word32],+ metadata :: InstructionMetadata+ }+ | LandingPad { + type' :: Type,+ personalityFunction :: Operand,+ cleanup :: Bool,+ clauses :: [LandingPadClause],+ metadata :: InstructionMetadata + }+ deriving (Eq, Read, Show)++-- | Instances of instructions may be given a name, allowing their results to be referenced as 'Operand's.+-- Sometimes instructions - e.g. a call to a function returning void - don't need names.+data Named a + = Name := a+ | Do a+ deriving (Eq, Read, Show)
+ src/LLVM/General/AST/IntegerPredicate.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE+ DeriveDataTypeable + #-} +-- | Predicates for the 'LLVM.General.AST.Instruction.ICmp' instruction+module LLVM.General.AST.IntegerPredicate where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#icmp-instruction>+data IntegerPredicate+ = EQ+ | NE+ | UGT+ | UGE+ | ULT+ | ULE+ | SGT+ | SGE+ | SLT+ | SLE+ deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Linkage.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-}+ +-- | Module to allow importing 'Linkage' distinctly qualified.+module LLVM.General.AST.Linkage where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#linkage>+data Linkage+ = Private+ | LinkerPrivate+ | LinkerPrivateWeak+ | Internal+ | AvailableExternally+ | LinkOnce+ | Weak+ | Common+ | Appending+ | ExternWeak+ | LinkOnceODR+ | WeakODR+ | External+ | DLLImport+ | DLLExport+ deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/AST/Name.hs view
@@ -0,0 +1,31 @@+-- | Names as used in LLVM IR+module LLVM.General.AST.Name where++import Data.Word++{- |+Objects of various sorts in LLVM IR are identified by address in the LLVM C++ API, and+may be given a string name. When printed to (resp. read from) human-readable LLVM assembly, objects without+string names are numbered sequentially (resp. must be numbered sequentially). String names may be quoted, and+are quoted when printed if they would otherwise be misread - e.g. when containing special characters. ++> 7++means the seventh unnamed object, while++> "7"++means the object named with the string "7".++This libraries handling of 'UnName's during translation of the AST down into C++ IR is somewhat more+forgiving than the LLVM assembly parser: it does not require that unnamed values be numbered sequentially;+however, the numbers of 'UnName's passed into C++ cannot be preserved in the C++ objects. If the C++ IR is+printed as assembly or translated into a Haskell AST, unnamed nodes will be renumbered sequentially. Thus+unnamed node numbers should be thought of as having any scope limited to the 'LLVM.General.AST.Module' in+which they are used.+-}+data Name + = Name String -- ^ a string name + | UnName Word -- ^ a number for a nameless thing+ deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/AST/Operand.hs view
@@ -0,0 +1,33 @@+-- | A type to represent operands to LLVM 'LLVM.General.AST.Instruction.Instruction's+module LLVM.General.AST.Operand where+ +import Data.Word++import LLVM.General.AST.Name+import LLVM.General.AST.Constant+import LLVM.General.AST.InlineAssembly++-- | A 'MetadataNodeID' is a number for identifying a metadata node.+-- Note this is different from "named metadata", which are represented with+-- 'LLVM.General.AST.NamedMetadataDefinition'.+newtype MetadataNodeID = MetadataNodeID Word+ deriving (Eq, Ord, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#metadata>+data MetadataNode + = MetadataNode [Operand]+ | MetadataNodeReference MetadataNodeID+ deriving (Eq, Ord, Read, Show)++-- | An 'Operand' is roughly that which is an argument to an 'LLVM.General.AST.Instruction.Instruction'+data Operand + -- | %foo+ = LocalReference Name+ -- | 'Constant's include 'LLVM.General.AST.Constant.GlobalReference', for \@foo+ | ConstantOperand Constant+ | MetadataStringOperand String+ | MetadataNodeOperand MetadataNode+ deriving (Eq, Ord, Read, Show)++-- | The 'LLVM.General.AST.Instruction.Call' instruction is special: the callee can be inline assembly+type CallableOperand = Either InlineAssembly Operand
+ src/LLVM/General/AST/RMWOperation.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE+ DeriveDataTypeable + #-} +-- | Operations for the 'LLVM.General.AST.Instruction.AtomicRMW' instruction+module LLVM.General.AST.RMWOperation where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#atomicrmw-instruction>+data RMWOperation+ = Xchg+ | Add+ | Sub+ | And+ | Nand+ | Or+ | Xor+ | Max+ | Min+ | UMax+ | UMin+ deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Type.hs view
@@ -0,0 +1,40 @@+-- | A representation of an LLVM type+module LLVM.General.AST.Type where++import LLVM.General.AST.AddrSpace+import LLVM.General.AST.Name++import Data.Word (Word32, Word64)++-- | LLVM supports some special formats floating point format. This type is to distinguish those format.+-- I believe it's treated as a format for "a" float, as opposed to a vector of two floats, because+-- its intended usage is to represent a single number with a combined significand.+data FloatingPointFormat+ = IEEE+ | DoubleExtended+ | PairOfFloats+ deriving (Eq, Ord, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#type-system>+data Type+ -- | <http://llvm.org/docs/LangRef.html#void-type>+ = VoidType+ -- | <http://llvm.org/docs/LangRef.html#integer-type>+ | IntegerType { typeBits :: Word32 }+ -- | <http://llvm.org/docs/LangRef.html#pointer-type>+ | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace }+ -- | <http://llvm.org/docs/LangRef.html#floating-point-types>+ | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat }+ -- | <http://llvm.org/docs/LangRef.html#function-type>+ | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool }+ -- | <http://llvm.org/docs/LangRef.html#vector-type>+ | VectorType { nVectorElements :: Word32, elementType :: Type }+ -- | <http://llvm.org/docs/LangRef.html#structure-type>+ | StructureType { isPacked :: Bool, elementTypes :: [Type] }+ -- | <http://llvm.org/docs/LangRef.html#array-type>+ | ArrayType { nArrayElements :: Word64, elementType :: Type }+ -- | <http://llvm.org/docs/LangRef.html#opaque-structure-types>+ | NamedTypeReference Name+ -- | <http://llvm.org/docs/LangRef.html#metadata-type>+ | MetadataType -- only to be used as a parameter type for a few intrinsics+ deriving (Eq, Ord, Read, Show)
+ src/LLVM/General/AST/Visibility.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-}+-- | Module to allow importing 'Visibility' distinctly qualified.+module LLVM.General.AST.Visibility where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#visibility>+data Visibility = Default | Hidden | Protected+ deriving (Eq, Read, Show, Typeable, Data)
− src/LLVM/General/Analysis.hs
@@ -1,8 +0,0 @@--- | functionality for analyzing 'LLVM.General.Module.Module's. Much of the analysis--- possible with LLVM is managed internally, as needed by 'Transforms', and so is not--- yet exposed here.-module LLVM.General.Analysis (- verify- ) where--import LLVM.General.Internal.Analysis
src/LLVM/General/CodeGenOpt.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-} -- | Code generation options, used in specifying TargetMachine module LLVM.General.CodeGenOpt where
src/LLVM/General/CodeModel.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-} -- | Relocations, used in specifying TargetMachine module LLVM.General.CodeModel where
src/LLVM/General/Diagnostic.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-} -- | Diagnostics describe parse errors module LLVM.General.Diagnostic ( DiagnosticKind(..),
src/LLVM/General/ExecutionEngine.hs view
@@ -1,8 +1,9 @@ -- | Tools for JIT execution module LLVM.General.ExecutionEngine (- ExecutionEngine(..),- ExecutableModule,- JIT, withJIT+ ExecutionEngine,+ withExecutionEngine,+ withModuleInEngine,+ findFunction ) where import LLVM.General.Internal.ExecutionEngine
− src/LLVM/General/Internal/Analysis.hs
@@ -1,19 +0,0 @@-module LLVM.General.Internal.Analysis where--import Control.Monad.Error-import Control.Monad.AnyCont--import qualified LLVM.General.Internal.FFI.Analysis as FFI-import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI--import LLVM.General.Internal.Module-import LLVM.General.Internal.Coding---- | 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- errorPtr <- alloca- result <- decodeM =<< (liftIO $ FFI.verifyModule m FFI.verifierFailureActionReturnStatus errorPtr)- when result $ fail =<< decodeM errorPtr-
src/LLVM/General/Internal/Atomicity.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances #-}+ module LLVM.General.Internal.Atomicity where import Control.Monad@@ -14,7 +16,7 @@ import qualified LLVM.General.AST as A -genCodingInstance [t| Maybe A.MemoryOrdering |] ''FFI.MemoryOrdering [+genCodingInstance' [t| Maybe A.MemoryOrdering |] ''FFI.MemoryOrdering [ (FFI.memoryOrderingNotAtomic, Nothing), (FFI.memoryOrderingUnordered, Just A.Unordered), (FFI.memoryOrderingMonotonic, Just A.Monotonic),
src/LLVM/General/Internal/Attribute.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses,- ConstraintKinds+ FlexibleInstances #-}+ module LLVM.General.Internal.Attribute where import Language.Haskell.TH
src/LLVM/General/Internal/BasicBlock.hs view
@@ -2,6 +2,7 @@ import Control.Monad import Control.Monad.Trans+import Control.Monad.Phased import Foreign.Ptr import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI@@ -14,13 +15,13 @@ import qualified LLVM.General.AST.Instruction as A -getBasicBlockTerminator :: Ptr FFI.BasicBlock -> DecodeAST (DecodeAST (A.Named A.Terminator))+getBasicBlockTerminator :: Ptr FFI.BasicBlock -> DecodeAST (A.Named A.Terminator) getBasicBlockTerminator = decodeM <=< (liftIO . FFI.getBasicBlockTerminator) -getNamedInstructions :: Ptr FFI.BasicBlock -> DecodeAST (DecodeAST [A.Named A.Instruction])+getNamedInstructions :: Ptr FFI.BasicBlock -> DecodeAST [A.Named A.Instruction] getNamedInstructions b = do ffiInstructions <- liftIO $ FFI.getXs (FFI.getFirstInstruction b) FFI.getNextInstruction let n = length ffiInstructions- liftM sequence . forM (take (n-1) ffiInstructions) $ decodeM+ forInterleavedM (take (n-1) ffiInstructions) $ decodeM
src/LLVM/General/Internal/CallingConvention.hs view
@@ -1,15 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses, TemplateHaskell,- QuasiQuotes+ QuasiQuotes,+ FlexibleInstances #-} module LLVM.General.Internal.CallingConvention where 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 qualified LLVM.General.AST.CallingConvention as A.CC @@ -24,8 +23,8 @@ instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallConv 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)+ [FFI.callConvP|C|] -> A.CC.C+ [FFI.callConvP|Fast|] -> A.CC.Fast+ [FFI.callConvP|Cold|] -> A.CC.Cold+ FFI.CallConv 10 -> A.CC.GHC+ FFI.CallConv ci | ci >= 64 -> A.CC.Numbered (fromIntegral ci)
src/LLVM/General/Internal/Coding.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE TemplateHaskell,+ FlexibleInstances,+ FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances@@ -9,12 +11,11 @@ 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.Word (Word32, Word64) import Data.Int (Int32) import Foreign.C@@ -31,12 +32,28 @@ class DecodeM d h c where decodeM :: c -> d h -genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec]-genCodingInstance ht ctn chs = do+genCodingInstance :: Data h => TypeQ -> Name -> [(Integer, h)] -> Q [Dec]+genCodingInstance ht ctn ihs = do let n = const Nothing+ TyConI (NewtypeD _ _ _ (NormalC ctcn _) _) <- reify ctn [d| instance Monad m => EncodeM m $(ht) $(conT ctn) where encodeM h = return $ $(+ caseE [| h |] [ match (dataToPatQ n h) (normalB (appE (conE ctcn) (litE (integerL i)))) [] | (i,h) <- ihs ] + )++ instance Monad m => DecodeM m $(ht) $(conT ctn) where+ decodeM i = return $ $(+ caseE [| i |] [ match (conP ctcn [litP (integerL i)]) (normalB (dataToExpQ n h)) [] | (i,h) <- ihs ]+ )+ |]++genCodingInstance' :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec]+genCodingInstance' ht ctn chs = do+ let n = const Nothing+ [d| + instance Monad m => EncodeM m $(ht) $(conT ctn) where+ encodeM h = return $ $( caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] ) @@ -85,22 +102,6 @@ decodeM (FFI.LLVMBool 0) = return $ False decodeM (FFI.LLVMBool 1) = return $ True -instance (Monad m, EncodeM m h (Ptr c)) => EncodeM m (Maybe h) (Ptr c) where- encodeM = maybe (return nullPtr) encodeM--instance (Monad m, DecodeM m h (Ptr c)) => DecodeM m (Maybe h) (Ptr c) where- decodeM p | p == nullPtr = return Nothing- | otherwise = liftM Just $ decodeM p--instance Monad m => EncodeM m (Maybe Bool) (FFI.NothingAsMinusOne Bool) where- encodeM = return . FFI.NothingAsMinusOne . maybe (-1) (fromIntegral . fromEnum)--instance Monad m => EncodeM m (Maybe Word) (FFI.NothingAsMinusOne Word) where- encodeM = return . FFI.NothingAsMinusOne . maybe (-1) fromIntegral--instance Monad m => EncodeM m Word CUInt where- encodeM = return . fromIntegral- instance Monad m => EncodeM m Word32 CUInt where encodeM = return . fromIntegral @@ -122,8 +123,3 @@ instance Monad m => DecodeM m Int CInt where decodeM = return . fromIntegral -instance Monad m => EncodeM m Word64 Word64 where- encodeM = return--instance Monad m => DecodeM m Word64 Word64 where- decodeM = return
src/LLVM/General/Internal/Constant.hs view
@@ -1,7 +1,10 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes,+ TupleSections, MultiParamTypeClasses,+ FlexibleInstances,+ FlexibleContexts, ScopedTypeVariables #-} module LLVM.General.Internal.Constant where@@ -23,11 +26,10 @@ import qualified LLVM.General.Internal.FFI.Constant as FFI import qualified LLVM.General.Internal.FFI.GlobalValue as FFI import qualified LLVM.General.Internal.FFI.Instruction as FFI-import LLVM.General.Internal.FFI.LLVMCTypes (valueSubclassIdP)+import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.User as FFI import qualified LLVM.General.Internal.FFI.Value as FFI-import qualified LLVM.General.Internal.FFI.BinaryOperator as FFI import qualified LLVM.General.AST.Constant as A (Constant) import qualified LLVM.General.AST.Constant as A.C hiding (Constant)@@ -77,9 +79,15 @@ A.F.X86_FP80 high low -> poke2 high low A.F.Quadruple high low -> poke2 high low A.F.PPC_FP128 high low -> poke2 high low- notPairOfFloats <- encodeM $ case v of A.F.PPC_FP128 _ _ -> False; _ -> True+ let fpSem = case v of+ A.F.Half _ -> FFI.floatSemanticsIEEEhalf+ A.F.Single _ -> FFI.floatSemanticsIEEEsingle+ A.F.Double _ -> FFI.floatSemanticsIEEEdouble+ A.F.Quadruple _ _ -> FFI.floatSemanticsIEEEquad+ A.F.X86_FP80 _ _ -> FFI.floatSemanticsx87DoubleExtended+ A.F.PPC_FP128 _ _ -> FFI.floatSemanticsPPCDoubleDouble nBits <- encodeM nBits- liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words notPairOfFloats+ liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words fpSem A.C.GlobalReference n -> FFI.upCast <$> referGlobal n A.C.BlockAddress f b -> do f' <- referGlobal f@@ -93,25 +101,23 @@ o -> $(do let constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) TH.caseE [| o |] $ do- (name, (Just (TH.RecC n fs), instrInfo)) <- Map.toList constExprInfo- let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs ]+ (name, (Just (TH.RecC n fs'), instrInfo)) <- Map.toList constExprInfo+ let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs' ] coreCall n = TH.dyn $ "FFI.constant" ++ n buildBody c = [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fns ] ++ [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fns)) |] ]- hasFlags = any (== ''Bool) [ h | (_, _, TH.ConT h) <- fs ] core <- case instrInfo of Just (_, iDef) -> do let opcode = TH.dataToExpQ (const Nothing) (ID.cppOpcode iDef) case ID.instructionKind iDef of- ID.Binary | hasFlags -> return $ coreCall name- | True -> return [| $(coreCall "BinaryOperator") $(opcode) |]+ ID.Binary -> return [| $(coreCall "BinaryOperator") $(opcode) |] ID.Cast -> return [| $(coreCall "Cast") $(opcode) |] _ -> return $ coreCall name- Nothing -> if (name `elem` ["Vector", "Null", "Array", "Undef"])+ Nothing -> if (name `elem` ["Vector", "Null", "Array"]) then return $ coreCall name else [] return $ TH.match- (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs])+ (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs']) (TH.normalB (TH.doE (buildBody core))) [] )@@ -134,16 +140,16 @@ decodeM <=< liftIO . FFI.getConstantDataSequentialElementAsConstant c . fromIntegral case valueSubclassId of- [valueSubclassIdP|Function|] -> globalRef- [valueSubclassIdP|GlobalAlias|] -> globalRef- [valueSubclassIdP|GlobalVariable|] -> globalRef- [valueSubclassIdP|ConstantInt|] -> do+ [FFI.valueSubclassIdP|Function|] -> globalRef+ [FFI.valueSubclassIdP|GlobalAlias|] -> globalRef+ [FFI.valueSubclassIdP|GlobalVariable|] -> globalRef+ [FFI.valueSubclassIdP|ConstantInt|] -> do np <- alloca wsp <- liftIO $ FFI.getConstantIntWords c np n <- peek np words <- decodeM (n, wsp) return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral (b :: Word64)) 0 words)- [valueSubclassIdP|ConstantFP|] -> do+ [FFI.valueSubclassIdP|ConstantFP|] -> do let A.FloatingPointType nBits fmt = t ws <- allocaWords nBits liftIO $ FFI.getConstantFloatWords c ws@@ -157,22 +163,22 @@ (128, A.PairOfFloats) -> A.F.PPC_FP128 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0 _ -> error $ "don't know how to decode floating point constant of type: " ++ show t )- [valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t- [valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t- [valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t- [valueSubclassIdP|BlockAddress|] -> + [FFI.valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t+ [FFI.valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t+ [FFI.valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t+ [FFI.valueSubclassIdP|BlockAddress|] -> return A.C.BlockAddress `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c) `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c)- [valueSubclassIdP|ConstantStruct|] -> + [FFI.valueSubclassIdP|ConstantStruct|] -> return A.C.Struct `ap` (return $ A.isPacked t) `ap` getConstantOperands- [valueSubclassIdP|ConstantDataArray|] -> + [FFI.valueSubclassIdP|ConstantDataArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData- [valueSubclassIdP|ConstantArray|] -> + [FFI.valueSubclassIdP|ConstantArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantOperands- [valueSubclassIdP|ConstantDataVector|] -> + [FFI.valueSubclassIdP|ConstantDataVector|] -> return A.C.Vector `ap` getConstantData- [valueSubclassIdP|ConstantExpr|] -> do+ [FFI.valueSubclassIdP|ConstantExpr|] -> do cppOpcode <- liftIO $ FFI.getConstantCPPOpcode c $( TH.caseE [| cppOpcode |] $ do@@ -192,10 +198,6 @@ return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |] | h == ''Bool -> case TH.nameBase fn of "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |]- "exact" -> return [| liftIO $ decodeM =<< FFI.isExact v |]- "nsw" -> return [| liftIO $ decodeM =<< FFI.hasNoSignedWrap v |]- "nuw" -> return [| liftIO $ decodeM =<< FFI.hasNoUnsignedWrap v |]- x -> error $ "constant bool field " ++ show x ++ " not handled yet" TH.AppT TH.ListT (TH.ConT h) | h == ''Word32 -> return [|
src/LLVM/General/Internal/DataLayout.hs view
@@ -1,21 +1,88 @@ module LLVM.General.Internal.DataLayout where -import Control.Monad.Error-import Control.Monad.AnyCont-import Control.Exception+import Text.ParserCombinators.Parsec -import Foreign.Ptr+import Data.Word+import Data.Functor -import qualified LLVM.General.Internal.FFI.DataLayout as FFI+import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set import LLVM.General.AST.DataLayout-import LLVM.General.DataLayout--import LLVM.General.Internal.Coding-import LLVM.General.Internal.String ()+import LLVM.General.AST.AddrSpace -withFFIDataLayout :: DataLayout -> (Ptr FFI.DataLayout -> IO a) -> IO a-withFFIDataLayout dl f = flip runAnyContT return $ do- dls <- encodeM (dataLayoutToString dl)- liftIO $ bracket (FFI.createDataLayout dls) FFI.disposeDataLayout f+dataLayoutToString :: DataLayout -> String+dataLayoutToString dl = + let sTriple :: (Word32, AlignmentInfo) -> String+ sTriple (s, ai) = show s ++ ":" ++ show (abiAlignment ai) ++ ":" ++ show (preferredAlignment ai)+ atChar at = case at of+ IntegerAlign -> "i"+ VectorAlign -> "v"+ FloatAlign -> "f"+ AggregateAlign -> "a"+ StackAlign -> "s"+ in+ List.intercalate "-" (+ (case endianness dl of Just BigEndian -> ["E"]; Just LittleEndian -> ["e"]; _ -> [])+ +++ (maybe [] (\s -> ["S" ++ show s]) (stackAlignment dl))+ +++ [ "p" ++ show a ++ ":" ++ sTriple t | (AddrSpace a, t) <- Map.toList . pointerLayouts $ dl]+ +++ [ atChar at ++ sTriple (s, ai) | ((at, s), ai) <- Map.toList . typeLayouts $ dl ]+ ++ + (maybe [] (\ns -> ["n" ++ (List.intercalate ":" (map show . Set.toList $ ns))]) (nativeSizes dl))+ ) +parseDataLayout :: String -> Maybe DataLayout+parseDataLayout "" = Nothing+parseDataLayout s = + let+ num :: Parser Word32+ num = read <$> many digit+ triple :: Parser (Word32, AlignmentInfo)+ triple = do+ s <- num+ char ':'+ abi <- num+ char ':'+ pref <- num+ return (s, (AlignmentInfo abi pref))+ parseSpec :: Parser (DataLayout -> DataLayout)+ parseSpec = choice [+ do+ char 'e'+ return $ \dl -> dl { endianness = Just LittleEndian },+ do+ char 'E' + return $ \dl -> dl { endianness = Just BigEndian },+ do+ char 'S'+ n <- num+ return $ \dl -> dl { stackAlignment = Just n },+ do+ char 'p'+ a <- AddrSpace . read <$> many digit+ char ':'+ t <- triple+ return $ \dl -> dl { pointerLayouts = Map.insert a t (pointerLayouts dl) },+ do+ at <- choice [+ char 'i' >> return IntegerAlign,+ char 'v' >> return VectorAlign,+ char 'f' >> return FloatAlign,+ char 'a' >> return AggregateAlign,+ char 's' >> return StackAlign+ ]+ (sz,ai) <- triple+ return $ \dl -> dl { typeLayouts = Map.insert (at,sz) ai (typeLayouts dl) },+ do + char 'n'+ ns <- num `sepBy` (char ':')+ return $ \dl -> dl { nativeSizes = Just (Set.fromList ns) }+ ]+ in + case parse (parseSpec `sepBy` (char '-')) "" s of+ Left _ -> error $ "ill formed data layout: " ++ show s+ Right fs -> Just $ foldr ($) defaultDataLayout fs
src/LLVM/General/Internal/DecodeAST.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving,+ FlexibleContexts,+ FlexibleInstances,+ TypeFamilies, MultiParamTypeClasses, UndecidableInstances #-}@@ -7,6 +10,7 @@ import Control.Applicative import Control.Monad.State+import Control.Monad.Phased import Control.Monad.AnyCont import Foreign.Ptr@@ -52,27 +56,42 @@ metadataNodes = Map.empty, metadataKinds = Array.listArray (1,0) [] }-newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (StateT DecodeState IO) a }+newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (PhasedT (StateT DecodeState IO)) a } deriving ( Applicative, Functor, Monad, MonadIO, MonadState DecodeState,- MonadAnyCont IO,- ScopeAnyCont+ MonadPhased ) +instance MonadAnyCont IO DecodeAST where+ anyContToM = DecodeAST . anyContIOToM+ scopeAnyCont = DecodeAST . scopeAnyCont . unDecodeAST+ runDecodeAST :: DecodeAST a -> IO a-runDecodeAST d = flip evalStateT initialDecode . flip runAnyContT return . unDecodeAST $ d+runDecodeAST d = flip evalStateT initialDecode . runPhasedT . flip runAnyContT return . unDecodeAST $ d localScope :: DecodeAST a -> DecodeAST a-localScope (DecodeAST x) = DecodeAST (tweak x)+localScope (DecodeAST x) = DecodeAST (mapAnyContT pScope (tweak x)) where tweak x = do modify (\s@DecodeState { localNameCounter = Nothing } -> s { localNameCounter = Just 0 }) r <- x modify (\s@DecodeState { localNameCounter = Just _ } -> s { localNameCounter = Nothing }) return r+ pScope (PhasedT x) = PhasedT $ do+ let s0 `withLocalsFrom` s1 = s0 { + localNameCounter = localNameCounter s1+ }+ state <- get -- save the state+ a <- x+ state' <- get -- get the modified state+ put $ state' `withLocalsFrom` state -- revert the local part+ -- Finally here's the fun bit - in the Left case where we're coming back to a deferment point,+ -- prepend an action which reinstates the local state, but re-wrap with pScope to continue+ -- containment.+ return $ either (Left . pScope . (modify (`withLocalsFrom` state') >>)) Right a getName :: (Ptr a -> IO CString) -> Ptr a
src/LLVM/General/Internal/Diagnostic.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ DeriveDataTypeable,+ MultiParamTypeClasses,+ FlexibleInstances #-} module LLVM.General.Internal.Diagnostic where @@ -15,7 +17,7 @@ import LLVM.General.Internal.Coding import LLVM.General.Internal.String () -genCodingInstance [t| DiagnosticKind |] ''FFI.DiagnosticKind [+genCodingInstance' [t| DiagnosticKind |] ''FFI.DiagnosticKind [ (FFI.diagnosticKindError, ErrorKind), (FFI.diagnosticKindWarning, WarningKind), (FFI.diagnosticKindNote, NoteKind)@@ -29,9 +31,9 @@ l <- decodeM =<< FFI.getSMDiagnosticLineNo p c <- decodeM =<< FFI.getSMDiagnosticColumnNo p k <- decodeM =<< FFI.getSMDiagnosticKind p- f <- decodeM =<< FFI.getSMDiagnosticFilename p- m <- decodeM =<< FFI.getSMDiagnosticMessage p- lc <- decodeM =<< FFI.getSMDiagnosticLineContents p+ f <- decodeM $ FFI.getSMDiagnosticFilename p+ m <- decodeM $ FFI.getSMDiagnosticMessage p+ lc <- decodeM $ FFI.getSMDiagnosticLineContents p return $ Diagnostic { lineNumber = l, columnNumber = c, diagnosticKind = k, filename = f, message = m, lineContents = lc }
src/LLVM/General/Internal/EncodeAST.hs view
@@ -1,12 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving,+ FlexibleContexts,+ FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+ module LLVM.General.Internal.EncodeAST where import Control.Exception import Control.Monad.State+import Control.Monad.Phased import Control.Monad.Error import Control.Monad.AnyCont @@ -18,6 +22,7 @@ import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI+import qualified LLVM.General.Internal.FFI.Type as FFI import qualified LLVM.General.AST as A @@ -36,17 +41,20 @@ encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type) } -newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ErrorT String (StateT EncodeState IO)) a }+newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (PhasedT (ErrorT String (StateT EncodeState IO))) a } deriving ( Functor, Monad, MonadIO, MonadState EncodeState,- MonadError String,- MonadAnyCont IO,- ScopeAnyCont+ MonadPhased,+ MonadError String ) +instance MonadAnyCont IO EncodeAST where+ anyContToM = EncodeAST . anyContIOToM+ scopeAnyCont = EncodeAST . scopeAnyCont . unEncodeAST+ lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) lookupNamedType n = do t <- gets $ Map.lookup n . encodeStateNamedTypes@@ -55,8 +63,8 @@ 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 -> IO (Either String a)+runEncodeAST context@(Context ctx) (EncodeAST a) = bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do let initEncodeState = EncodeState { encodeStateBuilder = builder,@@ -68,7 +76,7 @@ encodeStateMDNodes = Map.empty, encodeStateNamedTypes = Map.empty }- flip evalStateT initEncodeState . runErrorT . flip runAnyContT return $ a+ flip evalStateT initEncodeState . runErrorT . runPhasedT . flip runAnyContT return $ a withName :: A.Name -> (CString -> IO a) -> IO a withName (A.Name n) = withCString n@@ -78,19 +86,25 @@ encodeM (A.Name n) = encodeM n encodeM _ = encodeM "" -phase :: EncodeAST a -> EncodeAST (EncodeAST a)-phase p = do- let s0 `withLocalsFrom` s1 = s0 { - encodeStateLocals = encodeStateLocals s1,- encodeStateBlocks = encodeStateBlocks s1- }- s <- get- return $ do- s' <- get- put $ s' `withLocalsFrom` s- r <- p- modify (`withLocalsFrom` s')- return r+-- contain modifications to the local part of the encode state - in this case all those except+-- those to encodeStateAllBlocks+encodeScope :: EncodeAST a -> EncodeAST a+encodeScope (EncodeAST x) = + EncodeAST . mapAnyContT pScope $ x -- get inside the boring wrappers down to the phasing+ where pScope (PhasedT x) = PhasedT $ do+ let s0 `withLocalsFrom` s1 = s0 { + encodeStateLocals = encodeStateLocals s1,+ encodeStateBlocks = encodeStateBlocks s1+ }+ state <- get -- save the state+ a <- x+ state' <- get -- get the modified state+ put $ state' `withLocalsFrom` state -- revert the local part+ -- Finally here's the fun bit - in the Left case where we're coming back to a deferment point,+ -- prepend an action which reinstates the local state, but re-wrap with pScope to continue+ -- containment.+ return $ either (Left . pScope . (modify (`withLocalsFrom` state') >>)) Right a+ define :: (Ord n, FFI.DescendentOf p v) => (EncodeState -> Map n (Ptr p))
src/LLVM/General/Internal/ExecutionEngine.hs view
@@ -1,31 +1,28 @@-{-# LANGUAGE- MultiParamTypeClasses,- FunctionalDependencies,- RankNTypes- #-} module LLVM.General.Internal.ExecutionEngine where import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.AnyCont-import Control.Monad.Error+import Data.Functor -import Data.Word import Foreign.Ptr-import Foreign.C.Types (CUInt)+import Foreign.Marshal.Alloc (free) import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.ExecutionEngine as FFI+import qualified LLVM.General.Internal.FFI.Target as FFI import qualified LLVM.General.Internal.FFI.Module as FFI-import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.Module import LLVM.General.Internal.Context import LLVM.General.Internal.Coding-import LLVM.General.Internal.Target+ import qualified LLVM.General.AST as A +-- | <http://llvm.org/doxygen/classllvm_1_1ExecutionEngine.html>+newtype ExecutionEngine = ExecutionEngine (Ptr FFI.ExecutionEngine)+ removeModule :: Ptr FFI.ExecutionEngine -> Ptr FFI.Module -> IO () removeModule e m = flip runAnyContT return $ do d0 <- alloca@@ -33,60 +30,37 @@ r <- liftIO $ FFI.removeModule e m d0 d1 when (r /= 0) $ fail "FFI.removeModule failure" --- | a 'ExecutableModule' e represents a 'Module' which is currently "in" an--- 'ExecutionEngine', and so the functions of which may be executed.-data ExecutableModule e = ExecutableModule e (Ptr FFI.Module) --- | <http://llvm.org/doxygen/classllvm_1_1ExecutionEngine.html>-class ExecutionEngine e f | e -> f where- withModuleInEngine :: e -> Module -> (ExecutableModule e -> IO a) -> IO a- getFunction :: ExecutableModule e -> A.Name -> IO (Maybe f)--instance ExecutionEngine (Ptr FFI.ExecutionEngine) (FunPtr ()) where- withModuleInEngine e (Module m) = bracket_ (FFI.addModule e m) (removeModule e m) . ($ (ExecutableModule e m)) - getFunction (ExecutableModule e m) (A.Name name) = flip runAnyContT return $ do- name <- encodeM name- f <- liftIO $ FFI.getNamedFunction m name- if f == nullPtr - then - return Nothing- else- do- p <- liftIO $ FFI.getPointerToGlobal e (FFI.upCast f)- return $ if p == nullPtr then Nothing else Just (castPtrToFunPtr p)--withExecutionEngine :: - Context ->- Maybe (Ptr FFI.Module) -> - (Ptr (Ptr FFI.ExecutionEngine) -> Ptr FFI.Module -> Ptr FFI.MallocedCString -> IO CUInt) ->- (Ptr FFI.ExecutionEngine -> IO a) ->- IO a-withExecutionEngine c m createEngine f = flip runAnyContT return $ do- liftIO initializeNativeTarget+-- | bracket the creation and destruction of an 'ExecutionEngine'+withExecutionEngine :: Context -> (ExecutionEngine -> IO a) -> IO a+withExecutionEngine c f = flip runAnyContT return $ do+ liftIO $ FFI.initializeNativeTarget outExecutionEngine <- alloca outErrorCStringPtr <- alloca- Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runErrorT- . withModuleFromAST c (A.Module "" Nothing Nothing []))- (return . Module) m- r <- liftIO $ createEngine outExecutionEngine dummyModule outErrorCStringPtr- when (r /= 0) $ fail =<< decodeM outErrorCStringPtr- executionEngine <- anyContToM $ bracket (peek outExecutionEngine) FFI.disposeExecutionEngine+ Module dummyModule <- anyContT $ liftM (either undefined id) . withModuleFromAST c (A.Module "" Nothing Nothing [])+ r <- liftIO $ FFI.createExecutionEngineForModule outExecutionEngine dummyModule outErrorCStringPtr+ when (r /= 0) $ do+ s <- anyContT $ bracket (peek outErrorCStringPtr) free+ fail =<< decodeM s+ executionEngine <- anyContT $ bracket (peek outExecutionEngine) FFI.disposeExecutionEngine liftIO $ removeModule executionEngine dummyModule- liftIO $ f executionEngine+ liftIO $ f (ExecutionEngine executionEngine) --- | <http://llvm.org/doxygen/classllvm_1_1JIT.html>-newtype JIT = JIT (Ptr FFI.ExecutionEngine)---- | bracket the creation and destruction of a 'JIT'-withJIT :: - Context- -> Word -- ^ optimization level- -> (JIT -> IO a)- -> IO a-withJIT c opt = - withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))- . (. JIT)+ +-- | bracket the availability of machine code for a given 'Module' in an 'ExecutionEngine'.+-- See 'findFunction'.+withModuleInEngine :: ExecutionEngine -> Module -> IO a -> IO a+withModuleInEngine (ExecutionEngine e) (Module m) = bracket_ (FFI.addModule e m) (removeModule e m) -instance ExecutionEngine JIT (FunPtr ()) where- withModuleInEngine (JIT e) m f = withModuleInEngine e m (\(ExecutableModule e m) -> f (ExecutableModule (JIT e) m))- getFunction (ExecutableModule (JIT e) m) = getFunction (ExecutableModule e m)+-- | While a 'Module' is in an 'ExecutionEngine', use 'findFunction' to lookup functions in the module.+-- To run them from Haskell, treat them as any other function pointer: cast them to an appropriate and+-- foreign type, then wrap them with a dynamic FFI stub.+findFunction :: ExecutionEngine -> A.Name -> IO (Maybe (Ptr ()))+findFunction (ExecutionEngine e) (A.Name fName) = flip runAnyContT return $ do+ out <- alloca+ fName <- encodeM fName+ r <- liftIO $ FFI.findFunction e fName out+ if (r /= 0) then + return Nothing+ else + Just <$> (liftIO $ FFI.getPointerToGlobal e . FFI.upCast =<< peek out)
− src/LLVM/General/Internal/FFI/Analysis.h
@@ -1,11 +0,0 @@-#ifndef __LLVM_GENERAL_INTERNAL_FFI__ANALYSIS__H__-#define __LLVM_GENERAL_INTERNAL_FFI__ANALYSIS__H__--#include "llvm-c/Analysis.h"--#define LLVM_GENERAL_FOR_EACH_VERIFIER_FAILURE_ACTION(macro) \- macro(AbortProcess) \- macro(PrintMessage) \- macro(ReturnStatus)--#endif
− src/LLVM/General/Internal/FFI/Analysis.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}-module LLVM.General.Internal.FFI.Analysis where--import Foreign.Ptr-import Foreign.C--import LLVM.General.Internal.FFI.LLVMCTypes-import LLVM.General.Internal.FFI.Module--foreign import ccall unsafe "LLVMVerifyModule" verifyModule ::- Ptr Module -> VerifierFailureAction -> Ptr MallocedCString -> IO LLVMBool
src/LLVM/General/Internal/FFI/Assembly.hs view
@@ -8,7 +8,6 @@ import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.Module import LLVM.General.Internal.FFI.SMDiagnostic-import LLVM.General.Internal.FFI.LLVMCTypes import Foreign.C import Foreign.Ptr@@ -19,7 +18,7 @@ -- | LLVM's serializer to generate a string of llvm assembly from a module foreign import ccall unsafe "LLVM_General_GetModuleAssembly" getModuleAssembly ::- Ptr Module -> IO MallocedCString+ Ptr Module -> IO CString
src/LLVM/General/Internal/FFI/AssemblyC.cpp view
@@ -1,5 +1,6 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/Module.h" #include "llvm/Assembly/Parser.h" #include "llvm/Assembly/PrintModulePass.h" #include "llvm/Pass.h"
src/LLVM/General/Internal/FFI/BasicBlock.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses #-}
src/LLVM/General/Internal/FFI/BinaryOperator.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | FFI functions for handling the LLVM BinaryOperator class module LLVM.General.Internal.FFI.BinaryOperator where @@ -13,15 +16,20 @@ import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.LLVMCTypes +-- | a blind type to correspond to llvm::BinaryOperator+data BinaryOperator++instance ChildOf Instruction BinaryOperator+ foreign import ccall unsafe "LLVMIsABinaryOperator" isABinaryOperator :: Ptr Value -> IO (Ptr BinaryOperator) foreign import ccall unsafe "LLVM_General_HasNoSignedWrap" hasNoSignedWrap ::- Ptr Value -> IO LLVMBool+ Ptr BinaryOperator -> IO LLVMBool foreign import ccall unsafe "LLVM_General_HasNoUnsignedWrap" hasNoUnsignedWrap ::- Ptr Value -> IO LLVMBool+ Ptr BinaryOperator -> IO LLVMBool foreign import ccall unsafe "LLVM_General_IsExact" isExact ::- Ptr Value -> IO LLVMBool+ Ptr BinaryOperator -> IO LLVMBool
src/LLVM/General/Internal/FFI/Builder.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE ForeignFunctionInterface,- TemplateHaskell,- ViewPatterns+ EmptyDataDecls,+ TemplateHaskell #-}+ -- | 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 qualified LLVM.General.AST.Operand as A+import qualified LLVM.General.AST.Type as A import LLVM.General.Internal.InstructionDefs as ID @@ -20,9 +21,10 @@ import qualified Data.Map as Map -import LLVM.General.Internal.FFI.Cleanup-import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.BinaryOperator+import LLVM.General.Internal.FFI.Type import LLVM.General.Internal.FFI.PtrHierarchy data Builder@@ -64,23 +66,29 @@ $(do- liftM concat $ sequence $ do- let instrInfo = ID.outerJoin ID.astInstructionRecs ID.instructionDefs- (lrn, ii) <- Map.toList instrInfo- (TH.RecC _ (unzip3 -> (_, _, fieldTypes)), ID.InstructionDef { ID.cAPIName = a, ID.instructionKind = k }) <- case ii of- (Just r, Just d) -> return (r,d)- (Just _, Nothing) -> error $ "An AST instruction was not found in the LLVM instruction defs"- (Nothing, Just ID.InstructionDef { ID.instructionKind = k }) | k /= ID.Terminator -> - error $ "LLVM instruction def " ++ lrn ++ " not found in the AST"- _ -> []-- let ats = map typeMapping [ t | t <- fieldTypes, t /= TH.ConT ''A.InstructionMetadata ]- cName = (if hasFlags fieldTypes then "LLVM_General_" else "LLVM") ++ "Build" ++ a- rt <- case k of- ID.Binary -> [[t| BinaryOperator |]]- ID.Cast -> [[t| Instruction |]]- _ -> []- return $ foreignDecl cName ("build" ++ a) ([[t| Ptr Builder |]] ++ ats ++ [[t| CString |]]) [t| Ptr $(rt) |]+ sequence [+ TH.forImpD TH.cCall TH.unsafe cName (TH.mkName ("build" ++ a)) [t| + Ptr Builder -> $(foldr (\at rt -> [t| $(at) -> $(rt) |]) [t| CString -> IO (Ptr $(rt)) |] ats)+ |]+ | (lrn, ID.InstructionDef { ID.cAPIName = a, ID.instructionKind = k }) <- Map.toList ID.instructionDefs,+ let fieldTypes = + (\(TH.RecC _ fs) -> [ t | (_,_,t) <- fs]) $+ Map.findWithDefault + (error $ "LLVM instruction not found in AST: " ++ show lrn)+ lrn ID.astInstructionRecs+ ats = flip concatMap fieldTypes $ \ft ->+ case ft of+ TH.ConT h | h == ''Bool -> [[t| LLVMBool |]]+ | h == ''A.Operand -> [[t| Ptr Value |]]+ | h == ''A.Type -> [[t| Ptr Type |]]+ | h == ''A.InstructionMetadata -> []+ _ -> error $ "show ft = " ++ show ft+ cName = (if TH.ConT ''Bool `elem` fieldTypes then "LLVM_General_" else "LLVM") ++ "Build" ++ a,+ rt <- case k of+ ID.Binary -> [[t| BinaryOperator |]]+ ID.Cast -> [[t| Instruction |]]+ _ -> []+ ] ) foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca ::@@ -92,15 +100,8 @@ foreign import ccall unsafe "LLVM_General_BuildStore" buildStore :: Ptr Builder -> Ptr Value -> Ptr Value -> CUInt -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVMBuildGEP" buildGetElementPtr' ::- Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction)--foreign import ccall unsafe "LLVMBuildInBoundsGEP" buildInBoundsGetElementPtr' ::+foreign import ccall unsafe "LLVMBuildGEP" buildGetElementPtr :: 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 foreign import ccall unsafe "LLVMBuildFence" buildFence :: Ptr Builder -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)
src/LLVM/General/Internal/FFI/BuilderC.cpp view
@@ -1,6 +1,6 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/IRBuilder.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/IRBuilder.h" #include "llvm-c/Core.h" @@ -11,7 +11,7 @@ namespace llvm { static AtomicOrdering unwrap(LLVMAtomicOrdering l) { switch(l) {-#define ENUM_CASE(x) case LLVM ## x ## AtomicOrdering: return x;+#define ENUM_CASE(x) case LLVMAtomicOrdering ## x: return x; LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE) #undef ENUM_CASE default: return AtomicOrdering(0);@@ -28,9 +28,9 @@ } -static AtomicRMWInst::BinOp unwrap(LLVMAtomicRMWOperation l) {+static AtomicRMWInst::BinOp unwrap(LLVMAtomicRMWBinOp l) { switch(l) {-#define ENUM_CASE(x) case LLVM ## x ## RMWOperation: return AtomicRMWInst::x;+#define ENUM_CASE(x) case LLVMAtomicRMWBinOp ## x: return AtomicRMWInst::x; LLVM_GENERAL_FOR_EACH_RMW_OPERATION(ENUM_CASE) #undef ENUM_CASE default: return AtomicRMWInst::BinOp(0);@@ -92,7 +92,7 @@ ) { LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), align, isVolatile, name); i->setOrdering(unwrap(atomicOrdering));- if (atomicOrdering != LLVMNotAtomicAtomicOrdering) i->setSynchScope(unwrap(synchScope));+ i->setSynchScope(unwrap(synchScope)); return wrap(i); } @@ -109,7 +109,7 @@ StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), align, isVolatile); i->setName(name); i->setOrdering(unwrap(atomicOrdering));- if (atomicOrdering != LLVMNotAtomicAtomicOrdering) i->setSynchScope(unwrap(synchScope));+ i->setSynchScope(unwrap(synchScope)); return wrap(i); } @@ -141,7 +141,7 @@ LLVMValueRef LLVM_General_BuildAtomicRMW( LLVMBuilderRef b,- LLVMAtomicRMWOperation rmwOp,+ LLVMAtomicRMWBinOp rmwOp, LLVMValueRef ptr, LLVMValueRef val, LLVMBool v,
src/LLVM/General/Internal/FFI/Cleanup.hs view
@@ -8,19 +8,16 @@ import Data.Sequence as Seq import Data.Foldable (toList) +import Data.Function++import LLVM.General.Internal.FFI.LLVMCTypes import Data.Word import Data.Int import Foreign.C import Foreign.Ptr -import LLVM.General.Internal.FFI.LLVMCTypes-import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI- import qualified LLVM.General.AST.IntegerPredicate as A (IntegerPredicate) import qualified LLVM.General.AST.FloatingPointPredicate as A (FloatingPointPredicate) -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) foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ foreignDecl cName hName argTypeQs returnTypeQ = do@@ -62,23 +59,15 @@ ] ] --- | The LLVM C-API for instructions with boolean flags (e.g. nsw) 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).-hasFlags :: [Type] -> Bool-hasFlags = any (== ConT ''Bool)--typeMapping :: Type -> TypeQ-typeMapping t = case t of+typeMappingU :: (Type -> TypeQ) -> Type -> TypeQ+typeMappingU typeMapping t = case t of ConT h | h == ''Bool -> [t| LLVMBool |] | h == ''Int32 -> [t| CInt |] | h == ''Word32 -> [t| CUInt |] | h == ''String -> [t| CString |]- | h == ''A.Operand -> [t| Ptr FFI.Value |]- | h == ''A.Type -> [t| Ptr FFI.Type |]- | h == ''A.C.Constant -> [t| Ptr FFI.Constant |] | h == ''A.FloatingPointPredicate -> [t| FCmpPredicate |] | h == ''A.IntegerPredicate -> [t| ICmpPredicate |] AppT ListT x -> foldl1 appT [tupleT 2, [t| CUInt |], appT [t| Ptr |] (typeMapping x)]- x -> error $ "type not handled in Cleanup typeMapping: " ++ show x++typeMapping :: Type -> TypeQ+typeMapping = fix typeMappingU
+ src/LLVM/General/Internal/FFI/Constant.h view
@@ -0,0 +1,20 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__CONSTANT__H__+#define __LLVM_GENERAL_INTERNAL_FFI__CONSTANT__H__++#define LLVM_GENERAL_FOR_EACH_FLOAT_SEMANTICS(macro) \+ macro(IEEEhalf) \+ macro(IEEEsingle) \+ macro(IEEEdouble) \+ macro(IEEEquad) \+ macro(PPCDoubleDouble) \+ macro(x87DoubleExtended) \+ macro(Bogus)++typedef enum {+#define ENUM_CASE(x) LLVMFloatSemantics ## x,+LLVM_GENERAL_FOR_EACH_FLOAT_SEMANTICS(ENUM_CASE)+#undef ENUM_CASE+} LLVMFloatSemantics;+++#endif
src/LLVM/General/Internal/FFI/Constant.hs view
@@ -1,20 +1,23 @@ {-# LANGUAGE TemplateHaskell, ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances,- OverlappingInstances,- ViewPatterns+ OverlappingInstances #-}+ -- | FFI functions for handling the LLVM Constant class module LLVM.General.Internal.FFI.Constant where import qualified Language.Haskell.TH as TH import qualified LLVM.General.Internal.InstructionDefs as ID+import qualified LLVM.General.AST.Constant as A.C import Control.Monad+import Data.Function import qualified Data.Map as Map-import Data.Word import Foreign.Ptr import Foreign.C@@ -22,6 +25,7 @@ import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.Cleanup+import LLVM.General.Internal.FFI.Type import LLVM.General.Internal.FFI.LLVMCTypes foreign import ccall unsafe "LLVMIsConstant" isConstant ::@@ -40,7 +44,7 @@ Ptr Value -> IO (Ptr Constant) foreign import ccall unsafe "LLVM_General_GetConstantIntWords" getConstantIntWords ::- Ptr Constant -> Ptr CUInt -> IO (Ptr Word64)+ Ptr Constant -> Ptr CUInt -> IO (Ptr CULong) foreign import ccall unsafe "LLVM_General_ConstFloatDoubleValue" constFloatDoubleValue :: Ptr Constant -> IO CDouble@@ -57,15 +61,15 @@ Ptr Constant -> CUInt -> IO (Ptr Constant) foreign import ccall unsafe "LLVMConstIntOfArbitraryPrecision" constantIntOfArbitraryPrecision' ::- Ptr Type -> CUInt -> Ptr Word64 -> IO (Ptr Constant)+ Ptr Type -> CUInt -> Ptr CULong -> IO (Ptr Constant) constantIntOfArbitraryPrecision t = uncurry (constantIntOfArbitraryPrecision' t) foreign import ccall unsafe "LLVM_General_ConstFloatOfArbitraryPrecision" constantFloatOfArbitraryPrecision ::- Ptr Context -> CUInt -> Ptr Word64 -> LLVMBool -> IO (Ptr Constant)+ Ptr Context -> CUInt -> Ptr CULong -> FloatSemantics -> IO (Ptr Constant) foreign import ccall unsafe "LLVM_General_GetConstantFloatWords" getConstantFloatWords ::- Ptr Constant -> Ptr Word64 -> IO ()+ Ptr Constant -> Ptr CULong -> IO () foreign import ccall unsafe "LLVMConstVector" constantVector' :: Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)@@ -88,14 +92,14 @@ $(do let constExprInfo = ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs- liftM concat $ sequence $ do- (name, ((TH.RecC _ (unzip3 -> (_, _, fieldTypes)),_), ID.InstructionDef { ID.instructionKind = ik })) <- Map.toList constExprInfo- prefix <- case ik of- ID.Other -> return "LLVM"- ID.Binary | hasFlags fieldTypes -> return "LLVM_General_"- _ -> []- return $- foreignDecl (prefix ++ "Const" ++ name) ("constant" ++ name) (map typeMapping fieldTypes) [t| Ptr Constant |]+ let tm = fix tm' + where tm' _ (TH.ConT h) | h == ''A.C.Constant = [t| Ptr Constant |]+ tm' x t = typeMappingU x t+ + liftM concat $ sequence [ + foreignDecl ("LLVMConst" ++ name) ("constant" ++ name) [tm t | (_, _, t) <- fs ] [t| Ptr Constant |]+ | (name, ((TH.RecC _ fs,_), ID.InstructionDef { ID.instructionKind = ID.Other })) <- Map.toList constExprInfo+ ] ) foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' ::@@ -119,7 +123,7 @@ foreign import ccall unsafe "LLVM_General_GetConstIndices" getConstantIndices :: Ptr Constant -> Ptr CUInt -> IO (Ptr CUInt) -foreign import ccall unsafe "LLVMGetUndef" constantUndef ::+foreign import ccall unsafe "LLVMGetUndef" getUndef :: Ptr Type -> IO (Ptr Constant) foreign import ccall unsafe "LLVMBlockAddress" blockAddress ::
src/LLVM/General/Internal/FFI/ConstantC.cpp view
@@ -1,11 +1,27 @@ #define __STDC_LIMIT_MACROS+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/Constants.h"+#include "llvm/IR/Function.h"+ #include "llvm-c/Core.h"-#include "llvm/LLVMContext.h"-#include "llvm/Constants.h" #include "LLVM/General/Internal/FFI/Value.h"+#include "LLVM/General/Internal/FFI/Constant.h" using namespace llvm; +namespace llvm {++static const struct fltSemantics &unwrap(LLVMFloatSemantics s) {+ switch(s) {+#define ENUM_CASE(x) case LLVMFloatSemantics ## x: return APFloat::x;+LLVM_GENERAL_FOR_EACH_FLOAT_SEMANTICS(ENUM_CASE)+#undef ENUM_CASE+ default: return APFloat::Bogus;+ }+}++}+ extern "C" { LLVMValueRef LLVM_General_GetConstantDataSequentialElementAsConstant(LLVMValueRef v, unsigned i) {@@ -36,32 +52,6 @@ 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) { \- return wrap(ConstantExpr::get ## op(unwrap<Constant>(o0), unwrap<Constant>(o1), isExact != 0)); \-}-LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(CASE_CODE)-#undef CASE_CODE- unsigned LLVM_General_GetConstCPPOpcode(LLVMValueRef v) { return unwrap<ConstantExpr>(v)->getOpcode(); }@@ -86,12 +76,12 @@ LLVMContextRef c, unsigned bits, const uint64_t *words,- unsigned notPairOfFloats+ LLVMFloatSemantics semantics ) { return wrap( ConstantFP::get( *unwrap(c),- APFloat(APInt(bits, ArrayRef<uint64_t>(words, (bits-1)/64 + 1)), notPairOfFloats)+ APFloat(unwrap(semantics), APInt(bits, ArrayRef<uint64_t>(words, (bits-1)/64 + 1))) ) ); }
src/LLVM/General/Internal/FFI/Context.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE- ForeignFunctionInterface+ ForeignFunctionInterface,+ EmptyDataDecls #-} -- | Functions for handling the LLVMContext class. In all other LLVM interfaces,
− src/LLVM/General/Internal/FFI/DataLayout.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}--module LLVM.General.Internal.FFI.DataLayout where--import Foreign.C.String-import Foreign.Ptr--import LLVM.General.Internal.FFI.LLVMCTypes--data DataLayout---- Oooh those wacky LLVM C-API coders: C API called DataLayout TargetData.--- Great. Just great.--foreign import ccall unsafe "LLVMCreateTargetData" createDataLayout :: - CString -> IO (Ptr DataLayout)--foreign import ccall unsafe "LLVMDisposeTargetData" disposeDataLayout :: - Ptr DataLayout -> IO ()--foreign import ccall unsafe "LLVMCopyStringRepOfTargetData" dataLayoutToString ::- Ptr DataLayout -> IO MallocedCString
src/LLVM/General/Internal/FFI/ExecutionEngine.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE- ForeignFunctionInterface+ ForeignFunctionInterface,+ EmptyDataDecls #-} module LLVM.General.Internal.FFI.ExecutionEngine where@@ -8,37 +9,24 @@ import Foreign.C import LLVM.General.Internal.FFI.PtrHierarchy-import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.Module data ExecutionEngine foreign import ccall unsafe "LLVMCreateExecutionEngineForModule" createExecutionEngineForModule ::- Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr MallocedCString -> IO CUInt--foreign import ccall unsafe "LLVMCreateInterpreterForModule" createInterpreterForModule ::- Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr MallocedCString -> IO CUInt--foreign import ccall unsafe "LLVMCreateJITCompilerForModule" createJITCompilerForModule ::- Ptr (Ptr ExecutionEngine) -> Ptr Module -> CUInt -> Ptr MallocedCString -> IO CUInt+ Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr CString -> IO CUInt foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine ::- Ptr ExecutionEngine -> IO ()+ Ptr ExecutionEngine -> IO () foreign import ccall unsafe "LLVMAddModule" addModule ::- Ptr ExecutionEngine -> Ptr Module -> IO ()+ Ptr ExecutionEngine -> Ptr Module -> IO () foreign import ccall unsafe "LLVMRemoveModule" removeModule ::- Ptr ExecutionEngine -> Ptr Module -> Ptr (Ptr Module) -> Ptr CString -> IO CUInt+ Ptr ExecutionEngine -> Ptr Module -> Ptr (Ptr Module) -> Ptr CString -> IO CUInt foreign import ccall unsafe "LLVMFindFunction" findFunction ::- Ptr ExecutionEngine -> CString -> Ptr (Ptr Function) -> IO CUInt+ Ptr ExecutionEngine -> CString -> Ptr (Ptr Function) -> IO CUInt foreign import ccall unsafe "LLVMGetPointerToGlobal" getPointerToGlobal ::- Ptr ExecutionEngine -> Ptr GlobalValue -> IO (Ptr ())--foreign import ccall unsafe "LLVMLinkInInterpreter" linkInInterpreter :: - IO ()--foreign import ccall unsafe "LLVMLinkInJIT" linkInJIT :: - IO ()+ Ptr ExecutionEngine -> Ptr GlobalValue -> IO (Ptr ())
src/LLVM/General/Internal/FFI/Function.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses #-} @@ -55,8 +56,5 @@ foreign import ccall unsafe "LLVM_General_AddFunctionRetAttr" addFunctionRetAttr :: Ptr Function -> ParamAttr -> IO () -foreign import ccall unsafe "LLVMGetGC" getGC ::- Ptr Function -> IO CString -foreign import ccall unsafe "LLVMSetGC" setGC ::- Ptr Function -> CString -> IO ()+
src/LLVM/General/Internal/FFI/FunctionC.cpp view
@@ -1,6 +1,7 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/Attributes.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/Attributes.h"+#include "llvm/IR/Function.h" #include "llvm-c/Core.h" @@ -9,7 +10,7 @@ extern "C" { LLVMAttribute LLVM_General_GetFunctionRetAttr(LLVMValueRef f) {- return (LLVMAttribute)unwrap<Function>(f)->getRetAttributes().Raw();+ return (LLVMAttribute)unwrap<Function>(f)->getAttributes().Raw(AttributeSet::ReturnIndex); } void LLVM_General_AddFunctionRetAttr(LLVMValueRef v, LLVMAttribute attr) {@@ -17,7 +18,7 @@ LLVMContext &context = f.getContext(); AttrBuilder attrBuilder(attr); f.setAttributes(- f.getAttributes().addAttr(context, AttrListPtr::ReturnIndex, Attributes::get(context, attrBuilder))+ f.getAttributes().addAttributes(context, AttributeSet::ReturnIndex, AttributeSet::get(context, AttributeSet::ReturnIndex, attrBuilder)) ); }
src/LLVM/General/Internal/FFI/GlobalAlias.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | FFI functions for handling the LLVM GlobalAlias class module LLVM.General.Internal.FFI.GlobalAlias where
src/LLVM/General/Internal/FFI/GlobalAliasC.cpp view
@@ -1,6 +1,6 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/GlobalAlias.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/GlobalAlias.h" #include "llvm-c/Core.h"
src/LLVM/General/Internal/FFI/GlobalValue.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | FFI functions for handling the LLVM GlobalValue class module LLVM.General.Internal.FFI.GlobalValue where
src/LLVM/General/Internal/FFI/GlobalValueC.cpp view
@@ -1,5 +1,5 @@ #define __STDC_LIMIT_MACROS-+#include "llvm/IR/GlobalValue.h" #include "llvm-c/Core.h" using namespace llvm;
src/LLVM/General/Internal/FFI/GlobalVariable.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | FFI functions for handling the LLVM GlobalVariable class module LLVM.General.Internal.FFI.GlobalVariable where
src/LLVM/General/Internal/FFI/InlineAssembly.hs view
@@ -9,6 +9,7 @@ import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Type foreign import ccall unsafe "LLVMIsAInlineAsm" isAInlineAsm :: Ptr Value -> IO (Ptr InlineAsm)
src/LLVM/General/Internal/FFI/InlineAssemblyC.cpp view
@@ -1,5 +1,6 @@ #define __STDC_LIMIT_MACROS-#include "llvm/InlineAsm.h"+#include "llvm/IR/InlineAsm.h"+#include "llvm/IR/Function.h" #include "llvm-c/Core.h" #include "LLVM/General/Internal/FFI/InlineAssembly.h"
src/LLVM/General/Internal/FFI/Instruction.h view
@@ -1,6 +1,8 @@ #ifndef __LLVM_GENERAL_INTERNAL_FFI__INSTRUCTION__H__ #define __LLVM_GENERAL_INTERNAL_FFI__INSTRUCTION__H__ +#include "llvm/Config/llvm-config.h"+ #define LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(macro) \ macro(NotAtomic) \ macro(Unordered) \@@ -10,22 +12,6 @@ macro(AcquireRelease) \ macro(SequentiallyConsistent) -typedef enum {-#define ENUM_CASE(x) LLVM ## x ## AtomicOrdering,-LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE)-#undef ENUM_CASE-} LLVMAtomicOrdering;--#define LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(macro) \- macro(SingleThread) \- macro(CrossThread)--typedef enum {-#define ENUM_CASE(x) LLVM ## x ## SynchronizationScope,-LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE)-#undef ENUM_CASE-} LLVMSynchronizationScope;- #define LLVM_GENERAL_FOR_EACH_RMW_OPERATION(macro) \ macro(Xchg) \ macro(Add) \@@ -39,10 +25,14 @@ macro(UMax) \ macro(UMin) +#define LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(macro) \+ macro(SingleThread) \+ macro(CrossThread)+ typedef enum {-#define ENUM_CASE(x) LLVM ## x ## RMWOperation,-LLVM_GENERAL_FOR_EACH_RMW_OPERATION(ENUM_CASE)+#define ENUM_CASE(x) LLVM ## x ## SynchronizationScope,+LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE) #undef ENUM_CASE-} LLVMAtomicRMWOperation;+} LLVMSynchronizationScope; #endif
src/LLVM/General/Internal/FFI/Instruction.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, OverlappingInstances, TemplateHaskell #-}+ module LLVM.General.Internal.FFI.Instruction where import Control.Monad@@ -12,6 +15,7 @@ import Foreign.C import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Type import LLVM.General.Internal.FFI.LLVMCTypes foreign import ccall unsafe "LLVMIsAInstruction" isAInstruction ::@@ -115,7 +119,10 @@ foreign import ccall unsafe "LLVM_General_GetInBounds" getInBounds :: Ptr Value -> IO LLVMBool -foreign import ccall unsafe "LLVM_General_GetAtomicRMWOperation" getAtomicRMWOperation ::+foreign import ccall unsafe "LLVM_General_SetInBounds" setInBounds ::+ Ptr Instruction -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVM_General_GetAtomicRMWBinOp" getAtomicRMWBinOp :: Ptr Instruction -> IO RMWOperation foreign import ccall unsafe "LLVM_General_CountInstStructureIndices" countInstStructureIndices ::
src/LLVM/General/Internal/FFI/InstructionC.cpp view
@@ -1,9 +1,12 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/InstrTypes.h"+#include "llvm/Config/llvm-config.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/InstrTypes.h"+#include "llvm/IR/Attributes.h"+#include "llvm/IR/Operator.h"+#include "llvm/IR/BasicBlock.h"+#include "llvm/IR/Metadata.h" #include "llvm/Support/CallSite.h"-#include "llvm/Attributes.h"-#include "llvm/Operator.h" #include "llvm-c/Core.h" @@ -15,7 +18,7 @@ static LLVMAtomicOrdering wrap(AtomicOrdering l) { switch(l) {-#define ENUM_CASE(x) case x: return LLVM ## x ## AtomicOrdering;+#define ENUM_CASE(x) case x: return LLVMAtomicOrdering ## x; LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE) #undef ENUM_CASE default: return LLVMAtomicOrdering(0);@@ -31,12 +34,12 @@ } } -static LLVMAtomicRMWOperation wrap(AtomicRMWInst::BinOp l) {+static LLVMAtomicRMWBinOp wrap(AtomicRMWInst::BinOp l) { switch(l) {-#define ENUM_CASE(x) case AtomicRMWInst::x: return LLVM ## x ## RMWOperation;+#define ENUM_CASE(x) case AtomicRMWInst::x: return LLVMAtomicRMWBinOp ## x; LLVM_GENERAL_FOR_EACH_RMW_OPERATION(ENUM_CASE) #undef ENUM_CASE- default: return LLVMAtomicRMWOperation(0);+ default: return LLVMAtomicRMWBinOp(0); } } @@ -67,22 +70,22 @@ } LLVMAttribute LLVM_General_GetCallInstAttr(LLVMValueRef callInst, unsigned i) {- return (LLVMAttribute)CallSite(unwrap<Instruction>(callInst)).getAttributes().getParamAttributes(i).Raw();+ return (LLVMAttribute)CallSite(unwrap<Instruction>(callInst)).getAttributes().Raw(i); } 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().addAttr(context, i, Attributes::get(context, attrBuilder)));+ callSite.setAttributes(callSite.getAttributes().addAttributes(context, i, AttributeSet::get(context, i, attrBuilder))); } LLVMAttribute LLVM_General_GetCallInstFunctionAttr(LLVMValueRef callInst) {- return LLVM_General_GetCallInstAttr(callInst, AttrListPtr::FunctionIndex);+ return LLVM_General_GetCallInstAttr(callInst, AttributeSet::FunctionIndex); } void LLVM_General_AddCallInstFunctionAttr(LLVMValueRef callInst, LLVMAttribute attr) {- LLVM_General_AddCallInstAttr(callInst, AttrListPtr::FunctionIndex, attr);+ LLVM_General_AddCallInstAttr(callInst, AttributeSet::FunctionIndex, attr); } LLVMValueRef LLVM_General_GetAllocaNumElements(LLVMValueRef a) {@@ -111,7 +114,7 @@ void LLVM_General_SetInstrAlignment(LLVMValueRef l, unsigned a) { switch(unwrap<Instruction>(l)->getOpcode()) {-#define ENUM_CASE(n) case Instruction::n: unwrap<n ## Inst>(l)->setAlignment(a); break;+#define ENUM_CASE(n) case Instruction::n: unwrap<n ## Inst>(l)->setAlignment(a); LLVM_GENERAL_FOR_EACH_ALIGNMENT_INST(ENUM_CASE) #undef ENUM_CASE }@@ -165,7 +168,11 @@ return unwrap<GEPOperator>(i)->isInBounds(); } -LLVMAtomicRMWOperation LLVM_General_GetAtomicRMWOperation(LLVMValueRef i) {+void LLVM_General_SetInBounds(LLVMValueRef i, LLVMBool b) {+ unwrap<GetElementPtrInst>(i)->setIsInBounds(b);+}++LLVMAtomicRMWBinOp LLVM_General_GetAtomicRMWBinOp(LLVMValueRef i) { return wrap(unwrap<AtomicRMWInst>(i)->getOperation()); }
src/LLVM/General/Internal/FFI/InstructionDefs.hsc view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} -- This module translates the instruction data in "llvm/Instruction.def" into a Haskell data structure, -- so it may be accessed conveniently with Template Haskell code module LLVM.General.Internal.FFI.InstructionDefs where@@ -15,7 +16,9 @@ #define LAST_OTHER_INST(num) { 0, 0, 0, 0, } }; -#include "llvm/Instruction.def"+#include "llvm/Config/llvm-config.h"++#include "llvm/IR/Instruction.def" #{ define hsc_inject() { \
src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -1,4 +1,6 @@ {-# LANGUAGE+ DeriveDataTypeable,+ StandaloneDeriving, GeneralizedNewtypeDeriving #-} -- | Define types which correspond cleanly with some simple types on the C/C++ side.@@ -9,7 +11,6 @@ #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/Value.h" #include "LLVM/General/Internal/FFI/SMDiagnostic.h"@@ -18,8 +19,7 @@ #include "LLVM/General/Internal/FFI/Function.h" #include "LLVM/General/Internal/FFI/GlobalValue.h" #include "LLVM/General/Internal/FFI/Type.h"-#include "LLVM/General/Internal/FFI/Analysis.h"-#include "LLVM/General/Internal/FFI/Module.h"+#include "LLVM/General/Internal/FFI/Constant.h" import Language.Haskell.TH.Quote @@ -53,15 +53,6 @@ newtype LLVMBool = LLVMBool CUInt -newtype MallocedCString = MallocedCString CString- deriving (Storable)--newtype NothingAsMinusOne h = NothingAsMinusOne CInt- deriving (Storable)--newtype NothingAsEmptyString c = NothingAsEmptyString c- deriving (Storable)- newtype CPPOpcode = CPPOpcode CUInt deriving (Eq, Ord, Show, Typeable, Data) @@ -106,7 +97,7 @@ newtype MemoryOrdering = MemoryOrdering CUInt deriving (Eq, Typeable, Data)-#define MO_Rec(n) { #n, LLVM ## n ## AtomicOrdering },+#define MO_Rec(n) { #n, LLVMAtomicOrdering ## n }, #{inject ATOMIC_ORDERING, MemoryOrdering, MemoryOrdering, memoryOrdering, MO_Rec} newtype Linkage = Linkage CUInt@@ -141,7 +132,7 @@ newtype RMWOperation = RMWOperation CUInt deriving (Eq, Read, Show, Typeable, Data)-#define RMWOp_Rec(n) { #n, LLVM ## n ## RMWOperation },+#define RMWOp_Rec(n) { #n, LLVMAtomicRMWBinOp ## n }, #{inject RMW_OPERATION, RMWOperation, RMWOperation, rmwOperation, RMWOp_Rec} newtype RelocModel = RelocModel CUInt@@ -159,11 +150,6 @@ #define CGOL_Rec(n) { #n, LLVMCodeGenLevel ## n }, #{inject CODE_GEN_OPT_LEVEL, CodeGenOptLevel, CodeGenOptLevel, codeGenOptLevel, CGOL_Rec} -newtype CodeGenFileType = CodeGenFileType CUInt- deriving (Eq, Read, Show, Typeable, Data)-#define CGFT_Rec(n) { #n, LLVM ## n ## File },-#{inject CODE_GEN_FILE_TYPE, CodeGenFileType, CodeGenFileType, codeGenFileType, CGFT_Rec}- newtype FloatABIType = FloatABIType CUInt deriving (Eq, Read, Show, Typeable, Data) #define FAT_Rec(n) { #n, LLVM_General_FloatABI_ ## n },@@ -185,21 +171,16 @@ #{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec} newtype ParamAttr = ParamAttr CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num)+ deriving (Eq, Read, Show, Bits, Typeable, Data) #define PA_Rec(n) { #n, LLVM ## n ## Attribute }, #{inject PARAM_ATTR, ParamAttr, ParamAttr, paramAttr, PA_Rec} newtype FunctionAttr = FunctionAttr CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num)+ deriving (Eq, Read, Show, Bits, Typeable, Data) #define FA_Rec(n,a) { #n, LLVM ## n ## a }, #{inject FUNCTION_ATTR, FunctionAttr, FunctionAttr, functionAttr, FA_Rec} -newtype VerifierFailureAction = VerifierFailureAction CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num)-#define VFA_Rec(n) { #n, LLVM ## n ## Action },-#{inject VERIFIER_FAILURE_ACTION, VerifierFailureAction, VerifierFailureAction, verifierFailureAction, VFA_Rec}--newtype LinkerMode = LinkerMode CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num)-#define LM_Rec(n) { #n, LLVMLinker ## n },-#{inject LINKER_MODE, LinkerMode, LinkerMode, linkerMode, LM_Rec}+newtype FloatSemantics = FloatSemantics CUInt+ deriving (Eq, Read, Show, Typeable, Data)+#define FS_Rec(n) { #n, LLVMFloatSemantics ## n },+#{inject FLOAT_SEMANTICS, FloatSemantics, FloatSemantics, floatSemantics, FS_Rec}
src/LLVM/General/Internal/FFI/MetadataC.cpp view
@@ -1,7 +1,7 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/Metadata.h"-+#include "llvm/Config/llvm-config.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/Metadata.h" #include "llvm-c/Core.h" using namespace llvm;
− src/LLVM/General/Internal/FFI/Module.h
@@ -1,8 +0,0 @@-#ifndef __LLVM_GENERAL_INTERNAL_FFI__MODULE__H__-#define __LLVM_GENERAL_INTERNAL_FFI__MODULE__H__--#define LLVM_GENERAL_FOR_EACH_LINKER_MODE(macro) \- macro(DestroySource) \- macro(PreserveSource) --#endif
src/LLVM/General/Internal/FFI/Module.hs view
@@ -1,14 +1,16 @@ {-# LANGUAGE- ForeignFunctionInterface+ ForeignFunctionInterface,+ EmptyDataDecls #-}+ module LLVM.General.Internal.FFI.Module where import Foreign.Ptr import Foreign.C -import LLVM.General.Internal.FFI.Context-import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.Type data Module @@ -34,7 +36,7 @@ Ptr Module -> CString -> IO () foreign import ccall unsafe "LLVM_General_GetModuleIdentifier" getModuleIdentifier ::- Ptr Module -> IO MallocedCString+ Ptr Module -> IO CString foreign import ccall unsafe "LLVMGetFirstGlobal" getFirstGlobal :: Ptr Module -> IO (Ptr GlobalVariable)@@ -70,9 +72,6 @@ foreign import ccall unsafe "LLVMAddFunction" addFunction :: Ptr Module -> CString -> Ptr Type -> IO (Ptr Function) -foreign import ccall unsafe "LLVMGetNamedFunction" getNamedFunction ::- Ptr Module -> CString -> IO (Ptr Function)- foreign import ccall unsafe "LLVM_General_GetOrAddNamedMetadata" getOrAddNamedMetadata :: Ptr Module -> CString -> IO (Ptr NamedMetadata) @@ -85,9 +84,3 @@ foreign import ccall unsafe "LLVM_General_ModuleGetInlineAsm" moduleGetInlineAsm :: Ptr Module -> IO (ModuleAsm CString)--foreign import ccall unsafe "LLVM_General_WriteBitcodeToFile" writeBitcodeToFile ::- Ptr Module -> CString -> Ptr MallocedCString -> IO LLVMBool--foreign import ccall unsafe "LLVMLinkModules" linkModules ::- Ptr Module -> Ptr Module -> LinkerMode -> Ptr MallocedCString -> IO LLVMBool
src/LLVM/General/Internal/FFI/ModuleC.cpp view
@@ -1,10 +1,8 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/Module.h"-+#include "llvm/Config/llvm-config.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/Module.h" #include "llvm-c/Core.h"-#include "llvm/Support/raw_ostream.h"-#include "llvm/Bitcode/ReaderWriter.h" using namespace llvm; @@ -53,19 +51,6 @@ const char *LLVM_General_ModuleGetInlineAsm(LLVMModuleRef m) { return unwrap(m)->getModuleInlineAsm().c_str();-}--LLVMBool LLVM_General_WriteBitcodeToFile(LLVMModuleRef m, const char *path, char **error) {- std::string ErrorInfo;- raw_fd_ostream OS(path, ErrorInfo, raw_fd_ostream::F_Binary);-- if (!ErrorInfo.empty()) {- *error = strdup(ErrorInfo.c_str());- return -1;- }-- WriteBitcodeToFile(unwrap(m), OS);- return 0; } }
src/LLVM/General/Internal/FFI/PassManager.hs view
@@ -1,16 +1,15 @@ {-# LANGUAGE TemplateHaskell,- ForeignFunctionInterface+ ForeignFunctionInterface,+ EmptyDataDecls #-} module LLVM.General.Internal.FFI.PassManager where -import qualified Language.Haskell.TH as TH+import Language.Haskell.TH import Control.Monad -import Data.Word- import Foreign.Ptr import Foreign.C @@ -19,7 +18,6 @@ import LLVM.General.Internal.FFI.Cleanup import LLVM.General.Internal.FFI.Module import LLVM.General.Internal.FFI.Target-import LLVM.General.Internal.FFI.DataLayout import LLVM.General.Internal.FFI.Transforms import qualified LLVM.General.Transforms as G@@ -27,66 +25,43 @@ data PassManager foreign import ccall unsafe "LLVMCreatePassManager" createPassManager ::- IO (Ptr PassManager)+ IO (Ptr PassManager) foreign import ccall unsafe "LLVMDisposePassManager" disposePassManager ::- Ptr PassManager -> IO ()+ Ptr PassManager -> IO () foreign import ccall unsafe "LLVMRunPassManager" runPassManager ::- Ptr PassManager -> Ptr Module -> IO CUInt+ Ptr PassManager -> Ptr Module -> IO CUInt foreign import ccall unsafe "LLVMCreateFunctionPassManagerForModule" createFunctionPassManagerForModule ::- Ptr Module -> IO (Ptr PassManager)+ Ptr Module -> IO (Ptr PassManager) foreign import ccall unsafe "LLVMInitializeFunctionPassManager" initializeFunctionPassManager ::- Ptr PassManager -> IO CUInt+ Ptr PassManager -> IO CUInt foreign import ccall unsafe "LLVMRunFunctionPassManager" runFunctionPassManager ::- Ptr PassManager -> Ptr Value -> IO CUInt+ Ptr PassManager -> Ptr Value -> IO CUInt foreign import ccall unsafe "LLVMFinalizeFunctionPassManager" finalizeFunctionPassManager ::- Ptr PassManager -> IO CUInt--foreign import ccall unsafe "LLVMAddTargetData" addDataLayoutPass' ::- Ptr DataLayout -> Ptr PassManager -> IO ()--addDataLayoutPass = flip addDataLayoutPass'--foreign import ccall unsafe "LLVMAddTargetLibraryInfo" addTargetLibraryInfoPass' ::- Ptr TargetLibraryInfo -> Ptr PassManager -> IO ()--addTargetLibraryInfoPass = flip addTargetLibraryInfoPass'+ Ptr PassManager -> IO CUInt $(do- let declareForeign :: TH.Name -> [TH.Type] -> TH.DecsQ+ let declareForeign :: Name -> [Type] -> DecsQ declareForeign hName extraParams = do- let n = TH.nameBase hName- passTypeMapping :: TH.Type -> TH.TypeQ- passTypeMapping t = case t of- TH.ConT h | h == ''Word -> [t| CUInt |]- | h == ''G.GCOVVersion -> [t| LLVMBool |]- -- some of the LLVM methods for making passes use "-1" as a special value- -- handle those here- TH.AppT (TH.ConT mby) t' | mby == ''Maybe ->- case t' of- TH.ConT h | h == ''Bool -> [t| NothingAsMinusOne Bool |]- | h == ''Word -> [t| NothingAsMinusOne Word |]- | h == ''FilePath -> [t| NothingAsEmptyString CString |]- _ -> typeMapping t- _ -> typeMapping t+ let n = nameBase hName foreignDecl (cName n) ("add" ++ n ++ "Pass") ([[t| Ptr PassManager |]] ++ [[t| Ptr TargetLowering |] | needsTargetLowering n]- ++ map passTypeMapping extraParams)- (TH.tupleT 0)+ ++ map typeMapping extraParams)+ (tupleT 0) - TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''G.Pass+ TyConI (DataD _ _ _ cons _) <- reify ''G.Pass liftM concat $ forM cons $ \con -> case con of- TH.RecC n l -> declareForeign n [ t | (_,_,t) <- l ]- TH.NormalC n [] -> declareForeign n []- TH.NormalC n _ -> error "pass descriptor constructors with fields need to be records"+ RecC n l -> declareForeign n [ t | (_,_,t) <- l ]+ NormalC n [] -> declareForeign n []+ NormalC n _ -> error "pass descriptor constructors with fields need to be records" ) data PassManagerBuilder@@ -104,13 +79,13 @@ Ptr PassManagerBuilder -> CUInt -> IO () foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnitAtATime" passManagerBuilderSetDisableUnitAtATime ::- Ptr PassManagerBuilder -> LLVMBool -> IO () + Ptr PassManagerBuilder -> CUInt -> IO () foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnrollLoops" passManagerBuilderSetDisableUnrollLoops :: Ptr PassManagerBuilder -> CUInt -> IO () foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableSimplifyLibCalls" passManagerBuilderSetDisableSimplifyLibCalls ::- Ptr PassManagerBuilder -> LLVMBool -> IO () + Ptr PassManagerBuilder -> CUInt -> IO () foreign import ccall unsafe "LLVMPassManagerBuilderUseInlinerWithThreshold" passManagerBuilderUseInlinerWithThreshold :: Ptr PassManagerBuilder -> CUInt -> IO ()
src/LLVM/General/Internal/FFI/PassManagerC.cpp view
@@ -1,10 +1,8 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"-#include "llvm/DataLayout.h"+#include "llvm/IR/LLVMContext.h" #include "llvm/Transforms/Scalar.h" #include "llvm/Transforms/IPO.h" #include "llvm/Transforms/Vectorize.h"-#include "llvm/Transforms/Instrumentation.h" #include "llvm/PassManager.h" #include "llvm-c/Core.h"@@ -28,10 +26,6 @@ extern "C" { -void LLVM_General_AddDataLayoutPass(LLVMPassManagerRef PM, const char *dl) {- unwrap(PM)->add(new DataLayout(dl));-}- #define LLVM_GENERAL_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(macro) \ macro(BlockPlacement) \ macro(BreakCriticalEdges) \@@ -69,8 +63,8 @@ unwrap(PM)->add(createInternalizePass(exportList)); } -void LLVM_General_AddLoopStrengthReducePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T) {- unwrap(PM)->add(createLoopStrengthReducePass(unwrap(T)));+void LLVM_General_AddLoopStrengthReducePass(LLVMPassManagerRef PM) {+ unwrap(PM)->add(createLoopStrengthReducePass()); } void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T, LLVMBool expensiveEH) {@@ -131,48 +125,6 @@ vectorizeConfig.FastDep = fastDependencyAnalysis; unwrap(PM)->add(createBBVectorizePass(vectorizeConfig));-}--void LLVM_General_AddEdgeProfilerPass(LLVMPassManagerRef PM) {- unwrap(PM)->add(createEdgeProfilerPass());-}--void LLVM_General_AddOptimalEdgeProfilerPass(LLVMPassManagerRef PM) {- unwrap(PM)->add(createOptimalEdgeProfilerPass());-}--void LLVM_General_AddPathProfilerPass(LLVMPassManagerRef PM) {- unwrap(PM)->add(createPathProfilerPass());-}--void LLVM_General_AddGCOVProfilerPass(- LLVMPassManagerRef PM,- LLVMBool emitNotes,- LLVMBool emitData,- LLVMBool use402Format,- LLVMBool useCfgChecksum-) {- unwrap(PM)->add(- createGCOVProfilerPass(- emitNotes,- emitData,- use402Format,- useCfgChecksum- )- );-}--void LLVM_General_AddAddressSanitizerFunctionPass(LLVMPassManagerRef PM) {- unwrap(PM)->add(createAddressSanitizerPass()- );-}--void LLVM_General_AddThreadSanitizerPass(LLVMPassManagerRef PM) {- unwrap(PM)->add(createThreadSanitizerPass());-}--void LLVM_General_AddBoundsCheckingPass(LLVMPassManagerRef PM) {- unwrap(PM)->add(createBoundsCheckingPass());-}+} }
src/LLVM/General/Internal/FFI/PtrHierarchy.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,+ EmptyDataDecls, FunctionalDependencies,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | This module defines typeclasses to represent the relationships of an object-oriented inheritance hierarchy module LLVM.General.Internal.FFI.PtrHierarchy where @@ -68,11 +71,6 @@ instance ChildOf User Instruction --- | <http://llvm.org/doxygen/classllvm_1_1BinaryOperator.html>-data BinaryOperator--instance ChildOf Instruction BinaryOperator- -- | <http://llvm.org/doxygen/classllvm_1_1User.html> data User @@ -95,7 +93,3 @@ data InlineAsm instance ChildOf Value InlineAsm---- | <http://llvm.org/doxygen/classllvm_1_1Type.html>-data Type-
src/LLVM/General/Internal/FFI/SMDiagnostic.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE- ForeignFunctionInterface+ ForeignFunctionInterface,+ EmptyDataDecls #-}+ -- | FFI functions for handling the LLVM SMDiagnostic class module LLVM.General.Internal.FFI.SMDiagnostic where @@ -28,11 +30,11 @@ Ptr SMDiagnostic -> IO CInt foreign import ccall unsafe "LLVM_General_GetSMDiagnosticFilename" getSMDiagnosticFilename ::- Ptr SMDiagnostic -> IO CString + Ptr SMDiagnostic -> Ptr CUInt -> IO CString foreign import ccall unsafe "LLVM_General_GetSMDiagnosticMessage" getSMDiagnosticMessage ::- Ptr SMDiagnostic -> IO CString + Ptr SMDiagnostic -> Ptr CUInt -> IO CString foreign import ccall unsafe "LLVM_General_GetSMDiagnosticLineContents" getSMDiagnosticLineContents ::- Ptr SMDiagnostic -> IO CString + Ptr SMDiagnostic -> Ptr CUInt -> IO CString
src/LLVM/General/Internal/FFI/SMDiagnosticC.cpp view
@@ -1,5 +1,6 @@ #define __STDC_LIMIT_MACROS-#include "llvm/LLVMContext.h"+#include "llvm/Config/llvm-config.h"+#include "llvm/IR/LLVMContext.h" #include "llvm/Support/SourceMgr.h" #include "llvm-c/Core.h"@@ -24,8 +25,18 @@ int LLVM_General_GetSMDiagnosticLineNo(SMDiagnostic *p) { return p->getLineNo(); } int LLVM_General_GetSMDiagnosticColumnNo(SMDiagnostic *p) { return p->getColumnNo(); }-const char *LLVM_General_GetSMDiagnosticFilename(SMDiagnostic *p) { return p->getFilename().c_str(); }-const char *LLVM_General_GetSMDiagnosticMessage(SMDiagnostic *p) { return p->getMessage().c_str(); }-const char *LLVM_General_GetSMDiagnosticLineContents(SMDiagnostic *p) { return p->getLineContents().c_str(); }++const char *LLVM_General_GetSMDiagnosticFilename(SMDiagnostic *p, unsigned *len) { + *len = p->getFilename().size();+ return p->getFilename().data();+}+const char *LLVM_General_GetSMDiagnosticMessage(SMDiagnostic *p, unsigned *len) {+ *len = p->getMessage().size();+ return p->getMessage().data();+}+const char *LLVM_General_GetSMDiagnosticLineContents(SMDiagnostic *p, unsigned *len) {+ *len = p->getLineContents().size();+ return p->getLineContents().data();+} }
src/LLVM/General/Internal/FFI/Target.h view
@@ -21,10 +21,6 @@ macro(Default) \ macro(Aggressive) -#define LLVM_GENERAL_FOR_EACH_CODE_GEN_FILE_TYPE(macro) \- macro(Assembly) \- macro(Object)- #define LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(macro) \ macro(PrintMachineCode) \ macro(NoFramePointerElim) \
src/LLVM/General/Internal/FFI/Target.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE ForeignFunctionInterface,- GeneralizedNewtypeDeriving+ GeneralizedNewtypeDeriving,+ EmptyDataDecls #-}+ module LLVM.General.Internal.FFI.Target where import Foreign.Ptr import Foreign.C import LLVM.General.Internal.FFI.LLVMCTypes-import LLVM.General.Internal.FFI.Module data Target @@ -16,7 +17,7 @@ IO LLVMBool foreign import ccall unsafe "LLVM_General_LookupTarget" lookupTarget ::- CString -> CString -> Ptr MallocedCString -> Ptr MallocedCString -> IO (Ptr Target)+ CString -> CString -> Ptr CString -> Ptr CString -> IO (Ptr Target) data TargetOptions @@ -60,50 +61,25 @@ Ptr TargetOptions -> IO CUInt foreign import ccall unsafe "LLVM_General_DisposeTargetOptions" disposeTargetOptions ::- Ptr TargetOptions -> IO ()+ Ptr TargetOptions -> IO () data TargetMachine foreign import ccall unsafe "LLVM_General_CreateTargetMachine" createTargetMachine ::- Ptr Target- -> CString - -> CString- -> CString- -> Ptr TargetOptions- -> RelocModel- -> CodeModel- -> CodeGenOptLevel- -> IO (Ptr TargetMachine)+ Ptr Target+ -> CString + -> CString+ -> CString+ -> Ptr TargetOptions+ -> RelocModel+ -> CodeModel+ -> CodeGenOptLevel+ -> IO (Ptr TargetMachine) foreign import ccall unsafe "LLVMDisposeTargetMachine" disposeTargetMachine ::- Ptr TargetMachine -> IO ()--foreign import ccall unsafe "LLVMTargetMachineEmitToFile" targetMachineEmitToFile ::- Ptr TargetMachine -> Ptr Module -> CString -> CodeGenFileType -> Ptr MallocedCString -> IO LLVMBool+ Ptr TargetMachine -> IO () data TargetLowering foreign import ccall unsafe "LLVM_General_GetTargetLowering" getTargetLowering ::- Ptr TargetMachine -> IO (Ptr TargetLowering)--foreign import ccall unsafe "LLVM_General_GetDefaultTargetTriple" getDefaultTargetTriple :: - IO MallocedCString--foreign import ccall unsafe "LLVM_General_GetHostCPUName" getHostCPUName :: - IO MallocedCString--foreign import ccall unsafe "LLVM_General_GetHostCPUFeatures" getHostCPUFeatures :: - IO MallocedCString--foreign import ccall unsafe "LLVM_General_GetTargetMachineDataLayout" getTargetMachineDataLayout ::- Ptr TargetMachine -> IO MallocedCString--data TargetLibraryInfo--foreign import ccall unsafe "LLVM_General_CreateTargetLibraryInfo" createTargetLibraryInfo ::- CString -> IO (Ptr TargetLibraryInfo)--foreign import ccall unsafe "LLVM_General_DisposeTargetLibraryInfo" disposeTargetLibraryInfo ::- Ptr TargetLibraryInfo -> IO ()--foreign import ccall unsafe "LLVM_General_InitializeAllTargets" initializeAllTargets :: IO ()+ Ptr TargetMachine -> IO (Ptr TargetLowering)
src/LLVM/General/Internal/FFI/TargetC.cpp view
@@ -1,12 +1,7 @@ #define __STDC_LIMIT_MACROS #include "llvm/Support/TargetRegistry.h"-#include "llvm/Support/TargetSelect.h"-#include "llvm/Support/Host.h" #include "llvm/Target/TargetMachine.h"-#include "llvm/Target/TargetLibraryInfo.h" #include "llvm/ADT/Triple.h"-#include "llvm/ExecutionEngine/Interpreter.h"-#include "llvm/DataLayout.h" #include "llvm-c/Target.h" #include "llvm-c/TargetMachine.h" #include "llvm-c/Core.h"@@ -15,6 +10,23 @@ using namespace llvm; namespace llvm {+// Taken from llvm/lib/Target/TargetMachineC.cpp+static Target *unwrap(LLVMTargetRef P) {+ return reinterpret_cast<Target*>(P);+}+// Taken from llvm/lib/Target/TargetMachineC.cpp+static LLVMTargetRef wrap(const Target * P) {+ return reinterpret_cast<LLVMTargetRef>(const_cast<Target*>(P));+}+// Taken from llvm/lib/Target/TargetMachineC.cpp+inline TargetMachine *unwrap(LLVMTargetMachineRef P) {+ return reinterpret_cast<TargetMachine*>(P);+}+// Taken from llvm/lib/Target/TargetMachineC.cpp+inline LLVMTargetMachineRef wrap(const TargetMachine *P) {+ return+ reinterpret_cast<LLVMTargetMachineRef>(const_cast<TargetMachine*>(P));+} static Reloc::Model unwrap(LLVMRelocMode x) { switch(x) {@@ -25,15 +37,6 @@ } } -static CodeModel::Model unwrap(LLVMCodeModel x) {- switch(x) {-#define ENUM_CASE(x) case LLVMCodeModel ## x: return CodeModel::x;-LLVM_GENERAL_FOR_EACH_CODE_MODEL(ENUM_CASE)-#undef ENUM_CASE- default: return CodeModel::Model(0);- }-}- static CodeGenOpt::Level unwrap(LLVMCodeGenOptLevel x) { switch(x) { #define ENUM_CASE(x) case LLVMCodeGenLevel ## x: return CodeGenOpt::x;@@ -203,47 +206,5 @@ return unwrap(t)->getTargetLowering(); } -char *LLVM_General_GetDefaultTargetTriple() {- return strdup(sys::getDefaultTargetTriple().c_str()); } -char *LLVM_General_GetHostCPUName() {- return strdup(sys::getHostCPUName().c_str());-}--char *LLVM_General_GetHostCPUFeatures() {- StringMap<bool> featureMap;- std::string features;- if (sys::getHostCPUFeatures(featureMap)) {- for(llvm::StringMap<bool>::const_iterator it = featureMap.begin(); it != featureMap.end(); ++it) {- if (it->second) {- features += it->first().str() + " ";- }- }- }- return strdup(features.c_str());-}--char *LLVM_General_GetTargetMachineDataLayout(LLVMTargetMachineRef t) {- return strdup(unwrap(t)->getDataLayout()->getStringRepresentation().c_str());-}--LLVMTargetLibraryInfoRef LLVM_General_CreateTargetLibraryInfo(- const char *triple-) {- return wrap(new TargetLibraryInfo(Triple(triple)));-}--void LLVM_General_DisposeTargetLibraryInfo(LLVMTargetLibraryInfoRef l) {- delete unwrap(l);-}--void LLVM_General_InitializeAllTargets() {- InitializeAllTargetInfos();- InitializeAllTargets();- InitializeAllTargetMCs();- InitializeAllAsmPrinters();- // None of the other components are bound yet-}--}
src/LLVM/General/Internal/FFI/Transforms.hs view
@@ -3,7 +3,6 @@ -- | does the constructor for this pass require a TargetLowering object needsTargetLowering "CodeGenPrepare" = True-needsTargetLowering "LoopStrengthReduce" = True needsTargetLowering "LowerInvoke" = True needsTargetLowering _ = False @@ -14,7 +13,6 @@ -- | as part of this Haskell package ("LLVM_General_" prefix). cName n = let core = case n of- "AddressSanitizer" -> "AddressSanitizerFunction" "AggressiveDeadCodeElimination" -> "AggressiveDCE" "AlwaysInline" -> "AlwaysInliner" "DeadInstructionElimination" -> "DeadInstElimination"@@ -36,9 +34,6 @@ "SparseConditionalConstantPropagation" -> "SCCP" h -> h patchImpls = [- "AddressSanitizer",- "AddressSanitizerModule",- "BoundsChecking", "CodeGenPrepare", "GlobalValueNumbering", "InternalizeFunctions",@@ -47,28 +42,20 @@ "BreakCriticalEdges", "DeadCodeElimination", "DeadInstructionElimination",- "DebugExistingIR",- "DebugGeneratedIR", "DemoteRegisterToMemory",- "EdgeProfiler",- "GCOVProfiler", "LoopClosedSingleStaticAssignment", "LoopInstructionSimplify", "LoopStrengthReduce", "LowerAtomic", "LowerInvoke", "LowerSwitch",- "MemorySanitizer", "MergeFunctions",- "OptimalEdgeProfiler",- "PathProfiler", "PartialInlining", "ScalarReplacementOfAggregates", "Sinking", "StripDeadDebugInfo", "StripDebugDeclare",- "StripNonDebugSymbols",- "ThreadSanitizer"+ "StripNonDebugSymbols" ] in (if (n `elem` patchImpls) then "LLVM_General_" else "LLVM") ++ "Add" ++ core ++ "Pass"
src/LLVM/General/Internal/FFI/Type.hs view
@@ -1,17 +1,20 @@ {-# LANGUAGE- ForeignFunctionInterface+ ForeignFunctionInterface,+ EmptyDataDecls #-}+ -- | Functions for handling the LLVM types module LLVM.General.Internal.FFI.Type where import Foreign.Ptr import Foreign.C-import Data.Word import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.Context-import LLVM.General.Internal.FFI.PtrHierarchy +-- | a blind type to correspond to llvm::Type+data Type+ -- | <http://llvm.org/doxygen/group__LLVMCCoreType.html#ga112756467f0988613faa6043d674d843> foreign import ccall unsafe "LLVMGetTypeKind" getTypeKind :: Ptr Type -> IO TypeKind@@ -66,7 +69,7 @@ -- | what <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#gabd1666e080f693e1af0b4018005cd927> -- | would be if it supported 64-bit array sizes, as the C++ type does. foreign import ccall unsafe "LLVM_General_ArrayType" arrayType ::- Ptr Type -> Word64 -> IO (Ptr Type)+ Ptr Type -> CULong -> IO (Ptr Type) -- | <http://llvm.org/doxygen/group__LLVMCCoreTypeStruct.html#gaff2af74740a22f7d18701f0d8c3e5a6f> foreign import ccall unsafe "LLVMStructTypeInContext" structTypeInContext' ::@@ -109,7 +112,7 @@ -- | what <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga02dc08041a12265cb700ee469497df63> -- | would be if it supported 64 bit lengths foreign import ccall unsafe "LLVM_General_GetArrayLength" getArrayLength ::- Ptr Type -> IO Word64+ Ptr Type -> IO CULong -- | <http://llvm.org/doxygen/group__LLVMCCoreTypeOther.html#ga1c78ca6d7bf279330b9195fa52f23828> foreign import ccall unsafe "LLVMVoidTypeInContext" voidTypeInContext ::@@ -137,8 +140,4 @@ -- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#gac2491184fc3d8631c7b264c067f2f761> foreign import ccall unsafe "LLVMPPCFP128TypeInContext" ppcFP128TypeInContext ::- Ptr Context -> IO (Ptr Type)---- | <http://llvm.org/doxygen/classllvm_1_1Type.html#a28fdf240b8220065bc60d6d1b1a2f174>-foreign import ccall unsafe "LLVM_General_MetadataTypeInContext" metadataTypeInContext :: Ptr Context -> IO (Ptr Type)
src/LLVM/General/Internal/FFI/TypeC.cpp view
@@ -1,6 +1,8 @@ #define __STDC_LIMIT_MACROS #include "llvm-c/Core.h"-#include "llvm/Type.h"+#include "llvm/IR/LLVMContext.h"+#include "llvm/IR/Type.h"+#include "llvm/IR/DerivedTypes.h" using namespace llvm; @@ -30,8 +32,5 @@ return unwrap<ArrayType>(ArrayTy)->getNumElements(); } -LLVMTypeRef LLVM_General_MetadataTypeInContext(LLVMContextRef C) {- return wrap(Type::getMetadataTy(*unwrap(C)));-} }
src/LLVM/General/Internal/FFI/User.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | FFI functions for handling the LLVM User class module LLVM.General.Internal.FFI.User where
src/LLVM/General/Internal/FFI/Value.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE ForeignFunctionInterface,+ EmptyDataDecls, MultiParamTypeClasses,+ FlexibleContexts,+ FlexibleInstances, UndecidableInstances, OverlappingInstances #-}+ -- | FFI functions for handling the LLVM Value class module LLVM.General.Internal.FFI.Value where @@ -11,6 +15,7 @@ import Foreign.C import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Type import LLVM.General.Internal.FFI.PtrHierarchy -- | <http://llvm.org/doxygen/group__LLVMCCoreValueGeneral.html#ga12179f46b79de8436852a4189d4451e0>
src/LLVM/General/Internal/FFI/ValueC.cpp view
@@ -1,6 +1,6 @@ #define __STDC_LIMIT_MACROS #include "llvm-c/Core.h"-#include "llvm/Value.h"+#include "llvm/IR/Value.h" #include "LLVM/General/Internal/FFI/Value.h" using namespace llvm;
src/LLVM/General/Internal/FloatingPointPredicate.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses,- TemplateHaskell+ TemplateHaskell,+ FlexibleInstances #-}+ module LLVM.General.Internal.FloatingPointPredicate where import LLVM.General.Internal.Coding@@ -9,7 +11,7 @@ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.AST.FloatingPointPredicate as A.FPPred -genCodingInstance [t| A.FPPred.FloatingPointPredicate |] ''FFI.FCmpPredicate [+genCodingInstance' [t| A.FPPred.FloatingPointPredicate |] ''FFI.FCmpPredicate [ (FFI.fCmpPredFalse, A.FPPred.False), (FFI.fCmpPredOEQ, A.FPPred.OEQ), (FFI.fCmpPredOGT, A.FPPred.OGT),
src/LLVM/General/Internal/Function.hs view
@@ -10,7 +10,6 @@ import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import LLVM.General.Internal.DecodeAST-import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Value import LLVM.General.Internal.Coding import LLVM.General.Internal.Attribute ()@@ -39,8 +38,3 @@ `ap` getLocalName param `ap` (liftIO $ getParameterAttrs param) -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
src/LLVM/General/Internal/Global.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ FlexibleInstances,+ MultiParamTypeClasses,+ FlexibleContexts #-} module LLVM.General.Internal.Global where @@ -22,7 +24,7 @@ import qualified LLVM.General.AST.Linkage as A.L import qualified LLVM.General.AST.Visibility as A.V -genCodingInstance [t| A.L.Linkage |] ''FFI.Linkage [+genCodingInstance' [t| A.L.Linkage |] ''FFI.Linkage [ (FFI.linkageExternal, A.L.External), (FFI.linkageAvailableExternally, A.L.AvailableExternally), (FFI.linkageLinkOnceAny, A.L.LinkOnce),@@ -46,7 +48,7 @@ setLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.L.Linkage -> EncodeAST () setLinkage g l = liftIO . FFI.setLinkage (FFI.upCast g) =<< encodeM l -genCodingInstance [t| A.V.Visibility |] ''FFI.Visibility [+genCodingInstance' [t| A.V.Visibility |] ''FFI.Visibility [ (FFI.visibilityDefault, A.V.Default), (FFI.visibilityHidden, A.V.Hidden), (FFI.visibilityProtected, A.V.Protected)
src/LLVM/General/Internal/InlineAssembly.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances #-} module LLVM.General.Internal.InlineAssembly where @@ -24,7 +25,7 @@ import LLVM.General.Internal.DecodeAST import LLVM.General.Internal.Value -genCodingInstance [t| A.Dialect |] ''FFI.AsmDialect [+genCodingInstance' [t| A.Dialect |] ''FFI.AsmDialect [ (FFI.asmDialectATT, A.ATTDialect), (FFI.asmDialectIntel, A.IntelDialect) ]
src/LLVM/General/Internal/Instruction.hs view
@@ -1,21 +1,23 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes,+ TupleSections, MultiParamTypeClasses,- UndecidableInstances+ FlexibleContexts,+ FlexibleInstances #-} module LLVM.General.Internal.Instruction where 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.AnyCont import Control.Monad.State+import Control.Monad.Phased import Foreign.Ptr @@ -59,12 +61,6 @@ else return zip `ap` decodeM (n', ks) `ap` decodeM (n', ps) getMetadata 4 -setMD :: Ptr FFI.Instruction -> A.InstructionMetadata -> EncodeAST ()-setMD i md = forM_ md $ \(kindName, anode) -> do- kindID <- encodeM kindName- node <- encodeM anode- liftIO $ FFI.setMetadata i kindID node- instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where decodeM i = scopeAnyCont $ do n <- liftIO $ FFI.getInstructionDefOpcode i@@ -73,10 +69,10 @@ let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n) successor n = decodeM =<< (liftIO $ FFI.isABasicBlock =<< FFI.getOperand (FFI.upCast i) n) case n of- [instrP|Ret|] -> do+ [ID.instrP|Ret|] -> do returnOperand' <- if nOps == 0 then return Nothing else Just <$> op 0 return $ A.Ret { A.returnOperand = returnOperand', A.metadata' = md }- [instrP|Br|] -> do+ [ID.instrP|Br|] -> do n <- liftIO $ FFI.getNumOperands (FFI.upCast i) case n of 1 -> do@@ -92,7 +88,7 @@ A.trueDest = trueDest, A.metadata' = md }- [instrP|Switch|] -> do+ [ID.instrP|Switch|] -> do op0 <- op 0 dd <- successor 1 let nCases = (nOps - 2) `div` 2@@ -107,7 +103,7 @@ A.dests = dests, A.metadata' = md }- [instrP|IndirectBr|] -> do+ [ID.instrP|IndirectBr|] -> do op0 <- op 0 let nDests = nOps - 1 dests <- allocaArray nDests@@ -118,7 +114,7 @@ A.possibleDests = dests, A.metadata' = md }- [instrP|Invoke|] -> do+ [ID.instrP|Invoke|] -> do cc <- decodeM =<< liftIO (FFI.getInstructionCallConv i) rAttrs <- callInstAttr i 0 fv <- liftIO $ FFI.getCallInstCalledValue i@@ -137,13 +133,13 @@ A.exceptionDest = ed, A.metadata' = md }- [instrP|Resume|] -> do+ [ID.instrP|Resume|] -> do op0 <- op 0 return A.Resume { A.operand0' = op0, A.metadata' = md }- [instrP|Unreachable|] -> do+ [ID.instrP|Unreachable|] -> do return A.Unreachable { A.metadata' = md }@@ -220,7 +216,10 @@ } -> do i <- liftIO $ FFI.buildUnreachable builder return $ FFI.upCast i- setMD t' (A.metadata' t)+ forM (A.metadata' t) $ \(k, mdn) -> do+ k <- encodeM k+ mdn <- encodeM mdn+ liftIO $ FFI.setMetadata t' k mdn return t' $(do@@ -234,9 +233,9 @@ nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i) let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n) cop n = decodeM =<< (liftIO $ FFI.isAConstant =<< FFI.getOperand (FFI.upCast i) n)- get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap (FFI.upCast b)- get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap (FFI.upCast b)- get_exact b = liftIO $ decodeM =<< FFI.isExact (FFI.upCast b)+ get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap b+ get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap b+ get_exact b = liftIO $ decodeM =<< FFI.isExact b n <- liftIO $ FFI.getInstructionDefOpcode i $(@@ -248,8 +247,8 @@ "exact" -> (["b"], [| get_exact $(TH.dyn "b") |]) "operand0" -> ([], [| op 0 |]) "operand1" -> ([], [| op 1 |])- "address" -> ([], case lrn of "Store" -> [| op 1 |]; _ -> [| op 0 |])- "value" -> ([], case lrn of "Store" -> [| op 0 |]; _ -> [| op 1 |])+ "address" -> ([], [| op 0 |])+ "value" -> ([], [| op 1 |]) "expected" -> ([], [| op 1 |]) "replacement" -> ([], [| op 2 |]) "condition'" -> ([], [| op 0 |])@@ -307,7 +306,7 @@ a <- allocaArray n liftIO $ FFI.getInstStructureIndices i a decodeM (n, a) |])- "rmwOperation" -> ([], [| decodeM =<< liftIO (FFI.getAtomicRMWOperation i) |])+ "rmwOperation" -> ([], [| decodeM =<< liftIO (FFI.getAtomicRMWBinOp i) |]) "cleanup" -> ([], [| decodeM =<< liftIO (FFI.isCleanup i) |]) _ -> ([], [| error $ "unrecognized instruction field or depenency thereof: " ++ show s |]) in@@ -334,52 +333,52 @@ ] ) - instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction, EncodeAST ()) where+ instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction) where encodeM o = scopeAnyCont $ do builder <- gets encodeStateBuilder- let return' i = return (FFI.upCast i, return ()) s <- encodeM ""- (inst, act) <- $(+ $( [| case o of A.ICmp { - A.iPredicate = pred,- A.operand0 = op0,- A.operand1 = op1+ A.iPredicate = pred, + A.operand0 = op0, + A.operand1 = op1, + A.metadata = [] } -> do op0' <- encodeM op0 op1' <- encodeM op1 pred <- encodeM pred i <- liftIO $ FFI.buildICmp builder pred op0' op1' s- return' i+ return $ FFI.upCast i A.FCmp {- A.fpPredicate = pred,- A.operand0 = op0,- A.operand1 = op1+ A.fpPredicate = pred, + A.operand0 = op0, + A.operand1 = op1, + A.metadata = [] } -> do op0' <- encodeM op0 op1' <- encodeM op1 pred <- encodeM pred i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s- return' i+ return $ FFI.upCast 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'- )+ defer+ let (ivs3, bs3) = unzip ivs+ ivs3' <- encodeM ivs3+ bs3' <- encodeM bs3+ liftIO $ FFI.addIncoming i ivs3' bs3'+ return $ FFI.upCast i A.Call { A.isTailCall = tc, A.callingConvention = cc, A.returnAttributes = rAttrs, A.function = f, A.arguments = args,- A.functionAttributes = fAttrs+ A.functionAttributes = fAttrs,+ A.metadata = [] } -> do fv <- encodeM f let (argvs, argAttrs) = unzip args@@ -395,46 +394,46 @@ liftIO $ FFI.setTailCall i tc cc <- encodeM cc liftIO $ FFI.setInstructionCallConv i cc- return' i+ return $ FFI.upCast 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+ return $ FFI.upCast 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+ return $ FFI.upCast 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+ return $ FFI.upCast 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+ return $ FFI.upCast 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+ return $ FFI.upCast 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+ return $ FFI.upCast 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+ return $ FFI.upCast i A.LandingPad { A.type' = t, A.personalityFunction = pf,@@ -459,53 +458,58 @@ when cl $ do cl <- encodeM cl liftIO $ FFI.setCleanup i cl- return' i+ return $ FFI.upCast 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+ return $ FFI.upCast i A.Load { A.volatile = vol, A.address = a, A.alignment = al,- A.maybeAtomicity = mat+ A.maybeAtomicity = mat,+ A.metadata = [] } -> 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+ return $ FFI.upCast i A.Store { A.volatile = vol, A.address = a, A.value = v, A.maybeAtomicity = mat, - A.alignment = al+ A.alignment = al, + A.metadata = [] } -> 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+ i <- liftIO $ FFI.buildStore builder a' v' al vol mo ss s+ return $ FFI.upCast 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+ i <- liftIO $ FFI.buildGetElementPtr builder a' is' n s+ when ib $ do+ ib <- encodeM ib + liftIO $ FFI.setInBounds i ib+ return $ FFI.upCast i A.Fence { A.atomicity = at } -> do (ss, mo) <- encodeM at i <- liftIO $ FFI.buildFence builder mo ss s- return' i+ return $ FFI.upCast i A.CmpXchg { A.volatile = vol, A.address = a, A.expected = e, A.replacement = r,- A.atomicity = at+ A.atomicity = at,+ A.metadata = [] } -> do a' <- encodeM a e' <- encodeM e@@ -513,13 +517,14 @@ vol <- encodeM vol (ss, mo) <- encodeM at i <- liftIO $ FFI.buildCmpXchg builder a' e' r' vol mo ss s- return' i+ return $ FFI.upCast i A.AtomicRMW { A.volatile = vol, A.rmwOperation = rmwOp, A.address = a, A.value = v,- A.atomicity = at+ A.atomicity = at,+ A.metadata = [] } -> do a' <- encodeM a v' <- encodeM v@@ -527,7 +532,7 @@ vol <- encodeM vol (ss, mo) <- encodeM at i <- liftIO $ FFI.buildAtomicRMW builder rmwOp a' v' vol mo ss s- return' i+ return $ FFI.upCast i o -> $( let fieldData :: String -> [Either TH.ExpQ TH.ExpQ]@@ -538,7 +543,8 @@ "nsw" -> [Left [| encodeM $(TH.dyn s) |] ] "nuw" -> [Left [| encodeM $(TH.dyn s) |] ] "exact" -> [Left [| encodeM $(TH.dyn s) |] ]- "metadata" -> [Right [| return () |] ]+ "metadata" -> + [Right [| unless (List.null $(TH.dyn s)) $ error "can't handle metadata yet" |]] _ -> error $ "unhandled instruction field " ++ show s in TH.caseE [| o |] [@@ -578,7 +584,7 @@ let s = TH.nameBase f, Right action <- fieldData s ] ++ [- TH.noBindS [| return' $(TH.dyn "i") |]+ TH.noBindS [| return $ FFI.upCast $(TH.dyn "i") |] ] ) ]@@ -586,17 +592,14 @@ |] )- setMD inst (A.metadata o)- return (inst, act) |] ) -instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (DecodeAST (A.Named a)) (Ptr FFI.Instruction) where+instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (A.Named a) (Ptr FFI.Instruction) where decodeM i = do t <- typeOf i- w <- if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)- return $ return w `ap` decodeM i+ (if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)) `ap` (do defer; decodeM i) instance EncodeM EncodeAST a (Ptr FFI.Instruction) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where encodeM (A.Do o) = encodeM o@@ -607,15 +610,5 @@ liftIO $ FFI.setValueName v n' defineLocal n v return i--instance EncodeM EncodeAST a (Ptr FFI.Instruction, EncodeAST ()) => EncodeM EncodeAST (A.Named a) (EncodeAST ()) where- encodeM (A.Do o) = liftM snd $ (encodeM o :: EncodeAST (Ptr FFI.Instruction, EncodeAST ()))- encodeM (n A.:= o) = do- (i, later) <- encodeM o- let v = FFI.upCast (i :: Ptr FFI.Instruction)- n' <- encodeM n- liftIO $ FFI.setValueName v n'- defineLocal n v- return later
src/LLVM/General/Internal/InstructionDefs.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-}+ module LLVM.General.Internal.InstructionDefs ( astInstructionRecs, astConstantRecs,@@ -41,15 +42,13 @@ refName x = x innerJoin :: Ord k => Map k a -> Map k b -> Map k (a,b)-innerJoin = Map.intersectionWith (,)-+innerJoin = Map.mergeWithKey (\_ a b -> Just (a,b)) (const Map.empty) (const Map.empty)+ outerJoin :: Ord k => Map k a -> Map k b -> Map k (Maybe a, Maybe b)-outerJoin xs ys = Map.unionWith combine- (Map.map (\a -> (Just a, Nothing)) xs)- (Map.map (\b -> (Nothing, Just b)) ys)- where- combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)- combine _ _ = error "outerJoin: the impossible happened"+outerJoin = Map.mergeWithKey + (\_ a b -> Just (Just a, Just b))+ (Map.map $ \a -> (Just a, Nothing))+ (Map.map $ \b -> (Nothing, Just b)) instrP = TH.QuasiQuoter { TH.quoteExp = undefined,
src/LLVM/General/Internal/IntegerPredicate.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances #-}+ module LLVM.General.Internal.IntegerPredicate where import LLVM.General.Internal.Coding@@ -9,7 +11,7 @@ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.AST.IntegerPredicate as A.IPred -genCodingInstance [t| A.IPred.IntegerPredicate |] ''FFI.ICmpPredicate [+genCodingInstance' [t| A.IPred.IntegerPredicate |] ''FFI.ICmpPredicate [ (FFI.iCmpPredEQ, A.IPred.EQ), (FFI.iCmpPredNE, A.IPred.NE), (FFI.iCmpPredUGT, A.IPred.UGT),
src/LLVM/General/Internal/Metadata.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances #-} module LLVM.General.Internal.Metadata where
src/LLVM/General/Internal/Module.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE- TemplateHaskell,- ScopedTypeVariables,- MultiParamTypeClasses+ TupleSections,+ ScopedTypeVariables #-}+ -- | This Haskell module is for/of functions for handling LLVM modules. module LLVM.General.Internal.Module where import Control.Monad.Trans import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Phased import Control.Monad.AnyCont import Control.Applicative import Control.Exception import Foreign.Ptr+import Foreign.Marshal.Alloc (free) import qualified LLVM.General.Internal.FFI.Assembly as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI@@ -23,29 +24,25 @@ import qualified LLVM.General.Internal.FFI.GlobalValue as FFI import qualified LLVM.General.Internal.FFI.GlobalVariable as FFI import qualified LLVM.General.Internal.FFI.Iterate as FFI-import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI-import qualified LLVM.General.Internal.FFI.Metadata as FFI import qualified LLVM.General.Internal.FFI.Module as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI-import qualified LLVM.General.Internal.FFI.Target as FFI import qualified LLVM.General.Internal.FFI.Value as FFI+import qualified LLVM.General.Internal.FFI.Metadata as FFI import LLVM.General.Internal.BasicBlock import LLVM.General.Internal.Coding import LLVM.General.Internal.Context+import LLVM.General.Internal.DataLayout import LLVM.General.Internal.DecodeAST import LLVM.General.Internal.Diagnostic import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Function import LLVM.General.Internal.Global-import LLVM.General.Internal.Instruction () import LLVM.General.Internal.Metadata import LLVM.General.Internal.Operand-import LLVM.General.Internal.Target import LLVM.General.Internal.Type import LLVM.General.Internal.Value -import LLVM.General.DataLayout import LLVM.General.Diagnostic import qualified LLVM.General.AST as A@@ -56,67 +53,23 @@ -- | <http://llvm.org/doxygen/classllvm_1_1Module.html> newtype Module = Module (Ptr FFI.Module) -instance Error (Either String Diagnostic) where- strMsg = Left--genCodingInstance [t| Bool |] ''FFI.LinkerMode [- (FFI.linkerModeDestroySource, False),- (FFI.linkerModePreserveSource, True)- ]---- | link LLVM modules - move or copy parts of a source module into a destination module.--- Note that this operation is not commutative - not only concretely (e.g. the destination module--- is modified, becoming the result) but abstractly (e.g. unused private globals in the source--- module do not appear in the result, but similar globals in the destination remain).-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- preserveRight <- encodeM preserveRight- msgPtr <- alloca- result <- decodeM =<< (liftIO $ FFI.linkModules m m' preserveRight msgPtr)- when result $ fail =<< decodeM msgPtr- -- | parse 'Module' from LLVM assembly-withModuleFromString :: Context -> String -> (Module -> IO a) -> ErrorT (Either String Diagnostic) IO a+withModuleFromString :: Context -> String -> (Module -> IO a) -> IO (Either Diagnostic a) withModuleFromString (Context c) s f = flip runAnyContT return $ do s <- encodeM s- smDiag <- anyContToM withSMDiagnostic- m <- anyContToM $ bracket (FFI.getModuleFromAssemblyInContext c s smDiag) FFI.disposeModule- when (m == nullPtr) $ throwError . Right =<< liftIO (getDiagnostic smDiag)- liftIO $ f (Module m)+ liftIO $ withSMDiagnostic $ \smDiag -> do+ m <- FFI.getModuleFromAssemblyInContext c s smDiag+ if m == nullPtr then+ Left <$> getDiagnostic smDiag+ else+ Right <$> finally (f (Module m)) (FFI.disposeModule m) -- | generate LLVM assembly from a 'Module' moduleString :: Module -> IO String-moduleString (Module m) = decodeM =<< FFI.getModuleAssembly m---- | generate LLVM bitcode from a 'Module'-writeBitcodeToFile :: FilePath -> Module -> ErrorT String IO ()-writeBitcodeToFile path (Module m) = flip runAnyContT return $ do- msgPtr <- alloca- path <- encodeM path- result <- decodeM =<< (liftIO $ FFI.writeBitcodeToFile m path msgPtr)- when result $ fail =<< decodeM msgPtr--emitToFile :: FFI.CodeGenFileType -> TargetMachine -> FilePath -> Module -> ErrorT String IO ()-emitToFile fileType (TargetMachine tm) path (Module m) = flip runAnyContT return $ do- msgPtr <- alloca- path <- encodeM path- result <- decodeM =<< (liftIO $ FFI.targetMachineEmitToFile tm m path fileType msgPtr)- when result $ fail =<< decodeM msgPtr---- | write target-specific assembly directly into a file-writeAssemblyToFile :: TargetMachine -> FilePath -> Module -> ErrorT String IO ()-writeAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly---- | write target-specific object code directly into a file-writeObjectToFile :: TargetMachine -> FilePath -> Module -> ErrorT String IO ()-writeObjectToFile = emitToFile FFI.codeGenFileTypeObject+moduleString (Module m) = bracket (FFI.getModuleAssembly m) free $ decodeM -setTargetTriple :: Ptr FFI.Module -> String -> EncodeAST ()-setTargetTriple m t = do+setTargetTriple :: Ptr FFI.Module -> String -> IO ()+setTargetTriple m t = flip runAnyContT return $ do t <- encodeM t liftIO $ FFI.setTargetTriple m t @@ -125,153 +78,139 @@ s <- decodeM =<< liftIO (FFI.getTargetTriple m) return $ if s == "" then Nothing else Just s -setDataLayout :: Ptr FFI.Module -> A.DataLayout -> EncodeAST ()-setDataLayout m dl = do+setDataLayout :: Ptr FFI.Module -> A.DataLayout -> IO ()+setDataLayout m dl = flip runAnyContT return $ do s <- encodeM (dataLayoutToString dl) 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---- | 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@(Context c) (A.Module moduleId dataLayout triple definitions) f = runEncodeAST context $ do- moduleId <- encodeM moduleId- m <- anyContToM $ bracket (FFI.moduleCreateWithNameInContext moduleId c) FFI.disposeModule- maybe (return ()) (setDataLayout m) dataLayout- maybe (return ()) (setTargetTriple m) triple- let sequencePhases :: EncodeAST [EncodeAST (EncodeAST (EncodeAST (EncodeAST ())))] -> EncodeAST ()- sequencePhases l = (l >>= (sequence >=> sequence >=> sequence >=> sequence)) >> (return ())-- sequencePhases $ forM definitions $ \d -> case d of- A.TypeDefinition n t -> do- t' <- createNamedType n- defineType n t'- return $ do- maybe (return ()) (setNamedType t') t- return . return . return $ return ()+-- | Build a 'Module' from a 'LLVM.General.AST.Module'.+withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> IO (Either String a)+withModuleFromAST context@(Context c) (A.Module moduleId dataLayout triple definitions) f = do+ let makeModule = flip runAnyContT return $ do+ moduleId <- encodeM moduleId+ liftIO $ FFI.moduleCreateWithNameInContext moduleId c+ bracket makeModule FFI.disposeModule $ \m -> do+ maybe (return ()) (setDataLayout m) dataLayout+ maybe (return ()) (setTargetTriple m) triple+ r <- runEncodeAST context $ forInterleavedM definitions $ \d -> case d of+ A.TypeDefinition n t -> do+ t' <- createNamedType n+ defineType n t'+ defer+ maybe (return ()) (setNamedType t') t - A.MetadataNodeDefinition i os -> return . return $ do- t <- liftIO $ FFI.createTemporaryMDNodeInContext c- defineMDNode i t- return $ do- n <- encodeM (A.MetadataNode os)- liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)- defineMDNode i n- liftIO $ FFI.destroyTemporaryMDNode t- return $ return ()+ A.MetadataNodeDefinition i os -> do+ replicateM_ 2 defer+ t <- liftIO $ FFI.createTemporaryMDNodeInContext c+ defineMDNode i t+ defer+ n <- encodeM (A.MetadataNode os)+ liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)+ defineMDNode i n+ liftIO $ FFI.destroyTemporaryMDNode t - A.NamedMetadataDefinition n ids -> return . return . return . return $ do- n <- encodeM n- ids <- encodeM (map A.MetadataNodeReference ids)- nm <- liftIO $ FFI.getOrAddNamedMetadata m n- liftIO $ FFI.namedMetadataAddOperands nm ids- return ()+ A.NamedMetadataDefinition n ids -> do+ replicateM_ 4 defer+ n <- encodeM n+ ids <- encodeM (map A.MetadataNodeReference ids)+ nm <- liftIO $ FFI.getOrAddNamedMetadata m n+ liftIO $ FFI.namedMetadataAddOperands nm ids - A.ModuleInlineAssembly s -> do- s <- encodeM s- liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s)- return . return . return . return $ return ()+ A.ModuleInlineAssembly s -> do+ s <- encodeM s+ liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s) - 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 - (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g))- defineGlobal n 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)- FFI.setGlobalConstant g' ic- return $ do- maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)- setSection g' (A.G.section 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- defineGlobal n a'- return $ do- (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- 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- setSection f (A.G.section g)- setAlignment f (A.G.alignment g)- setGC f gc- forM blocks $ \(A.BasicBlock bName _ _) -> do- b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName- defineBasicBlock fName bName b- phase $ do- let nParams = length args- ps <- allocaArray nParams- liftIO $ FFI.getParams f ps- params <- peekArray nParams ps- forM (zip args params) $ \(A.Parameter _ n attrs, 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- builder <- gets encodeStateBuilder- liftIO $ FFI.positionBuilderAtEnd builder b)- finishes <- mapM encodeM namedInstrs :: EncodeAST [EncodeAST ()]- (encodeM term :: EncodeAST (Ptr FFI.Instruction))- return (sequence_ finishes)- sequence_ finishInstrs- return (FFI.upCast f)- return $ do- g' <- eg'- setLinkage g' (A.G.linkage g)- setVisibility g' (A.G.visibility g)- return $ return ()+ A.GlobalDefinition g -> do+ replicateM_ 2 defer+ g' :: 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 + (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g))+ defineGlobal n 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)+ FFI.setGlobalConstant g' ic+ defer+ maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)+ setSection g' (A.G.section 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+ defineGlobal n a'+ defer+ (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a)+ return (FFI.upCast a')+ (A.Function _ _ cc rAttrs resultType fName (args,isVarArgs) attrs _ _ blocks) -> do+ typ <- encodeM $ A.FunctionType resultType (map (\(A.Parameter t _ _) -> 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+ setSection f (A.G.section g)+ setAlignment f (A.G.alignment g)+ encodeScope $ do+ forM blocks $ \(A.BasicBlock bName _ _) -> do+ b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName+ defineBasicBlock fName bName b+ defer+ let nParams = length args+ ps <- allocaArray nParams+ liftIO $ FFI.getParams f ps+ params <- peekArray nParams ps+ forM (zip args params) $ \(A.Parameter _ n attrs, 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 ()+ forInterleavedM blocks $ \(A.BasicBlock bName namedInstrs term) -> do+ b <- encodeM bName+ (do builder <- gets encodeStateBuilder; liftIO $ FFI.positionBuilderAtEnd builder b)+ (mapM encodeM namedInstrs :: EncodeAST [Ptr FFI.Instruction])+ encodeM term :: EncodeAST (Ptr FFI.Instruction)+ return (FFI.upCast f)+ setLinkage g' (A.G.linkage g)+ setVisibility g' (A.G.visibility g) - liftIO $ f (Module m) + either (return . Left) (const $ Right <$> f (Module m)) r --- | Get an LLVM.General.AST.'LLVM.General.AST.Module' from a LLVM.General.'Module' - i.e.--- raise C++ objects into an Haskell AST.+-- | Get a 'LLVM.General.AST.Module' from a 'Module'. moduleAST :: Module -> IO A.Module moduleAST (Module mod) = runDecodeAST $ do c <- return Context `ap` liftIO (FFI.getModuleContext mod) getMetadataKindNames c return A.Module - `ap` (liftIO $ decodeM =<< FFI.getModuleIdentifier mod)+ `ap` (liftIO $ bracket (FFI.getModuleIdentifier mod) free decodeM) `ap` (liftIO $ getDataLayout mod) `ap` (liftIO $ do s <- decodeM <=< FFI.getTargetTriple $ mod return $ if s == "" then Nothing else Just s) `ap` ( do- gs <- map A.GlobalDefinition . concat <$> (join . liftM sequence . sequence) [+ gs <- map A.GlobalDefinition . concat <$> runInterleaved [ do ffiGlobals <- liftIO $ FFI.getXs (FFI.getFirstGlobal mod) FFI.getNextGlobal- liftM sequence . forM ffiGlobals $ \g -> do+ forM ffiGlobals $ \g -> do A.PointerType t as <- typeOf g- n <- getGlobalName g- return $ return A.GlobalVariable- `ap` return n+ return A.GlobalVariable+ `ap` getGlobalName g `ap` getLinkage g `ap` getVisibility g `ap` (liftIO $ decodeM =<< FFI.isThreadLocal g)@@ -280,6 +219,7 @@ `ap` (liftIO $ decodeM =<< FFI.isGlobalConstant g) `ap` return t `ap` (do+ defer i <- liftIO $ FFI.getInitializer g if i == nullPtr then return Nothing else Just <$> decodeM i) `ap` getSection g@@ -287,10 +227,9 @@ do ffiAliases <- liftIO $ FFI.getXs (FFI.getFirstAlias mod) FFI.getNextAlias- liftM sequence . forM ffiAliases $ \a -> do- n <- getGlobalName a- return $ return A.G.GlobalAlias- `ap` return n+ forM ffiAliases $ \a -> do+ return A.G.GlobalAlias+ `ap` (do n <- getGlobalName a; defer; return n) `ap` getLinkage a `ap` getVisibility a `ap` typeOf a@@ -298,30 +237,27 @@ do ffiFunctions <- liftIO $ FFI.getXs (FFI.getFirstFunction mod) FFI.getNextFunction- liftM sequence . forM ffiFunctions $ \f -> localScope $ do+ forM ffiFunctions $ \f -> localScope $ do A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f- n <- getGlobalName f- parameters <- getParameters f- decodeBlocks <- do- ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock- liftM sequence . forM ffiBasicBlocks $ \b -> do- n <- getLocalName b- decodeInstructions <- getNamedInstructions b- decodeTerminator <- getBasicBlockTerminator b- return $ return A.BasicBlock `ap` return n `ap` decodeInstructions `ap` decodeTerminator- return $ return A.Function+ return A.Function `ap` getLinkage f `ap` getVisibility f `ap` (liftIO $ decodeM =<< FFI.getFunctionCallConv f) `ap` (liftIO $ decodeM =<< FFI.getFunctionRetAttr f) `ap` return returnType- `ap` return n- `ap` return (parameters, isVarArg)+ `ap` (getGlobalName f)+ `ap` ((, isVarArg) <$> getParameters f) `ap` (liftIO $ getFunctionAttrs f) `ap` getSection f `ap` getAlignment f- `ap` getGC f- `ap` decodeBlocks+ `ap` (do+ ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock+ runInterleaved . flip map ffiBasicBlocks $ \b -> + return A.BasicBlock+ `ap` (do n <- getLocalName b; defer; return n)+ `iap` getNamedInstructions b+ `iap` getBasicBlockTerminator b+ ) ] tds <- getStructDefinitions
src/LLVM/General/Internal/Operand.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances #-} module LLVM.General.Internal.Operand where @@ -70,7 +71,7 @@ liftIO $ FFI.createMDNodeInContext c ops encodeM (A.MetadataNodeReference n) = referMDNode n -instance DecodeM DecodeAST [Maybe A.Operand] (Ptr FFI.MDNode) where+instance DecodeM DecodeAST [A.Operand] (Ptr FFI.MDNode) where decodeM p = scopeAnyCont $ do n <- liftIO $ FFI.getMDNodeNumOperands p ops <- allocaArray n
src/LLVM/General/Internal/PassManager.hs view
@@ -1,129 +1,108 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ FlexibleInstances #-}+ module LLVM.General.Internal.PassManager where import qualified Language.Haskell.TH as TH import Control.Exception-import Control.Monad hiding (forM_)+import Control.Monad import Control.Monad.IO.Class import Control.Applicative import Control.Monad.AnyCont -import Data.Word-import Data.Foldable (forM_) import Foreign.Ptr import qualified LLVM.General.Internal.FFI.PassManager as FFI import qualified LLVM.General.Internal.FFI.Transforms as FFI-import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.Module import LLVM.General.Internal.Target import LLVM.General.Internal.Coding-import LLVM.General.Internal.DataLayout import LLVM.General.Transforms -import LLVM.General.AST.DataLayout- -- | <http://llvm.org/doxygen/classllvm_1_1PassManager.html>--- Note: a PassManager does substantive behind-the-scenes work, arranging for the--- results of various analyses to be available as needed by transform passes, shared--- as possible. newtype PassManager = PassManager (Ptr FFI.PassManager) --- | There are different ways to get a 'PassManager'. This type embodies them.-data PassSetSpec- -- | a 'PassSetSpec' is a lower-level, detailed specification of a set of passes. It- -- allows fine-grained control of what passes are to be run when, and the specification- -- of passes not available through 'CuratedPassSetSpec'.- = PassSetSpec {- transforms :: [Pass],- dataLayout :: Maybe DataLayout,- targetLibraryInfo :: Maybe TargetLibraryInfo,- targetLowering :: Maybe TargetLowering- }- -- | This type is a high-level specification of a set of passes. It uses the same- -- collection of passes chosen by the LLVM team in the command line tool 'opt'. The fields- -- of this spec are much like typical compiler command-line flags - e.g. -O\<n\>, etc.- | CuratedPassSetSpec {- optLevel :: Maybe Word,- sizeLevel :: Maybe Word,- unitAtATime :: Maybe Bool,- simplifyLibCalls :: Maybe Bool,- useInlinerWithThreshold :: Maybe Word- }+-- | There are different ways to get a 'PassManager'. This class embodies them.+class PassManagerSpecification s where+ -- | make a 'PassManager'+ createPassManager :: s -> IO (Ptr FFI.PassManager) --- | Helper to make a curated 'PassSetSpec'+-- | This type is a high-level specification of a set of passes. It uses the same+-- collection of passes chosen by the LLVM team in the command line tool 'opt'. The fields+-- of this spec are much like typical compiler command-line flags - e.g. -O\<n\>, etc.+data CuratedPassSetSpec = CuratedPassSetSpec {+ optLevel :: Maybe Int,+ sizeLevel :: Maybe Int,+ unitAtATime :: Maybe Bool,+ simplifyLibCalls :: Maybe Bool,+ useInlinerWithThreshold :: Maybe Int+ }++-- | Helper to make a 'CuratedPassSetSpec' defaultCuratedPassSetSpec = CuratedPassSetSpec {- optLevel = Nothing,- sizeLevel = Nothing,- unitAtATime = Nothing,- simplifyLibCalls = Nothing,- useInlinerWithThreshold = Nothing-}+ optLevel = Nothing,+ sizeLevel = Nothing,+ unitAtATime = Nothing,+ simplifyLibCalls = Nothing,+ useInlinerWithThreshold = Nothing+ } --- | an empty 'PassSetSpec'-defaultPassSetSpec = PassSetSpec {- transforms = [],- dataLayout = Nothing,- targetLibraryInfo = Nothing,- targetLowering = Nothing-}+instance PassManagerSpecification CuratedPassSetSpec where+ createPassManager s = bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do+ let handleOption g m = maybe (return ()) (g b . fromIntegral . fromEnum) (m s)+ handleOption FFI.passManagerBuilderSetOptLevel optLevel+ handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel+ handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime)+ handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls)+ handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold+ pm <- FFI.createPassManager+ FFI.passManagerBuilderPopulateModulePassManager b pm+ return pm -instance (Monad m, MonadAnyCont IO m) => EncodeM m GCOVVersion FFI.LLVMBool where- encodeM (GCOVVersion "402*") = encodeM True- encodeM (GCOVVersion "404*") = encodeM False- encodeM s = fail $ "unsupported GCOVVersion: "++ show s ++ ". llvm-3.2 supports only \"402*\" and \"404*\""+data PassSetSpec = PassSetSpec [Pass] (Maybe TargetLowering) -createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager)-createPassManager pss = flip runAnyContT return $ do- pm <- liftIO $ FFI.createPassManager- case pss of- s@CuratedPassSetSpec {} -> liftIO $ do- bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do- let handleOption g m = forM_ (m s) (g b <=< encodeM) - handleOption FFI.passManagerBuilderSetOptLevel optLevel- handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel- handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime)- handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls)- handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold- FFI.passManagerBuilderPopulateModulePassManager b pm- PassSetSpec ps dl tli tl' -> do- let tl = maybe nullPtr (\(TargetLowering tl) -> tl) tl'- forM_ tli $ \(TargetLibraryInfo tli) -> do- liftIO $ FFI.addTargetLibraryInfoPass pm tli- forM_ dl $ \dl -> liftIO $ withFFIDataLayout dl $ FFI.addDataLayoutPass pm - forM_ ps $ \p -> $(- do- TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass- TH.caseE [| p |] $ flip map cons $ \con -> do- let- (n, fns) = case con of- TH.RecC n fs -> (n, [ TH.nameBase fn | (fn, _, _) <- fs ])- TH.NormalC n [] -> (n, [])- actions = - [ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn fn) |] | fn <- fns ]- ++ [- TH.noBindS [|- liftIO $(- foldl1 TH.appE- (map TH.dyn $- ["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"]- ++ ["tl" | FFI.needsTargetLowering (TH.nameBase n)]- ++ fns)- )- |]- ]- TH.match (TH.conP n $ map (TH.varP . TH.mkName) fns) (TH.normalB (TH.doE actions)) []- )- return pm+instance PassManagerSpecification PassSetSpec where+ createPassManager (PassSetSpec ps tl') = flip runAnyContT return $ do+ let tl = maybe nullPtr (\(TargetLowering tl) -> tl) tl'+ pm <- liftIO $ FFI.createPassManager+ forM ps $ \p -> $(+ do+ TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass+ TH.caseE [| p |] $ flip map cons $ \con -> do+ let+ (n, fns) = case con of+ TH.RecC n fs -> (n, [ TH.nameBase fn | (fn, _, _) <- fs ])+ TH.NormalC n [] -> (n, [])+ actions = + [ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn fn) |] | fn <- fns ]+ ++ [+ TH.noBindS [|+ liftIO $(+ foldl1 TH.appE+ (map TH.dyn $+ ["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"]+ ++ ["tl" | FFI.needsTargetLowering (TH.nameBase n)]+ ++ fns)+ )+ |]+ ]+ TH.match (TH.conP n $ map (TH.varP . TH.mkName) fns) (TH.normalB (TH.doE actions)) []+ )+ return pm +instance PassManagerSpecification [Pass] where+ createPassManager ps = createPassManager (PassSetSpec ps Nothing)++instance PassManagerSpecification ([Pass], TargetLowering) where+ createPassManager (ps, tl) = createPassManager (PassSetSpec ps (Just tl))+ -- | bracket the creation of a 'PassManager'-withPassManager :: PassSetSpec -> (PassManager -> IO a) -> IO a+withPassManager :: PassManagerSpecification s => s -> (PassManager -> IO a) -> IO a withPassManager s = bracket (createPassManager s) FFI.disposePassManager . (. PassManager) -- | run the passes in a 'PassManager' on a 'Module', modifying the 'Module'.
src/LLVM/General/Internal/RMWOperation.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE TemplateHaskell,- MultiParamTypeClasses+ MultiParamTypeClasses,+ FlexibleInstances #-}+ module LLVM.General.Internal.RMWOperation where import LLVM.General.AST.RMWOperation@@ -10,7 +12,7 @@ import LLVM.General.Internal.Coding -genCodingInstance [t| RMWOperation |] ''FFI.RMWOperation [+genCodingInstance' [t| RMWOperation |] ''FFI.RMWOperation [ (FFI.rmwOperationXchg, Xchg), (FFI.rmwOperationAdd, Add), (FFI.rmwOperationSub, Sub),
src/LLVM/General/Internal/String.hs view
@@ -1,57 +1,37 @@ {-# LANGUAGE MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances #-} module LLVM.General.Internal.String where import Control.Arrow import Control.Monad-import Control.Monad.AnyCont-import Control.Monad.IO.Class-import Control.Exception (finally)-import Data.Maybe (fromMaybe) import Foreign.C (CString, CChar) import Foreign.Ptr+import Control.Monad.AnyCont+import Control.Monad.IO.Class import Foreign.Storable (Storable)-import Foreign.Marshal.Alloc as F.M (alloca, free)--import LLVM.General.Internal.FFI.LLVMCTypes+import Foreign.Marshal.Alloc as F.M (alloca) import LLVM.General.Internal.Coding import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as BSUTF8--newtype UTF8ByteString = UTF8ByteString { utf8Bytes :: BS.ByteString }--instance (Monad e) => EncodeM e String UTF8ByteString where- encodeM = return . UTF8ByteString . BSUTF8.fromString--instance (Monad d) => DecodeM d String UTF8ByteString where- decodeM = return . BSUTF8.toString . utf8Bytes-+import qualified Data.Text as T+import qualified Data.Text.Encoding as T instance (MonadAnyCont IO e) => EncodeM e String CString where- encodeM s = anyContToM (BS.useAsCString . utf8Bytes =<< encodeM s)+ encodeM s = anyContToM (BS.useAsCString . T.encodeUtf8 . T.pack $ s) instance (Integral i, MonadAnyCont IO e) => EncodeM e String (Ptr CChar, i) where- encodeM s = anyContToM ((. (. second fromIntegral)) $ BS.useAsCStringLen . utf8Bytes =<< encodeM s)+ encodeM s = anyContToM ((. (. second fromIntegral)) . BS.useAsCStringLen . T.encodeUtf8 . T.pack $ s) instance (MonadIO d) => DecodeM d String CString where- decodeM = decodeM . UTF8ByteString <=< liftIO . BS.packCString--instance (MonadIO d) => DecodeM d String MallocedCString where- decodeM (MallocedCString s) = liftIO $ finally (decodeM s) (free s)--instance (MonadIO d) => DecodeM d String (Ptr MallocedCString) where- decodeM = liftIO . decodeM <=< peek+ decodeM = liftIO . liftM (T.unpack . T.decodeUtf8) . BS.packCString instance (Integral i, MonadIO d) => DecodeM d String (Ptr CChar, i) where- decodeM = decodeM . UTF8ByteString <=< liftIO . BS.packCStringLen . second fromIntegral+ decodeM = liftIO . liftM (T.unpack . T.decodeUtf8) . BS.packCStringLen . second fromIntegral instance (Integral i, Storable i, MonadIO d) => DecodeM d String (Ptr i -> IO (Ptr CChar)) where decodeM f = decodeM =<< (liftIO $ F.M.alloca $ \p -> (,) `liftM` f p `ap` peek p) -instance (Monad e, EncodeM e String c) => EncodeM e (Maybe String) (NothingAsEmptyString c) where- encodeM = liftM NothingAsEmptyString . encodeM . fromMaybe ""-
src/LLVM/General/Internal/Target.hs view
@@ -1,29 +1,24 @@ {-# LANGUAGE TemplateHaskell,+ FlexibleInstances, MultiParamTypeClasses,- RecordWildCards,- UndecidableInstances+ TupleSections,+ RecordWildCards #-} module LLVM.General.Internal.Target where import Control.Monad-import Control.Monad.Error import Control.Exception import Data.Functor+import Control.Monad.IO.Class 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 Foreign.Marshal.Alloc (free) import LLVM.General.Internal.Coding import LLVM.General.Internal.String ()-import LLVM.General.DataLayout -import LLVM.General.AST.DataLayout- import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.Target as FFI @@ -32,14 +27,14 @@ import qualified LLVM.General.CodeModel as CodeModel import qualified LLVM.General.CodeGenOpt as CodeGenOpt -genCodingInstance [t| Reloc.Model |] ''FFI.RelocModel [+genCodingInstance' [t| Reloc.Model |] ''FFI.RelocModel [ (FFI.relocModelDefault, Reloc.Default), (FFI.relocModelStatic, Reloc.Static), (FFI.relocModelPIC, Reloc.PIC), (FFI.relocModelDynamicNoPic, Reloc.DynamicNoPIC) ] -genCodingInstance [t| CodeModel.Model |] ''FFI.CodeModel [+genCodingInstance' [t| CodeModel.Model |] ''FFI.CodeModel [ (FFI.codeModelDefault,CodeModel.Default), (FFI.codeModelJITDefault, CodeModel.JITDefault), (FFI.codeModelSmall, CodeModel.Small),@@ -48,53 +43,48 @@ (FFI.codeModelLarge, CodeModel.Large) ] -genCodingInstance [t| CodeGenOpt.Level |] ''FFI.CodeGenOptLevel [+genCodingInstance' [t| CodeGenOpt.Level |] ''FFI.CodeGenOptLevel [ (FFI.codeGenOptLevelNone, CodeGenOpt.None), (FFI.codeGenOptLevelLess, CodeGenOpt.Less), (FFI.codeGenOptLevelDefault, CodeGenOpt.Default), (FFI.codeGenOptLevelAggressive, CodeGenOpt.Aggressive) ] -genCodingInstance [t| TO.FloatABI |] ''FFI.FloatABIType [+genCodingInstance' [t| TO.FloatABI |] ''FFI.FloatABIType [ (FFI.floatABIDefault, TO.FloatABIDefault), (FFI.floatABISoft, TO.FloatABISoft), (FFI.floatABIHard, TO.FloatABIHard) ] -genCodingInstance [t| TO.FloatingPointOperationFusionMode |] ''FFI.FPOpFusionMode [+genCodingInstance' [t| TO.FloatingPointOperationFusionMode |] ''FFI.FPOpFusionMode [ (FFI.fpOpFusionModeFast, TO.FloatingPointOperationFusionFast), (FFI.fpOpFusionModeStandard, TO.FloatingPointOperationFusionStandard), (FFI.fpOpFusionModeStrict, TO.FloatingPointOperationFusionStrict) ] --- | <http://llvm.org/doxygen/classllvm_1_1Target.html> newtype Target = Target (Ptr FFI.Target) --- | e.g. an instruction set extension-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---- | Find a 'Target' given an architecture and/or a \"triple\".+-- | 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 :: Maybe String -- ^ arch -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu- -> ErrorT String IO (Target, String)+ -> IO (Either String (Target, String)) lookupTarget arch triple = 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- liftM (Target target, ) $ decodeM cNewTripleP+ let readString p = do+ s <- peek p+ r <- decodeM s+ liftIO $ free s+ return r+ if (target == nullPtr) then+ Left <$> readString cErrorP+ else+ Right . (Target target, ) <$> readString cNewTripleP -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html> newtype TargetOptions = TargetOptions (Ptr FFI.TargetOptions)@@ -195,7 +185,7 @@ Target -> String -- ^ triple -> String -- ^ cpu- -> Set CPUFeature -- ^ features+ -> String -- ^ features -> TargetOptions -> Reloc.Model -> CodeModel.Model@@ -217,7 +207,7 @@ relocModel <- encodeM relocModel codeModel <- encodeM codeModel codeGenOptLevel <- encodeM codeGenOptLevel- anyContToM $ bracket (+ anyContT $ bracket ( FFI.createTargetMachine target triple@@ -237,56 +227,3 @@ -- | get the 'TargetLowering' of a 'TargetMachine' getTargetLowering :: TargetMachine -> IO TargetLowering getTargetLowering (TargetMachine tm) = TargetLowering <$> FFI.getTargetLowering tm---- | Initialize the native target. This function is called automatically in these Haskell bindings--- when creating an 'LLVM.General.ExecutionEngine.ExecutionEngine' which will require it, and so it should--- not be necessary to call it separately.-initializeNativeTarget :: IO ()-initializeNativeTarget = do- failure <- decodeM =<< liftIO FFI.initializeNativeTarget- when failure $ fail "native target initialization failed"---- | the default target triple that LLVM has been configured to produce code for-getDefaultTargetTriple :: IO String-getDefaultTargetTriple = decodeM =<< FFI.getDefaultTargetTriple---- | the LLVM name for the host CPU-getHostCPUName :: IO String-getHostCPUName = decodeM =<< FFI.getHostCPUName---- | a space-separated list of LLVM feature names supported by the host CPU-getHostCPUFeatures :: IO (Set CPUFeature)-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))---- | 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- liftIO $ initializeAllTargets- triple <- liftIO $ getDefaultTargetTriple- cpu <- liftIO $ getHostCPUName- features <- liftIO $ getHostCPUFeatures- (target, _) <- lookupTarget Nothing triple- liftIO $ withTargetOptions $ \options ->- withTargetMachine target triple cpu features options Reloc.Default CodeModel.Default CodeGenOpt.Default f---- | <http://llvm.org/docs/doxygen/html/classllvm_1_1TargetLibraryInfo.html>-newtype TargetLibraryInfo = TargetLibraryInfo (Ptr FFI.TargetLibraryInfo)---- | look up information about the library functions available on a given platform-withTargetLibraryInfo :: - String -- ^ triple- -> (TargetLibraryInfo -> IO a)- -> IO a-withTargetLibraryInfo triple f = flip runAnyContT return $ do- triple <- encodeM triple- liftIO $ bracket (FFI.createTargetLibraryInfo triple) FFI.disposeTargetLibraryInfo (f . TargetLibraryInfo)-
src/LLVM/General/Internal/Type.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes,+ FlexibleInstances, MultiParamTypeClasses #-} module LLVM.General.Internal.Type where@@ -13,9 +14,7 @@ import Foreign.Ptr import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI-import LLVM.General.Internal.FFI.LLVMCTypes (typeKindP) import qualified LLVM.General.Internal.FFI.Type as FFI-import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.AST as A import qualified LLVM.General.AST.AddrSpace as A@@ -99,15 +98,14 @@ packed <- encodeM packed liftIO $ FFI.structTypeInContext context ets packed A.NamedTypeReference n -> lookupNamedType n- A.MetadataType -> liftIO $ FFI.metadataTypeInContext context instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where decodeM t = scopeAnyCont $ do k <- liftIO $ FFI.getTypeKind t case k of- [typeKindP|Void|] -> return A.VoidType- [typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))- [typeKindP|Function|] -> + [FFI.typeKindP|Void|] -> return A.VoidType+ [FFI.typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))+ [FFI.typeKindP|Function|] -> return A.FunctionType `ap` (decodeM =<< liftIO (FFI.getReturnType t)) `ap` (do@@ -117,27 +115,27 @@ decodeM (n, ts) ) `ap` (decodeM =<< liftIO (FFI.isFunctionVarArg t))- [typeKindP|Pointer|] ->+ [FFI.typeKindP|Pointer|] -> return A.PointerType `ap` (decodeM =<< liftIO (FFI.getElementType t)) `ap` (decodeM =<< liftIO (FFI.getPointerAddressSpace t))- [typeKindP|Half|] -> return $ A.FloatingPointType 16 A.IEEE- [typeKindP|Float|] -> return $ A.FloatingPointType 32 A.IEEE- [typeKindP|Double|] -> return $ A.FloatingPointType 64 A.IEEE- [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|] -> + [FFI.typeKindP|Half|] -> return $ A.FloatingPointType 16 A.IEEE+ [FFI.typeKindP|Float|] -> return $ A.FloatingPointType 32 A.IEEE+ [FFI.typeKindP|Double|] -> return $ A.FloatingPointType 64 A.IEEE+ [FFI.typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE+ [FFI.typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended+ [FFI.typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats+ [FFI.typeKindP|Vector|] -> return A.VectorType `ap` (decodeM =<< liftIO (FFI.getVectorSize t)) `ap` (decodeM =<< liftIO (FFI.getElementType t))- [typeKindP|Struct|] -> do+ [FFI.typeKindP|Struct|] -> do let ifM c a b = c >>= \x -> if x then a else b ifM (decodeM =<< liftIO (FFI.structIsLiteral t)) (getStructure t) (saveNamedType t >> return A.NamedTypeReference `ap` getTypeName t) - [typeKindP|Array|] -> + [FFI.typeKindP|Array|] -> return A.ArrayType `ap` (decodeM =<< liftIO (FFI.getArrayLength t)) `ap` (decodeM =<< liftIO (FFI.getElementType t))
src/LLVM/General/Internal/Value.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE+ FlexibleContexts,+ FlexibleInstances, MultiParamTypeClasses #-} module LLVM.General.Internal.Value where
src/LLVM/General/Module.hs view
@@ -1,17 +1,11 @@ -- | A 'Module' holds a C++ LLVM IR module. 'Module's may be converted to or from strings or Haskell ASTs, or--- added to an 'LLVM.General.ExecutionEngine.ExecutionEngine' and so JIT compiled to get function pointers.+-- added to an 'LLVM.General.ExecutionEngine' and so JIT compiled to get funciton pointers. module LLVM.General.Module ( Module, withModuleFromAST, moduleAST, withModuleFromString,- moduleString,-- writeBitcodeToFile,- writeAssemblyToFile,- writeObjectToFile,-- linkModules+ moduleString ) where import LLVM.General.Internal.Module
src/LLVM/General/PassManager.hs view
@@ -1,12 +1,17 @@ -- | A 'PassManager' holds collection of passes, to be run on 'Module's.--- Build one with 'withPassManager':+-- Build one with 'createPassManager': -- --- * using 'CuratedPassSetSpec' if you want optimization but not to play with your compiler+-- * from a 'CuratedPassSetSpec' if you want optimization but not to play with your compiler ----- * using 'PassSetSpec' if you do want to play with your compiler+-- * from a ['LLVM.General.Transform.Pass'] if you do want to play with your compiler+--+-- * from a (['LLVM.General.Transform.Pass'], 'LLVM.General.Target.TargetLowering') if you+-- want to provide target-specific information (e.g. instruction costs) to the few passes+-- that use it (see comments on 'LLVM.General.Transforms.Pass'). module LLVM.General.PassManager ( PassManager,- PassSetSpec(..), defaultPassSetSpec, defaultCuratedPassSetSpec,+ PassManagerSpecification,+ CuratedPassSetSpec(..), defaultCuratedPassSetSpec, withPassManager, runPassManager ) where
src/LLVM/General/Relocation.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-} -- | Relocations, used in specifying TargetMachine module LLVM.General.Relocation where
src/LLVM/General/Target.hs view
@@ -4,15 +4,9 @@ module LLVM.General.Target ( lookupTarget, TargetOptions,- Target, TargetMachine, TargetLowering,- CPUFeature(..), withTargetOptions, peekTargetOptions, pokeTargetOptions,- withTargetMachine, withDefaultTargetMachine,- getTargetLowering,- getDefaultTargetTriple, getHostCPUName, getHostCPUFeatures,- getTargetMachineDataLayout, initializeNativeTarget, initializeAllTargets,- TargetLibraryInfo,- withTargetLibraryInfo+ withTargetMachine,+ getTargetLowering ) where import LLVM.General.Internal.Target
src/LLVM/General/Target/Options.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE+ DeriveDataTypeable + #-} -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html> module LLVM.General.Target.Options where
src/LLVM/General/Transforms.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE+ DeriveDataTypeable+ #-} -- | This module provides an enumeration of the various transformation (e.g. optimization) passes -- provided by LLVM. They can be used to create a 'LLVM.General.PassManager.PassManager' to, in turn, -- run the passes on 'LLVM.General.Module.Module's. If you don't know what passes you want, consider@@ -5,6 +8,7 @@ module LLVM.General.Transforms where import Data.Data+import Data.Int import Data.Word -- | <http://llvm.org/docs/Passes.html#transform-passes>@@ -35,9 +39,8 @@ | LoopIdiom | LoopInstructionSimplify | LoopRotate- -- | can use a 'LLVM.General.Target.TargetLowering' | LoopStrengthReduce- | LoopUnroll { loopUnrollThreshold :: Maybe Word, count :: Maybe Word, allowPartial :: Maybe Bool }+ | LoopUnroll { loopUnrollThreshold :: Int32, count :: Int32, allowPartial :: Int32 } | LoopUnswitch { optimizeForSize :: Bool } | LowerAtomic -- | can use a 'LLVM.General.Target.TargetLowering'@@ -49,11 +52,11 @@ | Reassociate | ScalarReplacementOfAggregates { requiresDominatorTree :: Bool } | OldScalarReplacementOfAggregates { - oldScalarReplacementOfAggregatesThreshold :: Maybe Word, + oldScalarReplacementOfAggregatesThreshold :: Int32, useDominatorTree :: Bool, - structMemberThreshold :: Maybe Word,- arrayElementThreshold :: Maybe Word,- scalarLoadThreshold :: Maybe Word+ structMemberThreshold :: Int32,+ arrayElementThreshold :: Int32,+ scalarLoadThreshold :: Int32 } | SparseConditionalConstantPropagation | SimplifyLibCalls@@ -67,7 +70,7 @@ | ConstantMerge | FunctionAttributes | FunctionInlining { - functionInliningThreshold :: Word+ functionInliningThreshold :: Int32 } | GlobalDeadCodeElimination | InternalizeFunctions { exportList :: [String] }@@ -83,44 +86,30 @@ -- here begin the vectorization passes | BasicBlockVectorize { - vectorBits :: Word,- vectorizeBools :: Bool,- vectorizeInts :: Bool,- vectorizeFloats :: Bool,- vectorizePointers :: Bool,- vectorizeCasts :: Bool,- vectorizeMath :: Bool,- vectorizeFusedMultiplyAdd :: Bool,- vectorizeSelect :: Bool,- vectorizeCmp :: Bool,- vectorizeGetElementPtr :: Bool,- vectorizeMemoryOperations :: Bool,- alignedOnly :: Bool,- requiredChainDepth :: Word,- searchLimit :: Word,- maxCandidatePairsForCycleCheck :: Word,- splatBreaksChain :: Bool,- maxInstructions :: Word,- maxIterations :: Word,- powerOfTwoLengthsOnly :: Bool,- noMemoryOperationBoost :: Bool,- fastDependencyAnalysis :: Bool+ vectorBits :: Word32,+ vectorizeBools :: Bool,+ vectorizeInts :: Bool,+ vectorizeFloats :: Bool,+ vectorizePointers :: Bool,+ vectorizeCasts :: Bool,+ vectorizeMath :: Bool,+ vectorizeFusedMultiplyAdd :: Bool,+ vectorizeSelect :: Bool,+ vectorizeCmp :: Bool,+ vectorizeGetElementPtr :: Bool,+ vectorizeMemoryOperations :: Bool,+ alignedOnly :: Bool,+ requiredChainDepth :: Word32,+ searchLimit :: Word32,+ maxCandidatePairsForCycleCheck :: Word32,+ splatBreaksChain :: Bool,+ maxInstructions :: Word32,+ maxIterations :: Word32,+ powerOfTwoLengthsOnly :: Bool,+ noMemoryOperationBoost :: Bool,+ fastDependencyAnalysis :: Bool } | LoopVectorize-- -- here begin the instrumentation passes- | EdgeProfiler- | OptimalEdgeProfiler- | PathProfiler- | GCOVProfiler {- emitNotes :: Bool,- emitData :: Bool,- version :: GCOVVersion,- useCfgChecksum :: Bool- }- | AddressSanitizer- | ThreadSanitizer- | BoundsChecking deriving (Eq, Ord, Read, Show, Typeable, Data) -- | Defaults for the 'BasicBlockVectorize' pass - copied from the C++ code to keep these defaults@@ -151,21 +140,3 @@ noMemoryOperationBoost = False, fastDependencyAnalysis = False }---- | See <http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/gcov-io.h?view=markup>.-newtype GCOVVersion = GCOVVersion String- deriving (Eq, Ord, Read, Show, Typeable, Data)---- | Defaults for 'GCOVProfiler'.-defaultGCOVProfiler = GCOVProfiler {- emitNotes = True,- emitData = True,- version = GCOVVersion "402*", - useCfgChecksum = False- }---- | Defaults for 'AddressSanitizer'.-defaultAddressSanitizer = AddressSanitizer---- | Defaults for 'ThreadSanitizer'.-defaultThreadSanitizer = ThreadSanitizer
− test/LLVM/General/Test/Analysis.hs
@@ -1,113 +0,0 @@-module LLVM.General.Test.Analysis where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit--import LLVM.General.Test.Support--import Control.Monad.Error--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.Name-import LLVM.General.AST.AddrSpace-import LLVM.General.AST.DataLayout-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.CallingConvention as CC-import qualified LLVM.General.AST.Attribute as A-import qualified LLVM.General.AST.Global as G-import qualified LLVM.General.AST.Constant as C--import qualified LLVM.General.Relocation as R-import qualified LLVM.General.CodeModel as CM-import qualified LLVM.General.CodeGenOpt as CGO--tests = testGroup "Analysis" [- testGroup "Verifier" [-{-- -- this test will cause an assertion if LLVM is compiled with assertions on.- testCase "Module" $ do- let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([- Parameter (IntegerType 32) (Name "x") []- ],False)- [] - Nothing 0 - [- BasicBlock (UnName 0) [- UnName 1 := Call {- isTailCall = False,- callingConvention = CC.C,- returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),- arguments = [- (ConstantOperand (C.Int 8 1), [])- ],- functionAttributes = [],- metadata = []- }- ] (- Do $ Ret Nothing []- )- ]- ]- Left s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify- s @?= "Call parameter type does not match function signature!\n\- \i8 1\n\- \ i32 call void @foo(i8 1)\n\- \Broken module found, compilation terminated.\n\- \Broken module found, compilation terminated.\n",--}-- testGroup "regression" [- testCase "load synchronization" $ do- let str = "; ModuleID = '<string>'\n\- \\n\- \define double @my_function2(double* %input_0) {\n\- \foo:\n\- \ %tmp_input_w0 = getelementptr inbounds double* %input_0, i64 0\n\- \ %0 = load double* %tmp_input_w0, align 8\n\- \ ret double %0\n\- \}\n"- ast = - Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = FloatingPointType 64 IEEE,- G.name = Name "my_function2",- G.parameters = ([- Parameter (PointerType (FloatingPointType 64 IEEE) (AddrSpace 0)) (Name "input_0") []- ],False),- G.basicBlocks = [- BasicBlock (Name "foo") [ - Name "tmp_input_w0" := GetElementPtr {- inBounds = True,- address = LocalReference (Name "input_0"),- indices = [ConstantOperand (C.Int 64 0)],- metadata = []- },- UnName 0 := Load {- volatile = False,- address = LocalReference (Name "tmp_input_w0"),- maybeAtomicity = Nothing,- alignment = 8,- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (UnName 0))) []- )- ]- }- ]- strCheck ast str- s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify- s @?= Right ()- ]- ]- ]
test/LLVM/General/Test/Constants.hs view
@@ -109,20 +109,10 @@ 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),- "global i32 undef"- ), ( "binop/cast", IntegerType 64,- C.Add False False (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2),+ C.Add (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (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),- "global i64 add nsw (i64 ptrtoint (i32* @1 to i64), i64 2)" ), ( "icmp", IntegerType 1,
+ test/LLVM/General/Test/DataLayout.hs view
@@ -0,0 +1,29 @@+module LLVM.General.Test.DataLayout where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import qualified Data.Set as Set++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.AST+import LLVM.General.AST.DataLayout+import qualified LLVM.General.AST.Global as G++tests = testGroup "DataLayout" [+ testCase name $ strCheck (Module "<string>" mdl Nothing []) ("; ModuleID = '<string>'\n" ++ sdl)+ | (name, mdl, sdl) <- [+ ("none",Nothing, "")+ ] ++ [+ (name, Just mdl, "target datalayout = \"" ++ sdl ++ "\"\n")+ | (name, mdl, sdl) <- [+ ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e"),+ ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E"),+ ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32")+ ]+ ]+ ]
test/LLVM/General/Test/ExecutionEngine.hs view
@@ -1,14 +1,10 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}+{-# LANGUAGE ForeignFunctionInterface #-} module LLVM.General.Test.ExecutionEngine where import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit -import LLVM.General.Test.Support- import Control.Monad import Data.Functor import Data.Maybe@@ -34,27 +30,23 @@ foreign import ccall "dynamic" mkIO32Stub :: FunPtr (Word32 -> IO Word32) -> (Word32 -> IO Word32) -testJIT :: ExecutionEngine e (FunPtr ()) => (Context -> (e -> IO ()) -> IO ()) -> Assertion-testJIT withEE = withContext $ \context -> withEE context $ \executionEngine -> do- let mAST = Module "runSomethingModule" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "_foo",- G.parameters = ([Parameter (IntegerType 32) (Name "bar") []],False),- G.basicBlocks = [+tests = testGroup "ExecutionEngine" [++ testCase "runSomething" $ withContext $ \context -> withExecutionEngine context $ \executionEngine -> do+ let mAST = Module "runSomethingModule" Nothing Nothing [+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "foo") []+ ],False) [] + Nothing 0+ [ BasicBlock (UnName 0) [] ( Do $ Ret (Just (ConstantOperand (C.Int 32 42))) []- )+ )+ ] ]- }- ]-- s <- withModuleFromAST' context mAST $ \m -> do- withModuleInEngine executionEngine m $ \em -> do- Just p <- getFunction em (Name "_foo")- (mkIO32Stub ((castFunPtr p) :: FunPtr (Word32 -> IO Word32))) 7- s @?= 42--tests = testGroup "ExecutionEngine" [- testCase "run something with JIT" $ testJIT (\c -> withJIT c 2)+ s <- withModuleFromAST context mAST $ \m -> do+ withModuleInEngine executionEngine m $ do+ Just p <- findFunction executionEngine (Name "foo")+ (mkIO32Stub ((castPtrToFunPtr p) :: FunPtr (Word32 -> IO Word32))) 7+ s @?= Right 42 ]
test/LLVM/General/Test/Global.hs view
@@ -4,8 +4,6 @@ import Test.Framework.Providers.HUnit import Test.HUnit -import LLVM.General.Test.Support- import LLVM.General.Context import LLVM.General.Module import LLVM.General.AST@@ -15,7 +13,7 @@ testGroup "Alignment" [ testCase name $ withContext $ \context -> do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition g ]- ast' <- withModuleFromAST' context ast moduleAST+ Right ast' <- withModuleFromAST context ast moduleAST ast' @?= ast | a <- [0,1], s <- [Nothing, Just "foo"],
test/LLVM/General/Test/InlineAssembly.hs view
@@ -21,11 +21,9 @@ testCase "expression" $ do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ - functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []],False),- G.basicBlocks = [+ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo")+ ([Parameter (IntegerType 32) (Name "x") []],False)+ [] Nothing 0 [ BasicBlock (UnName 0) [ UnName 1 := Call { isTailCall = False,@@ -49,7 +47,6 @@ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ]- } ] s = "; ModuleID = '<string>'\n\
test/LLVM/General/Test/Instructions.hs view
@@ -33,10 +33,7 @@ testGroup "regular" [ testCase name $ do let mAST = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.parameters = ([+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([ Parameter (IntegerType 32) (UnName 0) [], Parameter (FloatingPointType 32 IEEE) (UnName 1) [], Parameter (PointerType (IntegerType 32) (AddrSpace 0)) (UnName 2) [],@@ -44,16 +41,14 @@ Parameter (IntegerType 1) (UnName 4) [], Parameter (VectorType 2 (IntegerType 32)) (UnName 5) [], Parameter (StructureType False [IntegerType 32, IntegerType 32]) (UnName 6) []- ], False),- G.basicBlocks = [- BasicBlock (UnName 7) [- namedInstr- ] (- Do $ Ret Nothing []- )- ]- }- ]+ ],False) [] Nothing 0 [+ BasicBlock (UnName 7) [+ namedInstr+ ] (+ Do $ Ret Nothing []+ )+ ]+ ] mStr = "; ModuleID = '<string>'\n\ \\n\ \define void @0(i32, float, i32*, i64, i1, <2 x i32>, { i32, i32 }) {\n\@@ -230,6 +225,7 @@ metadata = [] }, "xor i32 %0, %0"),+ ("alloca", Alloca { allocatedType = IntegerType 32,@@ -238,14 +234,6 @@ metadata = [] }, "alloca i32"),- ("alloca tricky",- Alloca {- allocatedType = IntegerType 7,- numElements = Just (ConstantOperand (C.Int 32 2)),- alignment = 128,- metadata = [] - },- "alloca i7, i32 2, align 128"), ("load", Load { volatile = False,@@ -523,8 +511,8 @@ ("store", Do $ Store { volatile = False,- address = a 2,- value = a 0,+ address = a 0,+ value = a 2, maybeAtomicity = Nothing, alignment = 0, metadata = [] @@ -550,65 +538,20 @@ ] ) ],- testCase "GEP inBounds constant" $ do- let mAST = Module "<string>" Nothing Nothing [- GlobalDefinition $ globalVariableDefaults {- G.name = Name "fortytwo",- G.type' = IntegerType 32,- G.isConstant = True,- G.initializer = Just $ C.Int 32 42- },- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (UnName 1) [- UnName 2 := GetElementPtr {- inBounds = True,- address = ConstantOperand (C.GlobalReference (Name "fortytwo")),- indices = [ ConstantOperand (C.Int 32 0) ],- metadata = []- },- UnName 3 := Load {- volatile = False,- address = LocalReference (UnName 2),- maybeAtomicity = Nothing,- alignment = 1,- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (UnName 3))) []- )- ]- }- ]- mStr = "; ModuleID = '<string>'\n\- \\n\- \@0 = constant i32 42\n\- \\n\- \define i32 @1() {\n\- \ %1 = load i32* @0, align 1\n\- \ ret i32 %1\n\- \}\n"- s <- withContext $ \context -> withModuleFromAST' context mAST moduleString- s @?= mStr,- testGroup "terminators" [ testCase name $ strCheck mAST mStr | (name, mAST, mStr) <- [ ( "ret", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (UnName 0) [- ] (- Do $ Ret Nothing []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 0) [+ ] (+ Do $ Ret Nothing []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\@@ -618,18 +561,16 @@ ), ( "br", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (UnName 0) [] (- Do $ Br (Name "foo") []- ),- BasicBlock (Name "foo") [] (- Do $ Ret Nothing []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 0) [] (+ Do $ Br (Name "foo") []+ ),+ BasicBlock (Name "foo") [] (+ Do $ Ret Nothing []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\@@ -642,18 +583,16 @@ ), ( "condbr", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (Name "bar") [] (- Do $ CondBr (ConstantOperand (C.Int 1 1)) (Name "foo") (Name "bar") []- ),- BasicBlock (Name "foo") [] (- Do $ Ret Nothing []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ ],False) [] Nothing 0+ [+ BasicBlock (Name "bar") [] (+ Do $ CondBr (ConstantOperand (C.Int 1 1)) (Name "foo") (Name "bar") []+ ),+ BasicBlock (Name "foo") [] (+ Do $ Ret Nothing []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\@@ -667,27 +606,25 @@ ), ( "switch", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (UnName 0) [] (- Do $ Switch {- operand0' = ConstantOperand (C.Int 16 2),- defaultDest = Name "foo",- dests = [- (C.Int 16 0, UnName 0),- (C.Int 16 2, Name "foo"),- (C.Int 16 3, UnName 0)- ],- metadata' = []- }- ),- BasicBlock (Name "foo") [] (- Do $ Ret Nothing []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 0) [] (+ Do $ Switch {+ operand0' = ConstantOperand (C.Int 16 2),+ defaultDest = Name "foo",+ dests = [+ (C.Int 16 0, UnName 0),+ (C.Int 16 2, Name "foo"),+ (C.Int 16 3, UnName 0)+ ],+ metadata' = []+ }+ ),+ BasicBlock (Name "foo") [] (+ Do $ Ret Nothing []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\@@ -710,30 +647,28 @@ G.type' = PointerType (IntegerType 8) (AddrSpace 0), G.initializer = Just (C.BlockAddress (Name "foo") (UnName 2)) },- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = Name "foo",- G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Load {- volatile = False,- address = ConstantOperand (C.GlobalReference (UnName 0)),- maybeAtomicity = Nothing,- alignment = 0,- metadata = [] - }- ] (- Do $ IndirectBr {- operand0' = LocalReference (UnName 1),- possibleDests = [UnName 2],- metadata' = []- }- ),- BasicBlock (UnName 2) [] (- Do $ Ret Nothing []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (Name "foo") ([+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 0) [+ UnName 1 := Load {+ volatile = False,+ address = ConstantOperand (C.GlobalReference (UnName 0)),+ maybeAtomicity = Nothing,+ alignment = 0,+ metadata = [] + }+ ] (+ Do $ IndirectBr {+ operand0' = LocalReference (UnName 1),+ possibleDests = [UnName 2],+ metadata' = []+ }+ ),+ BasicBlock (UnName 2) [] (+ Do $ Ret Nothing []+ )+ ] ], -- \ indirectbr i8* null, [label %foo]\n\ "; ModuleID = '<string>'\n\@@ -750,48 +685,44 @@ ), ( "invoke", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.parameters = ([- Parameter (IntegerType 32) (UnName 0) [],- Parameter (IntegerType 16) (UnName 1) []- ], False),- G.basicBlocks = [- BasicBlock (UnName 2) [] (- Do $ Invoke {- callingConvention' = CC.C,- returnAttributes' = [],- function' = Right (ConstantOperand (C.GlobalReference (UnName 0))),- arguments' = [- (ConstantOperand (C.Int 32 4), []),- (ConstantOperand (C.Int 16 8), [])+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ Parameter (IntegerType 32) (UnName 0) [],+ Parameter (IntegerType 16) (UnName 1) []+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 2) [] (+ Do $ Invoke {+ callingConvention' = CC.C,+ returnAttributes' = [],+ function' = Right (ConstantOperand (C.GlobalReference (UnName 0))),+ arguments' = [+ (ConstantOperand (C.Int 32 4), []),+ (ConstantOperand (C.Int 16 8), [])+ ],+ functionAttributes' = [],+ returnDest = Name "foo",+ exceptionDest = Name "bar",+ metadata' = []+ }+ ),+ BasicBlock (Name "foo") [] (+ Do $ Ret Nothing []+ ),+ BasicBlock (Name "bar") [+ UnName 3 := LandingPad {+ type' = StructureType False [ + PointerType (IntegerType 8) (AddrSpace 0),+ IntegerType 32 ],- functionAttributes' = [],- returnDest = Name "foo",- exceptionDest = Name "bar",- metadata' = []- }- ),- BasicBlock (Name "foo") [] (- Do $ Ret Nothing []- ),- BasicBlock (Name "bar") [- UnName 3 := LandingPad {- type' = StructureType False [ - PointerType (IntegerType 8) (AddrSpace 0),- IntegerType 32- ],- personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)),- cleanup = True,- clauses = [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))],- metadata = []- }- ] (- Do $ Ret Nothing []- )- ]- }+ personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)),+ cleanup = True,+ clauses = [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))],+ metadata = []+ }+ ] (+ Do $ Ret Nothing []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\@@ -811,15 +742,13 @@ ), ( "resume", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (UnName 0) [] (- Do $ Resume (ConstantOperand (C.Int 32 1)) []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 0) [] (+ Do $ Resume (ConstantOperand (C.Int 32 1)) []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\@@ -829,15 +758,13 @@ ), ( "unreachable", Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = UnName 0,- G.basicBlocks = [- BasicBlock (UnName 0) [] (- Do $ Unreachable []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+ ],False) [] Nothing 0+ [+ BasicBlock (UnName 0) [] (+ Do $ Unreachable []+ )+ ] ], "; ModuleID = '<string>'\n\ \\n\
− test/LLVM/General/Test/Instrumentation.hs
@@ -1,141 +0,0 @@-module LLVM.General.Test.Instrumentation where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit--import LLVM.General.Test.Support--import Control.Monad.Error-import Data.Functor-import qualified Data.List as List-import qualified Data.Set as Set-import qualified Data.Map as Map--import LLVM.General.Module-import LLVM.General.Context-import LLVM.General.PassManager-import LLVM.General.Transforms-import LLVM.General.Target--import LLVM.General.AST as A-import LLVM.General.AST.Type-import LLVM.General.AST.Name-import LLVM.General.AST.AddrSpace-import LLVM.General.AST.DataLayout-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.CallingConvention as CC-import qualified LLVM.General.AST.Attribute as A-import qualified LLVM.General.AST.Global as G-import qualified LLVM.General.AST.Constant as C--instrument :: PassSetSpec -> A.Module -> IO A.Module-instrument s m = withContext $ \context -> withModuleFromAST' context m $ \mIn' -> do- withPassManager s $ \pm -> runPassManager pm mIn'- moduleAST mIn'--ast = do- dl <- withDefaultTargetMachine getTargetMachineDataLayout- return $ Module "<string>" (Just dl) Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 128) (Name "x") []],False),- G.basicBlocks = [- BasicBlock (UnName 0) [] (Do $ Br (Name "checkDone") []),- BasicBlock (Name "checkDone") [- UnName 1 := Phi {- type' = IntegerType 128,- incomingValues = [- (LocalReference (Name "x"), UnName 0),- (LocalReference (Name "x'"), Name "even"),- (LocalReference (Name "x''"), Name "odd")- ],- metadata = []- },- Name "count" := Phi {- type' = IntegerType 32,- incomingValues = [- (ConstantOperand (C.Int 32 1), UnName 0),- (LocalReference (Name "count'"), Name "even"),- (LocalReference (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)) []- ] (- Do $ CondBr (LocalReference (Name "is one")) (Name "done") (Name "checkOdd") []- ),- BasicBlock (Name "checkOdd") [- Name "is odd" := Trunc (LocalReference (UnName 1)) (IntegerType 1) []- ] (- Do $ CondBr (LocalReference (Name "is odd")) (Name "odd") (Name "even") []- ),- BasicBlock (Name "even") [- Name "x'" := UDiv True (LocalReference (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)) []- ] (- Do $ Br (Name "checkDone") []- ),- BasicBlock (Name "done") [- ] (- Do $ Ret (Just (LocalReference (Name "count'"))) []- )- ]- },- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "main",- G.parameters = ([- Parameter (IntegerType 32) (Name "argc") [],- Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []- ],False),- G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Call {- isTailCall = False,- callingConvention = CC.C,- returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),- arguments = [- (ConstantOperand (C.Int 128 9491828328), [])- ],- functionAttributes = [],- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (UnName 1))) []- )- ]- }- ]--tests = testGroup "Instrumentation" [- testGroup "basic" [- testCase n $ do- triple <- getDefaultTargetTriple- withTargetLibraryInfo triple $ \tli -> do- Right dl <- runErrorT $ withDefaultTargetMachine getTargetMachineDataLayout- Right ast <- runErrorT 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) <- [- ("EdgeProfiler", EdgeProfiler),- ("OptimalEdgeProfiler", OptimalEdgeProfiler),- ("PathProfiler", PathProfiler),- ("GCOVProfiler", defaultGCOVProfiler),- ("AddressSanitizer", defaultAddressSanitizer),- ("ThreadSanitizer", defaultThreadSanitizer),- ("BoundsChecking", BoundsChecking)- ]- ]- ]
− test/LLVM/General/Test/Linking.hs
@@ -1,67 +0,0 @@-module LLVM.General.Test.Linking where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit--import LLVM.General.Test.Support--import Control.Monad.Error-import Data.Functor-import qualified Data.Set as Set-import qualified Data.Map as Map--import LLVM.General.Module-import LLVM.General.Context-import LLVM.General.PassManager-import LLVM.General.Transforms-import LLVM.General.Target--import LLVM.General.AST as A-import LLVM.General.AST.Type-import LLVM.General.AST.Name-import LLVM.General.AST.AddrSpace-import LLVM.General.AST.DataLayout-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.CallingConvention as CC-import qualified LLVM.General.AST.Attribute as A-import qualified LLVM.General.AST.Global as G-import qualified LLVM.General.AST.Constant as C--tests = testGroup "Linking" [- testCase "basic" $ do- let - ast0 = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.linkage = L.Private,- G.returnType = IntegerType 32,- G.name = Name "private0"- },- GlobalDefinition $ functionDefaults {- G.linkage = L.External,- G.returnType = IntegerType 32,- G.name = Name "external0"- }- ]- ast1 = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.linkage = L.Private,- G.returnType = IntegerType 32,- G.name = Name "private1"- },- GlobalDefinition $ functionDefaults {- G.linkage = L.External,- G.returnType = IntegerType 32,- G.name = Name "external1"- }- ] -- Module { moduleDefinitions = defs } <- withContext $ \context -> - withModuleFromAST' context ast0 $ \m0 ->- withModuleFromAST' context ast1 $ \m1 -> do- runErrorT $ 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
@@ -16,33 +16,32 @@ tests = testGroup "Metadata" [ testCase "local" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = IntegerType 32 },- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Load {- volatile = False,- address = ConstantOperand (C.GlobalReference (UnName 0)),- maybeAtomicity = Nothing,- A.alignment = 0,- metadata = []- }- ] (- Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [- (- "my-metadatum", - MetadataNode [- Just $ LocalReference (UnName 1),- Just $ MetadataStringOperand "super hyper",- Nothing- ]- )- ]- )- ]- }+ GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = IntegerType 32 },+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ ],False)+ [] + Nothing 0 + [+ BasicBlock (UnName 0) [+ UnName 1 := Load {+ volatile = False,+ address = ConstantOperand (C.GlobalReference (UnName 0)),+ maybeAtomicity = Nothing,+ A.alignment = 0,+ metadata = []+ }+ ] (+ Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [+ (+ "my-metadatum", + MetadataNode [+ LocalReference (UnName 1),+ MetadataStringOperand "super hyper"+ ]+ )+ ]+ )+ ] ] let s = "; ModuleID = '<string>'\n\ \\n\@@ -50,25 +49,25 @@ \\n\ \define i32 @foo() {\n\ \ %1 = load i32* @0\n\- \ ret i32 0, !my-metadatum !{i32 %1, metadata !\"super hyper\", null}\n\+ \ ret i32 0, !my-metadatum !{i32 %1, metadata !\"super hyper\"}\n\ \}\n" strCheck ast s, testCase "global" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.basicBlocks = [- BasicBlock (UnName 0) [+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ ],False)+ [] + Nothing 0 + [+ BasicBlock (UnName 0) [ ] (- Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [- ("my-metadatum", MetadataNodeReference (MetadataNodeID 0))- ]- )- ]- },- MetadataNodeDefinition (MetadataNodeID 0) [ Just $ ConstantOperand (C.Int 32 1) ]+ Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [+ ("my-metadatum", MetadataNodeReference (MetadataNodeID 0))+ ]+ )+ ],+ MetadataNodeDefinition (MetadataNodeID 0) [ ConstantOperand (C.Int 32 1) ] ] let s = "; ModuleID = '<string>'\n\ \\n\@@ -81,8 +80,8 @@ testCase "named" $ do let ast = Module "<string>" Nothing Nothing [- NamedMetadataDefinition "my-module-metadata" [ MetadataNodeID 0 ],- MetadataNodeDefinition (MetadataNodeID 0) [ Just $ ConstantOperand (C.Int 32 1) ]+ NamedMetadataDefinition "my-module-metadata" [MetadataNodeID 0],+ MetadataNodeDefinition (MetadataNodeID 0) [ ConstantOperand (C.Int 32 1) ] ] let s = "; ModuleID = '<string>'\n\ \\n\@@ -91,27 +90,15 @@ \!0 = metadata !{i32 1}\n" strCheck ast s, - testCase "null" $ do- let ast = Module "<string>" Nothing Nothing [- NamedMetadataDefinition "my-module-metadata" [ MetadataNodeID 0 ],- MetadataNodeDefinition (MetadataNodeID 0) [ Nothing ]- ]- let s = "; ModuleID = '<string>'\n\- \\n\- \!my-module-metadata = !{!0}\n\- \\n\- \!0 = metadata !{null}\n"- strCheck ast s,- testGroup "cyclic" [ testCase "metadata-only" $ do let ast = Module "<string>" Nothing Nothing [ NamedMetadataDefinition "my-module-metadata" [MetadataNodeID 0], MetadataNodeDefinition (MetadataNodeID 0) [- Just $ MetadataNodeOperand (MetadataNodeReference (MetadataNodeID 1)) + MetadataNodeOperand (MetadataNodeReference (MetadataNodeID 1)) ], MetadataNodeDefinition (MetadataNodeID 1) [- Just $ MetadataNodeOperand (MetadataNodeReference (MetadataNodeID 0)) + MetadataNodeOperand (MetadataNodeReference (MetadataNodeID 0)) ] ] let s = "; ModuleID = '<string>'\n\@@ -124,18 +111,18 @@ testCase "metadata-global" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = VoidType,- G.name = Name "foo",- G.basicBlocks = [- BasicBlock (UnName 0) [- ] (- Do $ Ret Nothing [ ("my-metadatum", MetadataNodeReference (MetadataNodeID 0)) ]- )- ]- },+ GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([+ ],False)+ [] + Nothing 0 + [+ BasicBlock (UnName 0) [+ ] (+ Do $ Ret Nothing [ ("my-metadatum", MetadataNodeReference (MetadataNodeID 0)) ]+ )+ ], MetadataNodeDefinition (MetadataNodeID 0) [- Just $ ConstantOperand (C.GlobalReference (Name "foo"))+ ConstantOperand (C.GlobalReference (Name "foo")) ] ] let s = "; ModuleID = '<string>'\n\
test/LLVM/General/Test/Module.hs view
@@ -6,17 +6,12 @@ import LLVM.General.Test.Support -import Control.Monad.Error import Data.Bits-import Data.Word import Data.Functor -import qualified Data.Set as Set- import LLVM.General.Context import LLVM.General.Module import LLVM.General.Diagnostic-import LLVM.General.Target import LLVM.General.AST import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred@@ -28,10 +23,6 @@ import qualified LLVM.General.AST.Global as G import qualified LLVM.General.AST.Constant as C -import qualified LLVM.General.Relocation as R-import qualified LLVM.General.CodeModel as CM-import qualified LLVM.General.CodeGenOpt as CGO- handString = "; ModuleID = '<string>'\n\ \\n\ \%0 = type { i32, %1*, %0* }\n\@@ -48,11 +39,12 @@ \@two = alias i32 addrspace(3)* @three\n\ \\n\ \define i32 @bar() {\n\- \ %1 = call zeroext i32 @foo(i32 inreg 1, i8 signext 4) nounwind uwtable readnone\n\+ \ %1 = call zeroext i32 @foo(i32 inreg 1, i8 signext 4) #0\n\ \ ret i32 %1\n\ \}\n\ \\n\- \define zeroext i32 @foo(i32 inreg %x, i8 signext %y) nounwind uwtable readnone {\n\+ \; Function Attrs: nounwind readnone uwtable\n\+ \define zeroext i32 @foo(i32 inreg %x, i8 signext %y) #0 {\n\ \ %1 = mul nsw i32 %x, %x\n\ \ br label %here\n\ \\n\@@ -67,7 +59,9 @@ \elsewhere: ; preds = %there, %here\n\ \ %r = phi i32 [ 2, %there ], [ 57, %here ]\n\ \ ret i32 %r\n\- \}\n"+ \}\n\+ \\n\+ \attributes #0 = { nounwind readnone uwtable }\n" handAST = Module "<string>" Nothing Nothing [ TypeDefinition (UnName 0) (@@ -120,89 +114,80 @@ G.type' = PointerType (IntegerType 32) (AddrSpace 3), G.aliasee = C.GlobalReference (Name "three") },- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "bar",- G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Call {- isTailCall = False,- callingConvention = CC.C,- returnAttributes = [A.ZeroExt],- function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),- arguments = [- (ConstantOperand (C.Int 32 1), [A.InReg]),- (ConstantOperand (C.Int 8 4), [A.SignExt])- ],- functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (UnName 1))) []- )- ]- },- GlobalDefinition $ functionDefaults {- G.returnAttributes = [A.ZeroExt],- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "bar") ([],False) [] Nothing 0 [+ BasicBlock (UnName 0) [+ UnName 1 := Call {+ isTailCall = False,+ callingConvention = CC.C,+ returnAttributes = [A.ZeroExt],+ function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+ arguments = [+ (ConstantOperand (C.Int 32 1), [A.InReg]),+ (ConstantOperand (C.Int 8 4), [A.SignExt])+ ],+ functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],+ metadata = []+ }+ ] (+ Do $ Ret (Just (LocalReference (UnName 1))) []+ )+ ],+ GlobalDefinition $ Function L.External V.Default CC.C [A.ZeroExt] (IntegerType 32) (Name "foo") ([ Parameter (IntegerType 32) (Name "x") [A.InReg], Parameter (IntegerType 8) (Name "y") [A.SignExt]- ], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],- G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Mul {- nsw = True,- nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),- metadata = []- }- ] (- Do $ Br (Name "here") []- ),- BasicBlock (Name "here") [- Name "go" := ICmp {- iPredicate = IPred.EQ,- operand0 = LocalReference (UnName 1),- operand1 = LocalReference (Name "x"),- metadata = []- }- ] (- Do $ CondBr {- condition = LocalReference (Name "go"),- trueDest = Name "there",- falseDest = Name "elsewhere",- metadata' = []- }- ),- BasicBlock (Name "there") [- UnName 2 := Add {- nsw = True,- nuw = False,- operand0 = LocalReference (UnName 1),- operand1 = ConstantOperand (C.Int 32 3),- metadata = []- }- ] (- Do $ Br (Name "elsewhere") []- ),- BasicBlock (Name "elsewhere") [- Name "r" := Phi {- type' = IntegerType 32,- incomingValues = [- (ConstantOperand (C.Int 32 2), Name "there"),- (ConstantOperand (C.Int 32 57), Name "here")- ],- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (Name "r"))) []- )- ]- }+ ],False)+ [A.NoUnwind, A.ReadNone, A.UWTable] Nothing 0 + [+ BasicBlock (UnName 0) [+ UnName 1 := Mul {+ nsw = True,+ nuw = False,+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"),+ metadata = []+ }+ ] (+ Do $ Br (Name "here") []+ ),+ BasicBlock (Name "here") [+ Name "go" := ICmp {+ iPredicate = IPred.EQ,+ operand0 = LocalReference (UnName 1),+ operand1 = LocalReference (Name "x"),+ metadata = []+ }+ ] (+ Do $ CondBr {+ condition = LocalReference (Name "go"),+ trueDest = Name "there",+ falseDest = Name "elsewhere",+ metadata' = []+ }+ ),+ BasicBlock (Name "there") [+ UnName 2 := Add {+ nsw = True,+ nuw = False,+ operand0 = LocalReference (UnName 1),+ operand1 = ConstantOperand (C.Int 32 3),+ metadata = []+ }+ ] (+ Do $ Br (Name "elsewhere") []+ ),+ BasicBlock (Name "elsewhere") [+ Name "r" := Phi {+ type' = IntegerType 32,+ incomingValues = [+ (ConstantOperand (C.Int 32 2), Name "there"),+ (ConstantOperand (C.Int 32 57), Name "here")+ ],+ metadata = []+ }+ ] (+ Do $ Ret (Just (LocalReference (Name "r"))) []+ )+ ] ] tests = testGroup "Module" [@@ -230,8 +215,8 @@ ast @?= handAST, testCase "withModuleFromAST" $ withContext $ \context -> do- s <- withModuleFromAST' context handAST moduleString- s @?= handString,+ s <- withModuleFromAST context handAST moduleString+ s @?= Right handString, testCase "triple" $ withContext $ \context -> do let hAST = "; ModuleID = '<string>'\n\@@ -242,172 +227,58 @@ testGroup "regression" [ testCase "set flag on constant expr" $ withContext $ \context -> do let ast = 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 (UnName 0) [- UnName 1 := Mul {- nsw = True,- nuw = False,- operand0 = ConstantOperand (C.Int 32 1),- operand1 = ConstantOperand (C.Int 32 1),- metadata = []- }- ] (- Do $ Br (Name "here") []- ),- BasicBlock (Name "here") [- ] (- Do $ Ret (Just (LocalReference (UnName 1))) []- )- ]- }- ]- t <- withModuleFromAST' context ast $ \_ -> return True- t @?= True,-- testCase "Phi node finishes" $ withContext $ \context -> do- let ast = 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 (UnName 0) [- UnName 1 := Mul {- nsw = True,- nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),- metadata = []- }- ] (- Do $ Br (Name "here") []- ),- BasicBlock (Name "here") [- UnName 2 := Phi (IntegerType 32) [ (ConstantOperand (C.Int 32 42), UnName 0) ] []- ] (- Do $ Br (Name "elsewhere") []- ),- BasicBlock (Name "elsewhere") [ - ] (- Do $ Br (Name "there") []- ),- BasicBlock (Name "there") [- ] (- Do $ Ret (Just (LocalReference (UnName 1))) []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False)+ [] Nothing 0 + [+ BasicBlock (UnName 0) [+ UnName 1 := Mul {+ nsw = True,+ nuw = False,+ operand0 = ConstantOperand (C.Int 32 1),+ operand1 = ConstantOperand (C.Int 32 1),+ metadata = []+ }+ ] (+ Do $ Br (Name "here") []+ ),+ BasicBlock (Name "here") [+ ] (+ Do $ Ret (Just (LocalReference (UnName 1))) []+ )+ ] ]- s = "; ModuleID = '<string>'\n\- \\n\- \define i32 @foo(i32 %x) {\n\- \ %1 = mul nsw i32 %x, %x\n\- \ br label %here\n\- \\n\- \here: ; preds = %0\n\- \ %2 = phi i32 [ 42, %0 ]\n\- \ br label %elsewhere\n\- \\n\- \elsewhere: ; preds = %here\n\- \ br label %there\n\- \\n\- \there: ; preds = %elsewhere\n\- \ ret i32 %1\n\- \}\n"- strCheck ast s,-- testCase "switchblock" $ do- let count = 450- start = 2 -- won't come back the same w/o start = 2- ns = [start..count + start - 1]- vbps = zip [ ConstantOperand (C.Int 32 i) | i <- [0..] ] [ UnName n | n <- (1:ns) ]- cbps = zip [ C.Int 32 i | i <- [0..] ] [ UnName n | n <- ns ]-- withContext $ \context -> do- let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.name = Name "foo",- G.returnType = IntegerType 32,- G.parameters = ([Parameter (IntegerType 32) (UnName 0) []], False),- G.basicBlocks = [- BasicBlock (UnName 1) [] (Do $ Switch (LocalReference $ UnName 0) (Name "end") cbps [])- ] ++ [- BasicBlock (UnName n) [] (Do $ Br (Name "end") []) | n <- ns- ] ++ [- BasicBlock (Name "end") [- Name "val" := Phi (IntegerType 32) vbps []- ] (- Do $ Ret (Just (LocalReference (Name "val"))) []- )- ]- }- ]- s <- withModuleFromAST' context ast moduleString- m <- withModuleFromString' context s moduleAST- m @?= ast+ t <- withModuleFromAST context ast $ \_ -> return True+ t @?= Right True ],- + testGroup "failures" [ testCase "bad block reference" $ withContext $ \context -> do let badAST = 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 (UnName 0) [- UnName 1 := Mul {- nsw = True,- nuw = False,- operand0 = ConstantOperand (C.Int 32 1),- operand1 = ConstantOperand (C.Int 32 1),- metadata = []- }- ] (- Do $ Br (Name "not here") []- ),- BasicBlock (Name "here") [- ] (- Do $ Ret (Just (LocalReference (UnName 1))) []- )- ]- }- ]- t <- runErrorT $ 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.name = Name "foo",- G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Mul {- nsw = False,- nuw = False,- operand0 = LocalReference (Name "unknown"),- operand1 = ConstantOperand (C.Int 32 1),- metadata = []- },- UnName 2 := Mul {- nsw = False,- nuw = False,- operand0 = LocalReference (Name "unknown2"),- operand1 = LocalReference (UnName 1),- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (UnName 2))) []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False)+ [] Nothing 0 + [+ BasicBlock (UnName 0) [+ UnName 1 := Mul {+ nsw = True,+ nuw = False,+ operand0 = ConstantOperand (C.Int 32 1),+ operand1 = ConstantOperand (C.Int 32 1),+ metadata = []+ }+ ] (+ Do $ Br (Name "not here") []+ ),+ BasicBlock (Name "here") [+ ] (+ Do $ Ret (Just (LocalReference (UnName 1))) []+ )+ ] ]- t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True- t @?= Left "reference to undefined local: Name \"unknown\""+ t <- withModuleFromAST context badAST $ \_ -> return True+ t @?= Left "reference to undefined block: Name \"not here\"" ] ]
test/LLVM/General/Test/Optimization.hs view
@@ -4,13 +4,11 @@ import Test.Framework.Providers.HUnit import Test.HUnit -import LLVM.General.Test.Support- import Data.Functor-import qualified Data.Set as Set import qualified Data.Map as Map import LLVM.General.Module+import LLVM.General.CommandLine import LLVM.General.Context import LLVM.General.PassManager import LLVM.General.Transforms@@ -35,260 +33,258 @@ handAST = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], - G.basicBlocks = [- BasicBlock (UnName 0) [- UnName 1 := Mul {- nsw = False,- nuw = False,- operand0 = ConstantOperand (C.Int 32 6),- operand1 = ConstantOperand (C.Int 32 7),- metadata = []- }- ] (- Do $ Br (Name "here") []- ),- BasicBlock (Name "here") [- Name "go" := ICmp {- iPredicate = IPred.EQ,- operand0 = LocalReference (UnName 1),- operand1 = ConstantOperand (C.Int 32 42),- metadata = []- }- ] (- Do $ CondBr {- condition = LocalReference (Name "go"),- trueDest = Name "take",- falseDest = Name "done",- metadata' = []- }- ),- BasicBlock (Name "take") [- UnName 2 := Sub {- nsw = False,- nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),- metadata = []- }- ] (- Do $ Br (Name "done") []- ),- BasicBlock (Name "done") [- Name "r" := Phi {- type' = IntegerType 32,- incomingValues = [- (LocalReference (UnName 2), Name "take"),- (ConstantOperand (C.Int 32 57), Name "here")- ],- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (Name "r"))) []- )- ]- }- ]+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False)+ [A.NoUnwind, A.ReadNone, A.UWTable] + Nothing 0+ [+ BasicBlock (UnName 0) [+ UnName 1 := Mul {+ nsw = False,+ nuw = False,+ operand0 = ConstantOperand (C.Int 32 6),+ operand1 = ConstantOperand (C.Int 32 7),+ metadata = []+ }+ ] (+ Do $ Br (Name "here") []+ ),+ BasicBlock (Name "here") [+ Name "go" := ICmp {+ iPredicate = IPred.EQ,+ operand0 = LocalReference (UnName 1),+ operand1 = ConstantOperand (C.Int 32 42),+ metadata = []+ }+ ] (+ Do $ CondBr {+ condition = LocalReference (Name "go"),+ trueDest = Name "take",+ falseDest = Name "done",+ metadata' = []+ }+ ),+ BasicBlock (Name "take") [+ UnName 2 := Sub {+ nsw = False,+ nuw = False,+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"),+ metadata = []+ }+ ] (+ Do $ Br (Name "done") []+ ),+ BasicBlock (Name "done") [+ Name "r" := Phi {+ type' = IntegerType 32,+ incomingValues = [+ (LocalReference (UnName 2), Name "take"),+ (ConstantOperand (C.Int 32 57), Name "here")+ ],+ metadata = []+ }+ ] (+ Do $ Ret (Just (LocalReference (Name "r"))) []+ )+ ]+ ] -optimize :: PassSetSpec -> A.Module -> IO A.Module-optimize pss m = withContext $ \context -> withModuleFromAST' context m $ \mIn' -> do- withPassManager pss $ \pm -> runPassManager pm mIn'- moduleAST mIn'+optimize :: PassManagerSpecification s => s -> A.Module -> IO A.Module+optimize s m = do+ mOut <- withContext $ \context -> withModuleFromAST context m $ \mIn' -> do+ withPassManager s $ \pm -> runPassManager pm mIn'+ moduleAST mIn'+ either fail return mOut tests = testGroup "Optimization" [ testCase "curated" $ do mOut <- optimize defaultCuratedPassSetSpec handAST mOut @?= Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],- G.basicBlocks = [- BasicBlock (Name "here") [- ] (- Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False)+ [A.NoUnwind, A.ReadNone, A.UWTable] + Nothing 0 + [+ BasicBlock (Name "here") [+ ] (+ Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []+ )+ ] ], testGroup "individual" [ testCase "ConstantPropagation" $ do- mOut <- optimize defaultPassSetSpec { transforms = [ConstantPropagation] } handAST+ mOut <- optimize [ConstantPropagation] handAST mOut @?= Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = IntegerType 32,- G.name = Name "foo",- G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False),- G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],- G.basicBlocks = [- BasicBlock (UnName 0) [] (Do $ Br (Name "here") []),- BasicBlock (Name "here") [] (- Do $ CondBr {- condition = ConstantOperand (C.Int 1 1),- trueDest = Name "take", - falseDest = Name "done",- metadata' = []- }- ),- BasicBlock (Name "take") [- UnName 1 := Sub {- nsw = False,- nuw = False,- operand0 = LocalReference (Name "x"),- operand1 = LocalReference (Name "x"),- metadata = []- }- ] (- Do $ Br (Name "done") []- ),- BasicBlock (Name "done") [- Name "r" := Phi {- type' = IntegerType 32,- incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")],- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (Name "r"))) []- )- ]- }- ],+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False)+ [A.NoUnwind, A.ReadNone, A.UWTable] + Nothing 0 + [+ BasicBlock (UnName 0) [] (Do $ Br (Name "here") []),+ BasicBlock (Name "here") [] (+ Do $ CondBr {+ condition = ConstantOperand (C.Int 1 1),+ trueDest = Name "take", + falseDest = Name "done",+ metadata' = []+ }+ ),+ BasicBlock (Name "take") [+ UnName 1 := Sub {+ nsw = False,+ nuw = False,+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"),+ metadata = []+ }+ ] (+ Do $ Br (Name "done") []+ ),+ BasicBlock (Name "done") [+ Name "r" := Phi {type' = IntegerType 32, incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")], metadata = []}+ ] (+ Do $ Ret (Just (LocalReference (Name "r"))) []+ )+ ]+ ], testCase "BasicBlockVectorization" $ do+ parseCommandLineOptions ["test", "-bb-vectorize-ignore-target-info"] Nothing let mIn = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = FloatingPointType 64 IEEE,- G.name = Name "foo",- G.parameters = ([+ GlobalDefinition $ Function L.External V.Default CC.C [] (FloatingPointType 64 IEEE) (Name "foo") ([+ Parameter (FloatingPointType 64 IEEE) (Name "a1") [],+ Parameter (FloatingPointType 64 IEEE) (Name "a2") [],+ Parameter (FloatingPointType 64 IEEE) (Name "b1") [],+ Parameter (FloatingPointType 64 IEEE) (Name "b2") []+ ],False)+ [] + Nothing 0 + [+ BasicBlock (UnName 0) [+ Name "x1" := FSub { + operand0 = LocalReference (Name "a1"), + operand1 = LocalReference (Name "b1"),+ metadata = []+ },+ Name "x2" := FSub { + operand0 = LocalReference (Name "a2"), + operand1 = LocalReference (Name "b2"),+ metadata = []+ },+ Name "y1" := FMul { + operand0 = LocalReference (Name "x1"), + operand1 = LocalReference (Name "a1"),+ metadata = []+ },+ Name "y2" := FMul { + operand0 = LocalReference (Name "x2"), + operand1 = LocalReference (Name "a2"),+ metadata = []+ },+ Name "z1" := FAdd { + operand0 = LocalReference (Name "y1"), + operand1 = LocalReference (Name "b1"),+ metadata = []+ },+ Name "z2" := FAdd { + operand0 = LocalReference (Name "y2"), + operand1 = LocalReference (Name "b2"),+ metadata = []+ },+ Name "r" := FMul {+ operand0 = LocalReference (Name "z1"), + operand1 = LocalReference (Name "z2"),+ metadata = []+ }+ ] (Do $ Ret (Just (LocalReference (Name "r"))) [])+ ]+ ]+ mOut <- optimize [ + defaultVectorizeBasicBlocks {+ requiredChainDepth = 3+ },+ InstructionCombining,+ GlobalValueNumbering False+ ] mIn+ mOut @?= Module "<string>" Nothing Nothing [+ GlobalDefinition $ Function + L.External V.Default CC.C [] (FloatingPointType 64 IEEE) (Name "foo") ([ Parameter (FloatingPointType 64 IEEE) (Name "a1") [], Parameter (FloatingPointType 64 IEEE) (Name "a2") [], Parameter (FloatingPointType 64 IEEE) (Name "b1") [], Parameter (FloatingPointType 64 IEEE) (Name "b2") []- ], False),- G.basicBlocks = [- BasicBlock (UnName 0) [- Name "x1" := FSub { - operand0 = LocalReference (Name "a1"), - operand1 = LocalReference (Name "b1"),- metadata = []- },- Name "x2" := FSub { - operand0 = LocalReference (Name "a2"), - operand1 = LocalReference (Name "b2"),- metadata = []- },- Name "y1" := FMul { - operand0 = LocalReference (Name "x1"), - operand1 = LocalReference (Name "a1"),- metadata = []- },- Name "y2" := FMul { - operand0 = LocalReference (Name "x2"), - operand1 = LocalReference (Name "a2"),- metadata = []- },- Name "z1" := FAdd { - operand0 = LocalReference (Name "y1"), - operand1 = LocalReference (Name "b1"),- metadata = []- },- Name "z2" := FAdd { - operand0 = LocalReference (Name "y2"), - operand1 = LocalReference (Name "b2"),- metadata = []- },- Name "r" := FMul {- operand0 = LocalReference (Name "z1"), - operand1 = LocalReference (Name "z2"),- metadata = []- }- ] (Do $ Ret (Just (LocalReference (Name "r"))) [])- ]- }- ]- mOut <- - optimize (defaultPassSetSpec { transforms = [ defaultVectorizeBasicBlocks { requiredChainDepth = 3 }, InstructionCombining, GlobalValueNumbering False ] }) mIn- mOut @?= Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = FloatingPointType 64 IEEE,- G.name = Name "foo",- G.parameters = ([- Parameter (FloatingPointType 64 IEEE) (Name "a1") [],- Parameter (FloatingPointType 64 IEEE) (Name "a2") [],- Parameter (FloatingPointType 64 IEEE) (Name "b1") [],- Parameter (FloatingPointType 64 IEEE) (Name "b2") []- ], False),- G.basicBlocks = [- BasicBlock (UnName 0) [- Name "x1.v.i1.1" := InsertElement {- vector = ConstantOperand (C.Undef (VectorType 2 (FloatingPointType 64 IEEE))),- element = LocalReference (Name "b1"),- index = ConstantOperand (C.Int 32 0),- metadata = []- },- Name "x1.v.i1.2" := InsertElement {- vector = LocalReference (Name "x1.v.i1.1"),- element = LocalReference (Name "b2"),- index = ConstantOperand (C.Int 32 1),- metadata = []- },- Name "x1.v.i0.1" := InsertElement {- vector = ConstantOperand (C.Undef (VectorType 2 (FloatingPointType 64 IEEE))),- element = LocalReference (Name "a1"),- index = ConstantOperand (C.Int 32 0),- metadata = []- },- Name "x1.v.i0.2" := InsertElement {- vector = LocalReference (Name "x1.v.i0.1"),- element = LocalReference (Name "a2"),- index = ConstantOperand (C.Int 32 1),- metadata = []- },- Name "x1" := FSub {- operand0 = LocalReference (Name "x1.v.i0.2"),- operand1 = LocalReference (Name "x1.v.i1.2"),- metadata = []- },- Name "y1" := FMul {- operand0 = LocalReference (Name "x1"),- operand1 = LocalReference (Name "x1.v.i0.2"),- metadata = []- },- Name "z1" := FAdd {- operand0 = LocalReference (Name "y1"),- operand1 = LocalReference (Name "x1.v.i1.2"),- metadata = []- },- Name "z1.v.r1" := ExtractElement {- vector = LocalReference (Name "z1"),- index = ConstantOperand (C.Int 32 0),- metadata = []- },- Name "z1.v.r2" := ExtractElement {- vector = LocalReference (Name "z1"),- index = ConstantOperand (C.Int 32 1),- metadata = []- },- Name "r" := FMul {- operand0 = LocalReference (Name "z1.v.r1"),- operand1 = LocalReference (Name "z1.v.r2"),- metadata = []- }- ] (- Do $ Ret (Just (LocalReference (Name "r"))) []- )- ]- }- ],+ ],False)+ []+ Nothing 0+ [+ BasicBlock (UnName 0) [+ Name "x1.v.i1.1" := InsertElement {+ vector = ConstantOperand (C.Undef (VectorType 2 (FloatingPointType 64 IEEE))),+ element = LocalReference (Name "b1"),+ index = ConstantOperand (C.Int 32 0),+ metadata = []+ },+ Name "x1.v.i1.2" := InsertElement {+ vector = LocalReference (Name "x1.v.i1.1"),+ element = LocalReference (Name "b2"),+ index = ConstantOperand (C.Int 32 1),+ metadata = []+ },+ Name "x1.v.i0.1" := InsertElement {+ vector = ConstantOperand (C.Undef (VectorType 2 (FloatingPointType 64 IEEE))),+ element = LocalReference (Name "a1"),+ index = ConstantOperand (C.Int 32 0),+ metadata = []+ },+ Name "x1.v.i0.2" := InsertElement {+ vector = LocalReference (Name "x1.v.i0.1"),+ element = LocalReference (Name "a2"),+ index = ConstantOperand (C.Int 32 1),+ metadata = []+ },+ Name "x1" := FSub {+ operand0 = LocalReference (Name "x1.v.i0.2"),+ operand1 = LocalReference (Name "x1.v.i1.2"),+ metadata = []+ },+ Name "y1" := FMul {+ operand0 = LocalReference (Name "x1"),+ operand1 = LocalReference (Name "x1.v.i0.2"),+ metadata = []+ },+ Name "z1" := FAdd {+ operand0 = LocalReference (Name "y1"),+ operand1 = LocalReference (Name "x1.v.i1.2"),+ metadata = []+ },+ Name "z1.v.r1" := ExtractElement {+ vector = LocalReference (Name "z1"),+ index = ConstantOperand (C.Int 32 0),+ metadata = []+ },+ Name "z1.v.r2" := ExtractElement {+ vector = LocalReference (Name "z1"),+ index = ConstantOperand (C.Int 32 1),+ metadata = []+ },+ Name "r" := FMul {+ operand0 = LocalReference (Name "z1.v.r1"),+ operand1 = LocalReference (Name "z1.v.r2"),+ metadata = []+ }+ ] (+ Do $ Ret (Just (LocalReference (Name "r"))) []+ )+ ]+ ], testCase "LowerInvoke" $ do -- This test doesn't test much about what LowerInvoke does, just that it seems to work.@@ -296,45 +292,37 @@ -- how unwinding works (as is the invoke instruction) withContext $ \context -> do let triple = "x86_64-apple-darwin"- (target, _) <- failInIO $ lookupTarget Nothing triple+ Right (target, _) <- lookupTarget Nothing triple withTargetOptions $ \targetOptions -> do- withTargetMachine target triple "" Set.empty targetOptions- R.Default CM.Default CGO.Default $ \tm -> do- tl <- getTargetLowering tm- withPassManager (defaultPassSetSpec { transforms = [LowerInvoke False], targetLowering = Just tl}) $ \passManager -> do+ withTargetMachine target triple "" "" targetOptions+ R.Default CM.Default CGO.Default $ \targetMachine -> do+ targetLowering <- getTargetLowering targetMachine+ withPassManager ([LowerInvoke False], targetLowering) $ \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))) []- )- ]- }+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False) [] Nothing 0 [+ BasicBlock (Name "here") [+ ] (+ Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []+ )+ ] ] - astOut <- withModuleFromAST' context astIn $ \mIn -> do+ Right 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"- }- ]+ GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") []+ ],False) [] Nothing 0 [+ BasicBlock (Name "here") [+ ] (+ Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []+ )+ ],+ GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "abort") ([],False)+ [] Nothing 0 []+ ] ] ]
test/LLVM/General/Test/Support.hs view
@@ -5,40 +5,23 @@ import Test.HUnit import Data.Functor-import Control.Monad-import Control.Monad.Error import LLVM.General.Context import LLVM.General.Module import LLVM.General.Diagnostic-import LLVM.General.PrettyPrint -class FailInIO f where- errorToString :: f -> String--failInIO :: FailInIO f => ErrorT f IO a -> IO a-failInIO = either (fail . errorToString) return <=< runErrorT--instance FailInIO String where- errorToString = id--instance FailInIO (Either String Diagnostic) where- errorToString = either id diagnosticDisplay--withModuleFromString' c s f = failInIO $ withModuleFromString c s f-withModuleFromAST' c a f = failInIO $ withModuleFromAST c a f--assertEqPretty :: (Eq a, PrettyShow a) => a -> a -> Assertion-assertEqPretty actual expected = do- let showPretty = showPrettyEx 80 " " shortPrefixScheme- assertBool - ("expected: " ++ showPretty expected ++ "\n" ++ "but got: " ++ showPretty actual ++ "\n")- (expected == actual)+withModuleFromString' c s f = do+ e <- withModuleFromString c s f+ case e of+ Right r -> return r+ Left d -> do+ let e = diagnosticDisplay d+ putStrLn e+ fail e -strCheckC mAST mStr mStrCanon = withContext $ \context -> do+strCheck mAST mStr = withContext $ \context -> do a <- withModuleFromString' context mStr moduleAST- s <- withModuleFromAST' context mAST moduleString- (a,s) `assertEqPretty` (mAST, mStrCanon)--strCheck mAST mStr = strCheckC mAST mStr mStr+ s <- either error id <$> withModuleFromAST context mAST moduleString+ (a,s) @?= (mAST, mStr) +
test/LLVM/General/Test/Tests.hs view
@@ -12,10 +12,8 @@ import qualified LLVM.General.Test.Module as Module import qualified LLVM.General.Test.Optimization as Optimization import qualified LLVM.General.Test.Target as Target-import qualified LLVM.General.Test.Analysis as Analysis-import qualified LLVM.General.Test.Linking as Linking-import qualified LLVM.General.Test.Instrumentation as Instrumentation + tests = testGroup "llvm-general" [ Constants.tests, DataLayout.tests,@@ -26,8 +24,5 @@ Metadata.tests, Module.tests, Optimization.tests,- Target.tests,- Analysis.tests,- Linking.tests,- Instrumentation.tests+ Target.tests ]
test/Test.hs view