llvm-general 3.3.15.0 → 3.4.0.0
raw patch · 112 files changed
+1070/−2226 lines, 112 filesdep −transformers-compatdep ~basedep ~llvm-generaldep ~llvm-general-puresetup-changed
Dependencies removed: transformers-compat
Dependency ranges changed: base, llvm-general, llvm-general-pure, mtl
Files
- LICENSE +1/−1
- Setup.hs +11/−18
- changelog +0/−5
- llvm-general.cabal +15/−35
- src/Control/Monad/AnyCont.hs +0/−2
- src/Control/Monad/AnyCont/Class.hs +7/−17
- src/Control/Monad/Exceptable.hs +0/−221
- src/Control/Monad/Trans/AnyCont.hs +1/−2
- src/LLVM/General/CodeGenOpt.hs +1/−1
- src/LLVM/General/CodeModel.hs +1/−1
- src/LLVM/General/Diagnostic.hs +1/−1
- src/LLVM/General/Internal/Analysis.hs +4/−6
- src/LLVM/General/Internal/Atomicity.hs +2/−1
- src/LLVM/General/Internal/Attribute.hs +8/−11
- src/LLVM/General/Internal/BasicBlock.hs +1/−2
- src/LLVM/General/Internal/CallingConvention.hs +0/−2
- src/LLVM/General/Internal/Coding.hs +5/−2
- src/LLVM/General/Internal/CommandLine.hs +3/−5
- src/LLVM/General/Internal/Constant.hs +12/−25
- src/LLVM/General/Internal/Context.hs +1/−5
- src/LLVM/General/Internal/DataLayout.hs +1/−3
- src/LLVM/General/Internal/DecodeAST.hs +2/−2
- src/LLVM/General/Internal/Diagnostic.hs +0/−2
- src/LLVM/General/Internal/EncodeAST.hs +29/−40
- src/LLVM/General/Internal/ExecutionEngine.hs +7/−9
- src/LLVM/General/Internal/FFI/Analysis.hs +0/−2
- src/LLVM/General/Internal/FFI/Assembly.hs +0/−2
- src/LLVM/General/Internal/FFI/BasicBlock.hs +0/−2
- src/LLVM/General/Internal/FFI/BinaryOperator.h +0/−16
- src/LLVM/General/Internal/FFI/BinaryOperator.hs +2/−5
- src/LLVM/General/Internal/FFI/Bitcode.hs +0/−2
- src/LLVM/General/Internal/FFI/Builder.hs +20/−30
- src/LLVM/General/Internal/FFI/BuilderC.cpp +21/−21
- src/LLVM/General/Internal/FFI/ByteRangeCallback.hs +0/−2
- src/LLVM/General/Internal/FFI/Cleanup.hs +7/−6
- src/LLVM/General/Internal/FFI/CommandLine.hs +0/−2
- src/LLVM/General/Internal/FFI/Constant.hs +3/−7
- src/LLVM/General/Internal/FFI/ConstantC.cpp +12/−1
- src/LLVM/General/Internal/FFI/Context.hs +0/−2
- src/LLVM/General/Internal/FFI/DataLayout.hs +0/−2
- src/LLVM/General/Internal/FFI/ExecutionEngine.hs +0/−2
- src/LLVM/General/Internal/FFI/Function.h +10/−10
- src/LLVM/General/Internal/FFI/Function.hs +0/−2
- src/LLVM/General/Internal/FFI/GlobalAlias.hs +2/−3
- src/LLVM/General/Internal/FFI/GlobalValue.hs +2/−3
- src/LLVM/General/Internal/FFI/GlobalVariable.hs +2/−3
- src/LLVM/General/Internal/FFI/InlineAssembly.hs +0/−2
- src/LLVM/General/Internal/FFI/Instruction.h +0/−19
- src/LLVM/General/Internal/FFI/Instruction.hs +2/−2
- src/LLVM/General/Internal/FFI/InstructionC.cpp +0/−12
- src/LLVM/General/Internal/FFI/InstructionDefs.hsc +0/−2
- src/LLVM/General/Internal/FFI/Iterate.hs +2/−2
- src/LLVM/General/Internal/FFI/LLVMCTypes.hsc +2/−14
- src/LLVM/General/Internal/FFI/LibFunc.h +0/−311
- src/LLVM/General/Internal/FFI/MemoryBuffer.hs +1/−3
- src/LLVM/General/Internal/FFI/Metadata.hs +0/−2
- src/LLVM/General/Internal/FFI/Module.hs +0/−2
- src/LLVM/General/Internal/FFI/PassManager.hs +5/−15
- src/LLVM/General/Internal/FFI/PassManagerC.cpp +19/−53
- src/LLVM/General/Internal/FFI/PtrHierarchy.hs +2/−10
- src/LLVM/General/Internal/FFI/RawOStream.hs +1/−2
- src/LLVM/General/Internal/FFI/RawOStreamC.cpp +3/−3
- src/LLVM/General/Internal/FFI/SMDiagnostic.hs +0/−2
- src/LLVM/General/Internal/FFI/Target.h +0/−3
- src/LLVM/General/Internal/FFI/Target.hs +0/−17
- src/LLVM/General/Internal/FFI/TargetC.cpp +8/−66
- src/LLVM/General/Internal/FFI/Threading.hs +0/−19
- src/LLVM/General/Internal/FFI/Transforms.hs +20/−23
- src/LLVM/General/Internal/FFI/Type.hs +1/−2
- src/LLVM/General/Internal/FFI/User.hs +2/−3
- src/LLVM/General/Internal/FFI/Value.hs +2/−9
- src/LLVM/General/Internal/FFI/ValueC.cpp +0/−9
- src/LLVM/General/Internal/FastMathFlags.hs +0/−51
- src/LLVM/General/Internal/Function.hs +1/−2
- src/LLVM/General/Internal/Global.hs +3/−2
- src/LLVM/General/Internal/Inject.hs +0/−11
- src/LLVM/General/Internal/InlineAssembly.hs +1/−2
- src/LLVM/General/Internal/Instruction.hs +252/−163
- src/LLVM/General/Internal/InstructionDefs.hs +0/−2
- src/LLVM/General/Internal/LibraryFunction.hsc +0/−37
- src/LLVM/General/Internal/MemoryBuffer.hs +5/−9
- src/LLVM/General/Internal/Metadata.hs +1/−3
- src/LLVM/General/Internal/Module.hs +41/−50
- src/LLVM/General/Internal/Operand.hs +3/−18
- src/LLVM/General/Internal/PassManager.hs +11/−23
- src/LLVM/General/Internal/RawOStream.hs +20/−19
- src/LLVM/General/Internal/String.hs +1/−2
- src/LLVM/General/Internal/Target.hs +28/−81
- src/LLVM/General/Internal/Threading.hs +0/−34
- src/LLVM/General/Internal/Type.hs +12/−14
- src/LLVM/General/Internal/Value.hs +0/−2
- src/LLVM/General/Module.hs +0/−1
- src/LLVM/General/Relocation.hs +1/−1
- src/LLVM/General/Target.hs +2/−5
- src/LLVM/General/Target/LibraryFunction.hs +0/−7
- src/LLVM/General/Target/Options.hs +3/−6
- src/LLVM/General/Threading.hs +0/−7
- src/LLVM/General/Transforms.hs +20/−9
- test/LLVM/General/Test/Analysis.hs +13/−13
- test/LLVM/General/Test/Constants.hs +37/−37
- test/LLVM/General/Test/DataLayout.hs +0/−94
- test/LLVM/General/Test/ExecutionEngine.hs +2/−2
- test/LLVM/General/Test/Global.hs +2/−3
- test/LLVM/General/Test/InlineAssembly.hs +6/−7
- test/LLVM/General/Test/Instructions.hs +63/−70
- test/LLVM/General/Test/Instrumentation.hs +30/−43
- test/LLVM/General/Test/Linking.hs +6/−6
- test/LLVM/General/Test/Metadata.hs +7/−9
- test/LLVM/General/Test/Module.hs +58/−148
- test/LLVM/General/Test/Optimization.hs +142/−53
- test/LLVM/General/Test/Support.hs +3/−3
- test/LLVM/General/Test/Target.hs +32/−26
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013, Benjamin S. Scarlet and Google Inc.+Copyright (c) 2013, Benjamin S. Scarlet All rights reserved. Redistribution and use in source and binary forms, with or without
Setup.hs view
@@ -22,7 +22,7 @@ -- without checking they're already defined and so causes warnings. uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] -llvmVersion = Version [3,3] []+llvmVersion = Version [3,4] [] llvmConfigNames = [ "llvm-config-" ++ (intercalate "." . map show . versionBranch $ llvmVersion),@@ -48,21 +48,6 @@ instance Monad m => ProgramSearch (v -> p -> m (Maybe b)) where programSearch checkName = \v p -> findJustBy (\n -> checkName n v p) llvmConfigNames -class OldHookable hook where- preHookOld :: (PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()) -> hook -> hook---- this instance is used before Cabal-1.22.0.0, when testHook took four arguments-instance OldHookable (PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()) where- preHookOld f hook = \packageDescription localBuildInfo userHooks testFlags -> do- f packageDescription localBuildInfo userHooks testFlags- hook packageDescription localBuildInfo userHooks testFlags---- this instance is used for and after Cabal-1.22.0.0, when testHook took four five arguments-instance OldHookable (Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()) where- preHookOld f hook = \args packageDescription localBuildInfo userHooks testFlags -> do- f packageDescription localBuildInfo userHooks testFlags- hook args packageDescription localBuildInfo userHooks testFlags- llvmProgram = (simpleProgram "llvm-config") { programFindLocation = programSearch (programFindLocation . simpleProgram), programFindVersion = @@ -140,6 +125,14 @@ addLLVMToLdLibraryPath (configFlags localBuildInfo) buildHook simpleUserHooks packageDescription localBuildInfo userHooks buildFlags, - testHook = preHookOld (\_ localBuildInfo _ _ -> addLLVMToLdLibraryPath (configFlags localBuildInfo))- (testHook simpleUserHooks)+ 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 }
− changelog
@@ -1,5 +0,0 @@--*-change-log-*---3.3.14.3 Benjamin S. Scarlet <fgthb0@greynode.net> 2015-04-11- * Clean up warnings with ghc-7.10- * Start changelog
llvm-general.cabal view
@@ -1,10 +1,10 @@ name: llvm-general-version: 3.3.15.0+version: 3.4.0.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net> maintainer: Benjamin S. Scarlet <fgthb0@greynode.net>-copyright: (c) 2013 Benjamin S. Scarlet and Google Inc.+copyright: Benjamin S. Scarlet 2013 build-type: Custom stability: experimental cabal-version: >= 1.8@@ -15,32 +15,25 @@ it uses an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>), and so offers two advantages: it handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell.+ .+ For haddock, see <http://bscarlet.github.io/llvm-general/3.4.0.0/doc/html/llvm-general/index.html>. extra-source-files:- changelog src/LLVM/General/Internal/FFI/Analysis.h- src/LLVM/General/Internal/FFI/BinaryOperator.h src/LLVM/General/Internal/FFI/Constant.h src/LLVM/General/Internal/FFI/Function.h src/LLVM/General/Internal/FFI/GlobalValue.h src/LLVM/General/Internal/FFI/InlineAssembly.h src/LLVM/General/Internal/FFI/Instruction.h- src/LLVM/General/Internal/FFI/LibFunc.h src/LLVM/General/Internal/FFI/Module.h src/LLVM/General/Internal/FFI/SMDiagnostic.h src/LLVM/General/Internal/FFI/Target.h src/LLVM/General/Internal/FFI/Type.h src/LLVM/General/Internal/FFI/Value.h-+ source-repository head type: git location: git://github.com/bscarlet/llvm-general.git -source-repository this- type: git- location: git://github.com/bscarlet/llvm-general.git- branch: llvm-3.3- tag: v3.3.15.0- flag shared-llvm description: link against llvm shared rather than static library default: False@@ -52,23 +45,21 @@ library build-tools: llvm-config ghc-options: -fwarn-unused-imports- build-depends:- base >= 4.6 && < 5,+ build-depends: + base >= 4.5.0.0 && < 5, utf8-string >= 0.3.7, bytestring >= 0.9.1.10, transformers >= 0.3.0.0,- transformers-compat,- mtl >= 2.1.3,+ mtl >= 2.0.1.0, template-haskell >= 2.5.0.0, containers >= 0.4.2.1, parsec >= 3.1.3, array >= 0.4.0.0, setenv >= 0.1.0,- llvm-general-pure == 3.3.14.4+ llvm-general-pure == 3.4.0.0 extra-libraries: stdc++ hs-source-dirs: src extensions:- NoImplicitPrelude TupleSections DeriveDataTypeable EmptyDataDecls@@ -89,14 +80,11 @@ LLVM.General.PassManager LLVM.General.Relocation LLVM.General.Target- LLVM.General.Target.LibraryFunction LLVM.General.Target.Options- LLVM.General.Threading LLVM.General.Transforms other-modules: Control.Monad.AnyCont- Control.Monad.Exceptable Control.Monad.AnyCont.Class Control.Monad.Trans.AnyCont LLVM.General.Internal.Analysis@@ -113,16 +101,13 @@ LLVM.General.Internal.Diagnostic LLVM.General.Internal.EncodeAST LLVM.General.Internal.ExecutionEngine- LLVM.General.Internal.FastMathFlags LLVM.General.Internal.FloatingPointPredicate LLVM.General.Internal.Function LLVM.General.Internal.Global- LLVM.General.Internal.Inject LLVM.General.Internal.InlineAssembly LLVM.General.Internal.Instruction LLVM.General.Internal.InstructionDefs LLVM.General.Internal.IntegerPredicate- LLVM.General.Internal.LibraryFunction LLVM.General.Internal.MemoryBuffer LLVM.General.Internal.Metadata LLVM.General.Internal.Module@@ -132,7 +117,6 @@ LLVM.General.Internal.RMWOperation LLVM.General.Internal.String LLVM.General.Internal.Target- LLVM.General.Internal.Threading LLVM.General.Internal.Type LLVM.General.Internal.Value LLVM.General.Internal.FFI.Analysis@@ -165,14 +149,13 @@ LLVM.General.Internal.FFI.RawOStream LLVM.General.Internal.FFI.SMDiagnostic LLVM.General.Internal.FFI.Target- LLVM.General.Internal.FFI.Threading LLVM.General.Internal.FFI.Transforms LLVM.General.Internal.FFI.Type LLVM.General.Internal.FFI.User LLVM.General.Internal.FFI.Value include-dirs: src- c-sources:+ c-sources: src/LLVM/General/Internal/FFI/AssemblyC.cpp src/LLVM/General/Internal/FFI/BitcodeC.cpp src/LLVM/General/Internal/FFI/BuilderC.cpp@@ -198,19 +181,17 @@ test-suite test type: exitcode-stdio-1.0- build-depends:- base >= 4.6 && < 5,+ build-depends: + base >= 3 && < 5, test-framework >= 0.5, test-framework-hunit >= 0.2.7, HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1,- llvm-general == 3.3.15.0,- llvm-general-pure == 3.3.14.4,+ llvm-general == 3.4.0.0,+ llvm-general-pure == 3.4.0.0, containers >= 0.4.2.1,- mtl >= 2.1,- transformers >= 0.3.0.0,- transformers-compat+ mtl >= 2.0.1.0 hs-source-dirs: test extensions: TupleSections@@ -220,7 +201,6 @@ 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
src/Control/Monad/AnyCont.hs view
@@ -12,8 +12,6 @@ mapAnyContT ) where -import Prelude- import Control.Monad.Trans.AnyCont import Control.Monad.AnyCont.Class import Control.Monad.Trans.Class
src/Control/Monad/AnyCont/Class.hs view
@@ -5,14 +5,11 @@ #-} module Control.Monad.AnyCont.Class where -import Prelude- import Control.Monad.Trans.Class import Control.Monad.Trans.AnyCont (AnyContT) import qualified Control.Monad.Trans.AnyCont as AnyCont-import Control.Monad.Trans.Except as Except+import Control.Monad.Trans.Error as Error import Control.Monad.Trans.State as State-import Control.Monad.Exceptable as Exceptable class ScopeAnyCont m where scopeAnyCont :: m a -> m a@@ -26,7 +23,7 @@ instance Monad m => ScopeAnyCont (AnyContT m) where scopeAnyCont = lift . flip AnyCont.runAnyContT return-+ instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where anyContToM x = lift $ anyContToM x@@ -35,18 +32,14 @@ scopeAnyCont = StateT . (scopeAnyCont .) . runStateT -instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (ExceptT e m) where+instance (Error e, Monad m, MonadAnyCont b m) => MonadAnyCont b (ErrorT e m) where anyContToM x = lift $ anyContToM x -instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (Exceptable.ExceptableT e m) where- anyContToM x = lift $ anyContToM x+instance ScopeAnyCont m => ScopeAnyCont (ErrorT e m) where+ scopeAnyCont = mapErrorT scopeAnyCont -instance ScopeAnyCont m => ScopeAnyCont (ExceptT e m) where- scopeAnyCont = mapExceptT scopeAnyCont -instance ScopeAnyCont m => ScopeAnyCont (Exceptable.ExceptableT e m) where- scopeAnyCont = Exceptable.mapExceptableT scopeAnyCont class MonadTransAnyCont b m where liftAnyCont :: (forall r . (a -> b r) -> b r) -> (forall r . (a -> m r) -> m r)@@ -57,8 +50,5 @@ instance MonadTransAnyCont b m => MonadTransAnyCont b (StateT s m) where liftAnyCont c = (\c q -> StateT $ \s -> c $ ($ s) . runStateT . q) (liftAnyCont c) -instance MonadTransAnyCont b m => MonadTransAnyCont b (ExceptT e m) where- liftAnyCont c = (\c q -> ExceptT . c $ runExceptT . q) (liftAnyCont c)--instance MonadTransAnyCont b m => MonadTransAnyCont b (Exceptable.ExceptableT e m) where- liftAnyCont c = (\c q -> makeExceptableT . c $ Exceptable.runExceptableT . q) (liftAnyCont c)+instance MonadTransAnyCont b m => MonadTransAnyCont b (ErrorT e m) where+ liftAnyCont c = (\c q -> ErrorT . c $ runErrorT . q) (liftAnyCont c)
− src/Control/Monad/Exceptable.hs
@@ -1,221 +0,0 @@-{-# LANGUAGE- GeneralizedNewtypeDeriving,- MultiParamTypeClasses,- UndecidableInstances,- CPP- #-}--module Control.Monad.Exceptable (- -- * MonadError class- MonadError(..),-- -- * The Exceptable monad- Exceptable,- exceptable,- runExceptable,- mapExceptable,- withExceptable,- makeExceptableT,- -- * The ExceptT monad transformer- ExceptableT(ExceptableT),- unExceptableT,- runExceptableT,- mapExceptableT,- withExceptableT,- -- * Exception operations- throwE,- catchE,- -- * Lifting other operations- liftCallCC,- liftListen,- liftPass,- -- * underlying ExceptT type- Except.Except,- Except.ExceptT,-- module Control.Monad.Fix,- module Control.Monad.Trans,- -- * Example 1: Custom Error Data Type- -- $customErrorExample-- -- * Example 2: Using ExceptT Monad Transformer- -- $ExceptTExample- ) where--import Prelude--import qualified Control.Monad.Trans.Except as Except--import Control.Monad.Trans-import Control.Monad.Signatures-import Data.Functor.Classes-import Data.Functor.Identity--import Control.Monad.State.Class as State-import Control.Monad.Error.Class as Error--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-#if __GLASGOW_HASKELL__ < 710-import Data.Foldable-import Data.Traversable (Traversable(traverse))-#endif---{- |-Why does the Exceptable module exist? The present llvm general design-is around the use of the ExceptT transformer, first defined in transformers 0.4.--Well, the goal of this module is to allow LLVM-General to be compatible with-GHC 7.8 apis, and GHC 7.8 comes bundled with transformers 0.3. Thus LLVM-General-must be compatible with transformers 0.3 (via the use of transformers-compat)-in order to be usable in conjunction with usage of GHC as a library.--At some future point where the active "power users" base of LLVM-General-no longer needs to support GHC 7.8 heavily, removing this Module and reverting other-changes elsewhere to using ExceptT / Except will be a good idea.--A good "signpost" for reverting will be around GHC 7.12's release,-because then there will be >=2 GHC major version releases that come bundled with-Transformers >= 0.4---}---type Exceptable e = ExceptableT e Identity---- | Constructor for computations in the exception monad.--- (The inverse of 'runExcept').-except :: Either e a -> Exceptable e a-except m = makeExceptableT (Identity m)--exceptable :: Except.Except e a -> Exceptable e a-exceptable = ExceptableT---- | Extractor for computations in the exception monad.--- (The inverse of 'except').-runExceptable :: Exceptable e a -> Either e a-runExceptable (ExceptableT m) = runIdentity $ Except.runExceptT m---- | Map the unwrapped computation using the given function.------ * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@-mapExceptable :: (Either e a -> Either e' b)- -> Exceptable e a- -> Exceptable e' b-mapExceptable f = mapExceptableT (Identity . f . runIdentity)---- | Transform any exceptions thrown by the computation using the given--- function (a specialization of 'withExceptT').-withExceptable :: (e -> e') -> Exceptable e a -> Exceptable e' a-withExceptable = withExceptableT----newtype ExceptableT e m a = ExceptableT { unExceptableT :: Except.ExceptT e m a }- deriving (- Eq,- Eq1,- Ord,- Ord1,- Functor,- Foldable,- Applicative,- Alternative,- Monad,- MonadPlus,- MonadTrans,- MonadIO- )--instance MonadState s m => MonadState s (ExceptableT e m) where- get = lift get- put = lift . put- state = lift . state--instance Monad m => MonadError e (ExceptableT e m) where- throwError = throwE- catchError = catchE--instance (Traversable f) => Traversable (ExceptableT e f) where- traverse f a =- (ExceptableT . Except.ExceptT) <$>- traverse (either (pure . Left) (fmap Right . f)) (runExceptableT a)---instance (Read e, Read1 m, Read a) => Read (ExceptableT e m a) where- readsPrec = readsData $ readsUnary1 "ExceptableT" ExceptableT--instance (Show e, Show1 m, Show a) => Show (ExceptableT e m a) where- showsPrec d (ExceptableT m) = showsUnary1 "ExceptableT" d m--instance (Read e, Read1 m) => Read1 (ExceptableT e m) where readsPrec1 = readsPrec-instance (Show e, Show1 m) => Show1 (ExceptableT e m) where showsPrec1 = showsPrec--runExceptableT :: ExceptableT e m a -> m (Either e a)-runExceptableT = Except.runExceptT . unExceptableT--makeExceptableT :: m (Either e a) -> ExceptableT e m a-makeExceptableT = ExceptableT . Except.ExceptT------- | Map the unwrapped computation using the given function.------ * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@-mapExceptableT :: (m (Either e a) -> n (Either e' b))- -> ExceptableT e m a- -> ExceptableT e' n b-mapExceptableT f m = makeExceptableT $ f (runExceptableT m)---- | Transform any exceptions thrown by the computation using the--- given function.-withExceptableT :: (Functor m) => (e -> e') -> ExceptableT e m a -> ExceptableT e' m a-withExceptableT f = mapExceptableT $ fmap $ either (Left . f) Right----- | Signal an exception value @e@.------ * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@------ * @'throwE' e >>= m = 'throwE' e@-throwE :: (Monad m) => e -> ExceptableT e m a-throwE = makeExceptableT . return . Left---- | Handle an exception.------ * @'catchE' h ('lift' m) = 'lift' m@------ * @'catchE' h ('throwE' e) = h e@-catchE :: (Monad m) =>- ExceptableT e m a -- ^ the inner computation- -> (e -> ExceptableT e' m a) -- ^ a handler for exceptions in the inner- -- computation- -> ExceptableT e' m a-m `catchE` h = makeExceptableT $ do- a <- runExceptableT m- case a of- Left l -> runExceptableT (h l)- Right r -> return (Right r)---- | Lift a @callCC@ operation to the new monad.-liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptableT e m) a b-liftCallCC callCC f = makeExceptableT $- callCC $ \ c ->- runExceptableT (f (\ a -> makeExceptableT $ c (Right a)))---- | Lift a @listen@ operation to the new monad.-liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptableT e m) a-liftListen listen = mapExceptableT $ \ m -> do- (a, w) <- listen m- return $! fmap (\ r -> (r, w)) a---- | Lift a @pass@ operation to the new monad.-liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptableT e m) a-liftPass pass = mapExceptableT $ \ m -> pass $ do- a <- m- return $! case a of- Left l -> (Left l, id)- Right (r, f) -> (Right r, f)
src/Control/Monad/Trans/AnyCont.hs view
@@ -3,8 +3,7 @@ #-} module Control.Monad.Trans.AnyCont where -import LLVM.General.Prelude-+import Control.Applicative import Control.Monad.Cont newtype AnyContT m a = AnyContT { unAnyContT :: forall r . ContT r m a }
src/LLVM/General/CodeGenOpt.hs view
@@ -1,7 +1,7 @@ -- | Code generation options, used in specifying TargetMachine module LLVM.General.CodeGenOpt where -import LLVM.General.Prelude+import Data.Data -- | <http://llvm.org/doxygen/namespacellvm_1_1CodeGenOpt.html> data Level
src/LLVM/General/CodeModel.hs view
@@ -1,7 +1,7 @@ -- | Relocations, used in specifying TargetMachine module LLVM.General.CodeModel where -import LLVM.General.Prelude+import Data.Data -- | <http://llvm.org/doxygen/namespacellvm_1_1CodeModel.html> data Model
src/LLVM/General/Diagnostic.hs view
@@ -5,7 +5,7 @@ diagnosticDisplay ) where -import LLVM.General.Prelude+import Data.Data -- | What kind of problem does a diagnostic describe? data DiagnosticKind
src/LLVM/General/Internal/Analysis.hs view
@@ -1,8 +1,6 @@ module LLVM.General.Internal.Analysis where -import LLVM.General.Prelude--import Control.Monad.Exceptable+import Control.Monad.Error import Control.Monad.AnyCont import qualified LLVM.General.Internal.FFI.Analysis as FFI@@ -13,9 +11,9 @@ -- | Run basic sanity checks on a 'Module'. Note that the same checks will trigger assertions -- within LLVM if LLVM was built with them turned on, before this function can be is called.-verify :: Module -> ExceptT String IO ()-verify (Module m) = unExceptableT $ flip runAnyContT return $ do+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 $ throwError =<< decodeM errorPtr+ when result $ fail =<< decodeM errorPtr
src/LLVM/General/Internal/Atomicity.hs view
@@ -4,13 +4,14 @@ #-} module LLVM.General.Internal.Atomicity where -import LLVM.General.Prelude+import Control.Monad import Data.Maybe import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.Coding+ import qualified LLVM.General.AST as A genCodingInstance [t| Maybe A.MemoryOrdering |] ''FFI.MemoryOrdering [
src/LLVM/General/Internal/Attribute.hs view
@@ -5,11 +5,10 @@ #-} module LLVM.General.Internal.Attribute where -import LLVM.General.Prelude--import LLVM.General.TH+import Language.Haskell.TH import Language.Haskell.TH.Quote +import Data.Data import Data.List (genericSplitAt) import Data.Bits@@ -40,12 +39,10 @@ TyConI (NewtypeD _ _ _ (NormalC ctcn _) _) <- reify ctn let zero = [| $(conE ctcn) 0 |] sequence [- instanceD (sequence [appT (conT ''Monad) m]) [t| EncodeM $(m) [$(type')] $(conT ctn) |] [+ instanceD (sequence [classP ''Monad [m]]) [t| EncodeM $(m) [$(type')] $(conT ctn) |] [ funD (mkName "encodeM") [ clause [] (normalB [| return . (- let- encodeAlignment a | popCount a == 1 = 1 + popCount (a - 1)- encodeAlignment _ = error "Cannot encode alignment which is not a power of two"+ let encodeAttribute a = $( caseE [| a |] $ flip map attributeData' $ \(n, b, s, w) -> let bQ = (dataToExpQ (const Nothing) b)@@ -56,7 +53,7 @@ a <- newName "a" match (conP n [varP a])- (normalB [| ($(conE ctcn) (fromIntegral (encodeAlignment $(varE a)) `shiftL` s)) .&. $(bQ) |])+ (normalB [| ($(conE ctcn) (fromIntegral $(varE a) `shiftL` s)) .&. $(bQ) |]) [] ) in@@ -67,7 +64,7 @@ -- build a decoder which uses bit masking for multiple fields at once -- to eliminate multiple absent attributes in fewer tests- instanceD (sequence [appT (conT ''Monad) m]) [t| DecodeM $(m) [$(type')] $(conT ctn) |] [+ instanceD (sequence [classP ''Monad [m]]) [t| DecodeM $(m) [$(type')] $(conT ctn) |] [ funD (mkName "decodeM") [ do bits <- newName "bits"@@ -86,7 +83,7 @@ i' <- newName "i'" letE [valD (conP ctcn [varP i']) (normalB [| i |]) []]- [| $(conE n) (bit ((fromIntegral $(varE i')) - 1)) |])+ [| $(conE n) (fromIntegral $(varE i')) |]) | let i = ($(varE bits) .&. $(dataToExpQ (const Nothing) b)) `shiftR` s, i /= $(zero) ]@@ -121,7 +118,6 @@ (FFI.paramAttrSExt, "A.A.SignExt"), (FFI.paramAttrInReg, "A.A.InReg"), (FFI.paramAttrStructRet, "A.A.SRet"),- (FFI.paramAttrAlignment, "A.A.Alignment"), (FFI.paramAttrNoAlias, "A.A.NoAlias"), (FFI.paramAttrByVal, "A.A.ByVal"), (FFI.paramAttrNoCapture, "A.A.NoCapture"),@@ -138,6 +134,7 @@ (FFI.functionAttrOptimizeForSize, "A.A.OptimizeForSize"), (FFI.functionAttrStackProtect, "A.A.StackProtect"), (FFI.functionAttrStackProtectReq, "A.A.StackProtectReq"),+ (FFI.functionAttrAlignment, "A.A.Alignment"), (FFI.functionAttrNoRedZone, "A.A.NoRedZone"), (FFI.functionAttrNoImplicitFloat, "A.A.NoImplicitFloat"), (FFI.functionAttrNaked, "A.A.Naked"),
src/LLVM/General/Internal/BasicBlock.hs view
@@ -1,7 +1,6 @@ module LLVM.General.Internal.BasicBlock where -import LLVM.General.Prelude-+import Control.Monad import Control.Monad.Trans import Foreign.Ptr
src/LLVM/General/Internal/CallingConvention.hs view
@@ -5,8 +5,6 @@ #-} module LLVM.General.Internal.CallingConvention where -import LLVM.General.Prelude- import LLVM.General.Internal.Coding import Foreign.C.Types (CUInt(..))
src/LLVM/General/Internal/Coding.hs view
@@ -6,13 +6,16 @@ #-} module LLVM.General.Internal.Coding where -import LLVM.General.Prelude- import Language.Haskell.TH import Language.Haskell.TH.Quote +import Control.Monad import Control.Monad.AnyCont import Control.Monad.IO.Class++import Data.Data (Data)+import Data.Word (Word, Word32, Word64)+import Data.Int (Int32) import Foreign.C import Foreign.Ptr
src/LLVM/General/Internal/CommandLine.hs view
@@ -1,13 +1,11 @@ module LLVM.General.Internal.CommandLine where -import LLVM.General.Prelude--import Control.Monad.AnyCont-import Control.Monad.IO.Class+import qualified LLVM.General.Internal.FFI.CommandLine as FFI import Foreign.Ptr -import qualified LLVM.General.Internal.FFI.CommandLine as FFI+import Control.Monad.AnyCont+import Control.Monad.IO.Class import LLVM.General.Internal.Coding import LLVM.General.Internal.String ()
src/LLVM/General/Internal/Constant.hs view
@@ -6,16 +6,15 @@ #-} module LLVM.General.Internal.Constant where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified LLVM.General.Internal.InstructionDefs as ID +import Control.Applicative+import Data.Word (Word32, Word64) import Data.Bits-import Control.Monad.State (get, gets, modify, evalState)+import Control.Monad.State import Control.Monad.AnyCont-import Control.Monad.IO.Class import qualified Data.Map as Map import Foreign.Ptr@@ -27,7 +26,6 @@ import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import LLVM.General.Internal.FFI.LLVMCTypes (valueSubclassIdP) import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI-import qualified LLVM.General.Internal.FFI.Type 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@@ -89,21 +87,16 @@ A.F.PPC_FP128 _ _ -> FFI.floatSemanticsPPCDoubleDouble nBits <- encodeM nBits liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words fpSem- A.C.GlobalReference _ n -> FFI.upCast <$> referGlobal n+ A.C.GlobalReference n -> FFI.upCast <$> referGlobal n A.C.BlockAddress f b -> do f' <- referGlobal f b' <- getBlockForAddress f b liftIO $ FFI.blockAddress (FFI.upCast f') b'- A.C.Struct nm p ms -> do+ A.C.Struct p ms -> do+ Context context <- gets encodeStateContext p <- encodeM p ms <- encodeM ms- case nm of- Nothing -> do- Context context <- gets encodeStateContext- liftIO $ FFI.constStructInContext context ms p- Just nm -> do- t <- lookupNamedType nm- liftIO $ FFI.constNamedStruct t ms+ liftIO $ FFI.constStructInContext context ms p o -> $(do let constExprInfo = ID.outerJoin ID.astConstantRecs (ID.innerJoin ID.astInstructionRecs ID.instructionDefs) TH.caseE [| o |] $ do@@ -134,13 +127,10 @@ decodeM c = scopeAnyCont $ do let v = FFI.upCast c :: Ptr FFI.Value u = FFI.upCast c :: Ptr FFI.User- ft <- liftIO (FFI.typeOf v)- t <- decodeM ft+ t <- decodeM =<< liftIO (FFI.typeOf v) valueSubclassId <- liftIO $ FFI.getValueSubclassId v nOps <- liftIO $ FFI.getNumOperands u- let globalRef = return A.C.GlobalReference - `ap` (return t)- `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v))+ let globalRef = return A.C.GlobalReference `ap` (getGlobalName =<< liftIO (FFI.isAGlobalValue v)) op = decodeM <=< liftIO . FFI.getConstantOperand c getConstantOperands = mapM op [0..nOps-1] getConstantData = do@@ -159,7 +149,7 @@ wsp <- liftIO $ FFI.getConstantIntWords c np n <- peek np words <- decodeM (n, wsp)- return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral b) 0 (words :: [Word64]))+ return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral (b :: Word64)) 0 words) [valueSubclassIdP|ConstantFP|] -> do let A.FloatingPointType nBits fmt = t ws <- allocaWords nBits@@ -181,11 +171,8 @@ return A.C.BlockAddress `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c) `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c)- [valueSubclassIdP|ConstantStruct|] -> do- return A.C.Struct- `ap` (return $ case t of A.NamedTypeReference n -> Just n; _ -> Nothing)- `ap` (decodeM =<< liftIO (FFI.isPackedStruct ft))- `ap` getConstantOperands+ [valueSubclassIdP|ConstantStruct|] -> + return A.C.Struct `ap` (return $ A.isPacked t) `ap` getConstantOperands [valueSubclassIdP|ConstantDataArray|] -> return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData [valueSubclassIdP|ConstantArray|] ->
src/LLVM/General/Internal/Context.hs view
@@ -1,9 +1,6 @@ module LLVM.General.Internal.Context where -import LLVM.General.Prelude- import Control.Exception-import Control.Concurrent import Foreign.Ptr @@ -16,5 +13,4 @@ -- | Create a Context, run an action (to which it is provided), then destroy the Context. withContext :: (Context -> IO a) -> IO a-withContext = runBound . bracket FFI.contextCreate FFI.contextDispose . (. Context)- where runBound = if rtsSupportsBoundThreads then runInBoundThread else id+withContext = bracket FFI.contextCreate FFI.contextDispose . (. Context)
src/LLVM/General/Internal/DataLayout.hs view
@@ -1,8 +1,6 @@ module LLVM.General.Internal.DataLayout where -import LLVM.General.Prelude--import Control.Monad.Exceptable+import Control.Monad.Error import Control.Monad.AnyCont import Control.Exception
src/LLVM/General/Internal/DecodeAST.hs view
@@ -5,13 +5,13 @@ #-} module LLVM.General.Internal.DecodeAST where -import LLVM.General.Prelude-+import Control.Applicative import Control.Monad.State import Control.Monad.AnyCont import Foreign.Ptr import Foreign.C+import Data.Word import Data.Sequence (Seq) import qualified Data.Sequence as Seq
src/LLVM/General/Internal/Diagnostic.hs view
@@ -4,8 +4,6 @@ #-} module LLVM.General.Internal.Diagnostic where -import LLVM.General.Prelude- import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.SMDiagnostic as FFI
src/LLVM/General/Internal/EncodeAST.hs view
@@ -5,11 +5,9 @@ #-} module LLVM.General.Internal.EncodeAST where -import LLVM.General.Prelude- import Control.Exception import Control.Monad.State-import Control.Monad.Exceptable+import Control.Monad.Error import Control.Monad.AnyCont import Foreign.Ptr@@ -20,7 +18,6 @@ import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI-import qualified LLVM.General.Internal.FFI.Value as FFI import qualified LLVM.General.AST as A @@ -28,14 +25,10 @@ import LLVM.General.Internal.Coding import LLVM.General.Internal.String () -data LocalValue- = ForwardValue (Ptr FFI.Value)- | DefinedValue (Ptr FFI.Value)--data EncodeState = EncodeState {+data EncodeState = EncodeState { encodeStateBuilder :: Ptr FFI.Builder, encodeStateContext :: Context,- encodeStateLocals :: Map A.Name LocalValue,+ encodeStateLocals :: Map A.Name (Ptr FFI.Value), encodeStateGlobals :: Map A.Name (Ptr FFI.GlobalValue), encodeStateAllBlocks :: Map (A.Name, A.Name) (Ptr FFI.BasicBlock), encodeStateBlocks :: Map A.Name (Ptr FFI.BasicBlock),@@ -43,10 +36,9 @@ encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type) } -newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ExceptableT String (StateT EncodeState IO)) a }+newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ErrorT String (StateT EncodeState IO)) a } deriving ( Functor,- Applicative, Monad, MonadIO, MonadState EncodeState,@@ -58,15 +50,15 @@ lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) lookupNamedType n = do t <- gets $ Map.lookup n . encodeStateNamedTypes- maybe (throwError $ "reference to undefined type: " ++ show n) return t+ maybe (fail $ "reference to undefined type: " ++ show n) return t defineType :: A.Name -> Ptr FFI.Type -> EncodeAST () defineType n t = modify $ \s -> s { encodeStateNamedTypes = Map.insert n t (encodeStateNamedTypes s) } -runEncodeAST :: Context -> EncodeAST a -> ExceptT String IO a-runEncodeAST context@(Context ctx) (EncodeAST a) = unExceptableT $ makeExceptableT $+runEncodeAST :: Context -> EncodeAST a -> ErrorT String IO a+runEncodeAST context@(Context ctx) (EncodeAST a) = ErrorT $ bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do- let initEncodeState = EncodeState {+ let initEncodeState = EncodeState { encodeStateBuilder = builder, encodeStateContext = context, encodeStateLocals = Map.empty,@@ -76,7 +68,7 @@ encodeStateMDNodes = Map.empty, encodeStateNamedTypes = Map.empty }- flip evalStateT initEncodeState . runExceptableT . flip runAnyContT return $ a+ flip evalStateT initEncodeState . runErrorT . flip runAnyContT return $ a withName :: A.Name -> (CString -> IO a) -> IO a withName (A.Name n) = withCString n@@ -88,7 +80,7 @@ phase :: EncodeAST a -> EncodeAST (EncodeAST a) phase p = do- let s0 `withLocalsFrom` s1 = s0 {+ let s0 `withLocalsFrom` s1 = s0 { encodeStateLocals = encodeStateLocals s1, encodeStateBlocks = encodeStateBlocks s1 }@@ -100,34 +92,31 @@ modify (`withLocalsFrom` s') return r +define :: (Ord n, FFI.DescendentOf p v) => + (EncodeState -> Map n (Ptr p))+ -> (Map n (Ptr p) -> EncodeState -> EncodeState)+ -> n+ -> Ptr v+ -> EncodeAST ()+define r w n v = modify $ \b -> w (Map.insert n (FFI.upCast v) (r b)) b+ defineLocal :: FFI.DescendentOf FFI.Value v => A.Name -> Ptr v -> EncodeAST ()-defineLocal n v' = do- let v = FFI.upCast v'- def <- gets $ Map.lookup n . encodeStateLocals- case def of- Just (ForwardValue dummy) -> liftIO $ FFI.replaceAllUsesWith dummy v- _ -> return ()- modify $ \b -> b { encodeStateLocals = Map.insert n (DefinedValue v) (encodeStateLocals b) }+defineLocal = define encodeStateLocals (\m b -> b { encodeStateLocals = m }) defineGlobal :: FFI.DescendentOf FFI.GlobalValue v => A.Name -> Ptr v -> EncodeAST ()-defineGlobal n v = modify $ \b -> b { encodeStateGlobals = Map.insert n (FFI.upCast v) (encodeStateGlobals b) }+defineGlobal = define encodeStateGlobals (\m b -> b { encodeStateGlobals = m }) defineMDNode :: A.MetadataNodeID -> Ptr FFI.MDNode -> EncodeAST ()-defineMDNode n v = modify $ \b -> b { encodeStateMDNodes = Map.insert n (FFI.upCast v) (encodeStateMDNodes b) }+defineMDNode = define encodeStateMDNodes (\m b -> b { encodeStateMDNodes = m }) -refer :: (Show n, Ord n) => (EncodeState -> Map n v) -> n -> EncodeAST v -> EncodeAST v-refer r n f = do+refer :: (Show n, Ord n) => (EncodeState -> Map n (Ptr p)) -> String -> n -> EncodeAST (Ptr p)+refer r m n = do mop <- gets $ Map.lookup n . r- maybe f return mop--undefinedReference :: Show n => String -> n -> EncodeAST a-undefinedReference m n = throwError $ "reference to undefined " ++ m ++ ": " ++ show n--referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n (Ptr p)) -> String -> n -> EncodeAST (Ptr p)-referOrThrow r m n = refer r n $ undefinedReference m n+ maybe (fail $ "reference to undefined " ++ m ++ ": " ++ show n) return mop -referGlobal = referOrThrow encodeStateGlobals "global"-referMDNode = referOrThrow encodeStateMDNodes "metadata node"+referLocal = refer encodeStateLocals "local"+referGlobal = refer encodeStateGlobals "global"+referMDNode = refer encodeStateMDNodes "metadata node" defineBasicBlock :: A.Name -> A.Name -> Ptr FFI.BasicBlock -> EncodeAST () defineBasicBlock fn n b = modify $ \s -> s {@@ -136,8 +125,8 @@ } instance EncodeM EncodeAST A.Name (Ptr FFI.BasicBlock) where- encodeM = referOrThrow encodeStateBlocks "block"+ encodeM = refer encodeStateBlocks "block" getBlockForAddress :: A.Name -> A.Name -> EncodeAST (Ptr FFI.BasicBlock)-getBlockForAddress fn n = referOrThrow encodeStateAllBlocks "blockaddress" (fn, n)+getBlockForAddress fn n = refer encodeStateAllBlocks "blockaddress" (fn, n)
src/LLVM/General/Internal/ExecutionEngine.hs view
@@ -5,13 +5,13 @@ #-} module LLVM.General.Internal.ExecutionEngine where -import LLVM.General.Prelude- import Control.Exception+import Control.Monad import Control.Monad.IO.Class import Control.Monad.AnyCont-import Control.Monad.Exceptable+import Control.Monad.Error +import Data.Word import Data.IORef import Foreign.Ptr import Foreign.C (CUInt, CString)@@ -68,7 +68,7 @@ liftIO initializeNativeTarget outExecutionEngine <- alloca outErrorCStringPtr <- alloca- Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runExceptableT . ExceptableT+ Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runErrorT . withModuleFromAST c (A.Module "" Nothing Nothing [])) (return . Module) m r <- liftIO $ createEngine outExecutionEngine dummyModule outErrorCStringPtr@@ -86,10 +86,9 @@ -> Word -- ^ optimization level -> (JIT -> IO a) -> IO a-withJIT c opt f = FFI.linkInJIT >> withJIT' f- where withJIT' =- withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))- . (. JIT)+withJIT c opt = + withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))+ . (. JIT) instance ExecutionEngine JIT (FunPtr ()) where withModuleInEngine (JIT e) m f = withModuleInEngine e m (\(ExecutableModule e m) -> f (ExecutableModule (JIT e) m))@@ -117,7 +116,6 @@ -> (MCJIT -> IO a) -> IO a withMCJIT c opt cm fpe fisel f = do- FFI.linkInMCJIT let createMCJITCompilerForModule e m s = do size <- FFI.getMCJITCompilerOptionsSize allocaBytes (fromIntegral size) $ \p -> do
src/LLVM/General/Internal/FFI/Analysis.hs view
@@ -3,8 +3,6 @@ #-} module LLVM.General.Internal.FFI.Analysis where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Assembly.hs view
@@ -5,8 +5,6 @@ -- | Functions to read and write textual LLVM assembly module LLVM.General.Internal.FFI.Assembly where -import LLVM.General.Prelude- import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.MemoryBuffer import LLVM.General.Internal.FFI.Module
src/LLVM/General/Internal/FFI/BasicBlock.hs view
@@ -6,8 +6,6 @@ -- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html> module LLVM.General.Internal.FFI.BasicBlock where -import LLVM.General.Prelude- import Foreign.Ptr import LLVM.General.Internal.FFI.PtrHierarchy
− src/LLVM/General/Internal/FFI/BinaryOperator.h
@@ -1,16 +0,0 @@-#ifndef __LLVM_GENERAL_INTERNAL_FFI__BINARY_OPERATOR__H__-#define __LLVM_GENERAL_INTERNAL_FFI__BINARY_OPERATOR__H__--#define LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(macro) \- macro(UDiv) \- macro(SDiv) \- macro(LShr) \- macro(AShr)--#define LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(macro) \- macro(Add) \- macro(Mul) \- macro(Shl) \- macro(Sub) \--#endif
src/LLVM/General/Internal/FFI/BinaryOperator.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ OverlappingInstances #-} -- | FFI functions for handling the LLVM BinaryOperator class module LLVM.General.Internal.FFI.BinaryOperator where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C @@ -26,5 +25,3 @@ foreign import ccall unsafe "LLVM_General_IsExact" isExact :: Ptr Value -> IO LLVMBool -foreign import ccall unsafe "LLVM_General_GetFastMathFlags" getFastMathFlags ::- Ptr Value -> IO FastMathFlags
src/LLVM/General/Internal/FFI/Bitcode.hs view
@@ -5,8 +5,6 @@ -- | Functions to read and write LLVM bitcode module LLVM.General.Internal.FFI.Bitcode where -import LLVM.General.Prelude- import LLVM.General.Internal.FFI.RawOStream import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.MemoryBuffer
src/LLVM/General/Internal/FFI/Builder.hs view
@@ -7,19 +7,19 @@ -- | FFI glue for llvm::IRBuilder - llvm's IR construction state object module LLVM.General.Internal.FFI.Builder where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH +import Control.Monad++import qualified LLVM.General.AST.Instruction as A++import LLVM.General.Internal.InstructionDefs as ID+ import Foreign.Ptr import Foreign.C -import qualified Data.List as List import qualified Data.Map as Map -import qualified LLVM.General.AST.Instruction as A-import LLVM.General.Internal.InstructionDefs as ID- import LLVM.General.Internal.FFI.Cleanup import LLVM.General.Internal.FFI.Context import LLVM.General.Internal.FFI.LLVMCTypes@@ -74,7 +74,7 @@ error $ "LLVM instruction def " ++ lrn ++ " not found in the AST" _ -> [] - let ats = map typeMapping (fieldTypes List.\\ [TH.ConT ''A.InstructionMetadata, TH.ConT ''A.FastMathFlags])+ 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 |]]@@ -86,15 +86,11 @@ foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca :: Ptr Builder -> Ptr Type -> Ptr Value -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVM_General_BuildLoad" buildLoad' ::- Ptr Builder -> LLVMBool -> Ptr Value -> MemoryOrdering -> LLVMBool -> CUInt -> CString -> IO (Ptr Instruction)--buildLoad builder vol a' (ss, mo) al s = buildLoad' builder vol a' mo ss al s--foreign import ccall unsafe "LLVM_General_BuildStore" buildStore' ::- Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> MemoryOrdering -> LLVMBool -> CUInt -> CString -> IO (Ptr Instruction)+foreign import ccall unsafe "LLVM_General_BuildLoad" buildLoad ::+ Ptr Builder -> Ptr Value -> CUInt -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) -buildStore builder vol a' v' (ss, mo) al s = buildStore' builder vol a' v' mo ss al s+foreign import ccall unsafe "LLVM_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)@@ -102,25 +98,20 @@ foreign import ccall unsafe "LLVMBuildInBoundsGEP" buildInBoundsGetElementPtr' :: Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction) -buildGetElementPtr :: Ptr Builder -> LLVMBool -> Ptr Value -> (CUInt, Ptr (Ptr Value)) -> CString -> IO (Ptr Instruction)-buildGetElementPtr builder (LLVMBool 1) a (n, is) s = buildInBoundsGetElementPtr' builder a is n s-buildGetElementPtr builder (LLVMBool 0) a (n, is) s = buildGetElementPtr' builder a is n s+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 "LLVM_General_BuildFence" buildFence' ::+foreign import ccall unsafe "LLVM_General_BuildFence" buildFence :: Ptr Builder -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) -buildFence builder (ss, mo) s = buildFence' builder mo ss s+foreign import ccall unsafe "LLVM_General_BuildAtomicCmpXchg" buildCmpXchg ::+ Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVM_General_BuildAtomicCmpXchg" buildCmpXchg' ::- Ptr Builder -> LLVMBool -> Ptr Value -> Ptr Value -> Ptr Value -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)+foreign import ccall unsafe "LLVM_General_BuildAtomicRMW" buildAtomicRMW ::+ Ptr Builder -> RMWOperation -> Ptr Value -> Ptr Value -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction) -buildCmpXchg builder vol a e r (ss, mo) s = buildCmpXchg' builder vol a e r mo ss s -foreign import ccall unsafe "LLVM_General_BuildAtomicRMW" buildAtomicRMW' ::- Ptr Builder -> LLVMBool -> RMWOperation -> Ptr Value -> Ptr Value -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)--buildAtomicRMW builder vol rmwOp a v (ss, mo) s = buildAtomicRMW' builder vol rmwOp a v mo ss s - foreign import ccall unsafe "LLVMBuildICmp" buildICmp :: Ptr Builder -> ICmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction) @@ -157,5 +148,4 @@ foreign import ccall unsafe "LLVMBuildLandingPad" buildLandingPad :: Ptr Builder -> Ptr Type -> Ptr Value -> CUInt -> CString -> IO (Ptr Instruction) -foreign import ccall unsafe "LLVM_General_SetFastMathFlags" setFastMathFlags ::- Ptr Builder -> FastMathFlags -> IO ()+
src/LLVM/General/Internal/FFI/BuilderC.cpp view
@@ -5,7 +5,6 @@ #include "llvm-c/Core.h" #include "LLVM/General/Internal/FFI/Instruction.h"-#include "LLVM/General/Internal/FFI/BinaryOperator.h" using namespace llvm; @@ -38,18 +37,16 @@ } } -static FastMathFlags unwrap(LLVMFastMathFlags f) {- FastMathFlags r = FastMathFlags();-#define ENUM_CASE(x,l) if (f & LLVM ## x) r.set ## x();-LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)-#undef ENUM_CASE- return r; } -}- extern "C" { +#define LLVM_GENERAL_FOR_ALL_OVERFLOWING_BINARY_OPERATORS(macro) \+ macro(Add) \+ macro(Mul) \+ macro(Shl) \+ macro(Sub) \+ #define ENUM_CASE(Op) \ LLVMValueRef LLVM_General_Build ## Op( \ LLVMBuilderRef b, \@@ -61,9 +58,15 @@ ) { \ return wrap(unwrap(b)->Create ## Op(unwrap(o0), unwrap(o1), s, nuw, nsw)); \ }-LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(ENUM_CASE)+LLVM_GENERAL_FOR_ALL_OVERFLOWING_BINARY_OPERATORS(ENUM_CASE) #undef ENUM_CASE +#define LLVM_GENERAL_FOR_ALL_POSSIBLY_EXACT_OPERATORS(macro) \+ macro(AShr) \+ macro(LShr) \+ macro(SDiv) \+ macro(UDiv) \+ #define ENUM_CASE(Op) \ LLVMValueRef LLVM_General_Build ## Op( \ LLVMBuilderRef b, \@@ -74,20 +77,17 @@ ) { \ return wrap(unwrap(b)->Create ## Op(unwrap(o0), unwrap(o1), s, exact)); \ }-LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(ENUM_CASE)+LLVM_GENERAL_FOR_ALL_POSSIBLY_EXACT_OPERATORS(ENUM_CASE) #undef ENUM_CASE -void LLVM_General_SetFastMathFlags(LLVMBuilderRef b, LLVMFastMathFlags f) {- unwrap(b)->SetFastMathFlags(unwrap(f));-} LLVMValueRef LLVM_General_BuildLoad( LLVMBuilderRef b,- LLVMBool isVolatile, LLVMValueRef p,+ unsigned align,+ LLVMBool isVolatile, LLVMAtomicOrdering atomicOrdering, LLVMSynchronizationScope synchScope,- unsigned align, const char *name ) { LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), align, isVolatile, name);@@ -98,12 +98,12 @@ LLVMValueRef LLVM_General_BuildStore( LLVMBuilderRef b,- LLVMBool isVolatile,- LLVMValueRef p, LLVMValueRef v,+ LLVMValueRef p,+ unsigned align,+ LLVMBool isVolatile, LLVMAtomicOrdering atomicOrdering, LLVMSynchronizationScope synchScope,- unsigned align, const char *name ) { StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), align, isVolatile);@@ -123,10 +123,10 @@ LLVMValueRef LLVM_General_BuildAtomicCmpXchg( LLVMBuilderRef b,- LLVMBool v, LLVMValueRef ptr, LLVMValueRef cmp, LLVMValueRef n, + LLVMBool v, LLVMAtomicOrdering lao, LLVMSynchronizationScope lss, const char *name@@ -141,10 +141,10 @@ LLVMValueRef LLVM_General_BuildAtomicRMW( LLVMBuilderRef b,- LLVMBool v, LLVMAtomicRMWBinOp rmwOp, LLVMValueRef ptr, LLVMValueRef val, + LLVMBool v, LLVMAtomicOrdering lao, LLVMSynchronizationScope lss, const char *name
src/LLVM/General/Internal/FFI/ByteRangeCallback.hs view
@@ -3,8 +3,6 @@ #-} module LLVM.General.Internal.FFI.ByteRangeCallback where -import LLVM.General.Prelude- import Foreign.C import Foreign.Ptr
src/LLVM/General/Internal/FFI/Cleanup.hs view
@@ -3,11 +3,13 @@ #-} module LLVM.General.Internal.FFI.Cleanup where -import LLVM.General.Prelude- import Language.Haskell.TH+import Control.Monad import Data.Sequence as Seq+import Data.Foldable (toList) +import Data.Word+import Data.Int import Foreign.C import Foreign.Ptr @@ -19,7 +21,6 @@ import qualified LLVM.General.AST.Constant as A.C (Constant) import qualified LLVM.General.AST.Operand as A (Operand) import qualified LLVM.General.AST.Type as A (Type)-import qualified LLVM.General.AST.Instruction as A (FastMathFlags) foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ foreignDecl cName hName argTypeQs returnTypeQ = do@@ -61,9 +62,10 @@ ] ] --- | The LLVM C-API for instructions with boolean flags (e.g. nsw) and is weak, so they get+-- | 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.+-- 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) @@ -78,6 +80,5 @@ | h == ''A.C.Constant -> [t| Ptr FFI.Constant |] | h == ''A.FloatingPointPredicate -> [t| FCmpPredicate |] | h == ''A.IntegerPredicate -> [t| ICmpPredicate |]- | h == ''A.FastMathFlags -> [t| FastMathFlags |] AppT ListT x -> foldl1 appT [tupleT 2, [t| CUInt |], appT [t| Ptr |] (typeMapping x)] x -> error $ "type not handled in Cleanup typeMapping: " ++ show x
src/LLVM/General/Internal/FFI/CommandLine.hs view
@@ -3,8 +3,6 @@ #-} module LLVM.General.Internal.FFI.CommandLine where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Constant.hs view
@@ -3,17 +3,18 @@ ForeignFunctionInterface, MultiParamTypeClasses, UndecidableInstances,+ OverlappingInstances, ViewPatterns #-} -- | FFI functions for handling the LLVM Constant class module LLVM.General.Internal.FFI.Constant where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH import qualified LLVM.General.Internal.InstructionDefs as ID +import Control.Monad import qualified Data.Map as Map+import Data.Word import Foreign.Ptr import Foreign.C@@ -51,11 +52,6 @@ Ptr Context -> Ptr (Ptr Constant) -> CUInt -> LLVMBool -> IO (Ptr Constant) constStructInContext ctx (n, cs) p = constStructInContext' ctx cs n p--foreign import ccall unsafe "LLVMConstNamedStruct" constNamedStruct' ::- Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)--constNamedStruct ty (n, cs) = constNamedStruct' ty cs n foreign import ccall unsafe "LLVM_General_GetConstantDataSequentialElementAsConstant" getConstantDataSequentialElementAsConstant :: Ptr Constant -> CUInt -> IO (Ptr Constant)
src/LLVM/General/Internal/FFI/ConstantC.cpp view
@@ -6,7 +6,6 @@ #include "llvm-c/Core.h" #include "LLVM/General/Internal/FFI/Value.h" #include "LLVM/General/Internal/FFI/Constant.h"-#include "LLVM/General/Internal/FFI/BinaryOperator.h" using namespace llvm; @@ -53,12 +52,24 @@ return wrap(ConstantExpr::get(opcode, unwrap<Constant>(o0), unwrap<Constant>(o1))); } +#define LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(macro) \+ macro(Add) \+ macro(Sub) \+ macro(Mul) \+ macro(Shl)+ #define CASE_CODE(op) \ LLVMValueRef LLVM_General_Const ## op(unsigned nsw, unsigned nuw, LLVMValueRef o0, LLVMValueRef o1) { \ return wrap(ConstantExpr::get ## op(unwrap<Constant>(o0), unwrap<Constant>(o1), nuw != 0, nsw != 0)); \ } LLVM_GENERAL_FOR_EACH_OVERFLOWING_BINARY_OPERATOR(CASE_CODE) #undef CASE_CODE++#define LLVM_GENERAL_FOR_EACH_POSSIBLY_EXACT_BINARY_OPERATOR(macro) \+ macro(UDiv) \+ macro(SDiv) \+ macro(LShr) \+ macro(AShr) #define CASE_CODE(op) \ LLVMValueRef LLVM_General_Const ## op(unsigned isExact, LLVMValueRef o0, LLVMValueRef o1) { \
src/LLVM/General/Internal/FFI/Context.hs view
@@ -8,8 +8,6 @@ -- | This choice allows multiple threads to do independent work with LLVM safely. module LLVM.General.Internal.FFI.Context where -import LLVM.General.Prelude- import Foreign.Ptr -- | a blind type to correspond to LLVMContext
src/LLVM/General/Internal/FFI/DataLayout.hs view
@@ -4,8 +4,6 @@ module LLVM.General.Internal.FFI.DataLayout where -import LLVM.General.Prelude- import Foreign.C.String import Foreign.Ptr
src/LLVM/General/Internal/FFI/ExecutionEngine.hs view
@@ -4,8 +4,6 @@ module LLVM.General.Internal.FFI.ExecutionEngine where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Function.h view
@@ -6,16 +6,15 @@ macro(Fast) \ macro(Cold) \ -#define LLVM_GENERAL_FOR_EACH_PARAM_ATTR(macro) \- macro(ZExt,Attribute) \- macro(SExt,Attribute) \- macro(InReg,Attribute) \- macro(StructRet,Attribute) \- macro(Alignment,) \- macro(NoAlias,Attribute) \- macro(ByVal,Attribute) \- macro(NoCapture,Attribute) \- macro(Nest,Attribute)+#define LLVM_GENERAL_FOR_EACH_PARAM_ATTR(macro) \+ macro(ZExt) \+ macro(SExt) \+ macro(InReg) \+ macro(StructRet) \+ macro(NoAlias) \+ macro(ByVal) \+ macro(NoCapture) \+ macro(Nest) \ #define LLVM_GENERAL_FOR_EACH_FUNCTION_ATTR(macro) \ macro(NoReturn,Attribute) \@@ -27,6 +26,7 @@ macro(OptimizeForSize,Attribute) \ macro(StackProtect,Attribute) \ macro(StackProtectReq,Attribute) \+ macro(Alignment,) \ macro(NoRedZone,Attribute) \ macro(NoImplicitFloat,Attribute) \ macro(Naked,Attribute) \
src/LLVM/General/Internal/FFI/Function.hs view
@@ -5,8 +5,6 @@ module LLVM.General.Internal.FFI.Function where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/GlobalAlias.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ OverlappingInstances #-} -- | FFI functions for handling the LLVM GlobalAlias class module LLVM.General.Internal.FFI.GlobalAlias where--import LLVM.General.Prelude import Foreign.Ptr
src/LLVM/General/Internal/FFI/GlobalValue.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ OverlappingInstances #-} -- | FFI functions for handling the LLVM GlobalValue class module LLVM.General.Internal.FFI.GlobalValue where--import LLVM.General.Prelude import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/GlobalVariable.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ OverlappingInstances #-} -- | FFI functions for handling the LLVM GlobalVariable class module LLVM.General.Internal.FFI.GlobalVariable where--import LLVM.General.Prelude import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/InlineAssembly.hs view
@@ -4,8 +4,6 @@ module LLVM.General.Internal.FFI.InlineAssembly where -import LLVM.General.Prelude- import Foreign.C import Foreign.Ptr
src/LLVM/General/Internal/FFI/Instruction.h view
@@ -35,23 +35,4 @@ #undef ENUM_CASE } LLVMSynchronizationScope; -#define LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(macro) \- macro(UnsafeAlgebra, unsafeAlgebra) \- macro(NoNaNs, noNaNs) \- macro(NoInfs, noInfs) \- macro(NoSignedZeros, noSignedZeros) \- macro(AllowReciprocal, allowReciprocal)--typedef enum {-#define ENUM_CASE(x,l) LLVM ## x ## Bit,-LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)-#undef ENUM_CASE-} LLVMFastMathFlagBit;--typedef enum {-#define ENUM_CASE(x,l) LLVM ## x = (1 << LLVM ## x ## Bit),-LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)-#undef ENUM_CASE-} LLVMFastMathFlags;- #endif
src/LLVM/General/Internal/FFI/Instruction.hs view
@@ -2,12 +2,12 @@ ForeignFunctionInterface, MultiParamTypeClasses, UndecidableInstances,+ OverlappingInstances, TemplateHaskell #-} module LLVM.General.Internal.FFI.Instruction where -import LLVM.General.Prelude-+import Control.Monad import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/InstructionC.cpp view
@@ -43,16 +43,8 @@ } } -LLVMFastMathFlags wrap(FastMathFlags f) {- unsigned r = 0;-#define ENUM_CASE(u,l) if (f.l()) r |= unsigned(LLVM ## u);-LLVM_GENERAL_FOR_EACH_FAST_MATH_FLAG(ENUM_CASE)-#undef ENUM_CASE- return LLVMFastMathFlags(r); } -}- extern "C" { unsigned LLVM_General_GetInstructionDefOpcode(LLVMValueRef val) {@@ -69,10 +61,6 @@ int LLVM_General_IsExact(LLVMValueRef val) { return unwrap<PossiblyExactOperator>(val)->isExact();-}--LLVMFastMathFlags LLVM_General_GetFastMathFlags(LLVMValueRef val) {- return wrap(unwrap<Instruction>(val)->getFastMathFlags()); } LLVMValueRef LLVM_General_GetCallInstCalledValue(
src/LLVM/General/Internal/FFI/InstructionDefs.hsc view
@@ -2,8 +2,6 @@ -- so it may be accessed conveniently with Template Haskell code module LLVM.General.Internal.FFI.InstructionDefs where -import LLVM.General.Prelude- import LLVM.General.Internal.FFI.LLVMCTypes #define FIRST_TERM_INST(num) struct inst { const char *kind; int opcode; const char *name; const char *clas; } insts[] = { { "Terminator", },
src/LLVM/General/Internal/FFI/Iterate.hs view
@@ -1,8 +1,8 @@ -- | Functions to help handle LLVM iteration patterns module LLVM.General.Internal.FFI.Iterate where -import LLVM.General.Prelude-+import Control.Monad+import Data.Functor import Foreign.Ptr -- | retrieve a sequence of objects which form a linked list, given an action to
src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -5,8 +5,6 @@ -- Encapsulate hsc macro weirdness here, supporting higher-level tricks elsewhere. module LLVM.General.Internal.FFI.LLVMCTypes where -import LLVM.General.Prelude- #define __STDC_LIMIT_MACROS #include "llvm-c/Core.h" #include "llvm-c/Target.h"@@ -23,10 +21,10 @@ #include "LLVM/General/Internal/FFI/Constant.h" #include "LLVM/General/Internal/FFI/Analysis.h" #include "LLVM/General/Internal/FFI/Module.h"-#include "LLVM/General/Internal/FFI/LibFunc.h" import Language.Haskell.TH.Quote +import Data.Data import Data.Bits import Foreign.C import Foreign.Storable@@ -107,11 +105,6 @@ newtype MDKindID = MDKindID CUInt deriving (Storable) -newtype FastMathFlags = FastMathFlags CUInt- deriving (Eq, Ord, Show, Typeable, Data, Num, Bits)-#define FMF_Rec(n,l) { #n, LLVM ## n, },-#{inject FAST_MATH_FLAG, FastMathFlags, FastMathFlags, fastMathFlags, FMF_Rec}- newtype MemoryOrdering = MemoryOrdering CUInt deriving (Eq, Typeable, Data) #define MO_Rec(n) { #n, LLVMAtomicOrdering ## n },@@ -194,7 +187,7 @@ newtype ParamAttr = ParamAttr CUInt deriving (Eq, Read, Show, Bits, Typeable, Data, Num)-#define PA_Rec(n,a) { #n, LLVM ## n ## a },+#define PA_Rec(n) { #n, LLVM ## n ## Attribute }, #{inject PARAM_ATTR, ParamAttr, ParamAttr, paramAttr, PA_Rec} newtype FunctionAttr = FunctionAttr CUInt@@ -216,8 +209,3 @@ deriving (Eq, Read, Show, Bits, Typeable, Data, Num) #define LM_Rec(n) { #n, LLVMLinker ## n }, #{inject LINKER_MODE, LinkerMode, LinkerMode, linkerMode, LM_Rec}--newtype LibFunc = LibFunc CUInt- deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable)-#define LF_Rec(n) { #n, LLVMLibFunc__ ## n },-#{inject LIB_FUNC, LibFunc, LibFunc, libFunc__, LF_Rec}
− src/LLVM/General/Internal/FFI/LibFunc.h
@@ -1,311 +0,0 @@-#ifndef __LLVM_GENERAL_INTERNAL_FFI__LIB_FUNC__H__-#define __LLVM_GENERAL_INTERNAL_FFI__LIB_FUNC__H__--#define LLVM_GENERAL_FOR_EACH_LIB_FUNC(macro) \- macro(under_IO_getc) \- macro(under_IO_putc) \- macro(ZdaPv) \- macro(ZdlPv) \- macro(Znaj) \- macro(ZnajRKSt9nothrow_t) \- macro(Znam) \- macro(ZnamRKSt9nothrow_t) \- macro(Znwj) \- macro(ZnwjRKSt9nothrow_t) \- macro(Znwm) \- macro(ZnwmRKSt9nothrow_t) \- macro(cxa_atexit) \- macro(cxa_guard_abort) \- macro(cxa_guard_acquire) \- macro(cxa_guard_release) \- macro(dunder_isoc99_scanf) \- macro(dunder_isoc99_sscanf) \- macro(memcpy_chk) \- macro(dunder_strdup) \- macro(dunder_strndup) \- macro(dunder_strtok_r) \- macro(abs) \- macro(access) \- macro(acos) \- macro(acosf) \- macro(acosh) \- macro(acoshf) \- macro(acoshl) \- macro(acosl) \- macro(asin) \- macro(asinf) \- macro(asinh) \- macro(asinhf) \- macro(asinhl) \- macro(asinl) \- macro(atan) \- macro(atan2) \- macro(atan2f) \- macro(atan2l) \- macro(atanf) \- macro(atanh) \- macro(atanhf) \- macro(atanhl) \- macro(atanl) \- macro(atof) \- macro(atoi) \- macro(atol) \- macro(atoll) \- macro(bcmp) \- macro(bcopy) \- macro(bzero) \- macro(calloc) \- macro(cbrt) \- macro(cbrtf) \- macro(cbrtl) \- macro(ceil) \- macro(ceilf) \- macro(ceill) \- macro(chmod) \- macro(chown) \- macro(clearerr) \- macro(closedir) \- macro(copysign) \- macro(copysignf) \- macro(copysignl) \- macro(cos) \- macro(cosf) \- macro(cosh) \- macro(coshf) \- macro(coshl) \- macro(cosl) \- macro(ctermid) \- macro(exp) \- macro(exp10) \- macro(exp10f) \- macro(exp10l) \- macro(exp2) \- macro(exp2f) \- macro(exp2l) \- macro(expf) \- macro(expl) \- macro(expm1) \- macro(expm1f) \- macro(expm1l) \- macro(fabs) \- macro(fabsf) \- macro(fabsl) \- macro(fclose) \- macro(fdopen) \- macro(feof) \- macro(ferror) \- macro(fflush) \- macro(ffs) \- macro(ffsl) \- macro(ffsll) \- macro(fgetc) \- macro(fgetpos) \- macro(fgets) \- macro(fileno) \- macro(fiprintf) \- macro(flockfile) \- macro(floor) \- macro(floorf) \- macro(floorl) \- macro(fmod) \- macro(fmodf) \- macro(fmodl) \- macro(fopen) \- macro(fopen64) \- macro(fprintf) \- macro(fputc) \- macro(fputs) \- macro(fread) \- macro(free) \- macro(frexp) \- macro(frexpf) \- macro(frexpl) \- macro(fscanf) \- macro(fseek) \- macro(fseeko) \- macro(fseeko64) \- macro(fsetpos) \- macro(fstat) \- macro(fstat64) \- macro(fstatvfs) \- macro(fstatvfs64) \- macro(ftell) \- macro(ftello) \- macro(ftello64) \- macro(ftrylockfile) \- macro(funlockfile) \- macro(fwrite) \- macro(getc) \- macro(getc_unlocked) \- macro(getchar) \- macro(getenv) \- macro(getitimer) \- macro(getlogin_r) \- macro(getpwnam) \- macro(gets) \- macro(htonl) \- macro(htons) \- macro(iprintf) \- macro(isascii) \- macro(isdigit) \- macro(labs) \- macro(lchown) \- macro(llabs) \- macro(log) \- macro(log10) \- macro(log10f) \- macro(log10l) \- macro(log1p) \- macro(log1pf) \- macro(log1pl) \- macro(log2) \- macro(log2f) \- macro(log2l) \- macro(logb) \- macro(logbf) \- macro(logbl) \- macro(logf) \- macro(logl) \- macro(lstat) \- macro(lstat64) \- macro(malloc) \- macro(memalign) \- macro(memccpy) \- macro(memchr) \- macro(memcmp) \- macro(memcpy) \- macro(memmove) \- macro(memrchr) \- macro(memset) \- macro(memset_pattern16) \- macro(mkdir) \- macro(mktime) \- macro(modf) \- macro(modff) \- macro(modfl) \- macro(nearbyint) \- macro(nearbyintf) \- macro(nearbyintl) \- macro(ntohl) \- macro(ntohs) \- macro(open) \- macro(open64) \- macro(opendir) \- macro(pclose) \- macro(perror) \- macro(popen) \- macro(posix_memalign) \- macro(pow) \- macro(powf) \- macro(powl) \- macro(pread) \- macro(printf) \- macro(putc) \- macro(putchar) \- macro(puts) \- macro(pwrite) \- macro(qsort) \- macro(read) \- macro(readlink) \- macro(realloc) \- macro(reallocf) \- macro(realpath) \- macro(remove) \- macro(rename) \- macro(rewind) \- macro(rint) \- macro(rintf) \- macro(rintl) \- macro(rmdir) \- macro(round) \- macro(roundf) \- macro(roundl) \- macro(scanf) \- macro(setbuf) \- macro(setitimer) \- macro(setvbuf) \- macro(sin) \- macro(sinf) \- macro(sinh) \- macro(sinhf) \- macro(sinhl) \- macro(sinl) \- macro(siprintf) \- macro(snprintf) \- macro(sprintf) \- macro(sqrt) \- macro(sqrtf) \- macro(sqrtl) \- macro(sscanf) \- macro(stat) \- macro(stat64) \- macro(statvfs) \- macro(statvfs64) \- macro(stpcpy) \- macro(stpncpy) \- macro(strcasecmp) \- macro(strcat) \- macro(strchr) \- macro(strcmp) \- macro(strcoll) \- macro(strcpy) \- macro(strcspn) \- macro(strdup) \- macro(strlen) \- macro(strncasecmp) \- macro(strncat) \- macro(strncmp) \- macro(strncpy) \- macro(strndup) \- macro(strnlen) \- macro(strpbrk) \- macro(strrchr) \- macro(strspn) \- macro(strstr) \- macro(strtod) \- macro(strtof) \- macro(strtok) \- macro(strtok_r) \- macro(strtol) \- macro(strtold) \- macro(strtoll) \- macro(strtoul) \- macro(strtoull) \- macro(strxfrm) \- macro(system) \- macro(tan) \- macro(tanf) \- macro(tanh) \- macro(tanhf) \- macro(tanhl) \- macro(tanl) \- macro(times) \- macro(tmpfile) \- macro(tmpfile64) \- macro(toascii) \- macro(trunc) \- macro(truncf) \- macro(truncl) \- macro(uname) \- macro(ungetc) \- macro(unlink) \- macro(unsetenv) \- macro(utime) \- macro(utimes) \- macro(valloc) \- macro(vfprintf) \- macro(vfscanf) \- macro(vprintf) \- macro(vscanf) \- macro(vsnprintf) \- macro(vsprintf) \- macro(vsscanf) \- macro(write)--typedef enum {-#define ENUM_CASE(x) LLVMLibFunc__ ## x,-LLVM_GENERAL_FOR_EACH_LIB_FUNC(ENUM_CASE)-#undef ENUM_CASE-} LLVMLibFunc;--#endif
src/LLVM/General/Internal/FFI/MemoryBuffer.hs view
@@ -3,12 +3,10 @@ #-} module LLVM.General.Internal.FFI.MemoryBuffer where -import LLVM.General.Prelude+import LLVM.General.Internal.FFI.LLVMCTypes import Foreign.Ptr import Foreign.C--import LLVM.General.Internal.FFI.LLVMCTypes data MemoryBuffer
src/LLVM/General/Internal/FFI/Metadata.hs view
@@ -5,8 +5,6 @@ module LLVM.General.Internal.FFI.Metadata where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Module.hs view
@@ -3,8 +3,6 @@ #-} module LLVM.General.Internal.FFI.Module where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/PassManager.hs view
@@ -5,10 +5,12 @@ module LLVM.General.Internal.FFI.PassManager where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH +import Control.Monad++import Data.Word+ import Foreign.Ptr import Foreign.C @@ -50,9 +52,6 @@ addDataLayoutPass = flip addDataLayoutPass' -foreign import ccall unsafe "LLVM_General_LLVMAddAnalysisPasses" addAnalysisPasses ::- Ptr TargetMachine -> Ptr PassManager -> IO ()- foreign import ccall unsafe "LLVMAddTargetLibraryInfo" addTargetLibraryInfoPass' :: Ptr TargetLibraryInfo -> Ptr PassManager -> IO () @@ -79,7 +78,7 @@ (cName n) ("add" ++ n ++ "Pass") ([[t| Ptr PassManager |]] - ++ [[t| Ptr TargetLowering |] | needsTargetLowering n]+ ++ [[t| Ptr TargetMachine |] | needsTargetMachine n] ++ map passTypeMapping extraParams) (TH.tupleT 0) @@ -124,12 +123,3 @@ foreign import ccall unsafe "LLVMPassManagerBuilderPopulateLTOPassManager" passManagerBuilderPopulateLTOPassManager :: Ptr PassManagerBuilder -> Ptr PassManager -> CUChar -> CUChar -> IO () --foreign import ccall unsafe "LLVM_General_PassManagerBuilderSetLibraryInfo" passManagerBuilderSetLibraryInfo ::- Ptr PassManagerBuilder -> Ptr TargetLibraryInfo -> IO ()--foreign import ccall unsafe "LLVM_General_PassManagerBuilderSetLoopVectorize" passManagerBuilderSetLoopVectorize ::- Ptr PassManagerBuilder -> LLVMBool -> IO ()--foreign import ccall unsafe "LLVM_General_PassManagerBuilderSetSuperwordLevelParallelismVectorize" passManagerBuilderSetSuperwordLevelParallelismVectorize ::- Ptr PassManagerBuilder -> LLVMBool -> IO ()
src/LLVM/General/Internal/FFI/PassManagerC.cpp view
@@ -6,10 +6,6 @@ #include "llvm/Transforms/Vectorize.h" #include "llvm/Transforms/Instrumentation.h" #include "llvm/PassManager.h"-#include "llvm-c/Target.h"-#include "llvm-c/Transforms/PassManagerBuilder.h"-#include "llvm/Target/TargetLibraryInfo.h"-#include "llvm/Target/TargetMachine.h" #include "llvm-c/Core.h" @@ -37,30 +33,15 @@ inline LLVMTargetMachineRef wrap(const TargetMachine *P) { return reinterpret_cast<LLVMTargetMachineRef>(const_cast<TargetMachine *>(P)); }--// Taken from llvm/lib/Target/Target.cpp-inline TargetLibraryInfo *unwrap(LLVMTargetLibraryInfoRef P) {- return reinterpret_cast<TargetLibraryInfo*>(P); } -// Taken from llvm/lib/Transforms/IPO/PassManagerBuilder.cpp-inline PassManagerBuilder *unwrap(LLVMPassManagerBuilderRef P) {- return reinterpret_cast<PassManagerBuilder*>(P);-}-}- extern "C" { void LLVM_General_AddDataLayoutPass(LLVMPassManagerRef PM, const char *dl) { unwrap(PM)->add(new DataLayout(dl)); } -void LLVM_General_LLVMAddAnalysisPasses(LLVMTargetMachineRef T, LLVMPassManagerRef PM) {- unwrap(T)->addAnalysisPasses(*unwrap(PM));-}- #define LLVM_GENERAL_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(macro) \- macro(BlockPlacement) \ macro(BreakCriticalEdges) \ macro(DeadCodeElimination) \ macro(DeadInstElimination) \@@ -83,7 +64,7 @@ LLVM_GENERAL_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(ENUM_CASE) #undef ENUM_CASE -void LLVM_General_AddCodeGenPreparePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T) {+void LLVM_General_AddCodeGenPreparePass(LLVMPassManagerRef PM, LLVMTargetMachineRef T) { unwrap(PM)->add(createCodeGenPreparePass(unwrap(T))); } @@ -100,7 +81,7 @@ unwrap(PM)->add(createLoopStrengthReducePass()); } -void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T, LLVMBool expensiveEH) {+void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM, LLVMTargetMachineRef T, LLVMBool expensiveEH) { unwrap(PM)->add(createLowerInvokePass(unwrap(T), expensiveEH)); } @@ -160,23 +141,11 @@ 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,- char version[4],+ const char *version, LLVMBool useCfgChecksum, LLVMBool noRedZone, LLVMBool functionNamesInData@@ -238,28 +207,25 @@ unwrap(PM)->add(createBoundsCheckingPass()); } -void-LLVM_General_PassManagerBuilderSetLibraryInfo(- LLVMPassManagerBuilderRef PMB,- LLVMTargetLibraryInfoRef l-) {- // The PassManager frees the TargetLibraryInfo when done,- // but we also free our ref, so give it a new copy.- unwrap(PMB)->LibraryInfo = new TargetLibraryInfo(*unwrap(l));-}--void LLVM_General_PassManagerBuilderSetLoopVectorize(- LLVMPassManagerBuilderRef PMB,- LLVMBool runLoopVectorization+void LLVM_General_AddDebugGeneratedIRPass(+ LLVMPassManagerRef PM,+ LLVMBool hideDebugIntrinsics,+ LLVMBool hideDebugMetadata,+ const char *filename,+ const char *directory ) {- unwrap(PMB)->LoopVectorize = runLoopVectorization;+ unwrap(PM)->add(+ createDebugIRPass(+ hideDebugIntrinsics,+ hideDebugMetadata,+ filename,+ directory+ )+ ); } -void LLVM_General_PassManagerBuilderSetSuperwordLevelParallelismVectorize(- LLVMPassManagerBuilderRef PMB,- LLVMBool runSLPVectorization-) {- unwrap(PMB)->SLPVectorize = runSLPVectorization;+void LLVM_General_AddDebugExistingIRPass(LLVMPassManagerRef PM) {+ unwrap(PM)->add(createDebugIRPass()); } }
src/LLVM/General/Internal/FFI/PtrHierarchy.hs view
@@ -3,19 +3,11 @@ MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances,- CPP+ OverlappingInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#define CPP_OVERLAPPING-#else-#define CPP_OVERLAPPING {-# OVERLAPPING #-}-#endif -- | This module defines typeclasses to represent the relationships of an object-oriented inheritance hierarchy module LLVM.General.Internal.FFI.PtrHierarchy where -import LLVM.General.Prelude- import Foreign.Ptr -- | a class to represent safe casting of pointers to objects of descendant-classes to ancestor-classes.@@ -24,7 +16,7 @@ upCast = castPtr -- | trivial casts-instance CPP_OVERLAPPING DescendentOf a a where+instance DescendentOf a a where upCast = id -- | a class to represent direct parent-child relationships
src/LLVM/General/Internal/FFI/RawOStream.hs view
@@ -3,13 +3,12 @@ #-} module LLVM.General.Internal.FFI.RawOStream where -import LLVM.General.Prelude+import LLVM.General.Internal.FFI.ByteRangeCallback import Foreign.Ptr import Foreign.C import Control.Exception (bracket) -import LLVM.General.Internal.FFI.ByteRangeCallback import LLVM.General.Internal.FFI.LLVMCTypes data RawOStream
src/LLVM/General/Internal/FFI/RawOStreamC.cpp view
@@ -3,9 +3,9 @@ #include "llvm-c/Core.h" using namespace llvm;-static const unsigned F_None = 0;-static const unsigned F_Excl = raw_fd_ostream::F_Excl;-static const unsigned F_Binary = raw_fd_ostream::F_Binary;+using sys::fs::F_None;+using sys::fs::F_Excl;+using sys::fs::F_Binary; extern "C" {
src/LLVM/General/Internal/FFI/SMDiagnostic.hs view
@@ -4,8 +4,6 @@ -- | FFI functions for handling the LLVM SMDiagnostic class module LLVM.General.Internal.FFI.SMDiagnostic where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Target.h view
@@ -28,7 +28,6 @@ #define LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(macro) \ macro(PrintMachineCode) \ macro(NoFramePointerElim) \- macro(NoFramePointerElimNonLeaf) \ macro(LessPreciseFPMADOption) \ macro(UnsafeFPMath) \ macro(NoInfsFPMath) \@@ -36,12 +35,10 @@ macro(HonorSignDependentRoundingFPMathOption) \ macro(UseSoftFloat) \ macro(NoZerosInBSS) \- macro(JITExceptionHandling) \ macro(JITEmitDebugInfo) \ macro(JITEmitDebugInfoToDisk) \ macro(GuaranteedTailCallOpt) \ macro(DisableTailCalls) \- macro(RealignStack) \ macro(EnableFastISel) \ macro(PositionIndependentExecutable) \ macro(EnableSegmentedStacks) \
src/LLVM/General/Internal/FFI/Target.hs view
@@ -4,8 +4,6 @@ #-} module LLVM.General.Internal.FFI.Target where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C @@ -56,12 +54,6 @@ foreign import ccall unsafe "LLVM_General_GetAllowFPOpFusion" getAllowFPOpFusion :: Ptr TargetOptions -> IO FPOpFusionMode -foreign import ccall unsafe "LLVM_General_SetSSPBufferSize" setSSPBufferSize ::- Ptr TargetOptions -> CUInt -> IO ()--foreign import ccall unsafe "LLVM_General_GetSSPBufferSize" getSSPBufferSize ::- Ptr TargetOptions -> IO CUInt- foreign import ccall unsafe "LLVM_General_DisposeTargetOptions" disposeTargetOptions :: Ptr TargetOptions -> IO () @@ -113,15 +105,6 @@ foreign import ccall unsafe "LLVM_General_CreateTargetLibraryInfo" createTargetLibraryInfo :: CString -> IO (Ptr TargetLibraryInfo)--foreign import ccall unsafe "LLVM_General_GetLibFunc" getLibFunc ::- Ptr TargetLibraryInfo -> CString -> Ptr LibFunc -> IO LLVMBool--foreign import ccall unsafe "LLVM_General_LibFuncGetName" libFuncGetName ::- Ptr TargetLibraryInfo -> LibFunc -> Ptr CSize -> IO CString--foreign import ccall unsafe "LLVM_General_LibFuncSetAvailableWithName" libFuncSetAvailableWithName ::- Ptr TargetLibraryInfo -> LibFunc -> CString -> IO () foreign import ccall unsafe "LLVM_General_DisposeTargetLibraryInfo" disposeTargetLibraryInfo :: Ptr TargetLibraryInfo -> IO ()
src/LLVM/General/Internal/FFI/TargetC.cpp view
@@ -14,7 +14,6 @@ #include "llvm-c/TargetMachine.h" #include "llvm-c/Core.h" #include "LLVM/General/Internal/FFI/Target.h"-#include "LLVM/General/Internal/FFI/LibFunc.h" using namespace llvm; @@ -75,24 +74,6 @@ } } -static LibFunc::Func unwrap(LLVMLibFunc x) {- switch(x) {-#define ENUM_CASE(x) case LLVMLibFunc__ ## x: return LibFunc::x;-LLVM_GENERAL_FOR_EACH_LIB_FUNC(ENUM_CASE)-#undef ENUM_CASE- default: return LibFunc::Func(0);- }-}--static LLVMLibFunc wrap(LibFunc::Func x) {- switch(x) {-#define ENUM_CASE(x) case LibFunc::x : return LLVMLibFunc__ ## x;-LLVM_GENERAL_FOR_EACH_LIB_FUNC(ENUM_CASE)-#undef ENUM_CASE- default: return LLVMLibFunc(0);- }-}- static LLVM_General_FloatABI wrap(FloatABI::ABIType x) { switch(x) { #define ENUM_CASE(x) case FloatABI::x: return LLVM_General_FloatABI_ ## x;@@ -139,9 +120,9 @@ } LLVMTargetRef LLVM_General_LookupTarget(- const char *arch,- const char *ctriple,- const char **tripleOut,+ const char *arch, + const char *ctriple, + const char **tripleOut, const char **cerror ) { std::string error;@@ -156,7 +137,6 @@ TargetOptions *LLVM_General_CreateTargetOptions() { TargetOptions *to = new TargetOptions();- to->SSPBufferSize = 0; // this field was left uninitialized in LLVM 3.2 return to; } @@ -215,14 +195,6 @@ return wrap(to->AllowFPOpFusion); } -void LLVM_General_SetSSPBufferSize(TargetOptions *to, unsigned v) {- to->SSPBufferSize = v;-}--unsigned LLVM_General_GetSSPBufferSize(TargetOptions *to) {- return to->SSPBufferSize;-}- void LLVM_General_DisposeTargetOptions(TargetOptions *t) { delete t; }@@ -243,14 +215,14 @@ triple, cpu, features,- *targetOptions,+ *targetOptions, unwrap(relocModel), unwrap(codeModel), unwrap(codeGenOptLevel) ) ); }-+ const TargetLowering *LLVM_General_GetTargetLowering(LLVMTargetMachineRef t) { return unwrap(t)->getTargetLowering(); }@@ -271,11 +243,10 @@ StringMap<bool> featureMap; std::string features; if (sys::getHostCPUFeatures(featureMap)) {- bool first = true; for(llvm::StringMap<bool>::const_iterator it = featureMap.begin(); it != featureMap.end(); ++it) {- if (!first) { features += ","; }- first = false;- features += (it->second ? "+" : "-") + it->first().str();+ if (it->second) {+ features += it->first().str() + " ";+ } } } return strdup(features.c_str());@@ -289,35 +260,6 @@ const char *triple ) { return wrap(new TargetLibraryInfo(Triple(triple)));-}--LLVMBool LLVM_General_GetLibFunc(- LLVMTargetLibraryInfoRef l,- const char *funcName,- LLVMLibFunc *f-) {- LibFunc::Func func;- LLVMBool result = unwrap(l)->getLibFunc(funcName, func);- *f = wrap(func);- return result;-}--const char *LLVM_General_LibFuncGetName(- LLVMTargetLibraryInfoRef l,- LLVMLibFunc f,- size_t *nameSize-) {- StringRef s = unwrap(l)->getName(unwrap(f));- *nameSize = s.size();- return s.data();-}--void LLVM_General_LibFuncSetAvailableWithName(- LLVMTargetLibraryInfoRef l,- LLVMLibFunc f,- const char *name-) {- unwrap(l)->setAvailableWithName(unwrap(f), name); } void LLVM_General_DisposeTargetLibraryInfo(LLVMTargetLibraryInfoRef l) {
− src/LLVM/General/Internal/FFI/Threading.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}-module LLVM.General.Internal.FFI.Threading where--import LLVM.General.Prelude--import Foreign.C--import LLVM.General.Internal.FFI.LLVMCTypes--foreign import ccall unsafe "LLVMStartMultithreaded" startMultithreaded ::- IO LLVMBool--foreign import ccall unsafe "LLVMStopMultithreaded" stopMultithreaded ::- IO ()--foreign import ccall unsafe "LLVMIsMultithreaded" isMultithreaded ::- IO LLVMBool
src/LLVM/General/Internal/FFI/Transforms.hs view
@@ -1,12 +1,10 @@ -- | Code used with Template Haskell to build the FFI for transform passes. module LLVM.General.Internal.FFI.Transforms where -import LLVM.General.Prelude---- | does the constructor for this pass require a TargetLowering object-needsTargetLowering "CodeGenPrepare" = True-needsTargetLowering "LowerInvoke" = True-needsTargetLowering _ = False+-- | does the constructor for this pass require a TargetMachine object+needsTargetMachine "CodeGenPrepare" = True+needsTargetMachine "LowerInvoke" = True+needsTargetMachine _ = False -- | Translate a Haskell name (used in the public Haskell interface, typically not abbreviated) -- | for a pass into the (sometimes obscure, sometimes abbreviated) name used in the LLVM C interface.@@ -35,7 +33,6 @@ "OldScalarReplacementOfAggregates" -> "ScalarReplAggregates" "SimplifyControlFlowGraph" -> "CFGSimplification" "SparseConditionalConstantPropagation" -> "SCCP"- "SuperwordLevelParallelismVectorize" -> "SLPVectorize" h -> h patchImpls = [ "AddressSanitizer",@@ -45,31 +42,31 @@ "GlobalValueNumbering", "InternalizeFunctions", "BasicBlockVectorize",- "BlockPlacement",- "BreakCriticalEdges",- "DeadCodeElimination",- "DeadInstructionElimination",+ "BlockPlacement",+ "BreakCriticalEdges",+ "DeadCodeElimination",+ "DeadInstructionElimination", "DebugExistingIR", "DebugGeneratedIR",- "DemoteRegisterToMemory",+ "DemoteRegisterToMemory", "EdgeProfiler", "GCOVProfiler",- "LoopClosedSingleStaticAssignment",- "LoopInstructionSimplify",+ "LoopClosedSingleStaticAssignment",+ "LoopInstructionSimplify", "LoopStrengthReduce",- "LowerAtomic",- "LowerInvoke",- "LowerSwitch",+ "LowerAtomic",+ "LowerInvoke",+ "LowerSwitch", "MemorySanitizer",- "MergeFunctions",+ "MergeFunctions", "OptimalEdgeProfiler", "PathProfiler",- "PartialInlining",+ "PartialInlining", "ScalarReplacementOfAggregates",- "Sinking",- "StripDeadDebugInfo",- "StripDebugDeclare",- "StripNonDebugSymbols",+ "Sinking",+ "StripDeadDebugInfo",+ "StripDebugDeclare",+ "StripNonDebugSymbols", "ThreadSanitizer" ] in
src/LLVM/General/Internal/FFI/Type.hs view
@@ -4,10 +4,9 @@ -- | Functions for handling the LLVM types module LLVM.General.Internal.FFI.Type where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C+import Data.Word import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.Context
src/LLVM/General/Internal/FFI/User.hs view
@@ -1,12 +1,11 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ OverlappingInstances #-} -- | FFI functions for handling the LLVM User class module LLVM.General.Internal.FFI.User where--import LLVM.General.Prelude import Foreign.Ptr import Foreign.C
src/LLVM/General/Internal/FFI/Value.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE ForeignFunctionInterface, MultiParamTypeClasses,- UndecidableInstances+ UndecidableInstances,+ OverlappingInstances #-} -- | FFI functions for handling the LLVM Value class module LLVM.General.Internal.FFI.Value where -import LLVM.General.Prelude- import Foreign.Ptr import Foreign.C @@ -33,9 +32,3 @@ foreign import ccall unsafe "LLVMReplaceAllUsesWith" replaceAllUsesWith :: Ptr Value -> Ptr Value -> IO ()--foreign import ccall unsafe "LLVM_General_CreateArgument" createArgument ::- Ptr Type -> CString -> IO (Ptr Value)--foreign import ccall unsafe "LLVMDumpValue" dumpValue ::- Ptr Value -> IO ()
src/LLVM/General/Internal/FFI/ValueC.cpp view
@@ -1,8 +1,6 @@ #define __STDC_LIMIT_MACROS #include "llvm-c/Core.h"-#include "llvm/IR/Type.h" #include "llvm/IR/Value.h"-#include "llvm/IR/Argument.h" #include "LLVM/General/Internal/FFI/Value.h" using namespace llvm;@@ -17,13 +15,6 @@ default: break; } return LLVMValueSubclassId(0);-}--LLVMValueRef LLVM_General_CreateArgument(- LLVMTypeRef t,- const char *name-) {- return wrap(new Argument(unwrap(t), name)); } }
− src/LLVM/General/Internal/FastMathFlags.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE - MultiParamTypeClasses- #-}-module LLVM.General.Internal.FastMathFlags where--import LLVM.General.Prelude--import Control.Monad.Trans-import Control.Monad.AnyCont-import Control.Monad.State-import Control.Exception--import Data.Bits--import qualified LLVM.General.Internal.FFI.Builder as FFI-import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI--import LLVM.General.Internal.Coding-import LLVM.General.Internal.EncodeAST--import qualified LLVM.General.AST as A--instance EncodeM IO A.FastMathFlags FFI.FastMathFlags where- encodeM A.NoFastMathFlags = return 0- encodeM A.UnsafeAlgebra = return FFI.fastMathFlagsUnsafeAlgebra- encodeM f = return $ foldr1 (.|.) [ - if a f then b else 0- | (a,b) <- [- (A.noNaNs, FFI.fastMathFlagsNoNaNs),- (A.noInfs, FFI.fastMathFlagsNoInfs),- (A.noSignedZeros, FFI.fastMathFlagsNoSignedZeros),- (A.allowReciprocal, FFI.fastMathFlagsAllowReciprocal)- ] - ]--instance EncodeM EncodeAST A.FastMathFlags () where- encodeM f = do- f <- liftIO $ encodeM f- builder <- gets encodeStateBuilder- anyContToM $ bracket (FFI.setFastMathFlags builder f) (\() -> FFI.setFastMathFlags builder 0) --instance Monad m => DecodeM m A.FastMathFlags FFI.FastMathFlags where- decodeM 0 = return A.NoFastMathFlags- decodeM f | FFI.fastMathFlagsUnsafeAlgebra .&. f /= 0 = return A.UnsafeAlgebra- decodeM f = return A.FastMathFlags {- A.noNaNs = FFI.fastMathFlagsNoNaNs .&. f /= 0,- A.noInfs = FFI.fastMathFlagsNoInfs .&. f /= 0,- A.noSignedZeros = FFI.fastMathFlagsNoSignedZeros .&. f /= 0,- A.allowReciprocal = FFI.fastMathFlagsAllowReciprocal .&. f /= 0- }-
src/LLVM/General/Internal/Function.hs view
@@ -1,7 +1,6 @@ module LLVM.General.Internal.Function where -import LLVM.General.Prelude-+import Control.Monad import Control.Monad.Trans import Control.Monad.AnyCont
src/LLVM/General/Internal/Global.hs view
@@ -4,11 +4,12 @@ #-} module LLVM.General.Internal.Global where -import LLVM.General.Prelude- import Control.Monad.IO.Class+import Data.Functor import Foreign.Ptr import Control.Monad.AnyCont++import Data.Word import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI
− src/LLVM/General/Internal/Inject.hs
@@ -1,11 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-module LLVM.General.Internal.Inject where--import LLVM.General.Prelude--class Inject a b where- inject :: a -> b--instance Inject a a where- inject = id-
src/LLVM/General/Internal/InlineAssembly.hs view
@@ -4,8 +4,7 @@ #-} module LLVM.General.Internal.InlineAssembly where -import LLVM.General.Prelude-+import Control.Monad import Control.Monad.IO.Class import Foreign.C
src/LLVM/General/Internal/Instruction.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE+{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiParamTypeClasses,- UndecidableInstances,- ViewPatterns+ UndecidableInstances #-} module LLVM.General.Internal.Instruction where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified LLVM.General.Internal.InstructionDefs as ID import LLVM.General.Internal.InstructionDefs (instrP) -import Control.Monad.Exceptable+import Data.Functor+import Control.Monad+import Control.Monad.Trans import Control.Monad.AnyCont-import Control.Monad.State (gets)+import Control.Monad.State import Foreign.Ptr @@ -38,7 +37,6 @@ import LLVM.General.Internal.Coding import LLVM.General.Internal.DecodeAST import LLVM.General.Internal.EncodeAST-import LLVM.General.Internal.FastMathFlags () import LLVM.General.Internal.Metadata () import LLVM.General.Internal.Operand () import LLVM.General.Internal.RMWOperation ()@@ -239,7 +237,6 @@ get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap (FFI.upCast b) get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap (FFI.upCast b) get_exact b = liftIO $ decodeM =<< FFI.isExact (FFI.upCast b)- get_fastMathFlags b = liftIO $ decodeM =<< FFI.getFastMathFlags (FFI.upCast b) n <- liftIO $ FFI.getInstructionDefOpcode i $(@@ -249,7 +246,6 @@ "nsw" -> (["b"], [| get_nsw $(TH.dyn "b") |]) "nuw" -> (["b"], [| get_nuw $(TH.dyn "b") |]) "exact" -> (["b"], [| get_exact $(TH.dyn "b") |])- "fastMathFlags" -> (["b"], [| get_fastMathFlags $(TH.dyn "b") |]) "operand0" -> ([], [| op 0 |]) "operand1" -> ([], [| op 1 |]) "address" -> ([], case lrn of "Store" -> [| op 1 |]; _ -> [| op 0 |])@@ -343,160 +339,253 @@ builder <- gets encodeStateBuilder let return' i = return (FFI.upCast i, return ()) s <- encodeM ""- (inst, act) <- case o of- A.ICmp { - A.iPredicate = pred,- A.operand0 = op0,- A.operand1 = op1- } -> do- op0' <- encodeM op0- op1' <- encodeM op1- pred <- encodeM pred- i <- liftIO $ FFI.buildICmp builder pred op0' op1' s- return' i- A.FCmp {- A.fpPredicate = pred,- A.operand0 = op0,- A.operand1 = op1- } -> do- op0' <- encodeM op0- op1' <- encodeM op1- pred <- encodeM pred- i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s- return' i- A.Phi { A.type' = t, A.incomingValues = ivs } -> do- t' <- encodeM t- i <- liftIO $ FFI.buildPhi builder t' s- return (- FFI.upCast i,- do- let (ivs3, bs3) = unzip ivs- ivs3' <- encodeM ivs3- bs3' <- encodeM bs3- liftIO $ FFI.addIncoming i ivs3' bs3'- )- A.Call {- A.isTailCall = tc,- A.callingConvention = cc,- A.returnAttributes = rAttrs,- A.function = f,- A.arguments = args,- A.functionAttributes = fAttrs- } -> do- fv <- encodeM f- let (argvs, argAttrs) = unzip args- (n, argvs) <- encodeM argvs- i <- liftIO $ FFI.buildCall builder fv argvs n s- forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do- attrs <- encodeM attrs- liftIO $ FFI.addCallInstAttr i j attrs- fAttrs <- encodeM fAttrs- liftIO $ FFI.addCallInstFunctionAttr i fAttrs- when tc $ do- tc <- encodeM tc- liftIO $ FFI.setTailCall i tc- cc <- encodeM cc- liftIO $ FFI.setInstructionCallConv i cc- return' i- A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do- c' <- encodeM c- t' <- encodeM t- f' <- encodeM f- i <- liftIO $ FFI.buildSelect builder c' t' f' s- return' i- A.VAArg { A.argList = al, A.type' = t } -> do- al' <- encodeM al- t' <- encodeM t- i <- liftIO $ FFI.buildVAArg builder al' t' s- return' i- A.ExtractElement { A.vector = v, A.index = idx } -> do- v' <- encodeM v- idx' <- encodeM idx- i <- liftIO $ FFI.buildExtractElement builder v' idx' s- return' i- A.InsertElement { A.vector = v, A.element = e, A.index = idx } -> do- v' <- encodeM v- e' <- encodeM e- idx' <- encodeM idx- i <- liftIO $ FFI.buildInsertElement builder v' e' idx' s- return' i- A.ShuffleVector { A.operand0 = o0, A.operand1 = o1, A.mask = mask } -> do- o0' <- encodeM o0- o1' <- encodeM o1- mask' <- encodeM mask- i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' s- return' i- A.ExtractValue { A.aggregate = a, A.indices' = is } -> do- a' <- encodeM a- (n, is') <- encodeM is- i <- liftIO $ FFI.buildExtractValue builder a' is' n s- return' i- A.InsertValue { A.aggregate = a, A.element = e, A.indices' = is } -> do- a' <- encodeM a- e' <- encodeM e- (n, is') <- encodeM is- i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s- return' i- A.LandingPad { - A.type' = t,- A.personalityFunction = pf,- A.cleanup = cl, - A.clauses = cs- } -> do- t' <- encodeM t- pf' <- encodeM pf- i <- liftIO $ FFI.buildLandingPad builder t' pf' (fromIntegral $ length cs) s- forM cs $ \c -> - case c of- A.Catch a -> do- cn <- encodeM a- isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)- when isArray $ throwError $ "Catch clause cannot take an array: " ++ show c- liftIO $ FFI.addClause i cn- A.Filter a -> do- cn <- encodeM a- isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)- unless isArray $ throwError $ "filter clause must take an array: " ++ show c- liftIO $ FFI.addClause i cn- when cl $ do- cl <- encodeM cl- liftIO $ FFI.setCleanup i cl- return' i- A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do - alt' <- encodeM alt- n' <- encodeM n- i <- liftIO $ FFI.buildAlloca builder alt' n' s- unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment)- return' i- o -> $(TH.caseE [| o |] [- TH.match - (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])- (TH.normalB (TH.doE handlerBody))- []- |- (name, ID.instructionKind -> k) <- Map.toList ID.instructionDefs,- case (k, name) of- (ID.Binary, _) -> True- (ID.Cast, _) -> True- (ID.Memory, "Alloca") -> False- (ID.Memory, _) -> True- _ -> False,- let- TH.RecC fullName (unzip3 -> (fieldNames, _, _)) = findInstrFields name- encodeMFields = map TH.nameBase fieldNames List.\\ [ "metadata" ]- handlerBody = ([- TH.bindS (if s == "fastMathFlags" then TH.tupP [] else TH.varP (TH.mkName s))- [| encodeM $(TH.dyn s) |] | s <- encodeMFields - ] ++ [- TH.bindS (TH.varP (TH.mkName "i")) [| liftIO $ $(- foldl1 TH.appE . map TH.dyn $ - [ "FFI.build" ++ name, "builder" ] ++ (encodeMFields List.\\ [ "fastMathFlags" ]) ++ [ "s" ] - ) |],- TH.noBindS [| return' $(TH.dyn "i") |]- ])- ]- )+ (inst, act) <- $(+ [|+ case o of+ A.ICmp { + A.iPredicate = pred,+ A.operand0 = op0,+ A.operand1 = op1+ } -> do+ op0' <- encodeM op0+ op1' <- encodeM op1+ pred <- encodeM pred+ i <- liftIO $ FFI.buildICmp builder pred op0' op1' s+ return' i+ A.FCmp {+ A.fpPredicate = pred,+ A.operand0 = op0,+ A.operand1 = op1+ } -> do+ op0' <- encodeM op0+ op1' <- encodeM op1+ pred <- encodeM pred+ i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s+ return' i+ A.Phi { A.type' = t, A.incomingValues = ivs } -> do+ t' <- encodeM t+ i <- liftIO $ FFI.buildPhi builder t' s+ return (+ FFI.upCast i,+ do+ let (ivs3, bs3) = unzip ivs+ ivs3' <- encodeM ivs3+ bs3' <- encodeM bs3+ liftIO $ FFI.addIncoming i ivs3' bs3'+ )+ A.Call {+ A.isTailCall = tc,+ A.callingConvention = cc,+ A.returnAttributes = rAttrs,+ A.function = f,+ A.arguments = args,+ A.functionAttributes = fAttrs+ } -> do+ fv <- encodeM f+ let (argvs, argAttrs) = unzip args+ (n, argvs) <- encodeM argvs+ i <- liftIO $ FFI.buildCall builder fv argvs n s+ forM (zip (rAttrs : argAttrs) [0..]) $ \(attrs, j) -> do+ attrs <- encodeM attrs+ liftIO $ FFI.addCallInstAttr i j attrs+ fAttrs <- encodeM fAttrs+ liftIO $ FFI.addCallInstFunctionAttr i fAttrs+ when tc $ do+ tc <- encodeM tc+ liftIO $ FFI.setTailCall i tc+ cc <- encodeM cc+ liftIO $ FFI.setInstructionCallConv i cc+ return' i+ A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do+ c' <- encodeM c+ t' <- encodeM t+ f' <- encodeM f+ i <- liftIO $ FFI.buildSelect builder c' t' f' s+ return' i+ A.VAArg { A.argList = al, A.type' = t } -> do+ al' <- encodeM al+ t' <- encodeM t+ i <- liftIO $ FFI.buildVAArg builder al' t' s+ return' i+ A.ExtractElement { A.vector = v, A.index = idx } -> do+ v' <- encodeM v+ idx' <- encodeM idx+ i <- liftIO $ FFI.buildExtractElement builder v' idx' s+ return' i+ A.InsertElement { A.vector = v, A.element = e, A.index = idx } -> do+ v' <- encodeM v+ e' <- encodeM e+ idx' <- encodeM idx+ i <- liftIO $ FFI.buildInsertElement builder v' e' idx' s+ return' i+ A.ShuffleVector { A.operand0 = o0, A.operand1 = o1, A.mask = mask } -> do+ o0' <- encodeM o0+ o1' <- encodeM o1+ mask' <- encodeM mask+ i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' s+ return' i+ A.ExtractValue { A.aggregate = a, A.indices' = is } -> do+ a' <- encodeM a+ (n, is') <- encodeM is+ i <- liftIO $ FFI.buildExtractValue builder a' is' n s+ return' i+ A.InsertValue { A.aggregate = a, A.element = e, A.indices' = is } -> do+ a' <- encodeM a+ e' <- encodeM e+ (n, is') <- encodeM is+ i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s+ return' i+ A.LandingPad { + A.type' = t,+ A.personalityFunction = pf,+ A.cleanup = cl, + A.clauses = cs+ } -> do+ t' <- encodeM t+ pf' <- encodeM pf+ i <- liftIO $ FFI.buildLandingPad builder t' pf' (fromIntegral $ length cs) s+ forM cs $ \c -> + case c of+ A.Catch a -> do+ cn <- encodeM a+ isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)+ when isArray $ fail $ "Catch clause cannot take an array: " ++ show c+ liftIO $ FFI.addClause i cn+ A.Filter a -> do+ cn <- encodeM a+ isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)+ unless isArray $ fail $ "filter clause must take an array: " ++ show c+ liftIO $ FFI.addClause i cn+ when cl $ do+ cl <- encodeM cl+ liftIO $ FFI.setCleanup i cl+ return' i+ A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do + alt' <- encodeM alt+ n' <- maybe (return nullPtr) encodeM n+ i <- liftIO $ FFI.buildAlloca builder alt' n' s+ unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment)+ return' i+ A.Load {+ A.volatile = vol,+ A.address = a,+ A.alignment = al,+ A.maybeAtomicity = mat+ } -> do+ a' <- encodeM a+ al <- encodeM al+ vol <- encodeM vol+ (ss, mo) <- encodeM mat+ i <- liftIO $ FFI.buildLoad builder a' al vol mo ss s+ return' i+ A.Store { + A.volatile = vol, + A.address = a, + A.value = v, + A.maybeAtomicity = mat, + A.alignment = al+ } -> do+ a' <- encodeM a+ v' <- encodeM v+ al <- encodeM al+ vol <- encodeM vol+ (ss, mo) <- encodeM mat+ i <- liftIO $ FFI.buildStore builder v' a' al vol mo ss s+ return' i+ A.GetElementPtr { A.address = a, A.indices = is, A.inBounds = ib } -> do+ a' <- encodeM a+ (n, is') <- encodeM is+ ib <- encodeM ib + i <- liftIO $ FFI.buildGetElementPtr builder ib a' is' n s+ return' i+ A.Fence { A.atomicity = at } -> do+ (ss, mo) <- encodeM at+ i <- liftIO $ FFI.buildFence builder mo ss s+ return' i+ A.CmpXchg { + A.volatile = vol, + A.address = a, A.expected = e, A.replacement = r,+ A.atomicity = at+ } -> do+ a' <- encodeM a+ e' <- encodeM e+ r' <- encodeM r+ vol <- encodeM vol+ (ss, mo) <- encodeM at+ i <- liftIO $ FFI.buildCmpXchg builder a' e' r' vol mo ss s+ return' i+ A.AtomicRMW {+ A.volatile = vol,+ A.rmwOperation = rmwOp,+ A.address = a,+ A.value = v,+ A.atomicity = at+ } -> do+ a' <- encodeM a+ v' <- encodeM v+ rmwOp <- encodeM rmwOp+ vol <- encodeM vol+ (ss, mo) <- encodeM at+ i <- liftIO $ FFI.buildAtomicRMW builder rmwOp a' v' vol mo ss s+ return' i+ o -> $(+ let+ fieldData :: String -> [Either TH.ExpQ TH.ExpQ]+ fieldData s = case s of+ "operand0" -> [Left [| encodeM $(TH.dyn s) |] ]+ "operand1" -> [Left [| encodeM $(TH.dyn s) |] ]+ "type'" -> [Left [| encodeM $(TH.dyn s) |] ]+ "nsw" -> [Left [| encodeM $(TH.dyn s) |] ]+ "nuw" -> [Left [| encodeM $(TH.dyn s) |] ]+ "exact" -> [Left [| encodeM $(TH.dyn s) |] ]+ "metadata" -> [Right [| return () |] ]+ _ -> error $ "unhandled instruction field " ++ show s+ in+ TH.caseE [| o |] [+ TH.match + (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])+ (TH.normalB (TH.doE handlerBody))+ []+ |+ (name, ID.InstructionDef { ID.instructionKind = k }) <- Map.toList ID.instructionDefs,+ k `List.elem` [ID.Binary, ID.Cast],+ let+ TH.RecC fullName fields = findInstrFields name+ (fieldNames, _, _) = unzip3 fields+ cTorFields = [+ (s, binding)+ | f <- fieldNames,+ let s = TH.nameBase f,+ Left binding <- fieldData s+ ]+ handlerBody = (+ [ TH.bindS (TH.varP (TH.mkName s)) binding | (s, binding) <- cTorFields ]+ ++ [+ TH.bindS + (TH.varP (TH.mkName "i"))+ [| liftIO $ $(foldl1 TH.appE . map TH.dyn $ [ + "FFI.build" ++ name,+ "builder"+ ] ++ [+ s | (s, _) <- cTorFields, s /= "metadata"+ ] ++ [+ "s"+ ] ) |] + ] ++ [+ TH.noBindS action+ | f <- fieldNames,+ let s = TH.nameBase f,+ Right action <- fieldData s+ ] ++ [+ TH.noBindS [| return' $(TH.dyn "i") |]+ ]+ )+ ]+ )++ |]+ ) setMD inst (A.metadata o) return (inst, act) |]
src/LLVM/General/Internal/InstructionDefs.hs view
@@ -12,8 +12,6 @@ outerJoin ) where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH
− src/LLVM/General/Internal/LibraryFunction.hsc
@@ -1,37 +0,0 @@-{-# LANGUAGE- MultiParamTypeClasses- #-}-module LLVM.General.Internal.LibraryFunction where--import LLVM.General.Prelude--import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI--import LLVM.General.Internal.Coding--#include "LLVM/General/Internal/FFI/LibFunc.h"--#{-define hsc_inject(m) { \- struct { const char *s; unsigned n; } *p, list[] = { LLVM_GENERAL_FOR_EACH_LIB_FUNC(m) }; \- hsc_printf("data LibraryFunction\n"); \- for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \- hsc_printf(" %s LF__%s\n", (p == list ? "=" : "|"), p->s); \- } \- hsc_printf(" deriving (Eq, Ord, Enum, Bounded, Read, Show)"); \- hsc_printf("\n"); \- hsc_printf("instance Monad m => EncodeM m LibraryFunction FFI.LibFunc where\n"); \- for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \- hsc_printf(" encodeM LF__%s = return (FFI.LibFunc %u)\n", p->s, p->n); \- } \- hsc_printf("\n"); \- hsc_printf("instance Monad m => DecodeM m LibraryFunction FFI.LibFunc where\n"); \- for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \- hsc_printf(" decodeM (FFI.LibFunc %u) = return LF__%s \n", p->n, p->s); \- } \-}-}---- | <http://llvm.org/doxygen/namespacellvm_1_1LibFunc.html#abf8f6830387f338fed0bce2e65108c6f>-#define Mac(n) { #n, LLVMLibFunc__ ## n },-#{inject Mac}
src/LLVM/General/Internal/MemoryBuffer.hs view
@@ -4,18 +4,16 @@ #-} module LLVM.General.Internal.MemoryBuffer where -import LLVM.General.Prelude- import Control.Exception-import Control.Monad.Exceptable+import Control.Monad import Control.Monad.AnyCont+import Control.Monad.IO.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Foreign.Ptr import LLVM.General.Internal.Coding import LLVM.General.Internal.String-import LLVM.General.Internal.Inject import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.MemoryBuffer as FFI @@ -23,7 +21,7 @@ = Bytes { name :: String, content :: BS.ByteString } | File { pathName :: String } -instance (Inject String e, MonadError e m, Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where+instance (Monad e, MonadIO e, MonadAnyCont IO e) => EncodeM e Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where encodeM spec = liftM FFI.OwnerTransfered $ do case spec of Bytes name content -> do@@ -36,12 +34,10 @@ mbPtr <- alloca msgPtr <- alloca result <- decodeM =<< (liftIO $ FFI.createMemoryBufferWithContentsOfFile pathName mbPtr msgPtr)- when result $ do- msg <- decodeM msgPtr- throwError (inject (msg :: String))+ when result $ fail =<< decodeM msgPtr peek mbPtr -instance (Inject String e, MonadError e m, Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (Ptr FFI.MemoryBuffer) where+instance (Monad e, MonadIO e, MonadAnyCont IO e) => EncodeM e Specification (Ptr FFI.MemoryBuffer) where encodeM spec = do FFI.OwnerTransfered mb <- encodeM spec anyContToM $ bracket (return mb) FFI.disposeMemoryBuffer
src/LLVM/General/Internal/Metadata.hs view
@@ -3,9 +3,7 @@ #-} module LLVM.General.Internal.Metadata where -import LLVM.General.Prelude--import Control.Monad.State hiding (mapM, forM)+import Control.Monad.State import Control.Monad.AnyCont import Foreign.Ptr
src/LLVM/General/Internal/Module.hs view
@@ -7,19 +7,17 @@ -- | This Haskell module is for/of functions for handling LLVM modules. module LLVM.General.Internal.Module where -import LLVM.General.Prelude- import Control.Monad.Trans-import Control.Monad.State (gets)-import Control.Monad.Exceptable+import Control.Monad.State+import Control.Monad.Error import Control.Monad.AnyCont+import Control.Applicative import Control.Exception import Foreign.Ptr import Foreign.C import Data.IORef import qualified Data.ByteString as BS-import qualified Data.Map as Map import qualified LLVM.General.Internal.FFI.Assembly as FFI import qualified LLVM.General.Internal.FFI.Builder as FFI@@ -46,9 +44,8 @@ import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Function import LLVM.General.Internal.Global-import LLVM.General.Internal.Inject import LLVM.General.Internal.Instruction ()-import qualified LLVM.General.Internal.MemoryBuffer as MB+import qualified LLVM.General.Internal.MemoryBuffer as MB import LLVM.General.Internal.Metadata import LLVM.General.Internal.Operand import LLVM.General.Internal.RawOStream@@ -68,12 +65,11 @@ -- | <http://llvm.org/doxygen/classllvm_1_1Module.html> newtype Module = Module (Ptr FFI.Module) --- | A newtype to distinguish strings used for paths from other strings newtype File = File FilePath deriving (Eq, Ord, Read, Show) -instance Inject String (Either String Diagnostic) where- inject = Left+instance Error (Either String Diagnostic) where+ strMsg = Left genCodingInstance [t| Bool |] ''FFI.LinkerMode [ (FFI.linkerModeDestroySource, False),@@ -84,20 +80,19 @@ -- Note that this operation is not commutative - not only concretely (e.g. the destination module -- is modified, becoming the result) but abstractly (e.g. unused private globals in the source -- module do not appear in the result, but similar globals in the destination remain).-linkModules ::+linkModules :: Bool -- ^ True to leave the right module unmodified, False to cannibalize it (for efficiency's sake). -> Module -- ^ The module into which to link -> Module -- ^ The module to link into the other (and cannibalize or not)- -> ExceptT String IO ()-linkModules preserveRight (Module m) (Module m') = unExceptableT $ flip runAnyContT return $ do+ -> 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 $ throwError =<< decodeM msgPtr+ when result $ fail =<< decodeM msgPtr class LLVMAssemblyInput s where- llvmAssemblyMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)- => s -> m (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer))+ llvmAssemblyMemoryBuffer :: (MonadIO e, MonadAnyCont IO e) => s -> e (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) instance LLVMAssemblyInput (String, String) where llvmAssemblyMemoryBuffer (id, s) = do@@ -111,9 +106,8 @@ llvmAssemblyMemoryBuffer (File p) = encodeM (MB.File p) -- | parse 'Module' from LLVM assembly-withModuleFromLLVMAssembly :: LLVMAssemblyInput s- => Context -> s -> (Module -> IO a) -> ExceptT (Either String Diagnostic) IO a-withModuleFromLLVMAssembly (Context c) s f = unExceptableT $ flip runAnyContT return $ do+withModuleFromLLVMAssembly :: LLVMAssemblyInput s => Context -> s -> (Module -> IO a) -> ErrorT (Either String Diagnostic) IO a+withModuleFromLLVMAssembly (Context c) s f = flip runAnyContT return $ do mb <- llvmAssemblyMemoryBuffer s smDiag <- anyContToM withSMDiagnostic m <- anyContToM $ bracket (FFI.parseLLVMAssembly c mb smDiag) FFI.disposeModule@@ -133,13 +127,12 @@ return s -- | write LLVM assembly for a 'Module' to a file-writeLLVMAssemblyToFile :: File -> Module -> ExceptT String IO ()-writeLLVMAssemblyToFile (File path) (Module m) = unExceptableT $ flip runAnyContT return $ do+writeLLVMAssemblyToFile :: File -> Module -> ErrorT String IO ()+writeLLVMAssemblyToFile (File path) (Module m) = flip runAnyContT return $ do withFileRawOStream path False False $ liftIO . FFI.writeLLVMAssembly m class BitcodeInput b where- bitcodeMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)- => b -> m (Ptr FFI.MemoryBuffer)+ bitcodeMemoryBuffer :: (MonadIO e, MonadAnyCont IO e) => b -> e (Ptr FFI.MemoryBuffer) instance BitcodeInput (String, BS.ByteString) where bitcodeMemoryBuffer (s, bs) = encodeM (MB.Bytes s bs)@@ -148,53 +141,51 @@ bitcodeMemoryBuffer (File p) = encodeM (MB.File p) -- | parse 'Module' from LLVM bitcode-withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ExceptT String IO a-withModuleFromBitcode (Context c) b f = unExceptableT $ flip runAnyContT return $ do+withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ErrorT String IO a+withModuleFromBitcode (Context c) b f = flip runAnyContT return $ do mb <- bitcodeMemoryBuffer b msgPtr <- alloca m <- anyContToM $ bracket (FFI.parseBitcode c mb msgPtr) FFI.disposeModule- when (m == nullPtr) $ throwError =<< decodeM msgPtr+ when (m == nullPtr) $ fail =<< decodeM msgPtr liftIO $ f (Module m) -- | generate LLVM bitcode from a 'Module' moduleBitcode :: Module -> IO BS.ByteString-moduleBitcode (Module m) = do- r <- runExceptableT $ withBufferRawOStream (liftIO . FFI.writeBitcode m)- either fail return r+moduleBitcode (Module m) = withBufferRawOStream (liftIO . FFI.writeBitcode m) -- | write LLVM bitcode from a 'Module' into a file-writeBitcodeToFile :: File -> Module -> ExceptT String IO ()-writeBitcodeToFile (File path) (Module m) = unExceptableT $ flip runAnyContT return $ do+writeBitcodeToFile :: File -> Module -> ErrorT String IO ()+writeBitcodeToFile (File path) (Module m) = flip runAnyContT return $ do withFileRawOStream path False True $ liftIO . FFI.writeBitcode m -targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ExceptT String IO ()-targetMachineEmit fileType (TargetMachine tm) (Module m) os = unExceptableT $ flip runAnyContT return $ do+targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ErrorT String IO ()+targetMachineEmit fileType (TargetMachine tm) (Module m) os = flip runAnyContT return $ do msgPtr <- alloca r <- decodeM =<< (liftIO $ FFI.targetMachineEmit tm m fileType msgPtr os)- when r $ throwError =<< decodeM msgPtr+ when r $ fail =<< decodeM msgPtr -emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ExceptT String IO ()-emitToFile fileType tm (File path) m = unExceptableT$ flip runAnyContT return $ do+emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ErrorT String IO ()+emitToFile fileType tm (File path) m = flip runAnyContT return $ do withFileRawOStream path False True $ targetMachineEmit fileType tm m -emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ExceptT String IO BS.ByteString-emitToByteString fileType tm m = unExceptableT $ flip runAnyContT return $ do+emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ErrorT String IO BS.ByteString+emitToByteString fileType tm m = flip runAnyContT return $ do withBufferRawOStream $ targetMachineEmit fileType tm m -- | write target-specific assembly directly into a file-writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ExceptT String IO ()+writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ErrorT String IO () writeTargetAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly -- | produce target-specific assembly as a 'String'-moduleTargetAssembly :: TargetMachine -> Module -> ExceptT String IO String+moduleTargetAssembly :: TargetMachine -> Module -> ErrorT String IO String moduleTargetAssembly tm m = decodeM . UTF8ByteString =<< emitToByteString FFI.codeGenFileTypeAssembly tm m -- | produce target-specific object code as a 'ByteString'-moduleObject :: TargetMachine -> Module -> ExceptT String IO BS.ByteString+moduleObject :: TargetMachine -> Module -> ErrorT String IO BS.ByteString moduleObject = emitToByteString FFI.codeGenFileTypeObject -- | write target-specific object code directly into a file-writeObjectToFile :: TargetMachine -> File -> Module -> ExceptT String IO ()+writeObjectToFile :: TargetMachine -> File -> Module -> ErrorT String IO () writeObjectToFile = emitToFile FFI.codeGenFileTypeObject setTargetTriple :: Ptr FFI.Module -> String -> EncodeAST ()@@ -215,9 +206,11 @@ 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) -> ExceptT String IO a+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@@ -260,8 +253,8 @@ eg' :: EncodeAST (Ptr FFI.GlobalValue) <- case g of g@(A.GlobalVariable { A.G.name = n }) -> do typ <- encodeM (A.G.type' g)- g' <- liftIO $ withName n $ \gName ->- FFI.addGlobalInAddressSpace m typ gName+ g' <- liftIO $ withName n $ \gName -> + FFI.addGlobalInAddressSpace m typ gName (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g)) defineGlobal n g' liftIO $ do@@ -321,8 +314,6 @@ (encodeM term :: EncodeAST (Ptr FFI.Instruction)) return (sequence_ finishes) sequence_ finishInstrs- locals <- gets $ Map.toList . encodeStateLocals- forM [ n | (n, ForwardValue _) <- locals ] $ \n -> undefinedReference "local" n return (FFI.upCast f) return $ do g' <- eg'@@ -330,7 +321,7 @@ setVisibility g' (A.G.visibility g) return $ return () - liftIO $ f (Module m)+ liftIO $ f (Module m) -- | Get an LLVM.General.AST.'LLVM.General.AST.Module' from a LLVM.General.'Module' - i.e. -- raise C++ objects into an Haskell AST.@@ -338,7 +329,7 @@ moduleAST (Module mod) = runDecodeAST $ do c <- return Context `ap` liftIO (FFI.getModuleContext mod) getMetadataKindNames c- return A.Module+ return A.Module `ap` (liftIO $ decodeM =<< FFI.getModuleIdentifier mod) `ap` (liftIO $ getDataLayout mod) `ap` (liftIO $ do@@ -419,7 +410,7 @@ return A.NamedMetadataDefinition `ap` (decodeM $ FFI.getNamedMetadataName nm) `ap` liftM (map (\(A.MetadataNodeReference mid) -> mid)) (decodeM (n, os))-+ mds <- getMetadataDefinitions return $ tds ++ ias ++ gs ++ nmds ++ mds
src/LLVM/General/Internal/Operand.hs view
@@ -3,11 +3,9 @@ #-} module LLVM.General.Internal.Operand where -import LLVM.General.Prelude-+import Data.Functor import Control.Monad.State import Control.Monad.AnyCont-import qualified Data.Map as Map import Foreign.Ptr @@ -15,7 +13,6 @@ import qualified LLVM.General.Internal.FFI.InlineAssembly as FFI import qualified LLVM.General.Internal.FFI.Metadata as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI-import qualified LLVM.General.Internal.FFI.Value as FFI import LLVM.General.Internal.Coding import LLVM.General.Internal.Constant ()@@ -44,9 +41,7 @@ if mdn /= nullPtr then return A.MetadataNodeOperand `ap` decodeM mdn else- return A.LocalReference - `ap` (decodeM =<< (liftIO $ FFI.typeOf v))- `ap` getLocalName v+ return A.LocalReference `ap` getLocalName v instance DecodeM DecodeAST A.CallableOperand (Ptr FFI.Value) where decodeM v = do@@ -57,17 +52,7 @@ instance EncodeM EncodeAST A.Operand (Ptr FFI.Value) where encodeM (A.ConstantOperand c) = (FFI.upCast :: Ptr FFI.Constant -> Ptr FFI.Value) <$> encodeM c- encodeM (A.LocalReference t n) = do- lv <- refer encodeStateLocals n $ do- lv <- do- n <- encodeM n- t <- encodeM t- v <- liftIO $ FFI.createArgument t n- return $ ForwardValue v- modify $ \s -> s { encodeStateLocals = Map.insert n lv $ encodeStateLocals s }- return lv- return $ case lv of DefinedValue v -> v; ForwardValue v -> v-+ encodeM (A.LocalReference n) = referLocal n encodeM (A.MetadataStringOperand s) = do Context c <- gets encodeStateContext s <- encodeM s
src/LLVM/General/Internal/PassManager.hs view
@@ -4,21 +4,22 @@ #-} module LLVM.General.Internal.PassManager where -import LLVM.General.Prelude- import qualified Language.Haskell.TH as TH import Control.Exception+import Control.Monad hiding (forM_) import Control.Monad.IO.Class+import Control.Applicative import Control.Monad.AnyCont +import Data.Word+import Data.Foldable (forM_) import Foreign.C (CString) import Foreign.Ptr import qualified LLVM.General.Internal.FFI.PassManager as FFI import qualified LLVM.General.Internal.FFI.Transforms as FFI-import qualified LLVM.General.Internal.FFI.Target as FFI import LLVM.General.Internal.Module import LLVM.General.Internal.Target@@ -53,12 +54,7 @@ sizeLevel :: Maybe Word, unitAtATime :: Maybe Bool, simplifyLibCalls :: Maybe Bool,- loopVectorize :: Maybe Bool,- superwordLevelParallelismVectorize :: Maybe Bool,- useInlinerWithThreshold :: Maybe Word,- dataLayout :: Maybe DataLayout,- targetLibraryInfo :: Maybe TargetLibraryInfo,- targetMachine :: Maybe TargetMachine+ useInlinerWithThreshold :: Maybe Word } -- | Helper to make a curated 'PassSetSpec'@@ -67,12 +63,7 @@ sizeLevel = Nothing, unitAtATime = Nothing, simplifyLibCalls = Nothing,- loopVectorize = Nothing,- superwordLevelParallelismVectorize = Nothing,- useInlinerWithThreshold = Nothing,- dataLayout = Nothing,- targetLibraryInfo = Nothing,- targetMachine = Nothing+ useInlinerWithThreshold = Nothing } -- | an empty 'PassSetSpec'@@ -89,10 +80,6 @@ createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager) createPassManager pss = flip runAnyContT return $ do pm <- liftIO $ FFI.createPassManager- forM_ (dataLayout pss) $ \dl -> liftIO $ withFFIDataLayout dl $ FFI.addDataLayoutPass pm - forM_ (targetLibraryInfo pss) $ \(TargetLibraryInfo tli) -> do- liftIO $ FFI.addTargetLibraryInfoPass pm tli- forM_ (targetMachine pss) $ \(TargetMachine tm) -> liftIO $ FFI.addAnalysisPasses tm pm case pss of s@CuratedPassSetSpec {} -> liftIO $ do bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do@@ -102,11 +89,12 @@ handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime) handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls) handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold- handleOption FFI.passManagerBuilderSetLoopVectorize loopVectorize- handleOption FFI.passManagerBuilderSetSuperwordLevelParallelismVectorize superwordLevelParallelismVectorize FFI.passManagerBuilderPopulateModulePassManager b pm PassSetSpec ps dl tli tm' -> do- tl <- liftIO $ maybe (return nullPtr) (\(TargetMachine tm) -> FFI.getTargetLowering tm) tm'+ let tm = maybe nullPtr (\(TargetMachine tm) -> tm) tm'+ forM_ tli $ \(TargetLibraryInfo tli) -> do+ liftIO $ FFI.addTargetLibraryInfoPass pm tli+ forM_ dl $ \dl -> liftIO $ withFFIDataLayout dl $ FFI.addDataLayoutPass pm forM_ ps $ \p -> $( do TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass@@ -123,7 +111,7 @@ foldl1 TH.appE (map TH.dyn $ ["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"]- ++ ["tl" | FFI.needsTargetLowering (TH.nameBase n)]+ ++ ["tm" | FFI.needsTargetMachine (TH.nameBase n)] ++ fns) ) |]
src/LLVM/General/Internal/RawOStream.hs view
@@ -1,8 +1,7 @@ module LLVM.General.Internal.RawOStream where -import LLVM.General.Prelude--import Control.Monad.Exceptable+import Control.Monad+import Control.Monad.Error import Control.Monad.AnyCont import Data.IORef@@ -12,34 +11,36 @@ import qualified LLVM.General.Internal.FFI.RawOStream as FFI import LLVM.General.Internal.Coding-import LLVM.General.Internal.Inject import LLVM.General.Internal.String () -withFileRawOStream ::- (Inject String e, MonadError e m, MonadAnyCont IO m, MonadIO m)+withFileRawOStream :: + (MonadAnyCont IO m, MonadIO m) => String -> Bool -> Bool- -> (Ptr FFI.RawOStream -> ExceptT String IO ())+ -> (Ptr FFI.RawOStream -> ErrorT String IO ()) -> m () withFileRawOStream path excl binary c = do path <- encodeM path excl <- encodeM excl binary <- encodeM binary+ outputRef <- liftIO $ newIORef Nothing msgPtr <- alloca errorRef <- liftIO $ newIORef undefined- succeeded <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl binary msgPtr $ \os -> do- r <- runExceptableT (ExceptableT $ c os)- writeIORef errorRef r)- unless succeeded $ do- s <- decodeM msgPtr- throwError $ inject (s :: String)+ failed <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl binary msgPtr $ \os -> do+ r <- runErrorT (c os)+ writeIORef errorRef r)+ when failed $ fail =<< decodeM msgPtr e <- liftIO $ readIORef errorRef- either (throwError . inject) return e+ case e of+ Left e -> fail e+ _ -> do+ Just r <- liftIO $ readIORef outputRef+ return r -withBufferRawOStream ::- (Inject String e, MonadError e m, MonadIO m, DecodeM IO a (Ptr CChar, CSize))- => (Ptr FFI.RawOStream -> ExceptT String IO ())+withBufferRawOStream :: + (MonadIO m, DecodeM IO a (Ptr CChar, CSize))+ => (Ptr FFI.RawOStream -> ErrorT String IO ()) -> m a withBufferRawOStream c = do resultRef <- liftIO $ newIORef Nothing@@ -49,12 +50,12 @@ r <- decodeM (start, size) writeIORef resultRef (Just r) saveError os = do- r <- runExceptableT (ExceptableT $ c os)+ r <- runErrorT (c os) writeIORef errorRef r liftIO $ FFI.withBufferRawOStream saveBuffer saveError e <- liftIO $ readIORef errorRef case e of- Left e -> throwError $ inject e+ Left e -> fail e _ -> do Just r <- liftIO $ readIORef resultRef return r
src/LLVM/General/Internal/String.hs view
@@ -4,9 +4,8 @@ #-} module LLVM.General.Internal.String where -import LLVM.General.Prelude- import Control.Arrow+import Control.Monad import Control.Monad.AnyCont import Control.Monad.IO.Class import Control.Exception (finally)
src/LLVM/General/Internal/Target.hs view
@@ -6,22 +6,20 @@ #-} module LLVM.General.Internal.Target where -import LLVM.General.Prelude--import Control.Monad.Exceptable+import Control.Monad+import Control.Monad.Error import Control.Exception+import Data.Functor import Control.Monad.AnyCont+import Data.Maybe import Foreign.Ptr import Data.List (intercalate)-import Data.Map (Map)-import qualified Data.Map as Map--import Text.ParserCombinators.Parsec hiding (many)+import Data.Set (Set)+import qualified Data.Set as Set import LLVM.General.Internal.Coding import LLVM.General.Internal.String ()-import LLVM.General.Internal.LibraryFunction import LLVM.General.DataLayout import LLVM.General.AST.DataLayout@@ -76,35 +74,26 @@ newtype CPUFeature = CPUFeature String deriving (Eq, Ord, Read, Show) -instance EncodeM e String es => EncodeM e (Map CPUFeature Bool) es where- encodeM = encodeM . intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") ++ f) . Map.toList+instance 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 (Map CPUFeature Bool) es where- decodeM es = do- s <- decodeM es- let flag = do- en <- choice [char '-' >> return False, char '+' >> return True]- s <- many1 (noneOf ",")- return (CPUFeature s, en)- features = liftM Map.fromList (flag `sepBy` (char ','))- case parse (do f <- features; eof; return f) "CPU Feature string" (s :: String) of- Right features -> return features- Left _ -> fail "failure to parse CPUFeature string"- +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\". -- | <http://llvm.org/doxygen/structllvm_1_1TargetRegistry.html#a3105b45e546c9cc3cf78d0f2ec18ad89> -- | Be sure to run either 'initializeAllTargets' or 'initializeNativeTarget' before expecting this to succeed, depending on what target(s) you want to use.-lookupTarget ::+lookupTarget :: Maybe String -- ^ arch -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu- -> ExceptT String IO (Target, String)-lookupTarget arch triple = unExceptableT $ flip runAnyContT return $ do+ -> ErrorT String IO (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) $ throwError =<< decodeM cErrorP+ when (target == nullPtr) $ fail =<< decodeM cErrorP liftM (Target target, ) $ decodeM cNewTripleP -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>@@ -120,7 +109,6 @@ mapM_ (\(c, ha) -> FFI.setTargetOptionFlag cOpts c =<< encodeM (ha hOpts)) [ (FFI.targetOptionFlagPrintMachineCode, TO.printMachineCode), (FFI.targetOptionFlagNoFramePointerElim, TO.noFramePointerElimination),- (FFI.targetOptionFlagNoFramePointerElimNonLeaf, TO.noFramePointerEliminationNonLeaf), (FFI.targetOptionFlagLessPreciseFPMADOption, TO.lessPreciseFloatingPointMultiplyAddOption), (FFI.targetOptionFlagUnsafeFPMath, TO.unsafeFloatingPointMath), (FFI.targetOptionFlagNoInfsFPMath, TO.noInfinitiesFloatingPointMath),@@ -128,7 +116,6 @@ (FFI.targetOptionFlagHonorSignDependentRoundingFPMathOption, TO.honorSignDependentRoundingFloatingPointMathOption), (FFI.targetOptionFlagUseSoftFloat, TO.useSoftFloat), (FFI.targetOptionFlagNoZerosInBSS, TO.noZerosInBSS),- (FFI.targetOptionFlagJITExceptionHandling, TO.jITExceptionHandling), (FFI.targetOptionFlagJITEmitDebugInfo, TO.jITEmitDebugInfo), (FFI.targetOptionFlagJITEmitDebugInfoToDisk, TO.jITEmitDebugInfoToDisk), (FFI.targetOptionFlagGuaranteedTailCallOpt, TO.guaranteedTailCallOptimization),@@ -136,8 +123,7 @@ (FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection), (FFI.targetOptionFlagPositionIndependentExecutable, TO.positionIndependentExecutable), (FFI.targetOptionFlagEnableSegmentedStacks, TO.enableSegmentedStacks),- (FFI.targetOptionFlagUseInitArray, TO.useInitArray),- (FFI.targetOptionFlagRealignStack, TO.realignStack) + (FFI.targetOptionFlagUseInitArray, TO.useInitArray) ] FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts) flip runAnyContT return $ do@@ -145,18 +131,15 @@ liftIO $ FFI.setTrapFuncName cOpts n FFI.setFloatABIType cOpts =<< encodeM (TO.floatABIType hOpts) FFI.setAllowFPOpFusion cOpts =<< encodeM (TO.allowFloatingPointOperationFusion hOpts)- FFI.setSSPBufferSize cOpts =<< encodeM (TO.stackSmashingProtectionBufferSize hOpts) -- | get all target options peekTargetOptions :: TargetOptions -> IO TO.Options peekTargetOptions (TargetOptions tOpts) = do- let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts+ let gof = decodeM <=< FFI.getTargetOptionsFlag tOpts printMachineCode <- gof FFI.targetOptionFlagPrintMachineCode noFramePointerElimination <- gof FFI.targetOptionFlagNoFramePointerElim- noFramePointerEliminationNonLeaf- <- gof FFI.targetOptionFlagNoFramePointerElimNonLeaf lessPreciseFloatingPointMultiplyAddOption <- gof FFI.targetOptionFlagLessPreciseFPMADOption unsafeFloatingPointMath@@ -171,8 +154,6 @@ <- gof FFI.targetOptionFlagUseSoftFloat noZerosInBSS <- gof FFI.targetOptionFlagNoZerosInBSS- jITExceptionHandling- <- gof FFI.targetOptionFlagJITExceptionHandling jITEmitDebugInfo <- gof FFI.targetOptionFlagJITEmitDebugInfo jITEmitDebugInfoToDisk@@ -189,24 +170,21 @@ <- gof FFI.targetOptionFlagEnableSegmentedStacks useInitArray <- gof FFI.targetOptionFlagUseInitArray- realignStack- <- decodeM =<< FFI.getTargetOptionsFlag tOpts FFI.targetOptionFlagRealignStack stackAlignmentOverride <- decodeM =<< FFI.getStackAlignmentOverride tOpts trapFunctionName <- decodeM =<< FFI.getTrapFuncName tOpts floatABIType <- decodeM =<< FFI.getFloatABIType tOpts allowFloatingPointOperationFusion <- decodeM =<< FFI.getAllowFPOpFusion tOpts- stackSmashingProtectionBufferSize <- decodeM =<< FFI.getSSPBufferSize tOpts return TO.Options { .. } -- | <http://llvm.org/doxygen/classllvm_1_1TargetMachine.html> newtype TargetMachine = TargetMachine (Ptr FFI.TargetMachine) -- | bracket creation and destruction of a 'TargetMachine'-withTargetMachine ::+withTargetMachine :: Target -> String -- ^ triple -> String -- ^ cpu- -> Map CPUFeature Bool -- ^ features+ -> Set CPUFeature -- ^ features -> TargetOptions -> Reloc.Model -> CodeModel.Model@@ -270,29 +248,23 @@ getHostCPUName = decodeM =<< FFI.getHostCPUName -- | a space-separated list of LLVM feature names supported by the host CPU-getHostCPUFeatures :: IO (Map CPUFeature Bool)+getHostCPUFeatures :: IO (Set CPUFeature) getHostCPUFeatures = decodeM =<< FFI.getHostCPUFeatures-+ -- | 'DataLayout' to use for the given 'TargetMachine' getTargetMachineDataLayout :: TargetMachine -> IO DataLayout-getTargetMachineDataLayout (TargetMachine m) = do- dl <- decodeM =<< FFI.getTargetMachineDataLayout m- maybe (fail "parseDataLayout failed") return $ parseDataLayout dl+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 -{-# DEPRECATED withDefaultTargetMachine "use withHostTargetMachine or withTargetMachine" #-}--- | Bracket creation and destruction of a 'TargetMachine' configured for the host.-withDefaultTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a-withDefaultTargetMachine = withHostTargetMachine---- | Bracket creation and destruction of a 'TargetMachine' configured for the host-withHostTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a-withHostTargetMachine f = do+-- | 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 $ getProcessTargetTriple+ triple <- liftIO $ getDefaultTargetTriple cpu <- liftIO $ getHostCPUName features <- liftIO $ getHostCPUFeatures (target, _) <- lookupTarget Nothing triple@@ -302,33 +274,8 @@ -- | <http://llvm.org/docs/doxygen/html/classllvm_1_1TargetLibraryInfo.html> newtype TargetLibraryInfo = TargetLibraryInfo (Ptr FFI.TargetLibraryInfo) --- | Look up a 'LibraryFunction' by its standard name-getLibraryFunction :: TargetLibraryInfo -> String -> IO (Maybe LibraryFunction)-getLibraryFunction (TargetLibraryInfo f) name = flip runAnyContT return $ do- libFuncP <- alloca- name <- encodeM name- r <- decodeM =<< (liftIO $ FFI.getLibFunc f name libFuncP)- forM (if r then Just libFuncP else Nothing) $ decodeM <=< peek---- | Get a the current name to be emitted for a 'LibraryFunction'-getLibraryFunctionName :: TargetLibraryInfo -> LibraryFunction -> IO String-getLibraryFunctionName (TargetLibraryInfo f) l = flip runAnyContT return $ do- l <- encodeM l- decodeM $ FFI.libFuncGetName f l---- | Set the name of the function on the target platform that corresponds to funcName-setLibraryFunctionAvailableWithName ::- TargetLibraryInfo- -> LibraryFunction- -> String -- ^ The function name to be emitted- -> IO ()-setLibraryFunctionAvailableWithName (TargetLibraryInfo f) libraryFunction name = flip runAnyContT return $ do- name <- encodeM name- libraryFunction <- encodeM libraryFunction- liftIO $ FFI.libFuncSetAvailableWithName f libraryFunction name- -- | look up information about the library functions available on a given platform-withTargetLibraryInfo ::+withTargetLibraryInfo :: String -- ^ triple -> (TargetLibraryInfo -> IO a) -> IO a
− src/LLVM/General/Internal/Threading.hs
@@ -1,34 +0,0 @@-module LLVM.General.Internal.Threading (- setMultithreaded,- isMultithreaded- ) where--import LLVM.General.Prelude--import Control.Concurrent.MVar-import System.IO.Unsafe--import qualified LLVM.General.Internal.FFI.Threading as FFI--import LLVM.General.Internal.Coding--lock :: MVar ()-{-# NOINLINE lock #-}-lock = unsafePerformIO $ newMVar ()---- | Set the multithreading mode of LLVM. If it is disabled (as by default) locks are not enforced.-setMultithreaded :: Bool -> IO ()-setMultithreaded s = do- takeMVar lock- multi <- isMultithreaded- case (s,multi) of- (True,False) -> do- success <- decodeM =<< FFI.startMultithreaded- when (not success) $ error "setMultithreaded: LLVM not built with threading support"- (False,True) -> FFI.stopMultithreaded- _ -> return ()- putMVar lock ()---- | Check if multithreading is enabled in LLVM-isMultithreaded :: IO Bool-isMultithreaded = FFI.isMultithreaded >>= decodeM
src/LLVM/General/Internal/Type.hs view
@@ -4,11 +4,9 @@ #-} module LLVM.General.Internal.Type where -import LLVM.General.Prelude-+import Control.Applicative import Control.Monad.State import Control.Monad.AnyCont-import Control.Monad.Exceptable import qualified Data.Set as Set @@ -29,7 +27,7 @@ getStructure :: Ptr FFI.Type -> DecodeAST A.Type getStructure t = scopeAnyCont $ do- return A.StructureType+ return A.StructureType `ap` (decodeM =<< liftIO (FFI.isPackedStruct t)) `ap` do n <- liftIO (FFI.countStructElementTypes t)@@ -57,7 +55,7 @@ isArrayType t = do k <- liftIO $ FFI.getTypeKind t return $ k == FFI.typeKindArray-+ instance Monad m => EncodeM m A.AddrSpace FFI.AddrSpace where encodeM (A.AddrSpace a) = return FFI.AddrSpace `ap` encodeM a @@ -87,7 +85,7 @@ A.FloatingPointType 80 A.DoubleExtended -> liftIO $ FFI.x86FP80TypeInContext context A.FloatingPointType 128 A.IEEE -> liftIO $ FFI.fP128TypeInContext context A.FloatingPointType 128 A.PairOfFloats -> liftIO $ FFI.ppcFP128TypeInContext context- A.FloatingPointType _ _ -> throwError $ "unsupported floating point type: " ++ show f+ A.FloatingPointType _ _ -> fail $ "unsupported floating point type: " ++ show f A.VectorType sz e -> do e <- encodeM e sz <- encodeM sz@@ -109,7 +107,7 @@ case k of [typeKindP|Void|] -> return A.VoidType [typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))- [typeKindP|Function|] ->+ [typeKindP|Function|] -> return A.FunctionType `ap` (decodeM =<< liftIO (FFI.getReturnType t)) `ap` (do@@ -129,17 +127,17 @@ [typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE [typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended [typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats- [typeKindP|Vector|] ->+ [typeKindP|Vector|] -> return A.VectorType `ap` (decodeM =<< liftIO (FFI.getVectorSize t)) `ap` (decodeM =<< liftIO (FFI.getElementType t)) [typeKindP|Struct|] -> do let ifM c a b = c >>= \x -> if x then a else b- ifM (decodeM =<< liftIO (FFI.structIsLiteral t))+ ifM (decodeM =<< liftIO (FFI.structIsLiteral t)) (getStructure t) (saveNamedType t >> return A.NamedTypeReference `ap` getTypeName t)- [typeKindP|Metadata|] -> return A.MetadataType- [typeKindP|Array|] ->++ [typeKindP|Array|] -> return A.ArrayType `ap` (decodeM =<< liftIO (FFI.getArrayLength t)) `ap` (decodeM =<< liftIO (FFI.getElementType t))@@ -150,7 +148,7 @@ Context c <- gets encodeStateContext n <- case n of { A.Name n -> encodeM n; _ -> return nullPtr } liftIO $ FFI.structCreateNamed c n-+ setNamedType :: Ptr FFI.Type -> A.Type -> EncodeAST () setNamedType t (A.StructureType packed ets) = do@@ -158,5 +156,5 @@ packed <- encodeM packed liftIO $ FFI.structSetBody t ets packed --+ +
src/LLVM/General/Internal/Value.hs view
@@ -3,8 +3,6 @@ #-} module LLVM.General.Internal.Value where -import LLVM.General.Prelude- import Control.Monad.State import Foreign.Ptr
src/LLVM/General/Module.hs view
@@ -2,7 +2,6 @@ -- added to an 'LLVM.General.ExecutionEngine.ExecutionEngine' and so JIT compiled to get function pointers. module LLVM.General.Module ( Module,- File(..), withModuleFromAST, moduleAST,
src/LLVM/General/Relocation.hs view
@@ -1,7 +1,7 @@ -- | Relocations, used in specifying TargetMachine module LLVM.General.Relocation where -import LLVM.General.Prelude+import Data.Data -- | <http://llvm.org/doxygen/namespacellvm_1_1Reloc.html> data Model
src/LLVM/General/Target.hs view
@@ -1,4 +1,4 @@--- | A 'Target' describes that for which code may be intended. Targets are used both during actual+-- | A Target describes that for which code may be intended. Targets are used both during actual -- | lowering of LLVM IR to machine code and by some optimization passes which use the target to -- | judge costs. module LLVM.General.Target (@@ -7,14 +7,11 @@ Target, TargetMachine, TargetLowering, CPUFeature(..), withTargetOptions, peekTargetOptions, pokeTargetOptions,- withTargetMachine, withHostTargetMachine, withDefaultTargetMachine,+ withTargetMachine, withDefaultTargetMachine, getTargetLowering, getDefaultTargetTriple, getProcessTargetTriple, getHostCPUName, getHostCPUFeatures, getTargetMachineDataLayout, initializeNativeTarget, initializeAllTargets, TargetLibraryInfo,- getLibraryFunction,- getLibraryFunctionName,- setLibraryFunctionAvailableWithName, withTargetLibraryInfo ) where
− src/LLVM/General/Target/LibraryFunction.hs
@@ -1,7 +0,0 @@--- | A 'LibraryFunction' identifies a function of which LLVM has particular knowledge.-module LLVM.General.Target.LibraryFunction (- LibraryFunction(..)- ) where---import LLVM.General.Internal.LibraryFunction
src/LLVM/General/Target/Options.hs view
@@ -1,7 +1,8 @@ -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html> module LLVM.General.Target.Options where -import LLVM.General.Prelude+import Data.Data+import Data.Word -- | <http://llvm.org/doxygen/namespacellvm_1_1FloatABI.html#aea077c52d84934aabf9445cef9eab2e2> data FloatABI@@ -22,7 +23,6 @@ data Options = Options { printMachineCode :: Bool, noFramePointerElimination :: Bool,- noFramePointerEliminationNonLeaf :: Bool, lessPreciseFloatingPointMultiplyAddOption :: Bool, unsafeFloatingPointMath :: Bool, noInfinitiesFloatingPointMath :: Bool,@@ -30,12 +30,10 @@ honorSignDependentRoundingFloatingPointMathOption :: Bool, useSoftFloat :: Bool, noZerosInBSS :: Bool,- jITExceptionHandling :: Bool, jITEmitDebugInfo :: Bool, jITEmitDebugInfoToDisk :: Bool, guaranteedTailCallOptimization :: Bool, disableTailCalls :: Bool,- realignStack :: Bool, enableFastInstructionSelection :: Bool, positionIndependentExecutable :: Bool, enableSegmentedStacks :: Bool,@@ -43,8 +41,7 @@ stackAlignmentOverride :: Word32, trapFunctionName :: String, floatABIType :: FloatABI,- allowFloatingPointOperationFusion :: FloatingPointOperationFusionMode,- stackSmashingProtectionBufferSize :: Word32+ allowFloatingPointOperationFusion :: FloatingPointOperationFusionMode } deriving (Eq, Ord, Read, Show)
− src/LLVM/General/Threading.hs
@@ -1,7 +0,0 @@--- | functionality necessary when running LLVM in multiple threads at the same time.-module LLVM.General.Threading (- setMultithreaded,- isMultithreaded- ) where--import LLVM.General.Internal.Threading
src/LLVM/General/Transforms.hs view
@@ -4,18 +4,18 @@ -- instead using 'LLVM.General.PassManager.CuratedPassSetSpec'. module LLVM.General.Transforms where -import LLVM.General.Prelude+import Data.Data+import Data.Word -- | <http://llvm.org/docs/Passes.html#transform-passes>--- A few passes can make use of information in a 'LLVM.General.Target.TargetLowering' if one+-- A few passes can make use of information in a 'LLVM.General.Target.TargetMachine' if one -- is provided to 'LLVM.General.PassManager.createPassManager'. -- <http://llvm.org/doxygen/classllvm_1_1Pass.html> data Pass -- here begin the Scalar passes = AggressiveDeadCodeElimination- | BlockPlacement | BreakCriticalEdges- -- | can use a 'LLVM.General.Target.TargetLowering'+ -- | can use a 'LLVM.General.Target.TargetMachine' | CodeGenPrepare | ConstantPropagation | CorrelatedValuePropagation@@ -38,7 +38,7 @@ | LoopUnroll { loopUnrollThreshold :: Maybe Word, count :: Maybe Word, allowPartial :: Maybe Bool } | LoopUnswitch { optimizeForSize :: Bool } | LowerAtomic- -- | can use a 'LLVM.General.Target.TargetLowering'+ -- | can use a 'LLVM.General.Target.TargetMachine' | LowerInvoke { useExpensiveExceptionHandlingSupport :: Bool } | LowerSwitch | LowerExpectIntrinsic@@ -105,12 +105,8 @@ fastDependencyAnalysis :: Bool } | LoopVectorize- | SuperwordLevelParallelismVectorize -- here begin the instrumentation passes- | EdgeProfiler- | OptimalEdgeProfiler- | PathProfiler | GCOVProfiler { emitNotes :: Bool, emitData :: Bool,@@ -139,6 +135,13 @@ blackListFile :: Maybe FilePath } | BoundsChecking+ | DebugGeneratedIR {+ hideDebugIntrinsics :: Bool,+ hideDebugMetadata :: Bool,+ fileName :: Maybe FilePath,+ directory :: Maybe FilePath+ }+ | DebugExistingIR deriving (Eq, Ord, Read, Show, Typeable, Data) -- | Defaults for the 'BasicBlockVectorize' pass - copied from the C++ code to keep these defaults@@ -209,4 +212,12 @@ -- | Defaults for 'ThreadSanitizer'. defaultThreadSanitizer = ThreadSanitizer { blackListFile = Nothing+}++-- | Defaults for 'DebugGeneratedIR'.+defaultDebugGeneratedIR = DebugGeneratedIR {+ hideDebugIntrinsics = False,+ hideDebugMetadata = False,+ fileName = Nothing,+ directory = Nothing }
test/LLVM/General/Test/Analysis.hs view
@@ -6,14 +6,14 @@ import LLVM.General.Test.Support -import Control.Monad.Trans.Except+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 as A.T+import LLVM.General.AST.Type import LLVM.General.AST.Name import LLVM.General.AST.AddrSpace import LLVM.General.AST.DataLayout@@ -35,18 +35,18 @@ -- this test will cause an assertion if LLVM is compiled with assertions on. testCase "Module" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ Function L.External V.Default CC.C [] A.T.void (Name "foo") ([- Parameter i32 (Name "x") []+ GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([+ Parameter (IntegerType 32) (Name "x") [] ],False) [] - Nothing 0 Nothing + Nothing 0 [ BasicBlock (UnName 0) [ UnName 1 := Call { isTailCall = False, callingConvention = CC.C, returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (A.T.FunctionType A.T.void [A.T.i32] False) (Name "foo"))),+ function = Right (ConstantOperand (C.GlobalReference (Name "foo"))), arguments = [ (ConstantOperand (C.Int 8 1), []) ],@@ -58,7 +58,7 @@ ) ] ]- Left s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify+ 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\@@ -79,34 +79,34 @@ ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = double,+ G.returnType = FloatingPointType 64 IEEE, G.name = Name "my_function2", G.parameters = ([- Parameter (ptr double) (Name "input_0") []+ 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 (ptr double) (Name "input_0"),+ address = LocalReference (Name "input_0"), indices = [ConstantOperand (C.Int 64 0)], metadata = [] }, UnName 0 := Load { volatile = False,- address = LocalReference (ptr double) (Name "tmp_input_w0"),+ address = LocalReference (Name "tmp_input_w0"), maybeAtomicity = Nothing, alignment = 8, metadata = [] } ] (- Do $ Ret (Just (LocalReference double (UnName 0))) []+ Do $ Ret (Just (LocalReference (UnName 0))) [] ) ] } ] strCheck ast str- s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify+ s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify s @?= Right () ] ]
test/LLVM/General/Test/Constants.hs view
@@ -33,7 +33,7 @@ | (name, type', value, str) <- [ ( "integer",- i32,+ IntegerType 32, C.Int 32 1, "global i32 1" ), (@@ -53,111 +53,111 @@ "global i65 -1" ), ( "half",- half,+ FloatingPointType 16 IEEE, C.Float (F.Half 0x1234), "global half 0xH1234" ), ( "float",- float,+ FloatingPointType 32 IEEE, C.Float (F.Single 1), "global float 1.000000e+00" ), ( "double",- double,+ FloatingPointType 64 IEEE, C.Float (F.Double 1), "global double 1.000000e+00" ), ( "quad",- fp128,+ FloatingPointType 128 IEEE, C.Float (F.Quadruple 0x0007000600050004 0x0003000200010000), "global fp128 0xL00030002000100000007000600050004" -- yes, this order is weird ), ( "quad 1.0",- fp128,+ FloatingPointType 128 IEEE, C.Float (F.Quadruple 0x3fff000000000000 0x0000000000000000), "global fp128 0xL00000000000000003FFF000000000000" -- yes, this order is weird ), ( "x86_fp80",- x86_fp80,+ FloatingPointType 80 DoubleExtended, C.Float (F.X86_FP80 0x0004 0x0003000200010000), "global x86_fp80 0xK00040003000200010000" {- don't know how to test this - LLVM's handling of this weird type is even weirder ), ( "ppc_fp128",- ppc_fp128,+ FloatingPointType 128 PairOfFloats, C.Float (F.PPC_FP128 0x0007000600050004 0x0003000200010000), "global ppc_fp128 0xM????????????????" -} ), ( "struct",- StructureType False (replicate 2 i32),- C.Struct Nothing False (replicate 2 (C.Int 32 1)),+ StructureType False (replicate 2 (IntegerType 32)),+ C.Struct False (replicate 2 (C.Int 32 1)), "global { i32, i32 } { i32 1, i32 1 }" ), ( "dataarray",- ArrayType 3 i32,- C.Array i32 [C.Int 32 i | i <- [1,2,1]],+ ArrayType 3 (IntegerType 32),+ C.Array (IntegerType 32) [C.Int 32 i | i <- [1,2,1]], "global [3 x i32] [i32 1, i32 2, i32 1]" ), ( "array",- ArrayType 3 (StructureType False [i32]),- C.Array (StructureType False [i32]) [C.Struct Nothing False [C.Int 32 i] | i <- [1,2,1]],+ ArrayType 3 (StructureType False [IntegerType 32]),+ C.Array (StructureType False [IntegerType 32]) [C.Struct False [C.Int 32 i] | i <- [1,2,1]], "global [3 x { i32 }] [{ i32 } { i32 1 }, { i32 } { i32 2 }, { i32 } { i32 1 }]" ), ( "datavector",- VectorType 3 i32,+ VectorType 3 (IntegerType 32), C.Vector [C.Int 32 i | i <- [1,2,1]], "global <3 x i32> <i32 1, i32 2, i32 1>" ), ( "undef",- i32,- C.Undef i32,+ IntegerType 32,+ C.Undef (IntegerType 32), "global i32 undef" ), ( "binop/cast",- i64,- C.Add False False (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) (C.Int 64 2),+ IntegerType 64,+ C.Add False False (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",- i64,- C.Add True False (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64) (C.Int 64 2),+ 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",- i1,- C.ICmp IPred.SGE (C.GlobalReference (ptr i32) (UnName 1)) (C.GlobalReference (ptr i32) (UnName 2)),+ IntegerType 1,+ C.ICmp IPred.SGE (C.GlobalReference (UnName 1)) (C.GlobalReference (UnName 2)), "global i1 icmp sge (i32* @1, i32* @2)" ), ( "getelementptr",- ptr i32,- C.GetElementPtr True (C.GlobalReference (ptr i32) (UnName 1)) [C.Int 64 27],+ PointerType (IntegerType 32) (AddrSpace 0),+ C.GetElementPtr True (C.GlobalReference (UnName 1)) [C.Int 64 27], "global i32* getelementptr inbounds (i32* @1, i64 27)" ), ( "selectvalue",- i32,- C.Select (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i1) + IntegerType 32,+ C.Select (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 1)) (C.Int 32 1) (C.Int 32 2), "global i32 select (i1 ptrtoint (i32* @1 to i1), i32 1, i32 2)" ), ( "extractelement",- i32,+ IntegerType 32, C.ExtractElement (C.BitCast- (C.PtrToInt (C.GlobalReference (ptr i32) (UnName 1)) i64)- (VectorType 2 i32))+ (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64))+ (VectorType 2 (IntegerType 32))) (C.Int 32 1), "global i32 extractelement (<2 x i32> bitcast (i64 ptrtoint (i32* @1 to i64) to <2 x i32>), i32 1)" {- ), (--- This test make llvm abort, as of llvm-3.2.+-- This test made llvm abort as of llvm-3.2. Now, as a new feature in llvm-3.4, it makes it report a fatal error! "extractvalue",- i8,+ IntegerType 8, C.ExtractValue- (C.Select (C.PtrToInt (C.GlobalReference (p i32) (UnName 1)) i1) - (C.Array i8 [C.Int 8 0])- (C.Array i8 [C.Int 8 1]))+ (C.Select (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 1)) + (C.Array (IntegerType 8) [C.Int 8 0])+ (C.Array (IntegerType 8) [C.Int 8 1])) [0], "global i8 extractvalue ([1 x i8] select (i1 ptrtoint (i32* @1 to i1), [1 x i8] [ i8 1 ], [1 x i8] [ i8 2 ]), 0)" -}@@ -168,10 +168,10 @@ G.name = UnName 0, G.type' = type', G.initializer = Just value }, GlobalDefinition $ globalVariableDefaults {- G.name = UnName 1, G.type' = i32, G.initializer = Nothing + G.name = UnName 1, G.type' = IntegerType 32, G.initializer = Nothing }, GlobalDefinition $ globalVariableDefaults {- G.name = UnName 2, G.type' = i32, G.initializer = Nothing + G.name = UnName 2, G.type' = IntegerType 32, G.initializer = Nothing } ] mStr = "; ModuleID = '<string>'\n\n@0 = " ++ str ++ "\n\
− test/LLVM/General/Test/DataLayout.hs
@@ -1,94 +0,0 @@-module LLVM.General.Test.DataLayout where--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit--import LLVM.General.Test.Support--import Data.Maybe-import qualified Data.Set as Set-import qualified Data.Map as Map--import LLVM.General.Context-import LLVM.General.Module-import LLVM.General.AST-import LLVM.General.AST.DataLayout-import LLVM.General.AST.AddrSpace-import qualified LLVM.General.AST.Global as G--m s = "; ModuleID = '<string>'\n" ++ s-t s = "target datalayout = \"" ++ s ++ "\"\n"--tests = testGroup "DataLayout" [- testCase name $ strCheckC (Module "<string>" mdl Nothing []) (m sdl) (m sdlc)- | (name, mdl, sdl, sdlc) <- [- ("none", Nothing, "", "")- ] ++ [- (name, Just mdl, t sdl, t (fromMaybe sdl msdlc))- | (name, mdl, sdl, msdlc) <- [- ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e", Nothing),- ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E", Nothing),- ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32", Nothing),- (- "no pref",- defaultDataLayout {- pointerLayouts = - Map.singleton- (AddrSpace 0) - (- 8,- AlignmentInfo {- abiAlignment = 64,- preferredAlignment = Nothing- }- )- },- "p:8:64",- Nothing- ), (- "no pref",- defaultDataLayout {- pointerLayouts = - Map.singleton- (AddrSpace 1) - (- 8,- AlignmentInfo {- abiAlignment = 32,- preferredAlignment = Just 64- }- )- },- "p1:8:32:64",- Nothing- ), (- "big",- DataLayout {- endianness = Just LittleEndian,- stackAlignment = Just 128,- pointerLayouts = Map.fromList [- (AddrSpace 0, (64, AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}))- ],- typeLayouts = Map.fromList [- ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}),- ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}),- ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 16}),- ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}),- ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}),- ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}),- ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}),- ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}),- ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}),- ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}),- ((AggregateAlign, 0), AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 64}),- ((StackAlign, 0), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64})- ],- nativeSizes = Just (Set.fromList [8,16,32,64])- },- "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128",- Just "e-S128-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-v64:64:64-v128:128:128-f32:32:32-f64:64:64-f80:128:128-a0:0:64-s0:64:64-n8:16:32:64"- )- ]- ]- ]
test/LLVM/General/Test/ExecutionEngine.hs view
@@ -38,9 +38,9 @@ testJIT withEE = withContext $ \context -> withEE context $ \executionEngine -> do let mAST = Module "runSomethingModule" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "_foo",- G.parameters = ([Parameter i32 (Name "bar") []],False),+ G.parameters = ([Parameter (IntegerType 32) (Name "bar") []],False), G.basicBlocks = [ BasicBlock (UnName 0) [] ( Do $ Ret (Just (ConstantOperand (C.Int 32 42))) []
test/LLVM/General/Test/Global.hs view
@@ -9,7 +9,6 @@ import LLVM.General.Context import LLVM.General.Module import LLVM.General.AST-import LLVM.General.AST.Type as A.T import qualified LLVM.General.AST.Global as G tests = testGroup "Global" [@@ -23,12 +22,12 @@ g <- [ globalVariableDefaults { G.name = UnName 0,- G.type' = i32,+ G.type' = IntegerType 32, G.alignment = a, G.section = s }, functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.parameters = ([], False), G.alignment = a,
test/LLVM/General/Test/InlineAssembly.hs view
@@ -10,7 +10,6 @@ import LLVM.General.Module import LLVM.General.AST-import LLVM.General.AST.Type import LLVM.General.AST.InlineAssembly as IA import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V@@ -23,9 +22,9 @@ let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []],False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []],False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Call {@@ -33,7 +32,7 @@ callingConvention = CC.C, returnAttributes = [], function = Left $ InlineAssembly {- IA.type' = FunctionType i32 [i32] False,+ IA.type' = FunctionType (IntegerType 32) [IntegerType 32] False, assembly = "bswap $0", constraints = "=r,r", hasSideEffects = False,@@ -41,13 +40,13 @@ dialect = ATTDialect }, arguments = [- (LocalReference i32 (Name "x"), [])+ (LocalReference (Name "x"), []) ], functionAttributes = [], metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (UnName 1))) []+ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ] }@@ -67,7 +66,7 @@ ModuleInlineAssembly "bar", GlobalDefinition $ globalVariableDefaults { G.name = UnName 0,- G.type' = i32+ G.type' = IntegerType 32 } ] s = "; ModuleID = '<string>'\n\
test/LLVM/General/Test/Instructions.hs view
@@ -16,7 +16,7 @@ import LLVM.General.Module import LLVM.General.Diagnostic import LLVM.General.AST-import LLVM.General.AST.Type as A.T+import LLVM.General.AST.Type import LLVM.General.AST.Name import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred@@ -34,9 +34,17 @@ testCase name $ do let mAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0,- G.parameters = ([Parameter t (UnName n) [] | (t,n) <- zip ts [0..]], False),+ G.parameters = ([+ Parameter (IntegerType 32) (UnName 0) [],+ Parameter (FloatingPointType 32 IEEE) (UnName 1) [],+ Parameter (PointerType (IntegerType 32) (AddrSpace 0)) (UnName 2) [],+ Parameter (IntegerType 64) (UnName 3) [],+ Parameter (IntegerType 1) (UnName 4) [],+ Parameter (VectorType 2 (IntegerType 32)) (UnName 5) [],+ Parameter (StructureType False [IntegerType 32, IntegerType 32]) (UnName 6) []+ ], False), G.basicBlocks = [ BasicBlock (UnName 7) [ namedInstr@@ -53,16 +61,7 @@ \ ret void\n\ \}\n" strCheck mAST mStr- | let ts = [- i32,- float,- ptr i32,- i64,- i1,- VectorType 2 i32,- StructureType False [i32, i32]- ],- let a i = LocalReference (ts !! fromIntegral i) (UnName i),+ | let a = LocalReference . UnName, (name, namedInstr, namedInstrS) <- ( [ (name, UnName 8 := instr, "%8 = " ++ instrS)@@ -96,7 +95,6 @@ "add nuw i32 %0, %0"), ("fadd", FAdd {- fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -113,7 +111,6 @@ "sub i32 %0, %0"), ("fsub", FSub {- fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -130,7 +127,6 @@ "mul i32 %0, %0"), ("fmul", FMul {- fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -162,7 +158,6 @@ "sdiv i32 %0, %0"), ("fdiv", FDiv {- fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] @@ -184,20 +179,11 @@ "srem i32 %0, %0"), ("frem", FRem {- fastMathFlags = NoFastMathFlags, operand0 = a 1, operand1 = a 1, metadata = [] }, "frem float %1, %1"),- ("frem fast",- FRem {- fastMathFlags = UnsafeAlgebra,- operand0 = a 1,- operand1 = a 1,- metadata = [] - },- "frem fast float %1, %1"), ("shl", Shl { nsw = False,@@ -246,7 +232,7 @@ "xor i32 %0, %0"), ("alloca", Alloca {- allocatedType = i32,+ allocatedType = IntegerType 32, numElements = Nothing, alignment = 0, metadata = [] @@ -336,87 +322,94 @@ ("trunc", Trunc { operand0 = a 0,- type' = i16,+ type' = IntegerType 16, metadata = [] }, "trunc i32 %0 to i16"), ("zext", ZExt { operand0 = a 0,- type' = i64,+ type' = IntegerType 64, metadata = [] }, "zext i32 %0 to i64"), ("sext", SExt { operand0 = a 0,- type' = i64,+ type' = IntegerType 64, metadata = [] }, "sext i32 %0 to i64"), ("fptoui", FPToUI { operand0 = a 1,- type' = i64,+ type' = IntegerType 64, metadata = [] }, "fptoui float %1 to i64"), ("fptosi", FPToSI { operand0 = a 1,- type' = i64,+ type' = IntegerType 64, metadata = [] }, "fptosi float %1 to i64"), ("uitofp", UIToFP { operand0 = a 0,- type' = float,+ type' = FloatingPointType 32 IEEE, metadata = [] }, "uitofp i32 %0 to float"), ("sitofp", SIToFP { operand0 = a 0,- type' = float,+ type' = FloatingPointType 32 IEEE, metadata = [] }, "sitofp i32 %0 to float"), ("fptrunc", FPTrunc { operand0 = a 1,- type' = half,+ type' = FloatingPointType 16 IEEE, metadata = [] }, "fptrunc float %1 to half"), ("fpext", FPExt { operand0 = a 1,- type' = double,+ type' = FloatingPointType 64 IEEE, metadata = [] }, "fpext float %1 to double"), ("ptrtoint", PtrToInt { operand0 = a 2,- type' = i32,+ type' = IntegerType 32, metadata = [] }, "ptrtoint i32* %2 to i32"), ("inttoptr", IntToPtr { operand0 = a 0,- type' = ptr i32,+ type' = PointerType (IntegerType 32) (AddrSpace 0), metadata = [] }, "inttoptr i32 %0 to i32*"), ("bitcast", BitCast { operand0 = a 0,- type' = float,+ type' = FloatingPointType 32 IEEE, metadata = [] }, "bitcast i32 %0 to float"),+ ("addrspacecast",+ AddrSpaceCast {+ operand0 = a 2,+ type' = PointerType (IntegerType 32) (AddrSpace 2),+ metadata = [] + },+ "addrspacecast i32* %2 to i32 addrspace(2)*"), ("select", Select { condition' = a 4,@@ -428,7 +421,7 @@ ("vaarg", VAArg { argList = a 2,- type' = i16,+ type' = IntegerType 16, metadata = [] }, "va_arg i32* %2, i16"),@@ -474,10 +467,10 @@ ("landingpad-" ++ n, LandingPad { type' = StructureType False [ - ptr i8,- i32+ PointerType (IntegerType 8) (AddrSpace 0),+ IntegerType 32 ],- personalityFunction = ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0)),+ personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)), cleanup = cp, clauses = cls, metadata = []@@ -485,10 +478,10 @@ "landingpad { i8*, i32 } personality void (i32, float, i32*, i64, i1, <2 x i32>, { i32, i32 })* @0" ++ s) | (clsn,cls,clss) <- [ ("catch",- [Catch (C.Null (ptr i8))],+ [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))], "\n catch i8* null"), ("filter",- [Filter (C.Null (ArrayType 1 (ptr i8)))],+ [Filter (C.Null (ArrayType 1 (PointerType (IntegerType 8) (AddrSpace 0))))], "\n filter [1 x i8*] zeroinitializer") ], (cpn, cp, cps) <- [ ("-cleanup", True, "\n cleanup"), ("", False, "") ],@@ -555,8 +548,8 @@ isTailCall = False, callingConvention = CC.C, returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void ts False)) (UnName 0))),- arguments = [ (a i, []) | i <- [0..6] ],+ function = Right (ConstantOperand (C.GlobalReference (UnName 0))),+ arguments = [ (LocalReference (UnName i), []) | i <- [0..6] ], functionAttributes = [], metadata = [] },@@ -568,30 +561,30 @@ let mAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ globalVariableDefaults { G.name = Name "fortytwo",- G.type' = i32,+ G.type' = IntegerType 32, G.isConstant = True, G.initializer = Just $ C.Int 32 42 }, GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 1) [ UnName 2 := GetElementPtr { inBounds = True,- address = ConstantOperand (C.GlobalReference (ptr i32) (Name "fortytwo")),+ address = ConstantOperand (C.GlobalReference (Name "fortytwo")), indices = [ ConstantOperand (C.Int 32 0) ], metadata = [] }, UnName 3 := Load { volatile = False,- address = LocalReference (ptr i32) (UnName 2),+ address = LocalReference (UnName 2), maybeAtomicity = Nothing, alignment = 1, metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (UnName 3))) []+ Do $ Ret (Just (LocalReference (UnName 3))) [] ) ] }@@ -614,7 +607,7 @@ "ret", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [@@ -633,7 +626,7 @@ "br", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (@@ -657,7 +650,7 @@ "condbr", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.basicBlocks = [ BasicBlock (Name "bar") [] (@@ -682,7 +675,7 @@ "switch", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (@@ -721,24 +714,24 @@ Module "<string>" Nothing Nothing [ GlobalDefinition $ globalVariableDefaults { G.name = UnName 0,- G.type' = ptr i8,+ G.type' = PointerType (IntegerType 8) (AddrSpace 0), G.initializer = Just (C.BlockAddress (Name "foo") (UnName 2)) }, GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Load { volatile = False,- address = ConstantOperand (C.GlobalReference (ptr (ptr i8)) (UnName 0)),+ address = ConstantOperand (C.GlobalReference (UnName 0)), maybeAtomicity = Nothing, alignment = 0, metadata = [] } ] ( Do $ IndirectBr {- operand0' = LocalReference (ptr i8) (UnName 1),+ operand0' = LocalReference (UnName 1), possibleDests = [UnName 2], metadata' = [] }@@ -765,18 +758,18 @@ "invoke", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.parameters = ([- Parameter i32 (UnName 0) [],- Parameter i16 (UnName 1) []+ 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 (ptr (FunctionType A.T.void [i32, i16] False)) (UnName 0))),+ function' = Right (ConstantOperand (C.GlobalReference (UnName 0))), arguments' = [ (ConstantOperand (C.Int 32 4), []), (ConstantOperand (C.Int 16 8), [])@@ -793,12 +786,12 @@ BasicBlock (Name "bar") [ UnName 3 := LandingPad { type' = StructureType False [ - ptr i8,- i32+ PointerType (IntegerType 8) (AddrSpace 0),+ IntegerType 32 ],- personalityFunction = ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [i32, i16] False)) (UnName 0)),+ personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)), cleanup = True,- clauses = [Catch (C.Null (ptr i8))],+ clauses = [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))], metadata = [] } ] (@@ -826,7 +819,7 @@ "resume", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (@@ -844,7 +837,7 @@ "unreachable", Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = UnName 0, G.basicBlocks = [ BasicBlock (UnName 0) [] (
test/LLVM/General/Test/Instrumentation.hs view
@@ -6,8 +6,7 @@ import LLVM.General.Test.Support -import Control.Monad.Trans.Except -+import Control.Monad.Error import Data.Functor import qualified Data.List as List import qualified Data.Set as Set@@ -38,77 +37,66 @@ moduleAST mIn' ast = do- dl <- withHostTargetMachine getTargetMachineDataLayout+ dl <- withDefaultTargetMachine getTargetMachineDataLayout return $ Module "<string>" (Just dl) Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i128 (Name "x") []],False),+ G.parameters = ([Parameter (IntegerType 128) (Name "x") []],False), G.basicBlocks = [ BasicBlock (UnName 0) [] (Do $ Br (Name "checkDone") []), BasicBlock (Name "checkDone") [ UnName 1 := Phi {- type' = i128,+ type' = IntegerType 128, incomingValues = [- (LocalReference i128 (Name "x"), UnName 0),- (LocalReference i128 (Name "x'"), Name "even"),- (LocalReference i128 (Name "x''"), Name "odd")+ (LocalReference (Name "x"), UnName 0),+ (LocalReference (Name "x'"), Name "even"),+ (LocalReference (Name "x''"), Name "odd") ], metadata = [] }, Name "count" := Phi {- type' = i32,+ type' = IntegerType 32, incomingValues = [ (ConstantOperand (C.Int 32 1), UnName 0),- (LocalReference i32 (Name "count'"), Name "even"),- (LocalReference i32 (Name "count'"), Name "odd")+ (LocalReference (Name "count'"), Name "even"),+ (LocalReference (Name "count'"), Name "odd") ], metadata = [] },- Name "count'" := Add {- nsw = False,- nuw = False,- operand0 = LocalReference i32 (Name "count"),- operand1 = ConstantOperand (C.Int 32 1),- metadata = []- },- Name "is one" := ICmp {- iPredicate = IPred.EQ,- operand0 = LocalReference i128 (UnName 1),- operand1 = ConstantOperand (C.Int 128 1),- metadata = []- }+ 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 i1 (Name "is one")) (Name "done") (Name "checkOdd") []+ Do $ CondBr (LocalReference (Name "is one")) (Name "done") (Name "checkOdd") [] ), BasicBlock (Name "checkOdd") [- Name "is odd" := Trunc (LocalReference i128 (UnName 1)) i1 []+ Name "is odd" := Trunc (LocalReference (UnName 1)) (IntegerType 1) [] ] (- Do $ CondBr (LocalReference i1 (Name "is odd")) (Name "odd") (Name "even") []+ Do $ CondBr (LocalReference (Name "is odd")) (Name "odd") (Name "even") [] ), BasicBlock (Name "even") [- Name "x'" := UDiv True (LocalReference i128 (UnName 1)) (ConstantOperand (C.Int 128 2)) []+ 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 i128 (UnName 1)) (ConstantOperand (C.Int 128 3)) [],- Name "x''" := Add False False (LocalReference i128 (UnName 2)) (ConstantOperand (C.Int 128 1)) []+ 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 i32 (Name "count'"))) []+ Do $ Ret (Just (LocalReference (Name "count'"))) [] ) ] }, GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "main", G.parameters = ([- Parameter i32 (Name "argc") [],- Parameter (ptr (ptr i8)) (Name "argv") []+ Parameter (IntegerType 32) (Name "argc") [],+ Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") [] ],False), G.basicBlocks = [ BasicBlock (UnName 0) [@@ -116,7 +104,7 @@ isTailCall = False, callingConvention = CC.C, returnAttributes = [],- function = Right (ConstantOperand (C.GlobalReference (FunctionType i32 [i32, ptr (ptr i8)] False) (Name "foo"))),+ function = Right (ConstantOperand (C.GlobalReference (Name "foo"))), arguments = [ (ConstantOperand (C.Int 128 9491828328), []) ],@@ -124,7 +112,7 @@ metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (UnName 1))) []+ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ] }@@ -135,21 +123,20 @@ testCase n $ do triple <- getProcessTargetTriple withTargetLibraryInfo triple $ \tli -> do- Right dl <- runExceptT $ withHostTargetMachine getTargetMachineDataLayout- Right ast <- runExceptT ast+ 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), ("AddressSanitizerModule", defaultAddressSanitizerModule), ("MemorySanitizer", defaultMemorySanitizer), ("ThreadSanitizer", defaultThreadSanitizer),- ("BoundsChecking", BoundsChecking)+ ("BoundsChecking", BoundsChecking),+-- ("DebugGeneratedIR", defaultDebugGeneratedIR),+ ("DebugExistingIR", DebugExistingIR) ] ] ]
test/LLVM/General/Test/Linking.hs view
@@ -6,7 +6,7 @@ import LLVM.General.Test.Support -import Control.Monad.Trans.Except+import Control.Monad.Error import Data.Functor import qualified Data.Set as Set import qualified Data.Map as Map@@ -36,24 +36,24 @@ ast0 = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.linkage = L.Private,- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "private0" }, GlobalDefinition $ functionDefaults { G.linkage = L.External,- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "external0" } ] ast1 = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.linkage = L.Private,- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "private1" }, GlobalDefinition $ functionDefaults { G.linkage = L.External,- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "external1" } ] @@ -61,7 +61,7 @@ Module { moduleDefinitions = defs } <- withContext $ \context -> withModuleFromAST' context ast0 $ \m0 -> withModuleFromAST' context ast1 $ \m1 -> do- runExceptT $ linkModules False m0 m1+ 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
@@ -7,8 +7,6 @@ import LLVM.General.Test.Support import LLVM.General.AST as A-import LLVM.General.AST.Type as A.T-import LLVM.General.AST.AddrSpace as A import qualified LLVM.General.AST.Linkage as L import qualified LLVM.General.AST.Visibility as V import qualified LLVM.General.AST.CallingConvention as CC@@ -18,15 +16,15 @@ tests = testGroup "Metadata" [ testCase "local" $ do let ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = i32 },+ GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = IntegerType 32 }, GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Load { volatile = False,- address = ConstantOperand (C.GlobalReference (ptr i32) (UnName 0)),+ address = ConstantOperand (C.GlobalReference (UnName 0)), maybeAtomicity = Nothing, A.alignment = 0, metadata = []@@ -36,7 +34,7 @@ ( "my-metadatum", MetadataNode [- Just $ LocalReference i32 (UnName 1),+ Just $ LocalReference (UnName 1), Just $ MetadataStringOperand "super hyper", Nothing ]@@ -59,7 +57,7 @@ testCase "global" $ do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [@@ -127,7 +125,7 @@ testCase "metadata-global" $ do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [@@ -137,7 +135,7 @@ ] }, MetadataNodeDefinition (MetadataNodeID 0) [- Just $ ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [] False)) (Name "foo"))+ Just $ ConstantOperand (C.GlobalReference (Name "foo")) ] ] let s = "; ModuleID = '<string>'\n\
test/LLVM/General/Test/Module.hs view
@@ -6,19 +6,18 @@ import LLVM.General.Test.Support -import Control.Monad.Trans.Except+import Control.Monad.Error import Data.Bits import Data.Word+import Data.Functor -import qualified Data.Map as Map+import qualified Data.Set as Set import LLVM.General.Context import LLVM.General.Module-import LLVM.General.Analysis import LLVM.General.Diagnostic import LLVM.General.Target import LLVM.General.AST-import LLVM.General.AST.Type as A.T import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred @@ -49,12 +48,12 @@ \@two = alias i32 addrspace(3)* @three\n\ \\n\ \define i32 @bar() {\n\- \ %1 = call zeroext i32 @foo(i32 inreg align 16 1, i8 signext 4) #0\n\+ \ %1 = call zeroext i32 @foo(i32 inreg 1, i8 signext 4) #0\n\ \ ret i32 %1\n\ \}\n\ \\n\ \; Function Attrs: nounwind readnone uwtable\n\- \define zeroext i32 @foo(i32 inreg align 16 %x, i8 signext %y) #0 {\n\+ \define zeroext i32 @foo(i32 inreg %x, i8 signext %y) #0 {\n\ \ %1 = mul nsw i32 %x, %x\n\ \ br label %here\n\ \\n\@@ -76,27 +75,27 @@ handAST = Module "<string>" Nothing Nothing [ TypeDefinition (UnName 0) ( Just $ StructureType False [- i32,- ptr (NamedTypeReference (UnName 1)),- ptr (NamedTypeReference (UnName 0))+ IntegerType 32,+ PointerType (NamedTypeReference (UnName 1)) (AddrSpace 0),+ PointerType (NamedTypeReference (UnName 0)) (AddrSpace 0) ]), TypeDefinition (UnName 1) Nothing, GlobalDefinition $ globalVariableDefaults { G.name = UnName 0,- G.type' = i32,+ G.type' = IntegerType 32, G.initializer = Just (C.Int 32 1) }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 1, G.visibility = V.Protected,- G.type' = i32,+ G.type' = IntegerType 32, G.addrSpace = AddrSpace 3, G.section = Just "foo" }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 2, G.hasUnnamedAddr = True,- G.type' = i8,+ G.type' = IntegerType 8, G.initializer = Just (C.Int 8 2) }, GlobalDefinition $ globalVariableDefaults {@@ -105,27 +104,27 @@ }, GlobalDefinition $ globalVariableDefaults { G.name = UnName 4,- G.type' = ArrayType (1 `shift` 32) i32+ G.type' = ArrayType (1 `shift` 32) (IntegerType 32) }, GlobalDefinition $ globalVariableDefaults { G.name = Name ".argyle",- G.type' = i32,+ G.type' = IntegerType 32, G.initializer = Just (C.Int 32 0), G.isThreadLocal = True }, GlobalDefinition $ globalAliasDefaults { G.name = Name "three", G.linkage = L.Private,- G.type' = PointerType i32 (AddrSpace 3),- G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1)+ G.type' = PointerType (IntegerType 32) (AddrSpace 3),+ G.aliasee = C.GlobalReference (UnName 1) }, GlobalDefinition $ globalAliasDefaults { G.name = Name "two",- G.type' = PointerType i32 (AddrSpace 3),- G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (Name "three")+ G.type' = PointerType (IntegerType 32) (AddrSpace 3),+ G.aliasee = C.GlobalReference (Name "three") }, GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "bar", G.basicBlocks = [ BasicBlock (UnName 0) [@@ -133,26 +132,26 @@ isTailCall = False, callingConvention = CC.C, returnAttributes = [A.ZeroExt],- function = Right (ConstantOperand (C.GlobalReference (ptr (FunctionType i32 [i32, i8] False)) (Name "foo"))),+ function = Right (ConstantOperand (C.GlobalReference (Name "foo"))), arguments = [- (ConstantOperand (C.Int 32 1), [A.InReg, A.Alignment 16]),+ (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 i32 (UnName 1))) []+ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ] }, GlobalDefinition $ functionDefaults { G.returnAttributes = [A.ZeroExt],- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo", G.parameters = ([- Parameter i32 (Name "x") [A.InReg, A.Alignment 16],- Parameter i8 (Name "y") [A.SignExt]+ 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 = [@@ -160,8 +159,8 @@ UnName 1 := Mul { nsw = True, nuw = False,- operand0 = LocalReference i32 (Name "x"),- operand1 = LocalReference i32 (Name "x"),+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"), metadata = [] } ] (@@ -170,13 +169,13 @@ BasicBlock (Name "here") [ Name "go" := ICmp { iPredicate = IPred.EQ,- operand0 = LocalReference i32 (UnName 1),- operand1 = LocalReference i32 (Name "x"),+ operand0 = LocalReference (UnName 1),+ operand1 = LocalReference (Name "x"), metadata = [] } ] ( Do $ CondBr {- condition = LocalReference i1 (Name "go"),+ condition = LocalReference (Name "go"), trueDest = Name "there", falseDest = Name "elsewhere", metadata' = []@@ -186,7 +185,7 @@ UnName 2 := Add { nsw = True, nuw = False,- operand0 = LocalReference i32 (UnName 1),+ operand0 = LocalReference (UnName 1), operand1 = ConstantOperand (C.Int 32 3), metadata = [] }@@ -195,7 +194,7 @@ ), BasicBlock (Name "elsewhere") [ Name "r" := Phi {- type' = i32,+ type' = IntegerType 32, incomingValues = [ (ConstantOperand (C.Int 32 2), Name "there"), (ConstantOperand (C.Int 32 57), Name "here")@@ -203,7 +202,7 @@ metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (Name "r"))) []+ Do $ Ret (Just (LocalReference (Name "r"))) [] ) ] }@@ -233,7 +232,7 @@ a <- withModuleFromLLVMAssembly' context s $ \m -> do (t, _) <- failInIO $ lookupTarget Nothing "x86_64-unknown-linux" withTargetOptions $ \to -> do- withTargetMachine t "" "" Map.empty to R.Default CM.Default CGO.Default $ \tm -> do+ withTargetMachine t "" "" Set.empty to R.Default CM.Default CGO.Default $ \tm -> do failInIO $ moduleTargetAssembly tm m a @?= "\t.file\t\"<string>\"\n\ \\t.text\n\@@ -276,83 +275,12 @@ ast @?= defaultModule { moduleTargetTriple = Just "x86_64-unknown-linux" }, testGroup "regression" [- testCase "minimal type info" $ withContext $ \context -> do- let s = "; ModuleID = '<string>'\n\- \\n\- \define void @trouble() {\n\- \entry:\n\- \ ret void\n\- \\n\- \dead0: ; preds = %dead1\n\- \ %x0 = add i32 %x1, %x1\n\- \ br label %dead1\n\- \\n\- \dead1: ; preds = %dead0\n\- \ %x1 = add i32 %x0, %x0\n\- \ br label %dead0\n\- \}\n"- ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,- G.name = Name "trouble",- G.basicBlocks = [- BasicBlock (Name "entry") [- ] (- Do $ Ret Nothing []- ),- BasicBlock (Name "dead0") [- Name "x0" := Add {- nsw = False,- nuw = False,- operand0 = LocalReference i32 (Name "x1"),- operand1 = LocalReference i32 (Name "x1"),- metadata = []- }- ] (- Do $ Br (Name "dead1") []- ),- BasicBlock (Name "dead1") [- Name "x1" := Add {- nsw = False,- nuw = False,- operand0 = LocalReference i32 (Name "x0"),- operand1 = LocalReference i32 (Name "x0"),- metadata = []- }- ] (- Do $ Br (Name "dead0") []- )- ]- }- ]- strCheck ast s- s' <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify- s' @?= Right (),-- testCase "metadata type" $ withContext $ \context -> do- let s = "; ModuleID = '<string>'\n\- \\n\- \define void @bar(metadata) {\n\- \ ret void\n\- \}\n"- ast = Module "<string>" Nothing Nothing [- GlobalDefinition $ functionDefaults {- G.returnType = void,- G.name = Name "bar",- G.parameters = ([Parameter MetadataType (UnName 0) []], False),- G.basicBlocks = [- BasicBlock (UnName 1) [] (Do $ Ret Nothing [])- ]- }- ]- strCheck ast s,- testCase "set flag on constant expr" $ withContext $ \context -> do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul {@@ -367,7 +295,7 @@ ), BasicBlock (Name "here") [ ] (- Do $ Ret (Just (LocalReference i32 (UnName 1))) []+ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ] }@@ -378,23 +306,23 @@ testCase "Phi node finishes" $ withContext $ \context -> do let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { nsw = True, nuw = False,- operand0 = LocalReference i32 (Name "x"),- operand1 = LocalReference i32 (Name "x"),+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"), metadata = [] } ] ( Do $ Br (Name "here") [] ), BasicBlock (Name "here") [- UnName 2 := Phi i32 [ (ConstantOperand (C.Int 32 42), UnName 0) ] []+ UnName 2 := Phi (IntegerType 32) [ (ConstantOperand (C.Int 32 42), UnName 0) ] [] ] ( Do $ Br (Name "elsewhere") [] ),@@ -404,7 +332,7 @@ ), BasicBlock (Name "there") [ ] (- Do $ Ret (Just (LocalReference i32 (UnName 1))) []+ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ] }@@ -438,51 +366,33 @@ let ast = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults { G.name = Name "foo",- G.returnType = i32,- G.parameters = ([Parameter i32 (UnName 0) []], False),+ G.returnType = IntegerType 32,+ G.parameters = ([Parameter (IntegerType 32) (UnName 0) []], False), G.basicBlocks = [- BasicBlock (UnName 1) [] (Do $ Switch (LocalReference i32 (UnName 0)) (Name "end") cbps [])+ 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 i32 vbps []+ Name "val" := Phi (IntegerType 32) vbps [] ] (- Do $ Ret (Just (LocalReference i32 (Name "val"))) []+ Do $ Ret (Just (LocalReference (Name "val"))) [] ) ] } ] s <- withModuleFromAST' context ast moduleLLVMAssembly m <- withModuleFromLLVMAssembly' context s moduleAST- m @?= ast,-- testCase "struct constant" $ do- let s = "; ModuleID = '<string>'\n\- \\n\- \%0 = type { i32 }\n\- \\n\- \@0 = constant %0 { i32 1 }, align 4\n"- ast = Module "<string>" Nothing Nothing [- TypeDefinition (UnName 0) (Just $ StructureType False [i32]),- GlobalDefinition $ globalVariableDefaults {- G.name = UnName 0,- G.isConstant = True,- G.type' = NamedTypeReference (UnName 0),- G.initializer = Just $ C.Struct (Just $ UnName 0) False [ C.Int 32 1 ],- G.alignment = 4- }- ]- strCheck ast s+ m @?= ast ], testGroup "failures" [ testCase "bad block reference" $ withContext $ \context -> do let badAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul {@@ -497,42 +407,42 @@ ), BasicBlock (Name "here") [ ] (- Do $ Ret (Just (LocalReference i32 (UnName 1))) []+ Do $ Ret (Just (LocalReference (UnName 1))) [] ) ] } ]- t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True+ 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 = i32,+ G.returnType = IntegerType 32, G.name = Name "foo", G.basicBlocks = [ BasicBlock (UnName 0) [ UnName 1 := Mul { nsw = False, nuw = False,- operand0 = LocalReference i32 (Name "unknown"),+ operand0 = LocalReference (Name "unknown"), operand1 = ConstantOperand (C.Int 32 1), metadata = [] }, UnName 2 := Mul { nsw = False, nuw = False,- operand0 = LocalReference i32 (Name "unknown2"),- operand1 = LocalReference i32 (UnName 1),+ operand0 = LocalReference (Name "unknown2"),+ operand1 = LocalReference (UnName 1), metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (UnName 2))) []+ Do $ Ret (Just (LocalReference (UnName 2))) [] ) ] } ]- t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True+ t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True t @?= Left "reference to undefined local: Name \"unknown\"" ] ]
test/LLVM/General/Test/Optimization.hs view
@@ -7,6 +7,7 @@ import LLVM.General.Test.Support import Data.Functor+import qualified Data.Set as Set import qualified Data.Map as Map import LLVM.General.Module@@ -16,7 +17,7 @@ import LLVM.General.Target import LLVM.General.AST as A-import LLVM.General.AST.Type as A.T+import LLVM.General.AST.Type import LLVM.General.AST.Name import LLVM.General.AST.AddrSpace import LLVM.General.AST.DataLayout@@ -35,9 +36,9 @@ handAST = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], G.basicBlocks = [ BasicBlock (UnName 0) [@@ -54,13 +55,13 @@ BasicBlock (Name "here") [ Name "go" := ICmp { iPredicate = IPred.EQ,- operand0 = LocalReference i32 (UnName 1),+ operand0 = LocalReference (UnName 1), operand1 = ConstantOperand (C.Int 32 42), metadata = [] } ] ( Do $ CondBr {- condition = LocalReference i1 (Name "go"),+ condition = LocalReference (Name "go"), trueDest = Name "take", falseDest = Name "done", metadata' = []@@ -70,8 +71,8 @@ UnName 2 := Sub { nsw = False, nuw = False,- operand0 = LocalReference i32 (Name "x"),- operand1 = LocalReference i32 (Name "x"),+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"), metadata = [] } ] (@@ -79,28 +80,20 @@ ), BasicBlock (Name "done") [ Name "r" := Phi {- type' = i32,+ type' = IntegerType 32, incomingValues = [- (LocalReference i32 (UnName 2), Name "take"),+ (LocalReference (UnName 2), Name "take"), (ConstantOperand (C.Int 32 57), Name "here") ], metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (Name "r"))) []+ Do $ Ret (Just (LocalReference (Name "r"))) [] ) ] } ] -isVectory :: A.Module -> Assertion-isVectory Module { moduleDefinitions = ds } =- (@? "Module is not vectory") $ not $ null [ i - | GlobalDefinition (Function { G.basicBlocks = b }) <- ds,- BasicBlock _ is _ <- b,- _ := i@(InsertElement {}) <- is- ]- optimize :: PassSetSpec -> A.Module -> IO A.Module optimize pss m = withContext $ \context -> withModuleFromAST' context m $ \mIn' -> do withPassManager pss $ \pm -> runPassManager pm mIn'@@ -112,9 +105,9 @@ mOut @?= Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable], G.basicBlocks = [ BasicBlock (Name "here") [@@ -131,9 +124,9 @@ mOut @?= Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ 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") []),@@ -149,8 +142,8 @@ UnName 1 := Sub { nsw = False, nuw = False,- operand0 = LocalReference i32 (Name "x"),- operand1 = LocalReference i32 (Name "x"),+ operand0 = LocalReference (Name "x"),+ operand1 = LocalReference (Name "x"), metadata = [] } ] (@@ -158,12 +151,12 @@ ), BasicBlock (Name "done") [ Name "r" := Phi {- type' = i32,- incomingValues = [(LocalReference i32 (UnName 1), Name "take"),(ConstantOperand (C.Int 32 57), Name "here")],+ type' = IntegerType 32,+ incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")], metadata = [] } ] (- Do $ Ret (Just (LocalReference i32 (Name "r"))) []+ Do $ Ret (Just (LocalReference (Name "r"))) [] ) ] }@@ -173,33 +166,129 @@ let mIn = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = double,+ G.returnType = FloatingPointType 64 IEEE, G.name = Name "foo", G.parameters = ([- Parameter double (Name (l ++ n)) []- | l <- [ "a", "b" ], n <- ["1", "2"]+ 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 (l ++ n) := op NoFastMathFlags (LocalReference double (Name (o1 ++ n))) (LocalReference double (Name (o2 ++ n))) []- | (l, op, o1, o2) <- [- ("x", FSub, "a", "b"),- ("y", FMul, "x", "a"),- ("z", FAdd, "y", "b")],- n <- ["1", "2"]- ] ++ [- Name "r" := FMul NoFastMathFlags (LocalReference double (Name "z1")) (LocalReference double (Name "z2")) []- ]) (Do $ Ret (Just (LocalReference double (Name "r"))) [])+ 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- isVectory mOut,+ 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"))) []+ )+ ]+ }+ ], testCase "LowerInvoke" $ do -- This test doesn't test much about what LowerInvoke does, just that it seems to work.@@ -209,15 +298,15 @@ let triple = "x86_64-apple-darwin" (target, _) <- failInIO $ lookupTarget Nothing triple withTargetOptions $ \targetOptions -> do- withTargetMachine target triple "" Map.empty targetOptions+ withTargetMachine target triple "" Set.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do withPassManager (defaultPassSetSpec { transforms = [LowerInvoke False], targetMachine = Just tm}) $ \passManager -> do let astIn = Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.basicBlocks = [ BasicBlock (Name "here") [ ] (@@ -231,9 +320,9 @@ moduleAST mIn astOut @?= Module "<string>" Nothing Nothing [ GlobalDefinition $ functionDefaults {- G.returnType = i32,+ G.returnType = IntegerType 32, G.name = Name "foo",- G.parameters = ([Parameter i32 (Name "x") []], False),+ G.parameters = ([Parameter (IntegerType 32) (Name "x") []], False), G.basicBlocks = [ BasicBlock (Name "here") [ ] (@@ -242,7 +331,7 @@ ] }, GlobalDefinition $ functionDefaults {- G.returnType = A.T.void,+ G.returnType = VoidType, G.name = Name "abort" } ]
test/LLVM/General/Test/Support.hs view
@@ -6,7 +6,7 @@ import Data.Functor import Control.Monad-import Control.Monad.Trans.Except+import Control.Monad.Error import LLVM.General.Context import LLVM.General.Module@@ -16,8 +16,8 @@ class FailInIO f where errorToString :: f -> String -failInIO :: FailInIO f => ExceptT f IO a -> IO a-failInIO = either (fail . errorToString) return <=< runExceptT+failInIO :: FailInIO f => ErrorT f IO a -> IO a+failInIO = either (fail . errorToString) return <=< runErrorT instance FailInIO String where errorToString = id
test/LLVM/General/Test/Target.hs view
@@ -14,7 +14,6 @@ import LLVM.General.Target import LLVM.General.Target.Options-import LLVM.General.Target.LibraryFunction instance Arbitrary FloatABI where arbitrary = elements [minBound .. maxBound]@@ -26,7 +25,6 @@ arbitrary = do printMachineCode <- arbitrary noFramePointerElimination <- arbitrary- noFramePointerEliminationNonLeaf <- arbitrary lessPreciseFloatingPointMultiplyAddOption <- arbitrary unsafeFloatingPointMath <- arbitrary noInfinitiesFloatingPointMath <- arbitrary@@ -34,12 +32,10 @@ honorSignDependentRoundingFloatingPointMathOption <- arbitrary useSoftFloat <- arbitrary noZerosInBSS <- arbitrary- jITExceptionHandling <- arbitrary jITEmitDebugInfo <- arbitrary jITEmitDebugInfoToDisk <- arbitrary guaranteedTailCallOptimization <- arbitrary disableTailCalls <- arbitrary- realignStack <- arbitrary enableFastInstructionSelection <- arbitrary positionIndependentExecutable <- arbitrary enableSegmentedStacks <- arbitrary@@ -48,34 +44,44 @@ trapFunctionName <- elements [ "foo", "bar", "baz" ] floatABIType <- arbitrary allowFloatingPointOperationFusion <- arbitrary- stackSmashingProtectionBufferSize <- arbitrary return Options { .. } tests = testGroup "Target" [ testGroup "Options" [- testProperty "basic" $ \options -> ioProperty $ do+ testGroup "regressions" [+ testCase "hurm" $ do+ withTargetOptions $ \to -> do+ let o = Options {+ printMachineCode = True,+ noFramePointerElimination = False,+ lessPreciseFloatingPointMultiplyAddOption = True,+ unsafeFloatingPointMath = True,+ noInfinitiesFloatingPointMath = True,+ noNaNsFloatingPointMath = False,+ honorSignDependentRoundingFloatingPointMathOption = True,+ useSoftFloat = True,+ noZerosInBSS = False,+ jITEmitDebugInfo = True,+ jITEmitDebugInfoToDisk = False,+ guaranteedTailCallOptimization = False,+ disableTailCalls = False,+ enableFastInstructionSelection = True,+ positionIndependentExecutable = True,+ enableSegmentedStacks = False,+ useInitArray = True,+ stackAlignmentOverride = 9432851444,+ trapFunctionName = "baz",+ floatABIType = FloatABISoft,+ allowFloatingPointOperationFusion = FloatingPointOperationFusionStrict+ }+ pokeTargetOptions o to+ o' <- peekTargetOptions to+ o' @?= o+ ],+ testProperty "basic" $ \options -> morallyDubiousIOProperty $ do withTargetOptions $ \to -> do pokeTargetOptions options to options' <- peekTargetOptions to return $ options == options'- ],- testGroup "LibraryFunction" [- testGroup "set-get" [- testCase (show lf) $ do- triple <- getDefaultTargetTriple- withTargetLibraryInfo triple $ \tli -> do- setLibraryFunctionAvailableWithName tli lf "foo"- nm <- getLibraryFunctionName tli lf- nm @?= "foo"- | lf <- [minBound, maxBound]- ],- testCase "get" $ do- triple <- getDefaultTargetTriple- withTargetLibraryInfo triple $ \tli -> do- lf <- getLibraryFunction tli "printf"- lf @?= Just LF__printf- ],- testCase "Host" $ do- features <- getHostCPUFeatures- return ()+ ] ]