packages feed

llvm-general (empty) → 0.1

raw patch · 130 files changed

+10452/−0 lines, 130 filesdep +HUnitdep +QuickCheckdep +arraybuild-type:Customsetup-changed

Dependencies added: HUnit, QuickCheck, array, base, bytestring, containers, llvm-general, mtl, parsec, setenv, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Benjamin S. Scarlet+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Benjamin S. Scarlet nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,82 @@+import Control.Monad+import Data.List (isPrefixOf, (\\))+import Data.Map (Map)+import qualified Data.Map as Map+import Distribution.Simple+import Distribution.Simple.Program+import Distribution.Simple.Setup+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import System.Environment+import System.SetEnv+import Distribution.System++++-- define these selectively in C files (where _not_ using HsFFI.h),+-- rather than universally in the ccOptions, because HsFFI.h currently defines them+-- without checking they're already defined and so causes warnings.+uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"]++llvmProgram = simpleProgram "llvm-config"++main = do+  let (ldLibraryPathVar, ldLibraryPathSep) = +        case buildOS of+          OSX -> ("DYLD_LIBRARY_PATH",":")+          _ -> ("LD_LIBRARY_PATH",":")+      addToLdLibraryPath s = do+         v <- lookupEnv ldLibraryPathVar+         setEnv ldLibraryPathVar (s ++ maybe "" (ldLibraryPathSep ++) v)+      getLLVMConfig configFlags = do+         let verbosity = fromFlag $ configVerbosity configFlags+         -- preconfigure the configuration-generating program "llvm-config"+         programDb <- configureProgram verbosity llvmProgram+                      . userSpecifyPaths (configProgramPaths configFlags)+                      . userSpecifyArgss (configProgramArgs configFlags)+                      $ configPrograms configFlags+         let llvmConfig :: [String] -> IO String+             llvmConfig = getDbProgramOutput verbosity llvmProgram programDb+         return llvmConfig+      addLLVMToLdLibraryPath configFlags = do+        llvmConfig <- getLLVMConfig configFlags+        [libDir] <- liftM lines $ llvmConfig ["--libdir"]+        addToLdLibraryPath libDir+         +  defaultMainWithHooks simpleUserHooks {+    hookedPrograms = [ llvmProgram ],+    confHook = \(genericPackageDescription, hookedBuildInfo) configFlags -> do+      llvmConfig <- getLLVMConfig configFlags++      cppflags <- llvmConfig ["--cppflags"]+      let useCppFlags = (filter ("-D" `isPrefixOf`) $ words cppflags) \\ (map ("-D"++) uncheckedHsFFIDefines)+      includeDirs <- liftM lines $ llvmConfig ["--includedir"]+      libDirs@[libDir] <- liftM lines $ llvmConfig ["--libdir"]++      let genericPackageDescription' = genericPackageDescription {+            condLibrary = do+              libraryCondTree <- condLibrary genericPackageDescription+              return libraryCondTree {+                condTreeData = +                  let library = condTreeData libraryCondTree+                  in library { +                    libBuildInfo = +                      let buildInfo = libBuildInfo library +                      in buildInfo { ccOptions = ccOptions buildInfo ++ useCppFlags }+                    }+              }+           }+          configFlags' = configFlags {+            configExtraLibDirs = libDirs ++ configExtraLibDirs configFlags,+            configExtraIncludeDirs = includeDirs ++ configExtraIncludeDirs configFlags+           }+      addLLVMToLdLibraryPath configFlags'+      confHook simpleUserHooks (genericPackageDescription', hookedBuildInfo) configFlags',+    buildHook = \packageDescription localBuildInfo userHooks buildFlags -> do+      addLLVMToLdLibraryPath (configFlags localBuildInfo)+      buildHook simpleUserHooks packageDescription localBuildInfo userHooks buildFlags,+    testHook = \packageDescription localBuildInfo userHooks testFlags -> do+      addLLVMToLdLibraryPath (configFlags localBuildInfo)+      testHook simpleUserHooks packageDescription localBuildInfo userHooks testFlags+   }+
+ llvm-general.cabal view
@@ -0,0 +1,186 @@+name: llvm-general+version: 0.1+license: BSD3+license-file: LICENSE+author: Benjamin S.Scarlet <fgthb0@greynode.net>+maintainer: Benjamin S. Scarlet <fgthb0@greynode.net>+copyright: Benjamin S. Scarlet 2013+build-type: Custom+cabal-version: >= 1.8+category: Compilers/Interpreters, Code Generation+synopsis: General purpose LLVM bindings+description:+  llvm-general is a set of Haskell bindings for LLVM <http://llvm.org/>. Unlike other current Haskell bindings,+	it uses an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>), and so offers two advantages: it+	handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not+	only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell.+extra-source-files:+  src/LLVM/General/Internal/FFI/Instruction.h+  src/LLVM/General/Internal/FFI/Value.h+  src/LLVM/General/Internal/FFI/SMDiagnostic.h+  src/LLVM/General/Internal/FFI/InlineAssembly.h+  src/LLVM/General/Internal/FFI/Target.h+  src/LLVM/General/Internal/FFI/Function.h+  src/LLVM/General/Internal/FFI/GlobalValue.h+  src/LLVM/General/Internal/FFI/Type.h+   +source-repository head+  type: git+  location: git://github.com/bscarlet/llvm-general.git++library+  build-tools: llvm-config+  ghc-options: -fwarn-unused-imports+  build-depends: +    base >= 3 && < 5,+    text >= 0.11.2.1,+    bytestring >= 0.9.1.10,+    transformers >= 0.3.0.0,+    mtl >= 2.0.1.0,+    template-haskell >= 2.5.0.0,+    containers >= 0.5.0.0,+    parsec >= 3.1.3,+    array >= 0.4.0.1,+    setenv >= 0.1.0+  extra-libraries: LLVM-3.2svn stdc+++  hs-source-dirs: src+  exposed-modules:+    LLVM.General+    LLVM.General.AST+    LLVM.General.AST.AddrSpace+    LLVM.General.AST.InlineAssembly+    LLVM.General.AST.Attribute+    LLVM.General.AST.CallingConvention+    LLVM.General.AST.Constant+    LLVM.General.AST.DataLayout+    LLVM.General.AST.Float+    LLVM.General.AST.FloatingPointPredicate+    LLVM.General.AST.Global+    LLVM.General.AST.Instruction+    LLVM.General.AST.IntegerPredicate+    LLVM.General.AST.Linkage+    LLVM.General.AST.Name+    LLVM.General.AST.Operand+    LLVM.General.AST.RMWOperation+    LLVM.General.AST.Type+    LLVM.General.AST.Visibility+    LLVM.General.CodeGenOpt+    LLVM.General.CodeModel+    LLVM.General.Context+    LLVM.General.Diagnostic+    LLVM.General.ExecutionEngine+    LLVM.General.Module+    LLVM.General.PassManager+    LLVM.General.Relocation+    LLVM.General.Target+    LLVM.General.Target.Options+    LLVM.General.Transforms++  other-modules:+    Control.Monad.Phased+    Control.Monad.Phased.Class+    Control.Monad.Trans.Phased+    Control.Monad.AnyCont+    Control.Monad.AnyCont.Class+    Control.Monad.Trans.AnyCont+    LLVM.General.Internal.Atomicity+    LLVM.General.Internal.Attribute+    LLVM.General.Internal.BasicBlock+    LLVM.General.Internal.CallingConvention+    LLVM.General.Internal.Coding+    LLVM.General.Internal.Constant+    LLVM.General.Internal.Context+    LLVM.General.Internal.DataLayout+    LLVM.General.Internal.DecodeAST+    LLVM.General.Internal.Diagnostic+    LLVM.General.Internal.EncodeAST+    LLVM.General.Internal.ExecutionEngine+    LLVM.General.Internal.FloatingPointPredicate+    LLVM.General.Internal.Function+    LLVM.General.Internal.Global+    LLVM.General.Internal.InlineAssembly+    LLVM.General.Internal.Instruction+    LLVM.General.Internal.InstructionDefs+    LLVM.General.Internal.IntegerPredicate+    LLVM.General.Internal.Metadata+    LLVM.General.Internal.Module+    LLVM.General.Internal.Operand+    LLVM.General.Internal.PassManager+    LLVM.General.Internal.RMWOperation+    LLVM.General.Internal.String+    LLVM.General.Internal.Target+    LLVM.General.Internal.Type+    LLVM.General.Internal.Value+    LLVM.General.Internal.FFI.Assembly+    LLVM.General.Internal.FFI.BasicBlock+    LLVM.General.Internal.FFI.BinaryOperator+    LLVM.General.Internal.FFI.Builder+    LLVM.General.Internal.FFI.Cleanup+    LLVM.General.Internal.FFI.Constant+    LLVM.General.Internal.FFI.Context+    LLVM.General.Internal.FFI.ExecutionEngine+    LLVM.General.Internal.FFI.Function+    LLVM.General.Internal.FFI.GlobalAlias+    LLVM.General.Internal.FFI.GlobalValue+    LLVM.General.Internal.FFI.GlobalVariable+    LLVM.General.Internal.FFI.InlineAssembly+    LLVM.General.Internal.FFI.Instruction+    LLVM.General.Internal.FFI.InstructionDefs+    LLVM.General.Internal.FFI.Iterate+    LLVM.General.Internal.FFI.LLVMCTypes+    LLVM.General.Internal.FFI.Metadata+    LLVM.General.Internal.FFI.Module+    LLVM.General.Internal.FFI.PassManager+    LLVM.General.Internal.FFI.PtrHierarchy+    LLVM.General.Internal.FFI.SMDiagnostic+    LLVM.General.Internal.FFI.Target+    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: +    src/LLVM/General/Internal/FFI/AssemblyC.cpp+    src/LLVM/General/Internal/FFI/BuilderC.cpp+    src/LLVM/General/Internal/FFI/ConstantC.cpp+    src/LLVM/General/Internal/FFI/FunctionC.cpp+    src/LLVM/General/Internal/FFI/GlobalAliasC.cpp+    src/LLVM/General/Internal/FFI/GlobalValueC.cpp+    src/LLVM/General/Internal/FFI/InlineAssemblyC.cpp+    src/LLVM/General/Internal/FFI/InstructionC.cpp+    src/LLVM/General/Internal/FFI/MetadataC.cpp+    src/LLVM/General/Internal/FFI/ModuleC.cpp+    src/LLVM/General/Internal/FFI/PassManagerC.cpp+    src/LLVM/General/Internal/FFI/SMDiagnosticC.cpp+    src/LLVM/General/Internal/FFI/TargetC.cpp+    src/LLVM/General/Internal/FFI/TypeC.cpp+    src/LLVM/General/Internal/FFI/ValueC.cpp++test-suite test+  type: exitcode-stdio-1.0+  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 >= 0.1,+    containers >= 0.5.0.0+  hs-source-dirs: test+  main-is: Test.hs+  other-modules:+    LLVM.General.Test.Constants+    LLVM.General.Test.DataLayout+    LLVM.General.Test.ExecutionEngine+    LLVM.General.Test.Global+    LLVM.General.Test.InlineAssembly+    LLVM.General.Test.Instructions+    LLVM.General.Test.Metadata+    LLVM.General.Test.Module+    LLVM.General.Test.Optimization+    LLVM.General.Test.Support+    LLVM.General.Test.Target+    LLVM.General.Test.Tests+
+ src/Control/Monad/AnyCont.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE+  FlexibleInstances,+  MultiParamTypeClasses,+  UndecidableInstances+  #-}+module Control.Monad.AnyCont (+    MonadAnyCont(..),+    AnyContT(..),+    runAnyContT,+    withAnyContT,+    mapAnyContT,+    anyContIOToM,+    anyContT+  ) where++import Control.Monad.Trans.AnyCont+import Control.Monad.AnyCont.Class+import Control.Monad.Trans.Class+import Control.Monad.State.Class+import Control.Monad.Error.Class++instance MonadState s m => MonadState s (AnyContT m) where+  get = lift get+  put = lift . put+  state = lift . state++instance MonadError e m => MonadError e (AnyContT m) where+  throwError = lift . throwError+  x `catchError` h = anyContT $ \f -> (runAnyContT x f) `catchError` (\e -> runAnyContT (h e) f)
+ src/Control/Monad/AnyCont/Class.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE+  RankNTypes,+  MultiParamTypeClasses,+  FunctionalDependencies,+  FlexibleInstances,+  UndecidableInstances+  #-}+module Control.Monad.AnyCont.Class where++import Control.Monad.Trans.Class+import Control.Monad.Trans.AnyCont (AnyContT)+import qualified Control.Monad.Trans.AnyCont as AnyCont+import Control.Monad.Trans.Error as Error+import Control.Monad.Trans.State as State+import Control.Monad.Trans.Phased as Phased+import Control.Monad.IO.Class++class MonadAnyCont b m | m -> b where+  anyContToM :: (forall r . (a -> b r) -> b r) -> m a+  scopeAnyCont :: m a -> m a++instance Monad m => MonadAnyCont m (AnyContT m) where+  anyContToM = AnyCont.anyContT+  scopeAnyCont = lift . flip AnyCont.runAnyContT return+                                     +instance (Error e, Monad m, MonadAnyCont b m) => MonadAnyCont b (ErrorT e m) where+  anyContToM = lift . anyContToM+  scopeAnyCont = mapErrorT scopeAnyCont++instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (PhasedT m) where+  anyContToM = lift . anyContToM+  scopeAnyCont = mapPhasedT scopeAnyCont++instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (StateT s m) where+  anyContToM = lift . anyContToM+  scopeAnyCont = StateT . (scopeAnyCont .) . runStateT++anyContIOToM :: MonadIO m => (forall r . (a -> IO r) -> IO r) -> AnyContT m a+anyContIOToM ioac = AnyCont.anyContT (\c -> liftIO (ioac return) >>= c)
+ src/Control/Monad/Phased.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE+  FlexibleInstances,+  MultiParamTypeClasses,+  UndecidableInstances+  #-}+module Control.Monad.Phased (+  MonadPhased(..),+  PhasedT(..),+  runPhasedT,+  forInterleavedM,+  iap,+  defer,+  runInterleaved,+  mapPhasedT+  ) where++import Control.Monad+import Control.Monad.Trans.Phased++import Control.Monad.Trans.Class+import Control.Monad.State.Class+import Control.Monad.Reader.Class+import Control.Monad.Error.Class+import Control.Monad.Phased.Class++instance MonadState s m => MonadState s (PhasedT m) where+  state = lift . state++instance MonadReader r m => MonadReader r (PhasedT m) where+  ask = lift ask+  local f = PhasedT . local f . liftM (either (Left . local f) Right) . unPhasedT++instance (MonadError e m) => MonadError e (PhasedT m) where+  throwError = lift . throwError+  catchError pa ph = mapPhasedT (`catchError` (unPhasedT . ph)) pa+
+ src/Control/Monad/Phased/Class.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE+  MultiParamTypeClasses,+  UndecidableInstances,+  FlexibleInstances,+  TupleSections+  #-}+module Control.Monad.Phased.Class where++import Control.Monad.Trans.Class+import Control.Monad.Trans.Phased+import Control.Monad.Trans.AnyCont++class Monad m => MonadPhased m where+  later :: m a -> m a+  interleavePhasesWith :: (a -> b -> c) -> m a -> m b -> m c+  mergePhases :: m a -> m a++iap :: MonadPhased m => m (a -> b) -> m a -> m b+iap = interleavePhasesWith ($)++runInterleaved :: (MonadPhased m) => [m a] -> m [a]+runInterleaved = foldr (interleavePhasesWith (:)) (return [])++forInterleavedM x = runInterleaved . flip map x++defer :: MonadPhased m => m ()+defer = later (return ())++instance Monad m => MonadPhased (PhasedT m) where+  later = PhasedT . return . Left+  interleavePhasesWith p (PhasedT mx) (PhasedT my) = PhasedT $ do+    x <- mx+    y <- my+    return $ case (x,y) of+      (Right a, Right b) -> Right (p a b)+      _ -> Left $ interleavePhasesWith p (stall x) (stall y)+           where stall = either id return+  mergePhases = lift . runPhasedT++instance MonadPhased m => MonadPhased (AnyContT m) where+  later = lift . later . flip runAnyContT return+  interleavePhasesWith p mx my = +    anyContT $ (>>=) $ interleavePhasesWith p (runAnyContT mx return) (runAnyContT my return)+  mergePhases ma = anyContT (mergePhases (runAnyContT ma return) >>= )++
+ src/Control/Monad/Trans/AnyCont.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE+  RankNTypes+  #-}+module Control.Monad.Trans.AnyCont where++import Control.Applicative+import Control.Monad.Cont++newtype AnyContT m a = AnyContT { unAnyContT :: forall r . ContT r m a }++instance Functor (AnyContT m) where+  fmap f p = AnyContT $ fmap f . unAnyContT $ p++instance Applicative (AnyContT m) where+  pure a = AnyContT $ pure a+  f <*> v = AnyContT $ unAnyContT f <*> unAnyContT v++instance Monad m => Monad (AnyContT m) where+  AnyContT f >>= k = AnyContT $ f >>= unAnyContT . k+  return a = AnyContT $ return a+  fail s = AnyContT (ContT (\_ -> fail s))+  +instance MonadIO m => MonadIO (AnyContT m) where+  liftIO = lift . liftIO++instance MonadTrans AnyContT where+  lift ma = AnyContT (lift ma)++runAnyContT :: AnyContT m a -> (forall r . (a -> m r) -> m r)+runAnyContT = runContT . unAnyContT+anyContT :: (forall r . (a -> m r) -> m r) -> AnyContT m a+anyContT f = AnyContT (ContT f)++withAnyContT :: (forall r . (b -> m r) -> (a -> m r)) -> AnyContT m a -> AnyContT m b+withAnyContT f m = anyContT $ runAnyContT m . f++mapAnyContT :: (forall r . m r -> m r) -> AnyContT m a -> AnyContT m a+mapAnyContT f m = anyContT $ f . runAnyContT m+
+ src/Control/Monad/Trans/Phased.hs view
@@ -0,0 +1,33 @@+module Control.Monad.Trans.Phased where++import Control.Monad+import Control.Applicative+import Control.Monad.Trans.Class+import Control.Monad.IO.Class++newtype PhasedT m a = PhasedT { unPhasedT :: m (Either (PhasedT m a) a) }++instance Functor m => Functor (PhasedT m) where+  fmap f = PhasedT . fmap (either (Left . fmap f) (Right . f)) . unPhasedT++instance (Functor m, Monad m) => Applicative (PhasedT m) where+  pure = return+  (<*>) = ap++instance Monad m => Monad (PhasedT m) where+  k >>= f = PhasedT $ unPhasedT k >>= either (return . Left . (>>= f)) (unPhasedT . f)+  return = PhasedT . return . Right+  fail = PhasedT . fail++instance MonadTrans PhasedT where+  lift = PhasedT . liftM Right++runPhasedT :: Monad m => PhasedT m a -> m a+runPhasedT = either runPhasedT return <=< unPhasedT++instance MonadIO m => MonadIO (PhasedT m) where+  liftIO = PhasedT . liftM Right . liftIO++mapPhasedT :: Monad n => (m (Either (PhasedT m a) a) -> n (Either (PhasedT m a) b)) -> PhasedT m a -> PhasedT n b+mapPhasedT f (PhasedT x) = PhasedT $ return (either (Left . (mapPhasedT f)) Right) `ap` f x+
+ src/LLVM/General.hs view
@@ -0,0 +1,7 @@+-- | An interface to use LLVM in all capacities+module LLVM.General (+  module LLVM.General.Module+  ) where++import LLVM.General.Module+
+ src/LLVM/General/AST.hs view
@@ -0,0 +1,53 @@+-- | This module and descendants define AST data types to represent LLVM code.+-- Note that these types are designed for fidelity rather than convenience - if the truth+-- of what LLVM supports is less than pretty, so be it.+module LLVM.General.AST (+  Module(..), defaultModule,+  Definition(..),+  Global(GlobalVariable, GlobalAlias, Function), +        globalVariableDefaults,+        globalAliasDefaults,+        functionDefaults,+  Parameter(..),+  BasicBlock(..),+  module LLVM.General.AST.Instruction,+  module LLVM.General.AST.Name,+  module LLVM.General.AST.Operand,+  module LLVM.General.AST.Type+  ) where++import LLVM.General.AST.Name+import LLVM.General.AST.Type+import LLVM.General.AST.Global+import LLVM.General.AST.Operand+import LLVM.General.AST.Instruction+import LLVM.General.AST.DataLayout++-- | Any thing which can be at the top level of a 'Module'+data Definition +  = GlobalDefinition Global+  | TypeDefinition Name (Maybe Type)+  | MetadataNodeDefinition MetadataNodeID [Operand]+  | NamedMetadataDefinition String [MetadataNodeID]+  | ModuleInlineAssembly String+    deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#modulestructure>+data Module = +  Module {+    moduleName :: String,+    -- | a 'DataLayout', if specified, must match that of the eventual code generator+    moduleDataLayout :: Maybe DataLayout, +    moduleTargetTriple :: Maybe String,+    moduleDefinitions :: [Definition]+  } +  deriving (Eq, Read, Show)++-- | helper for making 'Module's+defaultModule = +  Module {+    moduleName = "<string>",+    moduleDataLayout = Nothing,+    moduleTargetTriple = Nothing,+    moduleDefinitions = []+  }
+ src/LLVM/General/AST/AddrSpace.hs view
@@ -0,0 +1,8 @@+-- | Pointers exist in Address Spaces +module LLVM.General.AST.AddrSpace where++import Data.Word++-- | See <http://llvm.org/docs/LangRef.html#pointer-type>+data AddrSpace = AddrSpace Word32+   deriving (Eq, Ord, Read, Show)
+ src/LLVM/General/AST/Attribute.hs view
@@ -0,0 +1,38 @@+-- | Module to allow importing 'Attribute' distinctly qualified.+module LLVM.General.AST.Attribute where++import Data.Word++-- | <http://llvm.org/docs/LangRef.html#parameter-attributes>+data ParameterAttribute+    = ZeroExt+    | SignExt+    | InReg+    | SRet+    | NoAlias+    | ByVal+    | NoCapture+    | Nest+  deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#function-attributes>+data FunctionAttribute+    = NoReturn+    | NoUnwind+    | ReadNone+    | ReadOnly+    | NoInline+    | AlwaysInline+    | OptimizeForSize+    | StackProtect+    | StackProtectReq+    | Alignment Word32+    | NoRedZone+    | NoImplicitFloat+    | Naked+    | InlineHint+    | StackAlignment Word32+    | ReturnsTwice+    | UWTable+    | NonLazyBind+  deriving (Eq, Read, Show)
+ src/LLVM/General/AST/CallingConvention.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | Module to allow importing 'CallingConvention' distinctly qualified.+module LLVM.General.AST.CallingConvention where++import Data.Data+import Data.Word++-- |  <http://llvm.org/docs/LangRef.html#callingconv>+data CallingConvention = C | Fast | Cold | GHC | Numbered Word32+  deriving (Eq, Read, Show, Typeable, Data)+
+ src/LLVM/General/AST/Constant.hs view
@@ -0,0 +1,218 @@+-- | A representation of LLVM constants+module LLVM.General.AST.Constant where++import Data.Word (Word32)+import Data.Bits ((.|.), (.&.), complement, testBit, shiftL)++import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate)+import LLVM.General.AST.IntegerPredicate (IntegerPredicate)+import qualified LLVM.General.AST.Float as F++{- |+<http://llvm.org/docs/LangRef.html#constants>++N.B. - <http://llvm.org/docs/LangRef.html#constant-expressions>++Although constant expressions and instructions have many similarites, there are important+differences - so they're represented using different types in this AST. At the cost of making it+harder to move an code back and forth between being constant and not, this approach embeds more of+the rules of what IR is legal into the Haskell types.+-} +data Constant+    = Int { integerBits :: Word32, integerValue :: Integer }+    | Float { floatValue :: F.SomeFloat }+    | Null { constantType :: Type }+    | Struct { isPacked :: Bool, memberValues :: [ Constant ] }+    | Array { memberType :: Type, memberValues :: [ Constant ] }+    | Vector { memberValues :: [ Constant ] }+    | Undef { constantType :: Type }+    | BlockAddress { blockAddressFunction :: Name, blockAddressBlock :: Name }+    | GlobalReference Name +    | Add { +        operand0 :: Constant,+        operand1 :: Constant+      }+    | FAdd {+        operand0 :: Constant,+        operand1 :: Constant+      }+    | Sub {+        operand0 :: Constant,+        operand1 :: Constant+      }+    | FSub { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | Mul { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | FMul { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | UDiv { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | SDiv { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | FDiv { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | URem { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | SRem { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | FRem { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | Shl { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | LShr { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | AShr { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | And { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | Or { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | Xor { +        operand0 :: Constant, +        operand1 :: Constant+      }+    | GetElementPtr { +        inBounds :: Bool,+        address :: Constant,+        indices :: [Constant]+      }+    | Trunc { +        operand0 :: Constant,+        type' :: Type+      }+    | ZExt {+        operand0 :: Constant,+        type' :: Type+      }+    | SExt {+        operand0 :: Constant,+        type' :: Type+      }+    | FPToUI {+        operand0 :: Constant,+        type' :: Type+      }+    | FPToSI {+        operand0 :: Constant,+        type' :: Type+      }+    | UIToFP {+        operand0 :: Constant,+        type' :: Type+      }+    | SIToFP {+        operand0 :: Constant,+        type' :: Type+      }+    | FPTrunc {+        operand0 :: Constant,+        type' :: Type+      }+    | FPExt {+        operand0 :: Constant,+        type' :: Type+      }+    | PtrToInt {+        operand0 :: Constant,+        type' :: Type+      }+    | IntToPtr {+        operand0 :: Constant,+        type' :: Type+      }+    | BitCast {+        operand0 :: Constant,+        type' :: Type+      }+    | ICmp {+        iPredicate :: IntegerPredicate,+        operand0 :: Constant,+        operand1 :: Constant+      }+    | FCmp {+        fpPredicate :: FloatingPointPredicate,+        operand0 :: Constant,+        operand1 :: Constant+      }+    | Select { +        condition' :: Constant,+        trueValue :: Constant,+        falseValue :: Constant+      }+    | ExtractElement { +        vector :: Constant,+        index :: Constant+      }+    | InsertElement { +        vector :: Constant,+        element :: Constant,+        index :: Constant+      }+    | ShuffleVector { +        operand0 :: Constant,+        operand1 :: Constant,+        mask :: Constant+      }+    | ExtractValue { +        aggregate :: Constant,+        indices' :: [Word32]+      }+    | InsertValue { +        aggregate :: Constant,+        element :: Constant,+        indices' :: [Word32]+      }+    deriving (Eq, Ord, Read, Show)+++-- | Since LLVM types don't include signedness, there's ambiguity in interpreting+-- an constant as an Integer. The LLVM assembly printer prints integers as signed, but+-- cheats for 1-bit integers and prints them as 'true' or 'false'. That way it circuments the+-- otherwise awkward fact that a twos complement 1-bit number only has the values -1 and 0.+signedIntegerValue :: Constant -> Integer+signedIntegerValue (Int nBits' bits) =+  let nBits = fromIntegral nBits'+  in+    if bits `testBit` (nBits - 1) then bits .|. (-1 `shiftL` nBits) else bits++-- | This library's conversion from LLVM C++ objects will always produce integer constants+-- as unsigned, so this function in many cases is not necessary. However, nothing's to keep+-- stop direct construction of an 'Int' with a negative 'integerValue'. There's nothing in principle+-- wrong with such a value - it has perfectly good low order bits like any integer, and will be used+-- as such, likely producing the intended result if lowered to C++. If, however one wishes to interpret+-- an 'Int' of unknown provenance as unsigned, then this function will serve.+unsignedIntegerValue :: Constant -> Integer+unsignedIntegerValue (Int nBits bits) =+  bits .&. (complement (-1 `shiftL` (fromIntegral nBits)))+
+ src/LLVM/General/AST/DataLayout.hs view
@@ -0,0 +1,51 @@+-- | <http://llvm.org/docs/LangRef.html#data-layout>+module LLVM.General.AST.DataLayout where++import Data.Word++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)++import LLVM.General.AST.AddrSpace++-- | Little Endian is the one true way :-). Sadly, we must support the infidels.+data Endianness = LittleEndian | BigEndian+  deriving (Eq, Ord, Read, Show)++-- | An AlignmentInfo describes how a given type must and would best be aligned+data AlignmentInfo = AlignmentInfo {+    abiAlignment :: Word32,+    preferredAlignment :: Word32+  }+  deriving (Eq, Ord, Read, Show)++-- | A type of type for which 'AlignmentInfo' may be specified+data AlignType+  = IntegerAlign+  | VectorAlign+  | FloatAlign+  | AggregateAlign+  | StackAlign+  deriving (Eq, Ord, Read, Show)++-- | a description of the various data layout properties which may be used during+-- optimization+data DataLayout = DataLayout {+    endianness :: Maybe Endianness,+    stackAlignment :: Maybe Word32,+    pointerLayouts :: Map AddrSpace (Word32, AlignmentInfo),+    typeLayouts :: Map (AlignType, Word32) AlignmentInfo,+    nativeSizes :: Maybe (Set Word32)+  }+  deriving (Eq, Ord, Read, Show)++-- | a 'DataLayout' which specifies nothing+defaultDataLayout = DataLayout {+  endianness = Nothing,+  stackAlignment = Nothing,+  pointerLayouts = Map.empty,+  typeLayouts = Map.empty,+  nativeSizes = Nothing+ }+
+ src/LLVM/General/AST/Float.hs view
@@ -0,0 +1,19 @@+-- | This module provides a sub-namespace for a type to support the various sizes of floating point+-- numbers LLVM supports. It is most definitely intended to be imported qualified.+module LLVM.General.AST.Float where++import Prelude as P+import Data.Word (Word16, Word64)++-- | A type summing up the various float types.+-- N.B. Note that in the constructors with multiple fields, the lower significance bits are on the right+-- - e.g. Quadruple highbits lowbits+data SomeFloat+  = Half Word16 +  | Single Float+  | Double P.Double+  | Quadruple Word64 Word64+  | X86_FP80 Word16 Word64+  | PPC_FP128 Word64 Word64+  deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/AST/FloatingPointPredicate.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE+  DeriveDataTypeable +  #-}  +-- | Predicates for the 'LLVM.General.AST.Instruction.FCmp' instruction+module LLVM.General.AST.FloatingPointPredicate where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#fcmp-instruction>+data FloatingPointPredicate+  = False+  | OEQ+  | OGT+  | OGE+  | OLT+  | OLE+  | ONE+  | ORD+  | UNO+  | UEQ+  | UGT+  | UGE+  | ULT+  | ULE+  | UNE+  | True+  deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Global.hs view
@@ -0,0 +1,109 @@+-- | 'Global's - top-level values in 'Module's - and supporting structures.+module LLVM.General.AST.Global where++import Data.Word++import LLVM.General.AST.Name+import LLVM.General.AST.Type+import LLVM.General.AST.Constant (Constant)+import LLVM.General.AST.AddrSpace+import LLVM.General.AST.Instruction (Named, Instruction, Terminator)+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalValue.html>+data Global+    -- | <http://llvm.org/docs/LangRef.html#global-variables>+    = GlobalVariable {+        name :: Name,+        linkage :: L.Linkage,+        visibility :: V.Visibility,+        isThreadLocal :: Bool,+        addrSpace :: AddrSpace,+        hasUnnamedAddr :: Bool,+        isConstant :: Bool,+        type' :: Type,+        initializer :: Maybe Constant,+        section :: Maybe String,+        alignment :: Word32+      }+    -- | <http://llvm.org/docs/LangRef.html#aliases>+    | GlobalAlias {+        name :: Name,+        linkage :: L.Linkage,+        visibility :: V.Visibility,+        type' :: Type,+        aliasee :: Constant+      }+    -- | <http://llvm.org/docs/LangRef.html#functions>+    | Function {+        linkage :: L.Linkage,+        visibility :: V.Visibility,+        callingConvention :: CC.CallingConvention,+        returnAttributes :: [A.ParameterAttribute],+        returnType :: Type,+        name :: Name,+        parameters :: ([Parameter],Bool),+        functionAttributes :: [A.FunctionAttribute],+        section :: Maybe String,+        alignment :: Word32,+        basicBlocks :: [BasicBlock]+      }+  deriving (Eq, Read, Show)++-- | 'Parameter's for 'Function's+data Parameter = Parameter Type Name [A.ParameterAttribute]+  deriving (Eq, Read, Show)++-- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html>+-- LLVM code in a function is a sequence of 'BasicBlock's each with a label,+-- some instructions, and a terminator.+data BasicBlock = BasicBlock Name [Named Instruction] (Named Terminator)+  deriving (Eq, Read, Show)++-- | helper for making 'GlobalVariable's+globalVariableDefaults :: Global+globalVariableDefaults = +  GlobalVariable {+  name = undefined,+  linkage = L.External,+  visibility = V.Default,+  isThreadLocal = False,+  addrSpace = AddrSpace 0,+  hasUnnamedAddr = False,+  isConstant = False,+  type' = undefined,+  initializer = Nothing,+  section = Nothing,+  alignment = 0+  }++-- | helper for making 'GlobalAlias's+globalAliasDefaults :: Global+globalAliasDefaults =+  GlobalAlias {+    name = undefined,+    linkage = L.External,+    visibility = V.Default,+    type' = undefined,+    aliasee = undefined+  }++-- | helper for making 'Function's+functionDefaults :: Global+functionDefaults = +  Function {+    linkage = L.External,+    visibility = V.Default,+    callingConvention = CC.C,+    returnAttributes = [],+    returnType = undefined,+    name = undefined,+    parameters = undefined,+    functionAttributes = [],+    section = Nothing,+    alignment = 0,+    basicBlocks = []+  }
+ src/LLVM/General/AST/InlineAssembly.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | A representation of an LLVM inline assembly+module LLVM.General.AST.InlineAssembly where++import Data.Data++import LLVM.General.AST.Type++-- | the dialect of assembly used in an inline assembly string+-- <http://en.wikipedia.org/wiki/X86_assembly_language#Syntax>+data Dialect+  = ATTDialect+  | IntelDialect+  deriving (Eq, Read, Show, Typeable, Data)++-- | <http://llvm.org/docs/LangRef.html#inline-assembler-expressions>+-- to be used through 'LLVM.General.AST.Operand.CallableOperand' with a+-- 'LLVM.General.AST.Instruction.Call' instruction+data InlineAssembly+  = InlineAssembly {+      type' :: Type,+      assembly :: String,+      constraints :: String,+      hasSideEffects :: Bool,+      alignStack :: Bool,+      dialect :: Dialect+    }+  deriving (Eq, Read, Show)
+ src/LLVM/General/AST/Instruction.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | LLVM instructions +-- <http://llvm.org/docs/LangRef.html#instruction-reference>+module LLVM.General.AST.Instruction where++import Data.Data+import Data.Word++import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.Constant+import LLVM.General.AST.Operand+import LLVM.General.AST.IntegerPredicate (IntegerPredicate)+import LLVM.General.AST.FloatingPointPredicate (FloatingPointPredicate)+import LLVM.General.AST.RMWOperation (RMWOperation)+import LLVM.General.AST.CallingConvention (CallingConvention)+import LLVM.General.AST.Attribute (ParameterAttribute, FunctionAttribute)++-- | <http://llvm.org/docs/LangRef.html#metadata-nodes-and-metadata-strings>+-- Metadata can be attached to an instruction+type InstructionMetadata = [(String, MetadataNode)]++-- | <http://llvm.org/docs/LangRef.html#terminators>+data Terminator +  = Ret { +      returnOperand :: Maybe Operand,+      metadata' :: InstructionMetadata+    }+  | CondBr { +      condition :: Operand, +      trueDest :: Name, +      falseDest :: Name,+      metadata' :: InstructionMetadata+    }+  | Br { +      dest :: Name,+      metadata' :: InstructionMetadata+    }+  | Switch {+      operand0' :: Operand,+      defaultDest :: Name,+      dests :: [(Constant, Name)],+      metadata' :: InstructionMetadata+    }+  | IndirectBr {+      operand0' :: Operand,+      possibleDests :: [Name],+      metadata' :: InstructionMetadata+    }+  | Invoke {+      callingConvention' :: CallingConvention,+      returnAttributes' :: [ParameterAttribute],+      function' :: CallableOperand,+      arguments' :: [(Operand, [ParameterAttribute])],+      functionAttributes' :: [FunctionAttribute],+      returnDest :: Name,+      exceptionDest :: Name,+      metadata' :: InstructionMetadata+    }+  | Resume {+      operand0' :: Operand,+      metadata' :: InstructionMetadata+    }+  | Unreachable {+      metadata' :: InstructionMetadata+    }+  deriving (Eq, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#atomic-memory-ordering-constraints>+-- <http://llvm.org/docs/Atomics.html>+data MemoryOrdering+  = Unordered+  | Monotonic+  | Acquire+  | Release+  | AcquireRelease+  | SequentiallyConsistent+  deriving (Eq, Ord, Read, Show, Data, Typeable)++-- | An 'Atomicity' describes constraints on the visibility of effects of an atomic instruction+data Atomicity = Atomicity { +  crossThread :: Bool, -- ^ <http://llvm.org/docs/LangRef.html#singlethread>+  memoryOrdering :: MemoryOrdering+ }+ deriving (Eq, Ord, Read, Show)++-- | For the redoubtably complex 'LandingPad' instruction+data LandingPadClause+    = Catch Constant+    | Filter Constant+    deriving (Eq, Ord, Read, Show)++-- | non-terminator instructions:+-- <http://llvm.org/docs/LangRef.html#binaryops>+-- <http://llvm.org/docs/LangRef.html#bitwiseops>+-- <http://llvm.org/docs/LangRef.html#memoryops>+-- <http://llvm.org/docs/LangRef.html#otherops>+data Instruction+  = Add { +      nsw :: Bool,+      nuw :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,+      metadata :: InstructionMetadata+    }+  | FAdd {+      operand0 :: Operand,+      operand1 :: Operand,+      metadata :: InstructionMetadata+    }+  | Sub {+      nsw :: Bool,+      nuw :: Bool,+      operand0 :: Operand,+      operand1 :: Operand,+      metadata :: InstructionMetadata+    }+  | FSub { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | Mul { +      nsw :: Bool, +      nuw :: Bool, +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata +    }+  | FMul { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | UDiv { +      exact :: Bool, +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | SDiv { +      exact :: Bool, +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | FDiv { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | URem { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | SRem { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | FRem { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | Shl { +      nsw :: Bool, +      nuw :: Bool, +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | LShr { +      exact :: Bool, +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | AShr { +      exact :: Bool, +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | And { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | Or { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | Xor { +      operand0 :: Operand, +      operand1 :: Operand, +      metadata :: InstructionMetadata+    }+  | Alloca { +      allocatedType :: Type,+      numElements :: Maybe Operand,+      alignment :: Word32,+      metadata :: InstructionMetadata+    }+  | Load {+      volatile :: Bool, +      address :: Operand,+      maybeAtomicity :: Maybe Atomicity,+      alignment :: Word32,+      metadata :: InstructionMetadata+    }+  | Store {+      volatile :: Bool, +      address :: Operand,+      value :: Operand,+      maybeAtomicity :: Maybe Atomicity,+      alignment :: Word32,+      metadata :: InstructionMetadata+    }+  | GetElementPtr { +      inBounds :: Bool,+      address :: Operand,+      indices :: [Operand],+      metadata :: InstructionMetadata+    }+  | Fence { +      atomicity :: Atomicity,+      metadata :: InstructionMetadata +    }+  | CmpXchg { +      volatile :: Bool,+      address :: Operand,+      expected :: Operand,+      replacement :: Operand,+      atomicity :: Atomicity,+      metadata :: InstructionMetadata +    }+  | AtomicRMW { +      volatile :: Bool,+      rmwOperation :: RMWOperation,+      address :: Operand,+      value :: Operand,+      atomicity :: Atomicity,+      metadata :: InstructionMetadata +    }+  | Trunc { +      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata +    }+  | ZExt {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata +    }+  | SExt {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | FPToUI {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | FPToSI {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | UIToFP {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | SIToFP {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | FPTrunc {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | FPExt {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | PtrToInt {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | IntToPtr {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | BitCast {+      operand0 :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata+    }+  | ICmp {+      iPredicate :: IntegerPredicate,+      operand0 :: Operand,+      operand1 :: Operand,+      metadata :: InstructionMetadata+    }+  | FCmp {+      fpPredicate :: FloatingPointPredicate,+      operand0 :: Operand,+      operand1 :: Operand,+      metadata :: InstructionMetadata+    }+  | Phi {+      type' :: Type,+      incomingValues :: [ (Operand, Name) ],+      metadata :: InstructionMetadata+  } +  | Call {+      isTailCall :: Bool,+      callingConvention :: CallingConvention,+      returnAttributes :: [ParameterAttribute],+      function :: CallableOperand,+      arguments :: [(Operand, [ParameterAttribute])],+      functionAttributes :: [FunctionAttribute],+      metadata :: InstructionMetadata+  }+  | Select { +      condition' :: Operand,+      trueValue :: Operand,+      falseValue :: Operand,+      metadata :: InstructionMetadata+    }+  | VAArg { +      argList :: Operand,+      type' :: Type,+      metadata :: InstructionMetadata +    }+  | ExtractElement { +      vector :: Operand,+      index :: Operand,+      metadata :: InstructionMetadata +    }+  | InsertElement { +      vector :: Operand,+      element :: Operand,+      index :: Operand,+      metadata :: InstructionMetadata+    }+  | ShuffleVector { +      operand0 :: Operand,+      operand1 :: Operand,+      mask :: Constant,+      metadata :: InstructionMetadata+    }+  | ExtractValue { +      aggregate :: Operand,+      indices' :: [Word32],+      metadata :: InstructionMetadata+    }+  | InsertValue { +      aggregate :: Operand,+      element :: Operand,+      indices' :: [Word32],+      metadata :: InstructionMetadata+    }+  | LandingPad { +      type' :: Type,+      personalityFunction :: Operand,+      cleanup :: Bool,+      clauses :: [LandingPadClause],+      metadata :: InstructionMetadata +    }+  deriving (Eq, Read, Show)++-- | Instances of instructions may be given a name, allowing their results to be referenced as 'Operand's.+-- Sometimes instructions - e.g. a call to a function returning void - don't need names.+data Named a +  = Name := a+  | Do a+  deriving (Eq, Read, Show)
+ src/LLVM/General/AST/IntegerPredicate.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE+  DeriveDataTypeable +  #-}  +-- | Predicates for the 'LLVM.General.AST.Instruction.ICmp' instruction+module LLVM.General.AST.IntegerPredicate where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#icmp-instruction>+data IntegerPredicate+  = EQ+  | NE+  | UGT+  | UGE+  | ULT+  | ULE+  | SGT+  | SGE+  | SLT+  | SLE+  deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Linkage.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+  +-- | Module to allow importing 'Linkage' distinctly qualified.+module LLVM.General.AST.Linkage where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#linkage>+data Linkage+    = Private+    | LinkerPrivate+    | LinkerPrivateWeak+    | Internal+    | AvailableExternally+    | LinkOnce+    | Weak+    | Common+    | Appending+    | ExternWeak+    | LinkOnceODR+    | WeakODR+    | External+    | DLLImport+    | DLLExport+  deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/AST/Name.hs view
@@ -0,0 +1,31 @@+-- | Names as used in LLVM IR+module LLVM.General.AST.Name where++import Data.Word++{- |+Objects of various sorts in LLVM IR are identified by address in the LLVM C++ API, and+may be given a string name. When printed to (resp. read from) human-readable LLVM assembly, objects without+string names are numbered sequentially (resp. must be numbered sequentially). String names may be quoted, and+are quoted when printed if they would otherwise be misread - e.g. when containing special characters. ++> 7++means the seventh unnamed object, while++> "7"++means the object named with the string "7".++This libraries handling of 'UnName's during translation of the AST down into C++ IR is somewhat more+forgiving than the LLVM assembly parser: it does not require that unnamed values be numbered sequentially;+however, the numbers of 'UnName's passed into C++ cannot be preserved in the C++ objects. If the C++ IR is+printed as assembly or translated into a Haskell AST, unnamed nodes will be renumbered sequentially. Thus+unnamed node numbers should be thought of as having any scope limited to the 'LLVM.General.AST.Module' in+which they are used.+-}+data Name +    = Name String -- ^ a string name +    | UnName Word -- ^ a number for a nameless thing+   deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/AST/Operand.hs view
@@ -0,0 +1,33 @@+-- | A type to represent operands to LLVM 'LLVM.General.AST.Instruction.Instruction's+module LLVM.General.AST.Operand where+  +import Data.Word++import LLVM.General.AST.Name+import LLVM.General.AST.Constant+import LLVM.General.AST.InlineAssembly++-- | A 'MetadataNodeID' is a number for identifying a metadata node.+-- Note this is different from "named metadata", which are represented with+-- 'LLVM.General.AST.NamedMetadataDefinition'.+newtype MetadataNodeID = MetadataNodeID Word+  deriving (Eq, Ord, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#metadata>+data MetadataNode +  = MetadataNode [Operand]+  | MetadataNodeReference MetadataNodeID+  deriving (Eq, Ord, Read, Show)++-- | An 'Operand' is roughly that which is an argument to an 'LLVM.General.AST.Instruction.Instruction'+data Operand +  -- | %foo+  = LocalReference Name+  -- | 'Constant's include 'LLVM.General.AST.Constant.GlobalReference', for \@foo+  | ConstantOperand Constant+  | MetadataStringOperand String+  | MetadataNodeOperand MetadataNode+  deriving (Eq, Ord, Read, Show)++-- | The 'LLVM.General.AST.Instruction.Call' instruction is special: the callee can be inline assembly+type CallableOperand  = Either InlineAssembly Operand
+ src/LLVM/General/AST/RMWOperation.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE+  DeriveDataTypeable +  #-}  +-- | Operations for the 'LLVM.General.AST.Instruction.AtomicRMW' instruction+module LLVM.General.AST.RMWOperation where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#atomicrmw-instruction>+data RMWOperation+  = Xchg+  | Add+  | Sub+  | And+  | Nand+  | Or+  | Xor+  | Max+  | Min+  | UMax+  | UMin+  deriving (Eq, Ord, Read, Show, Data, Typeable)+++
+ src/LLVM/General/AST/Type.hs view
@@ -0,0 +1,40 @@+-- | A representation of an LLVM type+module LLVM.General.AST.Type where++import LLVM.General.AST.AddrSpace+import LLVM.General.AST.Name++import Data.Word (Word32, Word64)++-- | LLVM supports some special formats floating point format. This type is to distinguish those format.+-- I believe it's treated as a format for "a" float, as opposed to a vector of two floats, because+-- its intended usage is to represent a single number with a combined significand.+data FloatingPointFormat+  = IEEE+  | DoubleExtended+  | PairOfFloats+  deriving (Eq, Ord, Read, Show)++-- | <http://llvm.org/docs/LangRef.html#type-system>+data Type+  -- | <http://llvm.org/docs/LangRef.html#void-type>+  = VoidType+  -- | <http://llvm.org/docs/LangRef.html#integer-type>+  | IntegerType { typeBits :: Word32 }+  -- | <http://llvm.org/docs/LangRef.html#pointer-type>+  | PointerType { pointerReferent :: Type, pointerAddrSpace :: AddrSpace }+  -- | <http://llvm.org/docs/LangRef.html#floating-point-types>+  | FloatingPointType { typeBits :: Word32, floatingPointFormat :: FloatingPointFormat }+  -- | <http://llvm.org/docs/LangRef.html#function-type>+  | FunctionType { resultType :: Type, argumentTypes :: [Type], isVarArg :: Bool }+  -- | <http://llvm.org/docs/LangRef.html#vector-type>+  | VectorType { nVectorElements :: Word32, elementType :: Type }+  -- | <http://llvm.org/docs/LangRef.html#structure-type>+  | StructureType { isPacked :: Bool, elementTypes :: [Type] }+  -- | <http://llvm.org/docs/LangRef.html#array-type>+  | ArrayType { nArrayElements :: Word64, elementType :: Type }+  -- | <http://llvm.org/docs/LangRef.html#opaque-structure-types>+  | NamedTypeReference Name+  -- | <http://llvm.org/docs/LangRef.html#metadata-type>+  | MetadataType -- only to be used as a parameter type for a few intrinsics+  deriving (Eq, Ord, Read, Show)
+ src/LLVM/General/AST/Visibility.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | Module to allow importing 'Visibility' distinctly qualified.+module LLVM.General.AST.Visibility where++import Data.Data++-- | <http://llvm.org/docs/LangRef.html#visibility>+data Visibility = Default | Hidden | Protected+  deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/CodeGenOpt.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | Code generation options, used in specifying TargetMachine+module LLVM.General.CodeGenOpt where++import Data.Data++-- | <http://llvm.org/doxygen/namespacellvm_1_1CodeGenOpt.html>+data Level+    = None+    | Less+    | Default+    | Aggressive+    deriving (Eq, Ord, Read, Show, Typeable, Data)
+ src/LLVM/General/CodeModel.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | Relocations, used in specifying TargetMachine+module LLVM.General.CodeModel where++import Data.Data++-- | <http://llvm.org/doxygen/namespacellvm_1_1CodeModel.html>+data Model+    = Default+    | JITDefault+    | Small+    | Kernel+    | Medium+    | Large+    deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/Context.hs view
@@ -0,0 +1,7 @@+-- | functions for the LLVM Context object which holds thread-scope state+module LLVM.General.Context (+  Context,+  withContext+  ) where++import LLVM.General.Internal.Context
+ src/LLVM/General/Diagnostic.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | Diagnostics describe parse errors+module LLVM.General.Diagnostic (+  DiagnosticKind(..),+  Diagnostic(..),+  diagnosticDisplay+ ) where++import Data.Data++-- | What kind of problem does a diagnostic describe?+data DiagnosticKind +  = ErrorKind+  | WarningKind+  | NoteKind+  deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | A 'Diagnostic' described a problem during parsing of LLVM IR+data Diagnostic = Diagnostic {+    lineNumber :: Int,+    columnNumber :: Int,+    diagnosticKind :: DiagnosticKind,+    filename :: String,+    message :: String,+    lineContents :: String+  }+  deriving (Eq, Ord, Read, Show)++-- | Convert a 'Diagnostic' to a printable form.+diagnosticDisplay :: Diagnostic -> String+diagnosticDisplay d = +  (filename d) ++ ":" ++ show (lineNumber d) ++ ":" ++ show (columnNumber d)+  ++ ":\n" ++ show (diagnosticKind d) ++ ": " ++ (message d) ++ "\n"+  ++ (lineContents d) ++ "\n"
+ src/LLVM/General/ExecutionEngine.hs view
@@ -0,0 +1,9 @@+-- | Tools for JIT execution+module LLVM.General.ExecutionEngine (+  ExecutionEngine,+  withExecutionEngine,+  withModuleInEngine,+  findFunction+  ) where++import LLVM.General.Internal.ExecutionEngine
+ src/LLVM/General/Internal/Atomicity.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances+  #-}++module LLVM.General.Internal.Atomicity where++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 [+  (FFI.memoryOrderingNotAtomic, Nothing),+  (FFI.memoryOrderingUnordered, Just A.Unordered),+  (FFI.memoryOrderingMonotonic, Just A.Monotonic),+  (FFI.memoryOrderingAcquire, Just A.Acquire),+  (FFI.memoryOrderingRelease, Just A.Release),+  (FFI.memoryOrderingAcquireRelease, Just A.AcquireRelease),+  (FFI.memoryOrderingSequentiallyConsistent, Just A.SequentiallyConsistent)+ ]++instance Monad m => EncodeM m (Maybe A.Atomicity) (FFI.LLVMBool, FFI.MemoryOrdering) where+  encodeM a =+    return (,) `ap` encodeM (maybe False A.crossThread a) `ap` encodeM (liftM A.memoryOrdering a)++instance Monad m => DecodeM m (Maybe A.Atomicity) (FFI.LLVMBool, FFI.MemoryOrdering) where+  decodeM (ss, ao) = return (liftM . A.Atomicity) `ap` decodeM ss `ap` decodeM ao++instance Monad m => EncodeM m A.Atomicity (FFI.LLVMBool, FFI.MemoryOrdering) where+  encodeM = encodeM . Just++instance Monad m => DecodeM m A.Atomicity (FFI.LLVMBool, FFI.MemoryOrdering) where+  decodeM = liftM fromJust . decodeM+
+ src/LLVM/General/Internal/Attribute.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances+  #-}++module LLVM.General.Internal.Attribute where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Data.Data+import Data.List (genericSplitAt)++import Data.Bits++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++import qualified LLVM.General.AST.Attribute as A.A++import LLVM.General.Internal.Coding++$(do+  let+    -- build an instance of the Coding class for lists of some kind of attribute+    genAttributeListCoding :: (Data a, Bits a) => TypeQ -> Name -> [(a, String)] -> DecsQ+    genAttributeListCoding type' ctn attributeData = do+      let+         lowZeroes :: Bits b => b -> Int+         lowZeroes b | testBit b 0 = 0+         lowZeroes b = 1 + lowZeroes (shiftR b 1)+         field :: Bits b => b -> (Int, Int)+         field b = +             let s = lowZeroes b+                 w = lowZeroes (complement (shiftR b s))+             in +               (s,w)+         attributeData' = [(mkName n, b, s,w) | (b,n) <- attributeData, let (s,w) = field b ]+      let m = varT . mkName $ "m"+      TyConI (NewtypeD _ _ _ (NormalC ctcn _) _) <- reify ctn+      let zero = [| $(conE ctcn) 0 |]+      sequence [+        instanceD (sequence [classP ''Monad [m]]) [t| EncodeM $(m) [$(type')] $(conT ctn) |] [+          funD (mkName "encodeM") [+            clause [] (normalB [| return . (+              let +                 encodeAttribute a = $(+                  caseE [| a |] $ flip map attributeData' $ \(n, b, s, w) ->+                    let bQ = (dataToExpQ (const Nothing) b)+                    in+                      case w of+                        1 -> match (conP n []) (normalB bQ) []+                        _ -> do +                          a <- newName "a"+                          match +                           (conP n [varP a])+                           (normalB [| ($(conE ctcn) (fromIntegral $(varE a) `shiftL` s)) .&. $(bQ) |])+                           []+                  )+              in+                foldl (.|.) $(zero) . map encodeAttribute+             ) |]) []+           ]+         ],+ +        -- build a decoder which uses bit masking for multiple fields at once+        -- to eliminate multiple absent attributes in fewer tests+        instanceD (sequence [classP ''Monad [m]]) [t| DecodeM $(m) [$(type')] $(conT ctn) |] [+          funD (mkName "decodeM") [+            do+              bits <- newName "bits"+              clause [varP bits] (normalB +                (let+                    code :: (Data a, Bits a) => [ (Name, a, Int, Int) ] -- attrs to handle+                         -> Int -- length (attrs), passed in to avoid recomputation+                         -> (a, ExpQ) -- (<bitmask for all the given attrs>, <code to decode the given attrs>)+                    code [(n, b, s, w)] _ = (+                       b, +                       case w of+                         1 -> [| [ $(conE n) | testBit $(varE bits) s ] |]+                         _-> [| +                               [ +                                 $(do+                                    i' <- newName "i'"+                                    letE +                                     [valD (conP ctcn [varP i']) (normalB [| i |]) []]+                                     [| $(conE n) (fromIntegral $(varE i')) |])+                                 | let i = ($(varE bits) .&. $(dataToExpQ (const Nothing) b)) `shiftR` s, +                                   i /= $(zero)+                               ]+                             |]+                      )+                    code attrs nAttrs =+                      let (nEarlyAttrs, nLateAttrs) = (nAttrs `div` 2, nAttrs - nEarlyAttrs)+                          (earlyAttrs, lateAttrs) = genericSplitAt nEarlyAttrs attrs+                          (earlyAttrBits, earlyAttrCode) = code earlyAttrs nEarlyAttrs+                          (lateAttrBits, lateAttrCode) = code lateAttrs nLateAttrs+                          attrBits = earlyAttrBits .|. lateAttrBits+                      in+                        (+                         attrBits, +                         [| +                            if ($(varE bits) .&. $(dataToExpQ (const Nothing) attrBits) /= $(zero)) then+                              ($earlyAttrCode ++ $lateAttrCode) +                            else+                              []+                          |]+                        )+                in+                  [| return $(snd $ code attributeData' (length attributeData')) |]+                )+               ) []+            ]+          ]+        ]++  pi <- genAttributeListCoding [t| A.A.ParameterAttribute |] ''FFI.ParamAttr [+    (FFI.paramAttrZExt, "A.A.ZeroExt"),+    (FFI.paramAttrSExt, "A.A.SignExt"),+    (FFI.paramAttrInReg, "A.A.InReg"),+    (FFI.paramAttrStructRet, "A.A.SRet"),+    (FFI.paramAttrNoAlias, "A.A.NoAlias"),+    (FFI.paramAttrByVal, "A.A.ByVal"),+    (FFI.paramAttrNoCapture, "A.A.NoCapture"),+    (FFI.paramAttrNest, "A.A.Nest")+   ]++  fi <- genAttributeListCoding [t| A.A.FunctionAttribute |] ''FFI.FunctionAttr [+    (FFI.functionAttrNoReturn, "A.A.NoReturn"),+    (FFI.functionAttrNoUnwind, "A.A.NoUnwind"),+    (FFI.functionAttrReadNone, "A.A.ReadNone"),+    (FFI.functionAttrReadOnly, "A.A.ReadOnly"),+    (FFI.functionAttrNoInline, "A.A.NoInline"),+    (FFI.functionAttrAlwaysInline, "A.A.AlwaysInline"),+    (FFI.functionAttrOptimizeForSize, "A.A.OptimizeForSize"),+    (FFI.functionAttrStackProtect, "A.A.StackProtect"),+    (FFI.functionAttrStackProtectReq, "A.A.StackProtectReq"),+    (FFI.functionAttrAlignment, "A.A.Alignment"),+    (FFI.functionAttrNoRedZone, "A.A.NoRedZone"),+    (FFI.functionAttrNoImplicitFloat, "A.A.NoImplicitFloat"),+    (FFI.functionAttrNaked, "A.A.Naked"),+    (FFI.functionAttrInlineHint, "A.A.InlineHint"),+    (FFI.functionAttrStackAlignment, "A.A.StackAlignment"),+    (FFI.functionAttrReturnsTwice, "A.A.ReturnsTwice"),+    (FFI.functionAttrUWTable, "A.A.UWTable"),+    (FFI.functionAttrNonLazyBind, "A.A.NonLazyBind")+   ]+  return (pi ++ fi)+ )+++
+ src/LLVM/General/Internal/BasicBlock.hs view
@@ -0,0 +1,27 @@+module LLVM.General.Internal.BasicBlock where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Phased+import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.BasicBlock as FFI+import qualified LLVM.General.Internal.FFI.Iterate as FFI++import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.Coding+import LLVM.General.Internal.Instruction ()++import qualified LLVM.General.AST.Instruction as A++getBasicBlockTerminator :: Ptr FFI.BasicBlock -> DecodeAST (A.Named A.Terminator)+getBasicBlockTerminator = decodeM <=< (liftIO . FFI.getBasicBlockTerminator)++getNamedInstructions :: Ptr FFI.BasicBlock -> DecodeAST [A.Named A.Instruction]+getNamedInstructions b = do+  ffiInstructions <- liftIO $ FFI.getXs (FFI.getFirstInstruction b) FFI.getNextInstruction+  let n = length ffiInstructions+  forInterleavedM (take (n-1) ffiInstructions) $ decodeM++
+ src/LLVM/General/Internal/CallingConvention.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE+  MultiParamTypeClasses,+  TemplateHaskell,+  QuasiQuotes,+  FlexibleInstances+  #-}+module LLVM.General.Internal.CallingConvention where++import LLVM.General.Internal.Coding++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++import qualified LLVM.General.AST.CallingConvention as A.CC++instance Monad m => EncodeM m A.CC.CallingConvention FFI.CallConv where+  encodeM cc = return $ +        case cc of+          A.CC.C -> FFI.callConvC+          A.CC.Fast -> FFI.callConvFast+          A.CC.Cold -> FFI.callConvCold+          A.CC.GHC ->  FFI.CallConv 10+          A.CC.Numbered cc' -> FFI.CallConv (fromIntegral cc')++instance Monad m => DecodeM m A.CC.CallingConvention FFI.CallConv where+  decodeM cc = return $ case cc of+    [FFI.callConvP|C|] -> A.CC.C+    [FFI.callConvP|Fast|] -> A.CC.Fast+    [FFI.callConvP|Cold|] -> A.CC.Cold+    FFI.CallConv 10 -> A.CC.GHC+    FFI.CallConv ci | ci >= 64 -> A.CC.Numbered (fromIntegral ci)
+ src/LLVM/General/Internal/Coding.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE+  TemplateHaskell,+  FlexibleInstances,+  FlexibleContexts,+  MultiParamTypeClasses,+  FunctionalDependencies,+  UndecidableInstances+  #-}+module LLVM.General.Internal.Coding where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Control.Monad.AnyCont+import Control.Monad.IO.Class++import Data.Data (Data)+import Data.Word (Word32, Word64)+import Data.Int (Int32)++import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++class EncodeM e h c where+  encodeM :: h -> e c++class DecodeM d h c where+  decodeM :: c -> d h++genCodingInstance :: Data h => TypeQ -> Name -> [(Integer, h)] -> Q [Dec]+genCodingInstance ht ctn ihs = do+  let n = const Nothing+  TyConI (NewtypeD _ _ _ (NormalC ctcn _) _) <- reify ctn+  [d| +    instance Monad m => EncodeM m $(ht) $(conT ctn) where+      encodeM h = return $ $(+        caseE [| h |] [ match (dataToPatQ n h) (normalB (appE (conE ctcn) (litE (integerL i)))) [] | (i,h) <- ihs ] +       )++    instance Monad m => DecodeM m $(ht) $(conT ctn) where+      decodeM i = return $ $(+        caseE [| i |] [ match (conP ctcn [litP (integerL i)]) (normalB (dataToExpQ n h)) [] | (i,h) <- ihs ]+       )+   |]++genCodingInstance' :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec]+genCodingInstance' ht ctn chs = do+  let n = const Nothing+  [d| +    instance Monad m => EncodeM m $(ht) $(conT ctn) where+      encodeM h = return $ $(+        caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ] +       )++    instance Monad m => DecodeM m $(ht) $(conT ctn) where+      decodeM c = return $ $(+        caseE [| c |] [ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs ]+       )+   |]++allocaArray :: (Integral i, Storable a, MonadAnyCont IO m) => i -> m (Ptr a)+allocaArray p = anyContToM $ Foreign.Marshal.Array.allocaArray (fromIntegral p)++alloca :: (Storable a, MonadAnyCont IO m) => m (Ptr a)+alloca = anyContToM Foreign.Marshal.Alloc.alloca++peek :: (Storable a, MonadIO m) => Ptr a -> m a+peek p = liftIO $ Foreign.Storable.peek p++peekByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> m a+peekByteOff p i = liftIO $ Foreign.Storable.peekByteOff p i++poke :: (Storable a, MonadIO m) => Ptr a -> a -> m ()+poke p a = liftIO $ Foreign.Storable.poke p a++pokeByteOff :: (Storable a, MonadIO m) => Ptr a -> Int -> a -> m ()+pokeByteOff p i a = liftIO $ Foreign.Storable.pokeByteOff p i a++peekArray :: (Integral i, Storable a, MonadIO m) => i -> Ptr a -> m [a]+peekArray n p = liftIO $ Foreign.Marshal.Array.peekArray (fromIntegral n) p++instance (Monad m, EncodeM m h c, Storable c, MonadAnyCont IO m) => EncodeM m [h] (CUInt, Ptr c) where+  encodeM hs = do+    hs <- mapM encodeM hs+    (anyContToM $ \x -> Foreign.Marshal.Array.withArrayLen hs $ \n hs -> x (fromIntegral n, hs))++instance (Monad m, DecodeM m h c, Storable c, MonadIO m) => DecodeM m [h] (CUInt, Ptr c) where+  decodeM (n, ca) = do+    cs <- liftIO $ Foreign.Marshal.Array.peekArray (fromIntegral n) ca+    mapM decodeM cs++instance Monad m => EncodeM m Bool FFI.LLVMBool where+  encodeM False = return $ FFI.LLVMBool 0+  encodeM True = return $ FFI.LLVMBool 1++instance Monad m => DecodeM m Bool FFI.LLVMBool where+  decodeM (FFI.LLVMBool 0) = return $ False+  decodeM (FFI.LLVMBool 1) = return $ True++instance Monad m => EncodeM m Word32 CUInt where+  encodeM = return . fromIntegral++instance Monad m => EncodeM m Word64 CULong where+  encodeM = return . fromIntegral++instance Monad m => DecodeM m Word32 CUInt where+  decodeM = return . fromIntegral++instance Monad m => DecodeM m Word64 CULong where+  decodeM = return . fromIntegral++instance Monad m => EncodeM m Int32 CInt where+  encodeM = return . fromIntegral++instance Monad m => DecodeM m Int32 CInt where+  decodeM = return . fromIntegral++instance Monad m => DecodeM m Int CInt where+  decodeM = return . fromIntegral+
+ src/LLVM/General/Internal/Constant.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE+  TemplateHaskell,+  QuasiQuotes,+  TupleSections,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  ScopedTypeVariables+  #-}+module LLVM.General.Internal.Constant where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH+import qualified LLVM.General.Internal.InstructionDefs as ID++import Control.Applicative+import Data.Word (Word32, Word64)+import Data.Bits+import Control.Monad.State+import Control.Monad.AnyCont++import qualified Data.Map as Map+import Foreign.Ptr+import Foreign.Storable (Storable, sizeOf)++import qualified LLVM.General.Internal.FFI.Constant as FFI+import qualified LLVM.General.Internal.FFI.GlobalValue as FFI+import qualified LLVM.General.Internal.FFI.Instruction as FFI+import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.User as FFI+import qualified LLVM.General.Internal.FFI.Value as FFI++import qualified LLVM.General.AST.Constant as A (Constant)+import qualified LLVM.General.AST.Constant as A.C hiding (Constant)+import qualified LLVM.General.AST.Type as A+import qualified LLVM.General.AST.IntegerPredicate as A (IntegerPredicate)+import qualified LLVM.General.AST.FloatingPointPredicate as A (FloatingPointPredicate)+import qualified LLVM.General.AST.Float as A.F++import LLVM.General.Internal.Coding+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.Context+import LLVM.General.Internal.Type ()+import LLVM.General.Internal.IntegerPredicate ()+import LLVM.General.Internal.FloatingPointPredicate ()++allocaWords :: forall a m . (Storable a, MonadAnyCont IO m, Monad m, MonadIO m) => Word32 -> m (Ptr a)+allocaWords nBits = do+  allocaArray (((nBits-1) `div` (8*(fromIntegral (sizeOf (undefined :: a))))) + 1)++instance EncodeM EncodeAST A.Constant (Ptr FFI.Constant) where+  encodeM c = scopeAnyCont $ case c of+    A.C.Int { A.C.integerBits = bits, A.C.integerValue = v } -> do+      t <- encodeM (A.IntegerType bits)+      words <- encodeM [+        fromIntegral ((v `shiftR` (w*64)) .&. 0xffffffffffffffff) :: Word64+        | w <- [0 .. ((fromIntegral bits-1) `div` 64)] +       ]+      liftIO $ FFI.constantIntOfArbitraryPrecision t words+    A.C.Float { A.C.floatValue = v } -> do+      Context context <- gets encodeStateContext+      let poke1 f = do+            let nBits = fromIntegral $ 8*(sizeOf f)+            words <- allocaWords nBits+            poke (castPtr words) f+            return (nBits, words)+          poke2 fh fl = do+             let nBits = fromIntegral $ 8*(sizeOf fh) + 8*(sizeOf fl)+             words <- allocaWords nBits+             pokeByteOff (castPtr words) 0 fl+             pokeByteOff (castPtr words) (sizeOf fl) fh+             return (nBits, words)+      (nBits, words) <- case v of+        A.F.Half f -> poke1 f+        A.F.Single f -> poke1 f+        A.F.Double f -> poke1 f+        A.F.X86_FP80 high low -> poke2 high low+        A.F.Quadruple high low -> poke2 high low+        A.F.PPC_FP128 high low -> poke2 high low+      notPairOfFloats <- encodeM $ case v of A.F.PPC_FP128 _ _ -> False; _ -> True+      nBits <- encodeM nBits+      liftIO $ FFI.constantFloatOfArbitraryPrecision context nBits words notPairOfFloats+    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 p ms -> do+      Context context <- gets encodeStateContext+      p <- encodeM p+      ms <- encodeM 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+        (name, (Just (TH.RecC n fs'), instrInfo)) <- Map.toList constExprInfo+        let fns = [ TH.mkName . TH.nameBase $ fn | (fn, _, _) <- fs' ]+            coreCall n = TH.dyn $ "FFI.constant" ++ n+            buildBody c = [ TH.bindS (TH.varP fn) [| encodeM $(TH.varE fn) |] | fn <- fns ]+                          ++ [ TH.noBindS [| liftIO $(foldl TH.appE c (map TH.varE fns)) |] ]+        core <- case instrInfo of+          Just (_, iDef) -> do+            let opcode = TH.dataToExpQ (const Nothing) (ID.cppOpcode iDef)+            case ID.instructionKind iDef of+              ID.Binary -> return [| $(coreCall "BinaryOperator") $(opcode) |]+              ID.Cast -> return [| $(coreCall "Cast") $(opcode) |]+              _ -> return $ coreCall name+          Nothing -> if (name `elem` ["Vector", "Null", "Array"]) +                      then return $ coreCall name+                      else []+        return $ TH.match+          (TH.recP n [(fn,) <$> (TH.varP . TH.mkName . TH.nameBase $ fn) | (fn, _, _) <- fs'])+          (TH.normalB (TH.doE (buildBody core)))+          []+      )++instance DecodeM DecodeAST A.Constant (Ptr FFI.Constant) where+  decodeM c = scopeAnyCont $ do+    let v = FFI.upCast c :: Ptr FFI.Value+        u = FFI.upCast c :: Ptr FFI.User+    t <- decodeM =<< liftIO (FFI.typeOf v)+    valueSubclassId <- liftIO $ FFI.getValueSubclassId v+    nOps <- liftIO $ FFI.getNumOperands u+    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+          let nElements = case t of+                            A.VectorType n _ -> n+                            A.ArrayType n _ | n <= (fromIntegral (maxBound :: Word32)) -> fromIntegral n+          forM [0..nElements-1] $ do+             decodeM <=< liftIO . FFI.getConstantDataSequentialElementAsConstant c . fromIntegral++    case valueSubclassId of+      [FFI.valueSubclassIdP|Function|] -> globalRef+      [FFI.valueSubclassIdP|GlobalAlias|] -> globalRef+      [FFI.valueSubclassIdP|GlobalVariable|] -> globalRef+      [FFI.valueSubclassIdP|ConstantInt|] -> do+        np <- alloca+        wsp <- liftIO $ FFI.getConstantIntWords c np+        n <- peek np+        words <- decodeM (n, wsp)+        return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral (b :: Word64)) 0 words)+      [FFI.valueSubclassIdP|ConstantFP|] -> do+        let A.FloatingPointType nBits fmt = t+        ws <- allocaWords nBits+        liftIO $ FFI.getConstantFloatWords c ws+        A.C.Float <$> (+          case (nBits, fmt) of+            (16, A.IEEE) -> A.F.Half <$> peek (castPtr ws)+            (32, A.IEEE) -> A.F.Single <$> peek (castPtr ws)+            (64, A.IEEE) -> A.F.Double <$> peek (castPtr ws)+            (128, A.IEEE) -> A.F.Quadruple <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0+            (80, A.DoubleExtended) -> A.F.X86_FP80 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0+            (128, A.PairOfFloats) -> A.F.PPC_FP128 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0+            _ -> error $ "don't know how to decode floating point constant of type: " ++ show t+          )+      [FFI.valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t+      [FFI.valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t+      [FFI.valueSubclassIdP|UndefValue|] -> return $ A.C.Undef t+      [FFI.valueSubclassIdP|BlockAddress|] -> +            return A.C.BlockAddress +               `ap` (getGlobalName =<< do liftIO $ FFI.isAGlobalValue =<< FFI.getBlockAddressFunction c)+               `ap` (getLocalName =<< do liftIO $ FFI.getBlockAddressBlock c)+      [FFI.valueSubclassIdP|ConstantStruct|] -> +            return A.C.Struct `ap` (return $ A.isPacked t) `ap` getConstantOperands+      [FFI.valueSubclassIdP|ConstantDataArray|] -> +            return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantData+      [FFI.valueSubclassIdP|ConstantArray|] -> +            return A.C.Array `ap` (return $ A.elementType t) `ap` getConstantOperands+      [FFI.valueSubclassIdP|ConstantDataVector|] -> +            return A.C.Vector `ap` getConstantData+      [FFI.valueSubclassIdP|ConstantExpr|] -> do+            cppOpcode <- liftIO $ FFI.getConstantCPPOpcode c+            $(+              TH.caseE [| cppOpcode |] $ do+                (name, ((TH.RecC n fs, _), iDef)) <- Map.toList $+                      ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs+                let apWrapper o (fn, _, ct) = do+                      a <- case ct of+                             TH.ConT h+                               | h == ''A.Constant -> do+                                               operandNumber <- get+                                               modify (+1)+                                               return [| op $(TH.litE . TH.integerL $ operandNumber) |]+                               | h == ''A.Type -> return [| pure t |]+                               | h == ''A.IntegerPredicate -> +                                 return [| liftIO $ decodeM =<< FFI.getConstantICmpPredicate c |]+                               | h == ''A.FloatingPointPredicate -> +                                 return [| liftIO $ decodeM =<< FFI.getConstantFCmpPredicate c |]+                               | h == ''Bool -> case TH.nameBase fn of+                                                  "inBounds" -> return [| liftIO $ decodeM =<< FFI.getInBounds v |]+                             TH.AppT TH.ListT (TH.ConT h) +                               | h == ''Word32 -> +                                  return [|+                                        do+                                          np <- alloca+                                          isp <- liftIO $ FFI.getConstantIndices c np+                                          n <- peek np+                                          decodeM (n, isp)+                                        |]+                               | h == ''A.Constant -> +                                  case TH.nameBase fn of+                                    "indices" -> do+                                      operandNumber <- get+                                      return [| mapM op [$(TH.litE . TH.integerL $ operandNumber)..nOps-1] |]+                             _ -> error $ "unhandled constant expr field type: " ++ show fn ++ " - " ++ show ct+                      return [| $(o) `ap` $(a) |]+                return $ TH.match +                          (TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef))+                          (TH.normalB (evalState (foldM apWrapper [| return $(TH.conE n) |] fs) 0))+                          []+             )+      _ -> error $ "unhandled constant valueSubclassId: " ++ show valueSubclassId+++  +
+ src/LLVM/General/Internal/Context.hs view
@@ -0,0 +1,16 @@+module LLVM.General.Internal.Context where++import Control.Exception++import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.Context as FFI++-- | a Context object holds the state the of LLVM system needs for one thread of+-- | LLVM compilation. Once upon a time, in early versions of LLVM, this state was global.+-- | Then it got packed up in this object to allow multiple threads to compile at once.+data Context = Context (Ptr FFI.Context)++-- | Create a Context, run an action (to which it is provided), then destroy the Context.+withContext :: (Context -> IO a) -> IO a+withContext = bracket FFI.contextCreate FFI.contextDispose . (. Context)
+ src/LLVM/General/Internal/DataLayout.hs view
@@ -0,0 +1,88 @@+module LLVM.General.Internal.DataLayout where++import Text.ParserCombinators.Parsec++import Data.Word+import Data.Functor++import qualified Data.List as List+import qualified Data.Map as Map+import qualified Data.Set as Set++import LLVM.General.AST.DataLayout+import LLVM.General.AST.AddrSpace++dataLayoutToString :: DataLayout -> String+dataLayoutToString dl = +  let sTriple :: (Word32, AlignmentInfo) -> String+      sTriple (s, ai) = show s ++ ":" ++ show (abiAlignment ai) ++ ":" ++ show (preferredAlignment ai)+      atChar at = case at of+                    IntegerAlign -> "i"+                    VectorAlign -> "v"+                    FloatAlign -> "f"+                    AggregateAlign -> "a"+                    StackAlign -> "s"+  in+  List.intercalate "-" (+    (case endianness dl of Just BigEndian -> ["E"]; Just LittleEndian -> ["e"]; _ -> [])+    +++    (maybe [] (\s -> ["S" ++ show s]) (stackAlignment dl))+    +++    [ "p" ++ show a ++ ":" ++ sTriple t | (AddrSpace a, t) <- Map.toList . pointerLayouts $ dl]+    +++    [ atChar at ++ sTriple (s, ai) | ((at, s), ai) <- Map.toList . typeLayouts $ dl ]+    ++ +    (maybe [] (\ns -> ["n" ++ (List.intercalate ":" (map show . Set.toList $ ns))]) (nativeSizes dl))+  )++parseDataLayout :: String -> Maybe DataLayout+parseDataLayout "" = Nothing+parseDataLayout s = +  let+    num :: Parser Word32+    num = read <$> many digit+    triple :: Parser (Word32, AlignmentInfo)+    triple = do+      s <- num+      char ':'+      abi <- num+      char ':'+      pref <- num+      return (s, (AlignmentInfo abi pref))+    parseSpec :: Parser (DataLayout -> DataLayout)+    parseSpec = choice [+      do+        char 'e'+        return $ \dl -> dl { endianness = Just LittleEndian },+      do+        char 'E' +        return $ \dl -> dl { endianness = Just BigEndian },+      do+        char 'S'+        n <- num+        return $ \dl -> dl { stackAlignment = Just n },+      do+        char 'p'+        a <- AddrSpace . read <$> many digit+        char ':'+        t <- triple+        return $ \dl -> dl { pointerLayouts = Map.insert a t (pointerLayouts dl) },+      do+        at <- choice [+               char 'i' >> return IntegerAlign,+               char 'v' >> return VectorAlign,+               char 'f' >> return FloatAlign,+               char 'a' >> return AggregateAlign,+               char 's' >> return StackAlign+              ]+        (sz,ai) <- triple+        return $ \dl -> dl { typeLayouts = Map.insert (at,sz) ai (typeLayouts dl) },+      do +        char 'n'+        ns <- num `sepBy` (char ':')+        return $ \dl -> dl { nativeSizes = Just (Set.fromList ns) }+     ]+  in +    case parse (parseSpec `sepBy` (char '-')) "" s of+      Left _ -> error $ "ill formed data layout: " ++ show s+      Right fs -> Just $ foldr ($) defaultDataLayout fs
+ src/LLVM/General/Internal/DecodeAST.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE+  GeneralizedNewtypeDeriving,+  FlexibleContexts,+  FlexibleInstances,+  TypeFamilies,+  MultiParamTypeClasses,+  UndecidableInstances+  #-}+module LLVM.General.Internal.DecodeAST where++import Control.Applicative+import Control.Monad.State+import Control.Monad.Phased+import Control.Monad.AnyCont++import Foreign.Ptr+import Foreign.C+import Data.Word++import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Array (Array)+import qualified Data.Array as Array++import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Value as FFI+import qualified LLVM.General.Internal.FFI.Type as FFI++import qualified LLVM.General.AST.Name as A+import qualified LLVM.General.AST.Operand as A (MetadataNodeID(..))++import LLVM.General.Internal.Coding+import LLVM.General.Internal.String ()++type NameMap a = Map (Ptr a) Word++data DecodeState = DecodeState {+    globalVarNum :: NameMap FFI.GlobalValue,+    localVarNum :: NameMap FFI.Value,+    localNameCounter :: Maybe Word,+    namedTypeNum :: NameMap FFI.Type,+    typesToDefine :: Seq (Ptr FFI.Type),+    metadataNodesToDefine :: Seq (A.MetadataNodeID, Ptr FFI.MDNode),+    metadataNodes :: Map (Ptr FFI.MDNode) A.MetadataNodeID,+    metadataKinds :: Array Word String+  }+initialDecode = DecodeState {+    globalVarNum = Map.empty,+    localVarNum = Map.empty,+    localNameCounter = Nothing,+    namedTypeNum = Map.empty,+    typesToDefine = Seq.empty,+    metadataNodesToDefine = Seq.empty,+    metadataNodes = Map.empty,+    metadataKinds = Array.listArray (1,0) []+  }+newtype DecodeAST a = DecodeAST { unDecodeAST :: AnyContT (PhasedT (StateT DecodeState IO)) a }+  deriving (+    Applicative,+    Functor,+    Monad,+    MonadIO,+    MonadState DecodeState,+    MonadPhased+  )++instance MonadAnyCont IO DecodeAST where+  anyContToM = DecodeAST . anyContIOToM+  scopeAnyCont = DecodeAST . scopeAnyCont . unDecodeAST++runDecodeAST :: DecodeAST a -> IO a+runDecodeAST d = flip evalStateT initialDecode . runPhasedT . flip runAnyContT return . unDecodeAST $ d++localScope :: DecodeAST a -> DecodeAST a+localScope (DecodeAST x) = DecodeAST (mapAnyContT pScope (tweak x))+  where tweak x = do+          modify (\s@DecodeState { localNameCounter = Nothing } -> s { localNameCounter = Just 0 })+          r <- x+          modify (\s@DecodeState { localNameCounter = Just _ } -> s { localNameCounter = Nothing })+          return r+        pScope (PhasedT x) = PhasedT $ do+          let s0 `withLocalsFrom` s1 = s0 { +                localNameCounter = localNameCounter s1+               }+          state <- get -- save the state+          a <- x+          state' <- get -- get the modified state+          put $ state' `withLocalsFrom` state -- revert the local part+          -- Finally here's the fun bit - in the Left case where we're coming back to a deferment point,+          -- prepend an action which reinstates the local state, but re-wrap with pScope to continue+          -- containment.+          return $ either (Left . pScope . (modify (`withLocalsFrom` state') >>)) Right a++getName :: (Ptr a -> IO CString)+           -> Ptr a+           -> (DecodeState -> NameMap a)+           -> DecodeAST Word+           -> DecodeAST A.Name+getName getCString v getNameMap generate = do+  name <- liftIO $ do+            n <- getCString v+            if n == nullPtr then return "" else decodeM n+  if name /= "" +     then+       return $ A.Name name+     else+       A.UnName <$> do+         nm <- gets getNameMap+         maybe generate return $ Map.lookup v nm++getValueName :: FFI.DescendentOf FFI.Value v => Ptr v -> (DecodeState -> NameMap v) -> DecodeAST Word -> DecodeAST A.Name+getValueName = getName (FFI.getValueName . FFI.upCast)++getLocalName :: FFI.DescendentOf FFI.Value v => Ptr v -> DecodeAST A.Name+getLocalName v' = do+  let v = FFI.upCast v'+  getValueName v localVarNum $ do+                    nm <- gets localVarNum+                    Just n <- gets localNameCounter+                    modify $ \s -> s { localNameCounter = Just (1 + n), localVarNum = Map.insert v n nm }+                    return n++getGlobalName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.Name+getGlobalName v' = do+  let v = FFI.upCast v'+  getValueName v globalVarNum $ do+                     nm <- gets globalVarNum+                     let n = fromIntegral $ Map.size nm+                     modify $ \s -> s { globalVarNum = Map.insert v n nm }+                     return n+++getTypeName :: Ptr FFI.Type -> DecodeAST A.Name+getTypeName t = do+  getName FFI.getStructName t namedTypeNum $ do+                  nm <- gets namedTypeNum+                  let n = fromIntegral $ Map.size nm+                  modify $ \s -> s { namedTypeNum = Map.insert t n nm }+                  return n++saveNamedType :: Ptr FFI.Type -> DecodeAST ()+saveNamedType t = do+  modify $ \s -> s { typesToDefine = t Seq.<| typesToDefine s }++getMetadataNodeID :: Ptr FFI.MDNode -> DecodeAST A.MetadataNodeID+getMetadataNodeID p = do+  mdns <- gets metadataNodes+  case Map.lookup p mdns of+    Just r -> return r+    Nothing -> do+      let r = A.MetadataNodeID (fromIntegral (Map.size mdns))+      modify $ \s -> s { +        metadataNodesToDefine = (r, p) Seq.<| metadataNodesToDefine s,+        metadataNodes = Map.insert p r (metadataNodes s)+      }+      return r++takeTypeToDefine :: DecodeAST (Maybe (Ptr FFI.Type))+takeTypeToDefine = state $ \s -> case Seq.viewr (typesToDefine s) of+  remaining Seq.:> t -> (Just t, s { typesToDefine = remaining })+  _ -> (Nothing, s)++takeMetadataNodeToDefine :: DecodeAST (Maybe (A.MetadataNodeID, Ptr FFI.MDNode))+takeMetadataNodeToDefine = state $ \s -> case Seq.viewr (metadataNodesToDefine s) of+  remaining Seq.:> md -> (Just md, s { metadataNodesToDefine = remaining })+  _ -> (Nothing, s)                              ++instance DecodeM DecodeAST A.Name (Ptr FFI.BasicBlock) where+  decodeM = getLocalName
+ src/LLVM/General/Internal/Diagnostic.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE+  TemplateHaskell,+  DeriveDataTypeable,+  MultiParamTypeClasses,+  FlexibleInstances+  #-}  +module LLVM.General.Internal.Diagnostic where++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.SMDiagnostic as FFI++import Control.Exception++import Foreign.Ptr++import LLVM.General.Diagnostic+import LLVM.General.Internal.Coding+import LLVM.General.Internal.String ()++genCodingInstance' [t| DiagnosticKind |] ''FFI.DiagnosticKind [+    (FFI.diagnosticKindError, ErrorKind),+    (FFI.diagnosticKindWarning, WarningKind),+    (FFI.diagnosticKindNote, NoteKind)+  ]++withSMDiagnostic :: (Ptr FFI.SMDiagnostic -> IO a) -> IO a+withSMDiagnostic = bracket FFI.createSMDiagnostic FFI.disposeSMDiagnostic++getDiagnostic :: Ptr FFI.SMDiagnostic -> IO Diagnostic+getDiagnostic p = do+  l <- decodeM =<< FFI.getSMDiagnosticLineNo p+  c <- decodeM =<< FFI.getSMDiagnosticColumnNo p+  k <- decodeM =<< FFI.getSMDiagnosticKind p+  f <- decodeM =<< FFI.getSMDiagnosticFilename p+  m <- decodeM =<< FFI.getSMDiagnosticMessage p+  lc <- decodeM =<< FFI.getSMDiagnosticLineContents p+  return $ Diagnostic { +    lineNumber = l, columnNumber = c, diagnosticKind = k, filename = f, message = m, lineContents = lc+   }+
+ src/LLVM/General/Internal/EncodeAST.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE+  GeneralizedNewtypeDeriving,+  FlexibleContexts,+  FlexibleInstances,+  MultiParamTypeClasses,+  UndecidableInstances+  #-}++module LLVM.General.Internal.EncodeAST where++import Control.Exception+import Control.Monad.State+import Control.Monad.Phased+import Control.Monad.Error+import Control.Monad.AnyCont++import Foreign.Ptr+import Foreign.C++import Data.Map (Map)+import qualified Data.Map as Map++import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Builder as FFI+import qualified LLVM.General.Internal.FFI.Type as FFI++import qualified LLVM.General.AST as A++import LLVM.General.Internal.Context+import LLVM.General.Internal.Coding+import LLVM.General.Internal.String ()++data EncodeState = EncodeState { +      encodeStateBuilder :: Ptr FFI.Builder,+      encodeStateContext :: Context,+      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),+      encodeStateMDNodes :: Map A.MetadataNodeID (Ptr FFI.MDNode),+      encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type)+    }++newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (PhasedT (ErrorT String (StateT EncodeState IO))) a }+    deriving (+       Functor,+       Monad,+       MonadIO,+       MonadState EncodeState,+       MonadPhased,+       MonadError String+     )++instance MonadAnyCont IO EncodeAST where+  anyContToM = EncodeAST . anyContIOToM+  scopeAnyCont = EncodeAST . scopeAnyCont . unEncodeAST++lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type)+lookupNamedType n = do+  t <- gets $ Map.lookup n . encodeStateNamedTypes+  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 -> IO (Either String a)+runEncodeAST context@(Context ctx) (EncodeAST a) = +    bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do+      let initEncodeState = EncodeState { +              encodeStateBuilder = builder,+              encodeStateContext = context,+              encodeStateLocals = Map.empty,+              encodeStateGlobals = Map.empty,+              encodeStateAllBlocks = Map.empty,+              encodeStateBlocks = Map.empty,+              encodeStateMDNodes = Map.empty,+              encodeStateNamedTypes = Map.empty+            }+      flip evalStateT initEncodeState . runErrorT . runPhasedT . flip runAnyContT return $ a++withName :: A.Name -> (CString -> IO a) -> IO a+withName (A.Name n) = withCString n+withName (A.UnName _) = withCString ""++instance MonadAnyCont IO m => EncodeM m A.Name CString where+  encodeM (A.Name n) = encodeM n+  encodeM _ = encodeM ""++-- contain modifications to the local part of the encode state - in this case all those except+-- those to encodeStateAllBlocks+encodeScope :: EncodeAST a -> EncodeAST a+encodeScope (EncodeAST x) = +  EncodeAST . mapAnyContT pScope $ x -- get inside the boring wrappers down to the phasing+  where pScope (PhasedT x) = PhasedT $ do+          let s0 `withLocalsFrom` s1 = s0 { +                 encodeStateLocals = encodeStateLocals s1,+                 encodeStateBlocks = encodeStateBlocks s1+                }+          state <- get -- save the state+          a <- x+          state' <- get -- get the modified state+          put $ state' `withLocalsFrom` state -- revert the local part+          -- Finally here's the fun bit - in the Left case where we're coming back to a deferment point,+          -- prepend an action which reinstates the local state, but re-wrap with pScope to continue+          -- containment.+          return $ either (Left . pScope . (modify (`withLocalsFrom` state') >>)) Right a+++define :: (Ord n, FFI.DescendentOf p v) => +          (EncodeState -> Map n (Ptr p))+          -> (Map n (Ptr p) -> EncodeState -> EncodeState)+          -> n+          -> Ptr v+          -> EncodeAST ()+define r w n v = modify $ \b -> w (Map.insert n (FFI.upCast v) (r b)) b++defineLocal :: FFI.DescendentOf FFI.Value v => A.Name -> Ptr v -> EncodeAST ()+defineLocal = define encodeStateLocals (\m b -> b { encodeStateLocals = m })++defineGlobal :: FFI.DescendentOf FFI.GlobalValue v => A.Name -> Ptr v -> EncodeAST ()+defineGlobal = define encodeStateGlobals (\m b -> b { encodeStateGlobals = m })++defineMDNode :: A.MetadataNodeID -> Ptr FFI.MDNode -> EncodeAST ()+defineMDNode = define encodeStateMDNodes (\m b -> b { encodeStateMDNodes = m })++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 (fail $ "reference to undefined " ++ m ++ ": " ++ show n) return mop++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 {+  encodeStateBlocks = Map.insert n b (encodeStateBlocks s),+  encodeStateAllBlocks = Map.insert (fn, n) b (encodeStateAllBlocks s)+}++instance EncodeM EncodeAST A.Name (Ptr FFI.BasicBlock) where+  encodeM = refer encodeStateBlocks "block"++getBlockForAddress :: A.Name -> A.Name -> EncodeAST (Ptr FFI.BasicBlock)+getBlockForAddress fn n = refer encodeStateAllBlocks "blockaddress" (fn, n)+
+ src/LLVM/General/Internal/ExecutionEngine.hs view
@@ -0,0 +1,66 @@+module LLVM.General.Internal.ExecutionEngine where++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.AnyCont+import Data.Functor++import Foreign.Ptr+import Foreign.Marshal.Alloc (free)++import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.ExecutionEngine as FFI+import qualified LLVM.General.Internal.FFI.Target as FFI+import qualified LLVM.General.Internal.FFI.Module as FFI++import LLVM.General.Internal.Module+import LLVM.General.Internal.Context+import LLVM.General.Internal.Coding++import qualified LLVM.General.AST as A++-- | <http://llvm.org/doxygen/classllvm_1_1ExecutionEngine.html>+newtype ExecutionEngine = ExecutionEngine (Ptr FFI.ExecutionEngine)++removeModule :: Ptr FFI.ExecutionEngine -> Ptr FFI.Module -> IO ()+removeModule e m = flip runAnyContT return $ do+  d0 <- alloca+  d1 <- alloca+  r <- liftIO $ FFI.removeModule e m d0 d1+  when (r /= 0) $ fail "FFI.removeModule failure"+++-- | bracket the creation and destruction of an 'ExecutionEngine'+withExecutionEngine :: Context -> (ExecutionEngine -> IO a) -> IO a+withExecutionEngine c f = flip runAnyContT return $ do+  liftIO $ FFI.initializeNativeTarget+  outExecutionEngine <- alloca+  outErrorCStringPtr <- alloca+  Module dummyModule <- anyContT $ liftM (either undefined id) . withModuleFromAST c (A.Module "" Nothing Nothing [])+  r <- liftIO $ FFI.createExecutionEngineForModule outExecutionEngine dummyModule outErrorCStringPtr+  when (r /= 0) $ do+    s <- anyContT $ bracket (peek outErrorCStringPtr) free+    fail =<< decodeM s+  executionEngine <- anyContT $ bracket (peek outExecutionEngine) FFI.disposeExecutionEngine+  liftIO $ removeModule executionEngine dummyModule+  liftIO $ f (ExecutionEngine executionEngine)+          +      +-- | bracket the availability of machine code for a given 'Module' in an 'ExecutionEngine'.+-- See 'findFunction'.+withModuleInEngine :: ExecutionEngine -> Module -> IO a -> IO a+withModuleInEngine (ExecutionEngine e) (Module m) = bracket_ (FFI.addModule e m) (removeModule e m)++-- | While a 'Module' is in an 'ExecutionEngine', use 'findFunction' to lookup functions in the module.+-- To run them from Haskell, treat them as any other function pointer: cast them to an appropriate and+-- foreign type, then wrap them with a dynamic FFI stub.+findFunction :: ExecutionEngine -> A.Name -> IO (Maybe (Ptr ()))+findFunction (ExecutionEngine e) (A.Name fName) = flip runAnyContT return $ do+  out <- alloca+  fName <- encodeM fName+  r <- liftIO $ FFI.findFunction e fName out+  if (r /= 0) then +      return Nothing+   else +      Just <$> (liftIO $ FFI.getPointerToGlobal e . FFI.upCast =<< peek out)
+ src/LLVM/General/Internal/FFI/Assembly.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE+  ForeignFunctionInterface+  #-}++-- | Functions to read and write textual LLVM assembly+module LLVM.General.Internal.FFI.Assembly where++import LLVM.General.Internal.FFI.Context +import LLVM.General.Internal.FFI.Module+import LLVM.General.Internal.FFI.SMDiagnostic++import Foreign.C+import Foreign.Ptr++-- | Use LLVM's parser to parse a string of llvm assembly to get a module+foreign import ccall unsafe "LLVM_General_GetModuleFromAssemblyInContext" getModuleFromAssemblyInContext ::+    Ptr Context -> CString -> Ptr SMDiagnostic -> IO (Ptr Module)++-- | LLVM's serializer to generate a string of llvm assembly from a module+foreign import ccall unsafe "LLVM_General_GetModuleAssembly" getModuleAssembly ::+    Ptr Module -> IO CString+++
+ src/LLVM/General/Internal/FFI/AssemblyC.cpp view
@@ -0,0 +1,33 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/Assembly/Parser.h"+#include "llvm/Assembly/PrintModulePass.h"+#include "llvm/Pass.h"+#include "llvm/Support/SourceMgr.h"+#include "llvm/Support/raw_ostream.h"++#include "llvm-c/Core.h"++using namespace llvm;++extern "C" {++LLVMModuleRef LLVM_General_GetModuleFromAssemblyInContext(+	LLVMContextRef context,+	const char *assembly,+	SMDiagnostic *error+) {+	wrap(ParseAssemblyString(assembly, NULL, *error, *unwrap(context))); +}++char *LLVM_General_GetModuleAssembly(LLVMModuleRef module) {+	std::string s;+	raw_string_ostream buf(s);+	ModulePass *printPass = createPrintModulePass(&buf);+	printPass->runOnModule(*unwrap(module));+	delete printPass;+	return strdup(buf.str().c_str());+}++}+
+ src/LLVM/General/Internal/FFI/BasicBlock.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses+  #-}++-- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html>+module LLVM.General.Internal.FFI.BasicBlock where++import Foreign.Ptr++import LLVM.General.Internal.FFI.PtrHierarchy++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueBasicBlock.html#gab57c996ff697ef40966432055ae47a4e>+foreign import ccall unsafe "LLVMIsABasicBlock" isABasicBlock ::+    Ptr Value -> IO (Ptr BasicBlock)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueBasicBlock.html#ga754e45f69f4b784b658d9e379943f354>+foreign import ccall unsafe "LLVMGetBasicBlockTerminator" getBasicBlockTerminator ::+    Ptr BasicBlock -> IO (Ptr Instruction)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueBasicBlock.html#ga9baf824cd325ad211027b23fce8a7494>+foreign import ccall unsafe "LLVMGetFirstInstruction" getFirstInstruction ::+    Ptr BasicBlock -> IO (Ptr Instruction)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueBasicBlock.html#gaa0bb2c95802d06bf94f4c55e61fc3477>+foreign import ccall unsafe "LLVMGetLastInstruction" getLastInstruction ::+    Ptr BasicBlock -> IO (Ptr Instruction)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueInstruction.html#ga1b4c3bd197e86e8bffdda247ddf8ec5e>+foreign import ccall unsafe "LLVMGetNextInstruction" getNextInstruction ::+    Ptr Instruction -> IO (Ptr Instruction)+
+ src/LLVM/General/Internal/FFI/BinaryOperator.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM BinaryOperator class+module LLVM.General.Internal.FFI.BinaryOperator where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.LLVMCTypes++-- | a blind type to correspond to llvm::BinaryOperator+data BinaryOperator++instance ChildOf Instruction BinaryOperator++foreign import ccall unsafe "LLVMIsABinaryOperator" isABinaryOperator ::+    Ptr Value -> IO (Ptr BinaryOperator)++foreign import ccall unsafe "LLVM_General_HasNoSignedWrap" hasNoSignedWrap ::+    Ptr BinaryOperator -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_HasNoUnsignedWrap" hasNoUnsignedWrap ::+    Ptr BinaryOperator -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_IsExact" isExact ::+    Ptr BinaryOperator -> IO LLVMBool+
+ src/LLVM/General/Internal/FFI/Builder.hs view
@@ -0,0 +1,152 @@+{-#+  LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  TemplateHaskell+  #-}++-- | FFI glue for llvm::IRBuilder - llvm's IR construction state object+module LLVM.General.Internal.FFI.Builder where++import qualified Language.Haskell.TH as TH++import qualified LLVM.General.AST.Instruction as A+import qualified LLVM.General.AST.Operand as A+import qualified LLVM.General.AST.Type as A++import LLVM.General.Internal.InstructionDefs as ID++import Foreign.Ptr+import Foreign.C++import qualified Data.Map as Map++import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.BinaryOperator+import LLVM.General.Internal.FFI.Type+import LLVM.General.Internal.FFI.PtrHierarchy++data Builder++foreign import ccall unsafe "LLVMCreateBuilderInContext" createBuilderInContext ::+  Ptr Context -> IO (Ptr Builder)++foreign import ccall unsafe "LLVMDisposeBuilder" disposeBuilder ::+  Ptr Builder -> IO ()++foreign import ccall unsafe "LLVMPositionBuilderAtEnd" positionBuilderAtEnd ::+  Ptr Builder -> Ptr BasicBlock -> IO ()+++foreign import ccall unsafe "LLVMBuildRet" buildRet ::+  Ptr Builder -> Ptr Value -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildBr" buildBr ::+  Ptr Builder -> Ptr BasicBlock -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildCondBr" buildCondBr ::+  Ptr Builder -> Ptr Value -> Ptr BasicBlock -> Ptr BasicBlock -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildSwitch" buildSwitch ::+  Ptr Builder -> Ptr Value -> Ptr BasicBlock -> CUInt -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildIndirectBr" buildIndirectBr ::+  Ptr Builder -> Ptr Value -> CUInt -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildInvoke" buildInvoke ::+  Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt+              -> Ptr BasicBlock -> Ptr BasicBlock -> CString -> IO (Ptr Instruction)+  +foreign import ccall unsafe "LLVMBuildResume" buildResume ::+  Ptr Builder -> Ptr Value -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildUnreachable" buildUnreachable ::+  Ptr Builder -> IO (Ptr Instruction)+++$(do+  sequence [+     TH.forImpD TH.cCall TH.unsafe cName (TH.mkName ("build" ++ a)) [t| +       Ptr Builder -> $(foldr (\at rt -> [t| $(at) -> $(rt) |]) [t| CString -> IO (Ptr $(rt)) |] ats)+       |]+     | (lrn, ID.InstructionDef { ID.cAPIName = a, ID.instructionKind = k }) <- Map.toList ID.instructionDefs,+       let fieldTypes = +             (\(TH.RecC _ fs) -> [ t | (_,_,t) <- fs]) $+             Map.findWithDefault +                  (error $ "LLVM instruction not found in AST: " ++ show lrn)+                  lrn ID.astInstructionRecs+           ats = flip concatMap fieldTypes $ \ft ->+                 case ft of+                   TH.ConT h | h == ''Bool -> [[t| LLVMBool |]]+                             | h == ''A.Operand -> [[t| Ptr Value |]]+                             | h == ''A.Type -> [[t| Ptr Type |]]+                             | h == ''A.InstructionMetadata -> []+                   _ -> error $ "show ft = " ++ show ft+           cName = (if TH.ConT ''Bool `elem` fieldTypes then "LLVM_General_" else "LLVM") ++ "Build" ++ a,+       rt <- case k of+               ID.Binary -> [[t| BinaryOperator |]]+               ID.Cast -> [[t| Instruction |]]+               _ -> []+    ]+ )++foreign import ccall unsafe "LLVMBuildArrayAlloca" buildAlloca ::+  Ptr Builder -> Ptr Type -> Ptr Value -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVM_General_BuildLoad" buildLoad ::+  Ptr Builder -> Ptr Value -> CUInt -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVM_General_BuildStore" buildStore ::+  Ptr Builder -> Ptr Value -> Ptr Value -> CUInt -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildGEP" buildGetElementPtr ::+  Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildFence" buildFence ::+  Ptr Builder -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVM_General_BuildAtomicCmpXchg" buildCmpXchg ::+  Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVM_General_BuildAtomicRMW" buildAtomicRMW ::+  Ptr Builder -> RMWOperation -> Ptr Value -> Ptr Value -> LLVMBool -> MemoryOrdering -> LLVMBool -> CString -> IO (Ptr Instruction)+++foreign import ccall unsafe "LLVMBuildICmp" buildICmp ::+  Ptr Builder -> ICmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildFCmp" buildFCmp ::+  Ptr Builder -> FCmpPredicate -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildPhi" buildPhi ::+  Ptr Builder -> Ptr Type -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildCall" buildCall ::+  Ptr Builder -> Ptr Value -> Ptr (Ptr Value) -> CUInt -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildSelect" buildSelect ::+  Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildVAArg" buildVAArg ::+  Ptr Builder -> Ptr Value -> Ptr Type -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildExtractElement" buildExtractElement ::+  Ptr Builder -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildInsertElement" buildInsertElement ::+  Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Value -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildShuffleVector" buildShuffleVector ::+  Ptr Builder -> Ptr Value -> Ptr Value -> Ptr Constant -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVM_General_BuildExtractValue" buildExtractValue ::+  Ptr Builder -> Ptr Value -> Ptr CUInt -> CUInt -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVM_General_BuildInsertValue" buildInsertValue ::+  Ptr Builder -> Ptr Value -> Ptr Value -> Ptr CUInt -> CUInt -> CString -> IO (Ptr Instruction)++foreign import ccall unsafe "LLVMBuildLandingPad" buildLandingPad ::+  Ptr Builder -> Ptr Type -> Ptr Value -> CUInt -> CString -> IO (Ptr Instruction)++
+ src/LLVM/General/Internal/FFI/BuilderC.cpp view
@@ -0,0 +1,181 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/IRBuilder.h"++#include "llvm-c/Core.h"++#include "LLVM/General/Internal/FFI/Instruction.h"++using namespace llvm;++namespace llvm {+static AtomicOrdering unwrap(LLVMAtomicOrdering l) {+	switch(l) {+#define ENUM_CASE(x) case LLVM ## x ## AtomicOrdering: return x;+LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE)+#undef ENUM_CASE+	default: return AtomicOrdering(0);+	}+}++static SynchronizationScope unwrap(LLVMSynchronizationScope l) {+	switch(l) {+#define ENUM_CASE(x) case LLVM ## x ## SynchronizationScope: return x;+LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE)+#undef ENUM_CASE+	default: return SynchronizationScope(0);+	}+}+++static AtomicRMWInst::BinOp unwrap(LLVMAtomicRMWOperation l) {+	switch(l) {+#define ENUM_CASE(x) case LLVM ## x ## RMWOperation: return AtomicRMWInst::x;+LLVM_GENERAL_FOR_EACH_RMW_OPERATION(ENUM_CASE)+#undef ENUM_CASE+	default: return AtomicRMWInst::BinOp(0);+	}+}++}++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,																											\+	LLVMBool nsw,																													\+	LLVMBool nuw,																													\+	LLVMValueRef o0,																											\+	LLVMValueRef o1,																											\+	const char *s																													\+) {																																			\+	return wrap(unwrap(b)->Create ## Op(unwrap(o0), unwrap(o1), s, nuw, nsw)); \+}+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,																											\+	LLVMBool exact,																												\+	LLVMValueRef o0,																											\+	LLVMValueRef o1,																											\+	const char *s																													\+) {																																			\+	return wrap(unwrap(b)->Create ## Op(unwrap(o0), unwrap(o1), s, exact)); \+}+LLVM_GENERAL_FOR_ALL_POSSIBLY_EXACT_OPERATORS(ENUM_CASE)+#undef ENUM_CASE+++LLVMValueRef LLVM_General_BuildLoad(+	LLVMBuilderRef b,+	LLVMValueRef p,+	unsigned align,+	LLVMBool isVolatile,+	LLVMAtomicOrdering atomicOrdering,+	LLVMSynchronizationScope synchScope,+	const char *name+) {+	LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), align, isVolatile, name);+	i->setOrdering(unwrap(atomicOrdering));+	i->setSynchScope(unwrap(synchScope));+	return wrap(i);+}++LLVMValueRef LLVM_General_BuildStore(+	LLVMBuilderRef b,+	LLVMValueRef v,+	LLVMValueRef p,+	unsigned align,+	LLVMBool isVolatile,+	LLVMAtomicOrdering atomicOrdering,+	LLVMSynchronizationScope synchScope,+	const char *name+) {+	StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), align, isVolatile);+	i->setName(name);+	i->setOrdering(unwrap(atomicOrdering));+	i->setSynchScope(unwrap(synchScope));+	return wrap(i);+}++LLVMValueRef LLVMBuildFence(+	LLVMBuilderRef b, LLVMAtomicOrdering lao, LLVMSynchronizationScope lss, const char *name+) {+	FenceInst *i = unwrap(b)->CreateFence(unwrap(lao), unwrap(lss));+	i->setName(name);+	return wrap(i);+}++LLVMValueRef LLVM_General_BuildAtomicCmpXchg(+	LLVMBuilderRef b,+	LLVMValueRef ptr, +	LLVMValueRef cmp, +	LLVMValueRef n, +	LLVMBool v,+	LLVMAtomicOrdering lao,+	LLVMSynchronizationScope lss,+	const char *name+) {+	AtomicCmpXchgInst *a = unwrap(b)->CreateAtomicCmpXchg(+		unwrap(ptr), unwrap(cmp), unwrap(n), unwrap(lao), unwrap(lss)+	);+	a->setVolatile(v);+	a->setName(name);+	return wrap(a);+}++LLVMValueRef LLVM_General_BuildAtomicRMW(+	LLVMBuilderRef b,+	LLVMAtomicRMWOperation rmwOp,+	LLVMValueRef ptr, +	LLVMValueRef val, +	LLVMBool v,+	LLVMAtomicOrdering lao,+	LLVMSynchronizationScope lss,+	const char *name+) {+	AtomicRMWInst *a = unwrap(b)->CreateAtomicRMW(+		unwrap(rmwOp), unwrap(ptr), unwrap(val), unwrap(lao), unwrap(lss)+	);+	a->setVolatile(v);+	a->setName(name);+	return wrap(a);+}++LLVMValueRef LLVM_General_BuildExtractValue(+	LLVMBuilderRef b,+	LLVMValueRef a,+	unsigned *idxs,+	unsigned n,+	const char *name+) {+	return wrap(unwrap(b)->CreateExtractValue(unwrap(a), ArrayRef<unsigned>(idxs, n), name));+}++LLVMValueRef LLVM_General_BuildInsertValue(+	LLVMBuilderRef b,+	LLVMValueRef a,+	LLVMValueRef v,+	unsigned *idxs,+	unsigned n,+	const char *name+) {+	return wrap(unwrap(b)->CreateInsertValue(unwrap(a), unwrap(v), ArrayRef<unsigned>(idxs, n), name));+}++}
+ src/LLVM/General/Internal/FFI/Cleanup.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE+  TemplateHaskell+  #-}+module LLVM.General.Internal.FFI.Cleanup where++import Language.Haskell.TH+import Control.Monad+import Data.Sequence as Seq+import Data.Foldable (toList)++import Data.Function++import LLVM.General.Internal.FFI.LLVMCTypes+import Data.Word+import Data.Int+import Foreign.C+import Foreign.Ptr++import qualified LLVM.General.AST.IntegerPredicate as A (IntegerPredicate) +import qualified LLVM.General.AST.FloatingPointPredicate as A (FloatingPointPredicate) ++foreignDecl :: String -> String -> [TypeQ] -> TypeQ -> DecsQ+foreignDecl cName hName argTypeQs returnTypeQ = do+  let foreignDecl' hName argTypeQs = +        forImpD cCall unsafe cName (mkName hName) +                  (foldr (\a b -> appT (appT arrowT a) b) (appT (conT ''IO) returnTypeQ) argTypeQs)+      splitTuples :: [Type] -> Q ([Type], [Pat], [Exp])+      splitTuples ts = do+        let f :: Type -> Q (Seq Type, Pat, Seq Exp)+            f x@(AppT _ _) = maybe (d x) (\q -> q >>= \(ts, ps, es) -> return (ts, TupP (toList ps), es)) (g 0 x)+            f x = d x+            g :: Int -> Type -> Maybe (Q (Seq Type, Seq Pat, Seq Exp))+            g n (TupleT m) | m == n = return (return (Seq.empty, Seq.empty, Seq.empty))+            g n (AppT a b) = do+              k <- g (n+1) a+              return $ do+                (ts, ps, es) <- k+                (ts', p', es') <- f b+                return (ts >< ts', ps |> p', es >< es')+            g _ _ = Nothing+            d :: Type -> Q (Seq Type, Pat, Seq Exp)+            d x = do+              n <- newName "v"+              return (Seq.singleton x, VarP n, Seq.singleton (VarE n))+            seqsToList :: [Seq a] -> [a]+            seqsToList = toList . foldr (><) Seq.empty+                +        (tss, ps, ess) <- liftM unzip3 . mapM f $ ts+        return (seqsToList tss, ps, seqsToList ess)++                                +  argTypes <- sequence argTypeQs+  (ts, ps, es) <- splitTuples argTypes+  let phName = hName ++ "'"+  sequence [+    foreignDecl' phName (map return ts),+    funD (mkName hName) [+     clause (map return ps) (normalB (foldl appE (varE (mkName phName)) (map return es))) []+    ]+   ]++typeMappingU :: (Type -> TypeQ) -> Type -> TypeQ+typeMappingU typeMapping t = case t of+  ConT h | h == ''Bool -> [t| LLVMBool |]+         | h == ''Int32 -> [t| CInt |]+         | h == ''Word32 -> [t| CUInt |]+         | h == ''String -> [t| CString |]+         | h == ''A.FloatingPointPredicate -> [t| FCmpPredicate |]+         | h == ''A.IntegerPredicate -> [t| ICmpPredicate |]+  AppT ListT x -> foldl1 appT [tupleT 2, [t| CUInt |], appT [t| Ptr |] (typeMapping x)]++typeMapping :: Type -> TypeQ+typeMapping = fix typeMappingU
+ src/LLVM/General/Internal/FFI/Constant.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE+  TemplateHaskell,+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM Constant class+module LLVM.General.Internal.FFI.Constant where++import qualified Language.Haskell.TH as TH+import qualified LLVM.General.Internal.InstructionDefs as ID+import qualified LLVM.General.AST.Constant as A.C++import Control.Monad+import Data.Function+import qualified Data.Map as Map++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.Cleanup+import LLVM.General.Internal.FFI.Type+import LLVM.General.Internal.FFI.LLVMCTypes++foreign import ccall unsafe "LLVMIsConstant" isConstant ::+  Ptr Value -> IO (CUInt)++foreign import ccall unsafe "LLVMIsAConstant" isAConstant ::+  Ptr Value -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMIsAConstantInt" isAConstantInt ::+  Ptr Value -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMGetOperand" getConstantOperand ::+  Ptr Constant -> CUInt -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMIsAConstantPointerNull" isAConstantPointerNull ::+  Ptr Value -> IO (Ptr Constant)++foreign import ccall unsafe "LLVM_General_GetConstantIntWords" getConstantIntWords ::+  Ptr Constant -> Ptr CUInt -> IO (Ptr CULong)++foreign import ccall unsafe "LLVM_General_ConstFloatDoubleValue" constFloatDoubleValue ::+  Ptr Constant -> IO CDouble++foreign import ccall unsafe "LLVM_General_ConstFloatFloatValue" constFloatFloatValue ::+  Ptr Constant -> IO CFloat++foreign import ccall unsafe "LLVMConstStructInContext" constStructInContext' ::+  Ptr Context -> Ptr (Ptr Constant) -> CUInt -> LLVMBool -> IO (Ptr Constant)++constStructInContext ctx (n, cs) p = constStructInContext' ctx cs n p++foreign import ccall unsafe "LLVM_General_GetConstantDataSequentialElementAsConstant" getConstantDataSequentialElementAsConstant ::+  Ptr Constant -> CUInt -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMConstIntOfArbitraryPrecision" constantIntOfArbitraryPrecision' ::+  Ptr Type -> CUInt -> Ptr CULong -> IO (Ptr Constant)++constantIntOfArbitraryPrecision t = uncurry (constantIntOfArbitraryPrecision' t)++foreign import ccall unsafe "LLVM_General_ConstFloatOfArbitraryPrecision" constantFloatOfArbitraryPrecision ::+  Ptr Context -> CUInt -> Ptr CULong -> LLVMBool -> IO (Ptr Constant)++foreign import ccall unsafe "LLVM_General_GetConstantFloatWords" getConstantFloatWords ::+  Ptr Constant -> Ptr CULong -> IO ()++foreign import ccall unsafe "LLVMConstVector" constantVector' ::+  Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)++constantVector (n, cs) = constantVector' cs n++foreign import ccall unsafe "LLVMConstNull" constantNull ::+  Ptr Type -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMConstArray" constantArray' ::+  Ptr Type -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)++constantArray t (n, cs) = constantArray' t cs n++foreign import ccall unsafe "LLVM_General_ConstCast" constantCast ::+  CPPOpcode -> Ptr Constant -> Ptr Type -> IO (Ptr Constant)++foreign import ccall unsafe "LLVM_General_ConstBinaryOperator" constantBinaryOperator ::+  CPPOpcode -> Ptr Constant -> Ptr Constant -> IO (Ptr Constant)++$(do+   let constExprInfo = ID.innerJoin (ID.innerJoin ID.astConstantRecs ID.astInstructionRecs) ID.instructionDefs+   let tm = fix tm' +         where tm' _ (TH.ConT h) | h == ''A.C.Constant = [t| Ptr Constant |]+               tm' x t = typeMappingU x t+               +   liftM concat $ sequence [      +     foreignDecl ("LLVMConst" ++ name) ("constant" ++ name) [tm t | (_, _, t) <- fs ] [t| Ptr Constant |]+     | (name, ((TH.RecC _ fs,_), ID.InstructionDef { ID.instructionKind = ID.Other })) <- Map.toList constExprInfo+    ]+  )++foreign import ccall unsafe "LLVMConstGEP" constantGetElementPtr' ::+  Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMConstInBoundsGEP" constantInBoundsGetElementPtr' ::+  Ptr Constant -> Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)++constantGetElementPtr (LLVMBool ib) a (n, is) = +  (case ib of { 0 -> constantGetElementPtr'; 1 -> constantInBoundsGetElementPtr' }) a is n++foreign import ccall unsafe "LLVM_General_GetConstCPPOpcode" getConstantCPPOpcode ::+  Ptr Constant -> IO CPPOpcode++foreign import ccall unsafe "LLVM_General_GetConstPredicate" getConstantICmpPredicate ::+  Ptr Constant -> IO ICmpPredicate++foreign import ccall unsafe "LLVM_General_GetConstPredicate" getConstantFCmpPredicate ::+  Ptr Constant -> IO FCmpPredicate++foreign import ccall unsafe "LLVM_General_GetConstIndices" getConstantIndices ::+  Ptr Constant -> Ptr CUInt -> IO (Ptr CUInt)++foreign import ccall unsafe "LLVMGetUndef" getUndef ::+  Ptr Type -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMBlockAddress" blockAddress ::+  Ptr Value -> Ptr BasicBlock -> IO (Ptr Constant)++foreign import ccall unsafe "LLVM_General_GetBlockAddressFunction" getBlockAddressFunction ::+  Ptr Constant -> IO (Ptr Value)++foreign import ccall unsafe "LLVM_General_GetBlockAddressBlock" getBlockAddressBlock ::+  Ptr Constant -> IO (Ptr BasicBlock)
+ src/LLVM/General/Internal/FFI/ConstantC.cpp view
@@ -0,0 +1,78 @@+#define __STDC_LIMIT_MACROS+#include "llvm-c/Core.h"+#include "llvm/LLVMContext.h"+#include "llvm/Constants.h"+#include "LLVM/General/Internal/FFI/Value.h"++using namespace llvm;++extern "C" {++LLVMValueRef LLVM_General_GetConstantDataSequentialElementAsConstant(LLVMValueRef v, unsigned i) {+	wrap(unwrap<ConstantDataSequential>(v)->getElementAsConstant(i));+}++LLVMValueRef LLVM_General_GetBlockAddressFunction(LLVMValueRef v) {+	return wrap(unwrap<BlockAddress>(v)->getFunction());+}++LLVMBasicBlockRef LLVM_General_GetBlockAddressBlock(LLVMValueRef v) {+	return wrap(unwrap<BlockAddress>(v)->getBasicBlock());+}++double LLVM_General_ConstFloatDoubleValue(LLVMValueRef v) {+	return unwrap<ConstantFP>(v)->getValueAPF().convertToDouble();+}++float LLVM_General_ConstFloatFloatValue(LLVMValueRef v) {+	return unwrap<ConstantFP>(v)->getValueAPF().convertToFloat();+}++LLVMValueRef LLVM_General_ConstCast(unsigned opcode, LLVMValueRef v, LLVMTypeRef t) {+	return wrap(ConstantExpr::getCast(opcode, unwrap<Constant>(v), unwrap(t)));+}++LLVMValueRef LLVM_General_ConstBinaryOperator(unsigned opcode, LLVMValueRef o0, LLVMValueRef o1) {+	return wrap(ConstantExpr::get(opcode, unwrap<Constant>(o0), unwrap<Constant>(o1)));+}++unsigned LLVM_General_GetConstCPPOpcode(LLVMValueRef v) {+	return unwrap<ConstantExpr>(v)->getOpcode();+}++unsigned LLVM_General_GetConstPredicate(LLVMValueRef v) {+	return unwrap<ConstantExpr>(v)->getPredicate();+}++const unsigned *LLVM_General_GetConstIndices(LLVMValueRef v, unsigned *n) {+	ArrayRef<unsigned> r = unwrap<ConstantExpr>(v)->getIndices();+	*n = r.size();+	return r.data();+}++const uint64_t *LLVM_General_GetConstantIntWords(LLVMValueRef v, unsigned *n) {+	const APInt &i = unwrap<ConstantInt>(v)->getValue();+	*n = i.getNumWords();+	return i.getRawData();+}++LLVMValueRef LLVM_General_ConstFloatOfArbitraryPrecision(+	LLVMContextRef c,+	unsigned bits,+	const uint64_t *words,+	unsigned notPairOfFloats+) {+	return wrap(+		ConstantFP::get(+			*unwrap(c),+			APFloat(APInt(bits, ArrayRef<uint64_t>(words, (bits-1)/64 + 1)), notPairOfFloats)+		)+	);+}++void LLVM_General_GetConstantFloatWords(LLVMValueRef v, uint64_t *bits) {+	APInt a = unwrap<ConstantFP>(v)->getValueAPF().bitcastToAPInt();+	for(unsigned i=0; i != a.getNumWords(); ++i) bits[i] = a.getRawData()[i];+}++}
+ src/LLVM/General/Internal/FFI/Context.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls+  #-}++-- | Functions for handling the LLVMContext class. In all other LLVM interfaces,+-- | prefer the newer explicitly thread-aware variants which use contexts+-- | over corresponding older variants which implicitly reference a global context.+-- | This choice allows multiple threads to do independent work with LLVM safely.+module LLVM.General.Internal.FFI.Context where++import Foreign.Ptr++-- | a blind type to correspond to LLVMContext+data Context++-- | <http://llvm.org/doxygen/group__LLVMCCoreContext.html#gaac4f39a2d0b9735e64ac7681ab543b4c>+foreign import ccall unsafe "LLVMContextCreate" contextCreate ::+    IO (Ptr Context)++-- | <http://llvm.org/doxygen/group__LLVMCCoreContext.html#ga0055cde9a9b2497b332d639d8844a810>+foreign import ccall unsafe "LLVMGetGlobalContext" getGlobalContext ::+    IO (Ptr Context)++-- | <http://llvm.org/doxygen/group__LLVMCCoreContext.html#ga9cf8b0fb4a546d4cdb6f64b8055f5f57>+foreign import ccall unsafe "LLVMContextDispose" contextDispose ::+    Ptr Context -> IO ()
+ src/LLVM/General/Internal/FFI/ExecutionEngine.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls+  #-}++module LLVM.General.Internal.FFI.ExecutionEngine where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Module++data ExecutionEngine++foreign import ccall unsafe "LLVMCreateExecutionEngineForModule" createExecutionEngineForModule ::+    Ptr (Ptr ExecutionEngine) -> Ptr Module -> Ptr CString -> IO CUInt++foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine ::+    Ptr ExecutionEngine -> IO ()++foreign import ccall unsafe "LLVMAddModule" addModule ::+    Ptr ExecutionEngine -> Ptr Module -> IO ()++foreign import ccall unsafe "LLVMRemoveModule" removeModule ::+    Ptr ExecutionEngine -> Ptr Module -> Ptr (Ptr Module) -> Ptr CString -> IO CUInt++foreign import ccall unsafe "LLVMFindFunction" findFunction ::+    Ptr ExecutionEngine -> CString -> Ptr (Ptr Function) -> IO CUInt++foreign import ccall unsafe "LLVMGetPointerToGlobal" getPointerToGlobal ::+    Ptr ExecutionEngine -> Ptr GlobalValue -> IO (Ptr ())
+ src/LLVM/General/Internal/FFI/Function.h view
@@ -0,0 +1,39 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__FUNCTION__H__+#define __LLVM_GENERAL_INTERNAL_FFI__FUNCTION__H__++#define LLVM_GENERAL_FOR_EACH_CALLCONV(macro) \+	macro(C)																		\+	macro(Fast)																	\+	macro(Cold)																	\++#define LLVM_GENERAL_FOR_EACH_PARAM_ATTR(macro)				 \+	macro(ZExt)																					 \+	macro(SExt)																					 \+	macro(InReg)																				 \+	macro(StructRet)																		 \+	macro(NoAlias)																			 \+	macro(ByVal)																				 \+	macro(NoCapture)																		 \+	macro(Nest)																					 \++#define LLVM_GENERAL_FOR_EACH_FUNCTION_ATTR(macro)	\+	macro(NoReturn,Attribute)													\+	macro(NoUnwind,Attribute)													\+	macro(ReadNone,Attribute)													\+	macro(ReadOnly,Attribute)													\+	macro(NoInline,Attribute)													\+	macro(AlwaysInline,Attribute)											\+	macro(OptimizeForSize,Attribute)									\+	macro(StackProtect,Attribute)											\+	macro(StackProtectReq,Attribute)									\+	macro(Alignment,)																	\+	macro(NoRedZone,Attribute)												\+	macro(NoImplicitFloat,Attribute)									\+	macro(Naked,Attribute)														\+	macro(InlineHint,Attribute)												\+	macro(StackAlignment,)														\+	macro(ReturnsTwice,)															\+	macro(UWTable,)																		\+	macro(NonLazyBind,)																\++#endif
+ src/LLVM/General/Internal/FFI/Function.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses+  #-}++module LLVM.General.Internal.FFI.Function where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.PtrHierarchy++foreign import ccall unsafe "LLVMGetFunctionCallConv" getFunctionCallConv ::+    Ptr Function -> IO CallConv++foreign import ccall unsafe "LLVMSetFunctionCallConv" setFunctionCallConv ::+    Ptr Function -> CallConv -> IO ()++foreign import ccall unsafe "LLVMAddFunctionAttr" addFunctionAttr ::+    Ptr Function -> FunctionAttr -> IO ()++foreign import ccall unsafe "LLVMGetFunctionAttr" getFunctionAttr ::+    Ptr Function -> IO FunctionAttr++foreign import ccall unsafe "LLVMGetFirstBasicBlock" getFirstBasicBlock ::+    Ptr Function -> IO (Ptr BasicBlock)++foreign import ccall unsafe "LLVMGetLastBasicBlock" getLastBasicBlock ::+    Ptr Function -> IO (Ptr BasicBlock)++foreign import ccall unsafe "LLVMGetNextBasicBlock" getNextBasicBlock ::+    Ptr BasicBlock -> IO (Ptr BasicBlock)++foreign import ccall unsafe "LLVMAppendBasicBlockInContext" appendBasicBlockInContext ::+    Ptr Context -> Ptr Function -> CString -> IO (Ptr BasicBlock)+++foreign import ccall unsafe "LLVMCountParams" countParams ::+    Ptr Function -> IO CUInt++foreign import ccall unsafe "LLVMGetParams" getParams ::+    Ptr Function -> Ptr (Ptr Parameter) -> IO ()++foreign import ccall unsafe "LLVMGetAttribute" getAttribute ::+    Ptr Parameter -> IO ParamAttr++foreign import ccall unsafe "LLVMAddAttribute" addAttribute ::+    Ptr Parameter -> ParamAttr -> IO ()++foreign import ccall unsafe "LLVM_General_GetFunctionRetAttr" getFunctionRetAttr ::+    Ptr Function -> IO ParamAttr++foreign import ccall unsafe "LLVM_General_AddFunctionRetAttr" addFunctionRetAttr ::+    Ptr Function -> ParamAttr -> IO ()+++
+ src/LLVM/General/Internal/FFI/FunctionC.cpp view
@@ -0,0 +1,25 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/Attributes.h"++#include "llvm-c/Core.h"++using namespace llvm;++extern "C" {++LLVMAttribute LLVM_General_GetFunctionRetAttr(LLVMValueRef f) {+	return (LLVMAttribute)unwrap<Function>(f)->getRetAttributes().Raw();+}++void LLVM_General_AddFunctionRetAttr(LLVMValueRef v, LLVMAttribute attr) {+	Function &f = *unwrap<Function>(v);+	LLVMContext &context = f.getContext();+	AttrBuilder attrBuilder(attr);+	f.setAttributes(+		f.getAttributes().addAttr(context, AttrListPtr::ReturnIndex, Attributes::get(context, attrBuilder))+	);+}+++}
+ src/LLVM/General/Internal/FFI/GlobalAlias.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM GlobalAlias class+module LLVM.General.Internal.FFI.GlobalAlias where++import Foreign.Ptr++import LLVM.General.Internal.FFI.PtrHierarchy++-- | test if a 'Value' is a 'GlobalAlias'+foreign import ccall unsafe "LLVMIsAGlobalAlias" isAGlobalAlias ::+    Ptr Value -> IO (Ptr GlobalAlias)++-- | get the constant aliased by this alias+foreign import ccall unsafe "LLVM_General_GetAliasee" getAliasee ::+    Ptr GlobalAlias -> IO (Ptr Constant)++-- | set the constant aliased by this alias+foreign import ccall unsafe "LLVM_General_SetAliasee" setAliasee ::+    Ptr GlobalAlias -> Ptr Constant -> IO ()+
+ src/LLVM/General/Internal/FFI/GlobalAliasC.cpp view
@@ -0,0 +1,21 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/GlobalAlias.h"++#include "llvm-c/Core.h"++#include <iostream>++using namespace llvm;++extern "C" {++LLVMValueRef LLVM_General_GetAliasee(LLVMValueRef g) {+	return wrap(unwrap<GlobalAlias>(g)->getAliasee());+}++void LLVM_General_SetAliasee(LLVMValueRef g, LLVMValueRef c) {+	unwrap<GlobalAlias>(g)->setAliasee(unwrap<Constant>(c));+}++}
+ src/LLVM/General/Internal/FFI/GlobalValue.h view
@@ -0,0 +1,29 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__GLOBAL_VALUE__H__+#define __LLVM_GENERAL_INTERNAL_FFI__GLOBAL_VALUE__H__++#define LLVM_GENERAL_FOR_EACH_LINKAGE(macro)		\+	macro(External)																\+	macro(AvailableExternally)										\+	macro(LinkOnceAny)														\+	macro(LinkOnceODR)														\+	macro(LinkOnceODRAutoHide)										\+	macro(WeakAny)																\+	macro(WeakODR)																\+	macro(Appending)															\+	macro(Internal)																\+	macro(Private)																\+	macro(DLLImport)															\+	macro(DLLExport)															\+	macro(ExternalWeak)														\+	macro(Ghost)																	\+	macro(Common)																	\+	macro(LinkerPrivate)													\+	macro(LinkerPrivateWeak)											\+++#define LLVM_GENERAL_FOR_EACH_VISIBILITY(macro)	\+	macro(Default)																\+	macro(Hidden)																	\+	macro(Protected)															\++#endif
+ src/LLVM/General/Internal/FFI/GlobalValue.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM GlobalValue class+module LLVM.General.Internal.FFI.GlobalValue where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.LLVMCTypes++foreign import ccall unsafe "LLVMIsAGlobalValue" isAGlobalValue ::+    Ptr Value -> IO (Ptr GlobalValue)++foreign import ccall unsafe "LLVMGetLinkage" getLinkage ::+    Ptr GlobalValue -> IO Linkage++foreign import ccall unsafe "LLVMSetLinkage" setLinkage ::+    Ptr GlobalValue -> Linkage -> IO ()++foreign import ccall unsafe "LLVMGetSection" getSection ::+    Ptr GlobalValue -> IO CString++foreign import ccall unsafe "LLVMSetSection" setSection ::+    Ptr GlobalValue -> CString -> IO ()++foreign import ccall unsafe "LLVMGetVisibility" getVisibility ::+    Ptr GlobalValue -> IO Visibility++foreign import ccall unsafe "LLVMSetVisibility" setVisibility ::+    Ptr GlobalValue -> Visibility -> IO ()++foreign import ccall unsafe "LLVMGetAlignment" getAlignment ::+    Ptr GlobalValue -> IO CUInt++foreign import ccall unsafe "LLVMSetAlignment" setAlignment ::+    Ptr GlobalValue -> CUInt -> IO ()++foreign import ccall unsafe "LLVM_General_HasUnnamedAddr" hasUnnamedAddr ::+    Ptr GlobalValue -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_SetUnnamedAddr" setUnnamedAddr ::+    Ptr GlobalValue -> LLVMBool -> IO ()+++
+ src/LLVM/General/Internal/FFI/GlobalValueC.cpp view
@@ -0,0 +1,17 @@+#define __STDC_LIMIT_MACROS++#include "llvm-c/Core.h"++using namespace llvm;++extern "C" {++LLVMBool LLVM_General_HasUnnamedAddr(LLVMValueRef globalVal) {+	return unwrap<GlobalValue>(globalVal)->hasUnnamedAddr();+}++void LLVM_General_SetUnnamedAddr(LLVMValueRef globalVal, LLVMBool isUnnamedAddr) {+	unwrap<GlobalValue>(globalVal)->setUnnamedAddr(isUnnamedAddr);+}++}
+ src/LLVM/General/Internal/FFI/GlobalVariable.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM GlobalVariable class+module LLVM.General.Internal.FFI.GlobalVariable where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.LLVMCTypes++foreign import ccall unsafe "LLVMIsAGlobalVariable" isAGlobalVariable ::+    Ptr Value -> IO (Ptr GlobalVariable)++foreign import ccall unsafe "LLVMIsGlobalConstant" isGlobalConstant ::+    Ptr GlobalVariable -> IO LLVMBool++foreign import ccall unsafe "LLVMSetGlobalConstant" setGlobalConstant ::+    Ptr GlobalVariable -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVMGetInitializer" getInitializer ::+    Ptr GlobalVariable -> IO (Ptr Constant)++foreign import ccall unsafe "LLVMSetInitializer" setInitializer ::+    Ptr GlobalVariable -> Ptr Constant -> IO ()++foreign import ccall unsafe "LLVMIsThreadLocal" isThreadLocal ::+    Ptr GlobalVariable -> IO LLVMBool++foreign import ccall unsafe "LLVMSetThreadLocal" setThreadLocal ::+    Ptr GlobalVariable -> LLVMBool -> IO ()+
+ src/LLVM/General/Internal/FFI/InlineAssembly.h view
@@ -0,0 +1,14 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__INLINE_ASSEMBLY__H__+#define __LLVM_GENERAL_INTERNAL_FFI__INLINE_ASSEMBLY__H__++#define LLVM_GENERAL_FOR_EACH_ASM_DIALECT(macro) \+	macro(ATT) \+	macro(Intel) \++typedef enum {+#define ENUM_CASE(d) LLVMAsmDialect_ ## d,+	LLVM_GENERAL_FOR_EACH_ASM_DIALECT(ENUM_CASE)+#undef ENUM_CASE+} LLVMAsmDialect;++#endif
+ src/LLVM/General/Internal/FFI/InlineAssembly.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE+  ForeignFunctionInterface+  #-}++module LLVM.General.Internal.FFI.InlineAssembly where++import Foreign.C+import Foreign.Ptr++import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Type++foreign import ccall unsafe "LLVMIsAInlineAsm" isAInlineAsm ::+  Ptr Value -> IO (Ptr InlineAsm)++foreign import ccall unsafe "LLVM_General_CreateInlineAsm" createInlineAsm ::+  Ptr Type -> CString -> CString -> LLVMBool -> LLVMBool -> AsmDialect -> IO (Ptr InlineAsm)++foreign import ccall unsafe "LLVM_General_GetInlineAsmAsmString" getInlineAsmAssemblyString ::+  Ptr InlineAsm -> IO CString++foreign import ccall unsafe "LLVM_General_GetInlineAsmConstraintString" getInlineAsmConstraintString ::+  Ptr InlineAsm -> IO CString++foreign import ccall unsafe "LLVM_General_InlineAsmHasSideEffects" inlineAsmHasSideEffects ::+  Ptr InlineAsm -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_InlineAsmIsAlignStack" inlineAsmIsAlignStack ::+  Ptr InlineAsm -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_GetInlineAsmDialect" getInlineAsmDialect ::+  Ptr InlineAsm -> IO AsmDialect+
+ src/LLVM/General/Internal/FFI/InlineAssemblyC.cpp view
@@ -0,0 +1,72 @@+#define __STDC_LIMIT_MACROS+#include "llvm/InlineAsm.h"+#include "llvm-c/Core.h"++#include "LLVM/General/Internal/FFI/InlineAssembly.h"++using namespace llvm;++namespace llvm {+static LLVMAsmDialect wrap(InlineAsm::AsmDialect d) {+	switch(d) {+#define ENUM_CASE(x) case InlineAsm::AD_ ## x: return LLVMAsmDialect_ ## x;+LLVM_GENERAL_FOR_EACH_ASM_DIALECT(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMAsmDialect(0);+	}+}++static InlineAsm::AsmDialect unwrap(LLVMAsmDialect d) {+	switch(d) {+#define ENUM_CASE(x) case LLVMAsmDialect_ ## x: return InlineAsm::AD_ ## x;+LLVM_GENERAL_FOR_EACH_ASM_DIALECT(ENUM_CASE)+#undef ENUM_CASE+	default: return InlineAsm::AsmDialect(0);+	}+}+}++extern "C" {++LLVMValueRef LLVM_General_CreateInlineAsm(+	LLVMTypeRef t,+	const char *asmStr,+	const char *constraintsStr,+	LLVMBool hasSideEffects,+	LLVMBool isAlignStack,+	LLVMAsmDialect dialect+) {+	return wrap(+		InlineAsm::get(+			unwrap<FunctionType>(t), +			asmStr,+			constraintsStr,+			hasSideEffects,+			isAlignStack,+			unwrap(dialect)+		)+	);+}++const char *LLVM_General_GetInlineAsmAsmString(LLVMValueRef v) {+	return unwrap<InlineAsm>(v)->getAsmString().c_str();+}++const char *LLVM_General_GetInlineAsmConstraintString(LLVMValueRef v) {+	return unwrap<InlineAsm>(v)->getConstraintString().c_str();+}++LLVMBool LLVM_General_InlineAsmHasSideEffects(LLVMValueRef v) {+	return unwrap<InlineAsm>(v)->hasSideEffects();+}++LLVMBool LLVM_General_InlineAsmIsAlignStack(LLVMValueRef v) {+	return unwrap<InlineAsm>(v)->isAlignStack();+}++LLVMAsmDialect LLVM_General_GetInlineAsmDialect(LLVMValueRef v) {+	return wrap(unwrap<InlineAsm>(v)->getDialect());+}++}+
+ src/LLVM/General/Internal/FFI/Instruction.h view
@@ -0,0 +1,48 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__INSTRUCTION__H__+#define __LLVM_GENERAL_INTERNAL_FFI__INSTRUCTION__H__++#define LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(macro) \+	macro(NotAtomic) \+	macro(Unordered) \+	macro(Monotonic) \+	macro(Acquire) \+	macro(Release) \+	macro(AcquireRelease) \+	macro(SequentiallyConsistent)++typedef enum {+#define ENUM_CASE(x) LLVM ## x ## AtomicOrdering,+LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE)+#undef ENUM_CASE+} LLVMAtomicOrdering;++#define LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(macro) \+	macro(SingleThread) \+	macro(CrossThread)++typedef enum {+#define ENUM_CASE(x) LLVM ## x ## SynchronizationScope,+LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE)+#undef ENUM_CASE+} LLVMSynchronizationScope;++#define LLVM_GENERAL_FOR_EACH_RMW_OPERATION(macro) \+	macro(Xchg) \+	macro(Add) \+	macro(Sub) \+	macro(And) \+	macro(Nand) \+	macro(Or) \+	macro(Xor) \+	macro(Max) \+	macro(Min) \+	macro(UMax) \+	macro(UMin)++typedef enum {+#define ENUM_CASE(x) LLVM ## x ## RMWOperation,+LLVM_GENERAL_FOR_EACH_RMW_OPERATION(ENUM_CASE)+#undef ENUM_CASE+} LLVMAtomicRMWOperation;++#endif
+ src/LLVM/General/Internal/FFI/Instruction.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances,+  TemplateHaskell+  #-}++module LLVM.General.Internal.FFI.Instruction where++import Control.Monad+import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Type+import LLVM.General.Internal.FFI.LLVMCTypes++foreign import ccall unsafe "LLVMIsAInstruction" isAInstruction ::+  Ptr Value -> IO (Ptr Instruction)++newtype COpcode = COpcode CUInt++-- get the C API opcode+foreign import ccall unsafe "LLVMGetInstructionOpcode" getInstructionOpcode :: +  Ptr Instruction -> IO COpcode++-- get the C++ API opcode (one less level of mapping than for that from the C API)+foreign import ccall unsafe "LLVM_General_GetInstructionDefOpcode" getInstructionDefOpcode :: +  Ptr Instruction -> IO CPPOpcode++foreign import ccall unsafe "LLVMGetICmpPredicate" getICmpPredicate ::+  Ptr Instruction -> IO ICmpPredicate++foreign import ccall unsafe "LLVM_General_GetFCmpPredicate" getFCmpPredicate ::+  Ptr Instruction -> IO FCmpPredicate++foreign import ccall unsafe "LLVMGetInstructionCallConv" getInstructionCallConv ::+  Ptr Instruction -> IO CallConv++foreign import ccall unsafe "LLVMSetInstructionCallConv" setInstructionCallConv ::+  Ptr Instruction -> CallConv -> IO ()++foreign import ccall unsafe "LLVMIsTailCall" isTailCall ::+  Ptr Instruction -> IO LLVMBool++foreign import ccall unsafe "LLVMSetTailCall" setTailCall ::+  Ptr Instruction -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVM_General_GetCallInstCalledValue" getCallInstCalledValue ::+  Ptr Instruction -> IO (Ptr Value)++foreign import ccall unsafe "LLVM_General_GetCallInstFunctionAttr" getCallInstFunctionAttr ::+  Ptr Instruction -> IO FunctionAttr++foreign import ccall unsafe "LLVM_General_AddCallInstFunctionAttr" addCallInstFunctionAttr ::+  Ptr Instruction -> FunctionAttr -> IO ()++foreign import ccall unsafe "LLVM_General_GetCallInstAttr" getCallInstAttr ::+  Ptr Instruction -> CUInt -> IO ParamAttr++foreign import ccall unsafe "LLVM_General_AddCallInstAttr" addCallInstAttr ::+  Ptr Instruction -> CUInt -> ParamAttr -> IO ()++foreign import ccall unsafe "LLVMAddIncoming" addIncoming' ::+  Ptr Instruction -> Ptr (Ptr Value) -> Ptr (Ptr BasicBlock) -> CUInt -> IO ()++addIncoming :: Ptr Instruction -> (CUInt, Ptr (Ptr Value)) -> (CUInt, Ptr (Ptr BasicBlock)) -> IO ()+addIncoming i (nvs, vs) (nbs, bs) | nbs == nvs = addIncoming' i vs bs nbs++foreign import ccall unsafe "LLVMCountIncoming" countIncoming ::+  Ptr Instruction -> IO CUInt++foreign import ccall unsafe "LLVMGetIncomingValue" getIncomingValue ::+  Ptr Instruction -> CUInt -> IO (Ptr Value)++foreign import ccall unsafe "LLVMGetIncomingBlock" getIncomingBlock ::+  Ptr Instruction -> CUInt -> IO (Ptr BasicBlock)+++foreign import ccall unsafe "LLVMAddCase" addCase ::+  Ptr Instruction -> Ptr Constant -> Ptr BasicBlock -> IO ()++foreign import ccall unsafe "LLVM_General_GetSwitchCases" getSwitchCases ::+  Ptr Instruction -> Ptr (Ptr Constant) -> Ptr (Ptr BasicBlock) -> IO ()++foreign import ccall unsafe "LLVMAddDestination" addDestination ::+  Ptr Instruction -> Ptr BasicBlock -> IO ()++foreign import ccall unsafe "LLVM_General_GetIndirectBrDests" getIndirectBrDests ::+  Ptr Instruction -> Ptr (Ptr BasicBlock) -> IO ()+++foreign import ccall unsafe "LLVM_General_GetInstrAlignment" getInstrAlignment ::+  Ptr Instruction -> IO CUInt++foreign import ccall unsafe "LLVM_General_SetInstrAlignment" setInstrAlignment ::+  Ptr Instruction -> CUInt -> IO ()++foreign import ccall unsafe "LLVM_General_GetAllocaNumElements" getAllocaNumElements ::+  Ptr Instruction -> IO (Ptr Value)++foreign import ccall unsafe "LLVM_General_GetAllocatedType" getAllocatedType ::+  Ptr Instruction -> IO (Ptr Type)++foreign import ccall unsafe "LLVM_General_GetAtomicOrdering" getAtomicOrdering ::+  Ptr Instruction -> IO MemoryOrdering++foreign import ccall unsafe "LLVM_General_GetSynchronizationScope" getSynchronizationScope ::+  Ptr Instruction -> IO LLVMBool++getAtomicity i = return (,) `ap` getSynchronizationScope i `ap` getAtomicOrdering i++foreign import ccall unsafe "LLVM_General_GetVolatile" getVolatile ::+  Ptr Instruction -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_GetInBounds" getInBounds ::+  Ptr Value -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_SetInBounds" setInBounds ::+  Ptr Instruction -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVM_General_GetAtomicRMWOperation" getAtomicRMWOperation ::+  Ptr Instruction -> IO RMWOperation++foreign import ccall unsafe "LLVM_General_CountInstStructureIndices" countInstStructureIndices ::+  Ptr Instruction -> IO CUInt++foreign import ccall unsafe "LLVM_General_GetInstStructureIndices" getInstStructureIndices ::+  Ptr Instruction -> Ptr CUInt -> IO ()++foreign import ccall unsafe "LLVMAddClause" addClause ::+  Ptr Instruction -> Ptr Constant -> IO ()++foreign import ccall unsafe "LLVMSetCleanup" setCleanup ::+  Ptr Instruction -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVM_General_IsCleanup" isCleanup ::+  Ptr Instruction -> IO LLVMBool++foreign import ccall unsafe "LLVMSetMetadata" setMetadata ::+  Ptr Instruction -> MDKindID -> Ptr MDNode -> IO ()++foreign import ccall unsafe "LLVM_General_GetMetadata" getMetadata ::+  Ptr Instruction -> Ptr MDKindID -> Ptr (Ptr MDNode) -> CUInt -> IO CUInt
+ src/LLVM/General/Internal/FFI/InstructionC.cpp view
@@ -0,0 +1,241 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/InstrTypes.h"+#include "llvm/Support/CallSite.h"+#include "llvm/Attributes.h"+#include "llvm/Operator.h"++#include "llvm-c/Core.h"++#include "LLVM/General/Internal/FFI/Instruction.h"++using namespace llvm;++namespace llvm {++static LLVMAtomicOrdering wrap(AtomicOrdering l) {+	switch(l) {+#define ENUM_CASE(x) case x: return LLVM ## x ## AtomicOrdering;+LLVM_GENERAL_FOR_EACH_ATOMIC_ORDERING(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMAtomicOrdering(0);+	}+}++static LLVMSynchronizationScope wrap(SynchronizationScope l) {+	switch(l) {+#define ENUM_CASE(x) case x: return LLVM ## x ## SynchronizationScope;+LLVM_GENERAL_FOR_EACH_SYNCRONIZATION_SCOPE(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMSynchronizationScope(0);+	}+}++static LLVMAtomicRMWOperation wrap(AtomicRMWInst::BinOp l) {+	switch(l) {+#define ENUM_CASE(x) case AtomicRMWInst::x: return LLVM ## x ## RMWOperation;+LLVM_GENERAL_FOR_EACH_RMW_OPERATION(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMAtomicRMWOperation(0);+	}+}++}++extern "C" {++unsigned LLVM_General_GetInstructionDefOpcode(LLVMValueRef val) {+	return unwrap<Instruction>(val)->getOpcode();+}++unsigned LLVM_General_HasNoSignedWrap(LLVMValueRef val) {+	return unwrap<OverflowingBinaryOperator>(val)->hasNoSignedWrap();+}++unsigned LLVM_General_HasNoUnsignedWrap(LLVMValueRef val) {+	return unwrap<OverflowingBinaryOperator>(val)->hasNoUnsignedWrap();+}++int LLVM_General_IsExact(LLVMValueRef val) {+	return unwrap<PossiblyExactOperator>(val)->isExact();+}++LLVMValueRef LLVM_General_GetCallInstCalledValue(+	LLVMValueRef callInst+) {+	return wrap(CallSite(unwrap<Instruction>(callInst)).getCalledValue());+}++LLVMAttribute LLVM_General_GetCallInstAttr(LLVMValueRef callInst, unsigned i) {+	return (LLVMAttribute)CallSite(unwrap<Instruction>(callInst)).getAttributes().getParamAttributes(i).Raw();+}++void LLVM_General_AddCallInstAttr(LLVMValueRef callInst, unsigned i, LLVMAttribute attr) {+	CallSite callSite(unwrap<Instruction>(callInst));+	LLVMContext &context = callSite->getContext();+	AttrBuilder attrBuilder(attr);+	callSite.setAttributes(callSite.getAttributes().addAttr(context, i, Attributes::get(context, attrBuilder)));+}++LLVMAttribute LLVM_General_GetCallInstFunctionAttr(LLVMValueRef callInst) {+	return LLVM_General_GetCallInstAttr(callInst, AttrListPtr::FunctionIndex);+}++void LLVM_General_AddCallInstFunctionAttr(LLVMValueRef callInst, LLVMAttribute attr) {+	LLVM_General_AddCallInstAttr(callInst, AttrListPtr::FunctionIndex, attr);+}++LLVMValueRef LLVM_General_GetAllocaNumElements(LLVMValueRef a) {+	return wrap(unwrap<AllocaInst>(a)->getArraySize());+}++LLVMTypeRef LLVM_General_GetAllocatedType(LLVMValueRef a) {+	return wrap(unwrap<AllocaInst>(a)->getAllocatedType());+}++// ------------------------------------------------------------++#define LLVM_GENERAL_FOR_EACH_ALIGNMENT_INST(macro) \+	macro(Alloca) \+	macro(Load) \+	macro(Store)++unsigned LLVM_General_GetInstrAlignment(LLVMValueRef l) {+	switch(unwrap<Instruction>(l)->getOpcode()) {+#define ENUM_CASE(n) case Instruction::n: return unwrap<n ## Inst>(l)->getAlignment();+		LLVM_GENERAL_FOR_EACH_ALIGNMENT_INST(ENUM_CASE)+#undef ENUM_CASE+	default: return 0;+	}+}++void LLVM_General_SetInstrAlignment(LLVMValueRef l, unsigned a) {+	switch(unwrap<Instruction>(l)->getOpcode()) {+#define ENUM_CASE(n) case Instruction::n: unwrap<n ## Inst>(l)->setAlignment(a);+		LLVM_GENERAL_FOR_EACH_ALIGNMENT_INST(ENUM_CASE)+#undef ENUM_CASE+	}+}++// ------------------------------------------------------------++#define LLVM_GENERAL_FOR_EACH_ATOMIC_INST(macro) \+	macro(Load) \+	macro(Store) \+	macro(Fence) \+	macro(AtomicCmpXchg) \+	macro(AtomicRMW)++LLVMAtomicOrdering LLVM_General_GetAtomicOrdering(LLVMValueRef i) {+	switch(unwrap<Instruction>(i)->getOpcode()) {+#define ENUM_CASE(n) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getOrdering());+		LLVM_GENERAL_FOR_EACH_ATOMIC_INST(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMAtomicOrdering(0);+	}+}++LLVMSynchronizationScope LLVM_General_GetSynchronizationScope(LLVMValueRef i) {+	switch(unwrap<Instruction>(i)->getOpcode()) {+#define ENUM_CASE(n) case Instruction::n: return wrap(unwrap<n ## Inst>(i)->getSynchScope());+		LLVM_GENERAL_FOR_EACH_ATOMIC_INST(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMSynchronizationScope(0);+	}+}++#define LLVM_GENERAL_FOR_EACH_VOLATILITY_INST(macro) \+	macro(Load) \+	macro(Store) \+	macro(AtomicCmpXchg) \+	macro(AtomicRMW)++LLVMBool LLVM_General_GetVolatile(LLVMValueRef i) {+	switch(unwrap<Instruction>(i)->getOpcode()) {+#define ENUM_CASE(n) case Instruction::n: return unwrap<n ## Inst>(i)->isVolatile();+		LLVM_GENERAL_FOR_EACH_VOLATILITY_INST(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMBool(0);+	}+}++// ------------------------------------------------------------++LLVMBool LLVM_General_GetInBounds(LLVMValueRef i) {+	return unwrap<GEPOperator>(i)->isInBounds();+}++void LLVM_General_SetInBounds(LLVMValueRef i, LLVMBool b) {+	unwrap<GetElementPtrInst>(i)->setIsInBounds(b);+}++LLVMAtomicRMWOperation LLVM_General_GetAtomicRMWOperation(LLVMValueRef i) {+	return wrap(unwrap<AtomicRMWInst>(i)->getOperation());+}++LLVMRealPredicate LLVM_General_GetFCmpPredicate(LLVMValueRef Inst) {+	if (FCmpInst *I = dyn_cast<FCmpInst>(unwrap(Inst)))+		return (LLVMRealPredicate)I->getPredicate();+	if (ConstantExpr *CE = dyn_cast<ConstantExpr>(unwrap(Inst)))+		if (CE->getOpcode() == Instruction::FCmp)+			return (LLVMRealPredicate)CE->getPredicate();+	return (LLVMRealPredicate)0;+}++unsigned LLVM_General_CountInstStructureIndices(LLVMValueRef v) {+	if (ExtractValueInst *i = dyn_cast<ExtractValueInst>(unwrap(v))) return i->getNumIndices();+	if (InsertValueInst *i = dyn_cast<InsertValueInst>(unwrap(v))) return i->getNumIndices();+	return 0;+}++void LLVM_General_GetInstStructureIndices(LLVMValueRef v, unsigned *is) {+	ArrayRef<unsigned> a;+	if (ExtractValueInst *i = dyn_cast<ExtractValueInst>(unwrap(v))) a = i->getIndices();+	if (InsertValueInst *i = dyn_cast<InsertValueInst>(unwrap(v))) a = i->getIndices();+	std::copy(a.begin(), a.end(), is);+}++LLVMBool LLVM_General_IsCleanup(LLVMValueRef v) {+	return unwrap<LandingPadInst>(v)->isCleanup();+}++void LLVM_General_GetSwitchCases(+	LLVMValueRef v,+	LLVMValueRef *values,+	LLVMBasicBlockRef *dests+) {+	SwitchInst *s = unwrap<SwitchInst>(v);+	for(SwitchInst::CaseIt i = s->case_begin(); i != s->case_end(); ++i, ++values, ++dests) {+		*values = wrap(i.getCaseValue());+		*dests = wrap(i.getCaseSuccessor());+	}+}++void LLVM_General_GetIndirectBrDests(+	LLVMValueRef v,+	LLVMBasicBlockRef *dests+) {+	IndirectBrInst *ib = unwrap<IndirectBrInst>(v);+	for(unsigned i=0; i != ib->getNumDestinations(); ++i, ++dests)+		*dests = wrap(ib->getDestination(i));+}++unsigned LLVM_General_GetMetadata(+	LLVMValueRef i,+	unsigned *kinds,+	LLVMValueRef *nodes,+	unsigned nKinds+) {+	SmallVector<std::pair<unsigned, MDNode *>, 4> mds;+	unwrap<Instruction>(i)->getAllMetadata(mds);+	if (mds.size() <= nKinds) {+		for(unsigned i=0; i<mds.size(); ++i) {+			kinds[i] = mds[i].first;+			nodes[i] = wrap(mds[i].second);+		}+	}+	return mds.size();+}++}+
+ src/LLVM/General/Internal/FFI/InstructionDefs.hsc view
@@ -0,0 +1,56 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- This module translates the instruction data in "llvm/Instruction.def" into a Haskell data structure,+-- so it may be accessed conveniently with Template Haskell code+module LLVM.General.Internal.FFI.InstructionDefs where++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", },++#define FIRST_BINARY_INST(num) { "Binary" },+#define FIRST_MEMORY_INST(num) { "Memory" },+#define FIRST_CAST_INST(num) { "Cast" },+#define FIRST_OTHER_INST(num) { "Other" },++#define HANDLE_INST(num,opcode,class) { 0, num, #opcode, #class, },++#define LAST_OTHER_INST(num) { 0, 0, 0, 0, } };++#include "llvm/Instruction.def"++#{+define hsc_inject() {                                       \+  hsc_printf(" [ ");                                       \+  struct inst *i;                                           \+  const char *kind;                                         \+  int first = 1;                                            \+  for(i = insts; i->kind || i->opcode; ++i) {               \+    if (i->kind) { kind = i->kind; continue; }              \+    if (!first) { hsc_printf(", "); } else { first = 0; }  \+    hsc_printf(                                             \+        "  (CPPOpcode %d,\"%s\",\"%s\", %s)",               \+        i->opcode, i->name, i->clas, kind                   \+      );                                                    \+  }                                                         \+  hsc_printf(" ] ");                                       \+}+}++data InstructionKind = Terminator | Binary | Memory | Cast | Other+  deriving (Eq, Ord, Show)++data InstructionDef = InstructionDef {+    cppOpcode :: CPPOpcode,+    cAPIName :: String,+    cAPIClassName :: String,+    instructionKind :: InstructionKind+  }+  deriving (Eq, Ord, Show)++instructionDefs :: [InstructionDef]+instructionDefs = [ + InstructionDef o an acn k+ | (o, an, acn, k) <- #{inject},+ an /= "UserOp1" && an /= "UserOp2"+ ]+
+ src/LLVM/General/Internal/FFI/Iterate.hs view
@@ -0,0 +1,13 @@+-- | Functions to help handle LLVM iteration patterns+module LLVM.General.Internal.FFI.Iterate where++import Control.Monad+import Data.Functor+import Foreign.Ptr++-- | retrieve a sequence of objects which form a linked list, given an action to+-- | retrieve the first member and an action to proceed through the list+getXs :: IO (Ptr a) -> (Ptr a -> IO (Ptr a)) -> IO [Ptr a]+getXs firstX nextX = walk =<< firstX+    where walk x | x == nullPtr = return []+          walk x = (x:) <$> (walk <=< nextX) x
+ src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -0,0 +1,180 @@+{-# LANGUAGE+  DeriveDataTypeable,+  StandaloneDeriving,+  GeneralizedNewtypeDeriving+  #-}+-- | Define types which correspond cleanly with some simple types on the C/C++ side.+-- Encapsulate hsc macro weirdness here, supporting higher-level tricks elsewhere.+module LLVM.General.Internal.FFI.LLVMCTypes where++#define __STDC_LIMIT_MACROS+#include "llvm-c/Core.h"+#include "llvm-c/Target.h"+#include "llvm-c/TargetMachine.h"+#include "LLVM/General/Internal/FFI/Instruction.h"+#include "LLVM/General/Internal/FFI/Value.h"+#include "LLVM/General/Internal/FFI/SMDiagnostic.h"+#include "LLVM/General/Internal/FFI/InlineAssembly.h"+#include "LLVM/General/Internal/FFI/Target.h"+#include "LLVM/General/Internal/FFI/Function.h"+#include "LLVM/General/Internal/FFI/GlobalValue.h"+#include "LLVM/General/Internal/FFI/Type.h"++import Language.Haskell.TH.Quote++import Data.Data+import Data.Bits+import Foreign.C+import Foreign.Storable++#{+define hsc_inject(l, typ, cons, hprefix, recmac) { \+  struct { const char *s; unsigned n; } *p, list[] = { LLVM_GENERAL_FOR_EACH_ ## l(recmac) }; \+  for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \+    hsc_printf(#hprefix "%s :: " #typ "\n", p->s); \+    hsc_printf(#hprefix "%s = " #cons " %u\n", p->s, p->n); \+  } \+  hsc_printf(#hprefix "P = QuasiQuoter {\n" \+             "  quoteExp = undefined,\n" \+             "  quotePat = \\s -> dataToPatQ (const Nothing) $ case s of"); \+  for(p = list; p < list + sizeof(list)/sizeof(list[0]); ++p) { \+    hsc_printf("\n    \"%s\" -> " #hprefix "%s", p->s, p->s); \+  } \+  hsc_printf("\n    x -> error $ \"bad quasiquoted FFI constant for " #hprefix ": \" ++ x"); \+  hsc_printf(",\n" \+             "  quoteType = undefined,\n" \+             "  quoteDec = undefined\n" \+             " }\n"); \+} +}++deriving instance Data CUInt++newtype LLVMBool = LLVMBool CUInt++newtype CPPOpcode = CPPOpcode CUInt+  deriving (Eq, Ord, Show, Typeable, Data)++newtype ICmpPredicate = ICmpPredicate CUInt+  deriving (Eq, Ord, Show, Typeable, Data)+#{enum ICmpPredicate, ICmpPredicate,+ iCmpPredEQ = LLVMIntEQ,+ iCmpPredNE = LLVMIntNE,+ iCmpPredUGT = LLVMIntUGT,+ iCmpPredUGE = LLVMIntUGE,+ iCmpPredULT = LLVMIntULT,+ iCmpPredULE = LLVMIntULE,+ iCmpPredSGT = LLVMIntSGT,+ iCmpPredSGE = LLVMIntSGE,+ iCmpPredSLT = LLVMIntSLT,+ iCmpPredSLE = LLVMIntSLE+}++newtype FCmpPredicate = FCmpPredicate CUInt+  deriving (Eq, Ord, Show, Typeable, Data)+#{enum FCmpPredicate, FCmpPredicate,+ fCmpPredFalse = LLVMRealPredicateFalse,+ fCmpPredOEQ = LLVMRealOEQ,+ fCmpPredOGT = LLVMRealOGT,+ fCmpPredOGE = LLVMRealOGE,+ fCmpPredOLT = LLVMRealOLT,+ fCmpPredOLE = LLVMRealOLE,+ fCmpPredONE = LLVMRealONE,+ fCmpPredORD = LLVMRealORD,+ fCmpPredUNO = LLVMRealUNO,+ fCmpPredUEQ = LLVMRealUEQ,+ fCmpPredUGT = LLVMRealUGT,+ fCmpPredUGE = LLVMRealUGE,+ fCmpPredULT = LLVMRealULT,+ fCmpPredULE = LLVMRealULE,+ fCmpPredUNE = LLVMRealUNE,+ fcmpPredTrue = LLVMRealPredicateTrue+}++newtype MDKindID = MDKindID CUInt+  deriving (Storable)++newtype MemoryOrdering = MemoryOrdering CUInt+  deriving (Eq, Typeable, Data)+#define MO_Rec(n) { #n, LLVM ## n ## AtomicOrdering },+#{inject ATOMIC_ORDERING, MemoryOrdering, MemoryOrdering, memoryOrdering, MO_Rec}++newtype Linkage = Linkage CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define LK_Rec(n) { #n, LLVM ## n ## Linkage },+#{inject LINKAGE, Linkage, Linkage, linkage, LK_Rec}++newtype Visibility = Visibility CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define VIS_Rec(n) { #n, LLVM ## n ## Visibility },+#{inject VISIBILITY, Visibility, Visibility, visibility, VIS_Rec}++newtype CallConv = CallConv CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define CC_Rec(n) { #n, LLVM ## n ## CallConv },+#{inject CALLCONV, CallConv, CallConv, callConv, CC_Rec}++newtype ValueSubclassId = ValueSubclassId CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define VSID_Rec(n) { #n, LLVM ## n ## SubclassId },+#{inject VALUE_SUBCLASS, ValueSubclassId, ValueSubclassId, valueSubclassId, VSID_Rec}++newtype DiagnosticKind = DiagnosticKind CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define DK_Rec(n) { #n, LLVMDiagnosticKind ## n },+#{inject DIAGNOSTIC_KIND, DiagnosticKind, DiagnosticKind, diagnosticKind, DK_Rec}++newtype AsmDialect = AsmDialect CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define ASM_Rec(n) { #n, LLVMAsmDialect_ ## n },+#{inject ASM_DIALECT, AsmDialect, AsmDialect, asmDialect, ASM_Rec}++newtype RMWOperation = RMWOperation CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define RMWOp_Rec(n) { #n, LLVM ## n ## RMWOperation },+#{inject RMW_OPERATION, RMWOperation, RMWOperation, rmwOperation, RMWOp_Rec}++newtype RelocModel = RelocModel CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define RM_Rec(n,m) { #n, LLVMReloc ## n },+#{inject RELOC_MODEL, RelocModel, RelocModel, relocModel, RM_Rec}++newtype CodeModel = CodeModel CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define CM_Rec(n) { #n, LLVMCodeModel ## n },+#{inject CODE_MODEL, CodeModel, CodeModel, codeModel, CM_Rec}++newtype CodeGenOptLevel = CodeGenOptLevel CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define CGOL_Rec(n) { #n, LLVMCodeGenLevel ## n },+#{inject CODE_GEN_OPT_LEVEL, CodeGenOptLevel, CodeGenOptLevel, codeGenOptLevel, CGOL_Rec}++newtype FloatABIType = FloatABIType CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define FAT_Rec(n) { #n, LLVM_General_FloatABI_ ## n },+#{inject FLOAT_ABI, FloatABIType, FloatABIType, floatABI, FAT_Rec}++newtype FPOpFusionMode = FPOpFusionMode CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define FPOFM_Rec(n) { #n, LLVM_General_FPOpFusionMode_ ## n },+#{inject FP_OP_FUSION_MODE, FPOpFusionMode, FPOpFusionMode, fpOpFusionMode, FPOFM_Rec}++newtype TargetOptionFlag = TargetOptionFlag CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define TOF_Rec(n) { #n, LLVM_General_TargetOptionFlag_ ## n },+#{inject TARGET_OPTION_FLAG, TargetOptionFlag, TargetOptionFlag, targetOptionFlag, TOF_Rec}++newtype TypeKind = TypeKind CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define TK_Rec(n) { #n, LLVM ## n ## TypeKind },+#{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec}++newtype ParamAttr = ParamAttr CUInt+  deriving (Eq, Read, Show, Bits, Typeable, Data)+#define PA_Rec(n) { #n, LLVM ## n ## Attribute },+#{inject PARAM_ATTR, ParamAttr, ParamAttr, paramAttr, PA_Rec}++newtype FunctionAttr = FunctionAttr CUInt+  deriving (Eq, Read, Show, Bits, Typeable, Data)+#define FA_Rec(n,a) { #n, LLVM ## n ## a },+#{inject FUNCTION_ATTR, FunctionAttr, FunctionAttr, functionAttr, FA_Rec}
+ src/LLVM/General/Internal/FFI/Metadata.hs view
@@ -0,0 +1,69 @@+{-#+  LANGUAGE+  ForeignFunctionInterface+  #-}++module LLVM.General.Internal.FFI.Metadata where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.LLVMCTypes++foreign import ccall unsafe "LLVMIsAMDString" isAMDString ::+  Ptr Value -> IO (Ptr MDString)++foreign import ccall unsafe "LLVMIsAMDNode" isAMDNode ::+  Ptr Value -> IO (Ptr MDNode)++foreign import ccall unsafe "LLVMGetMDKindIDInContext" getMDKindIDInContext' ::+  Ptr Context -> Ptr CChar -> CUInt -> IO MDKindID++getMDKindIDInContext ctx (c, n) = getMDKindIDInContext' ctx c n++foreign import ccall unsafe "LLVM_General_GetMDKindNames" getMDKindNames ::+  Ptr Context -> Ptr (Ptr CChar) -> Ptr CUInt -> CUInt -> IO CUInt++foreign import ccall unsafe "LLVMMDStringInContext" mdStringInContext' ::+  Ptr Context -> CString -> CUInt -> IO (Ptr MDString)++mdStringInContext ctx (p, n) = mdStringInContext' ctx p n++foreign import ccall unsafe "LLVMGetMDString" getMDString ::+  Ptr MDString -> Ptr CUInt -> IO CString++foreign import ccall unsafe "LLVMMDNodeInContext" createMDNodeInContext' ::+  Ptr Context -> Ptr (Ptr Value) -> CUInt -> IO (Ptr MDNode)++createMDNodeInContext ctx (n, vs) = createMDNodeInContext' ctx vs n++foreign import ccall unsafe "LLVM_General_CreateTemporaryMDNodeInContext" createTemporaryMDNodeInContext ::+  Ptr Context -> IO (Ptr MDNode)++foreign import ccall unsafe "LLVM_General_DestroyTemporaryMDNode" destroyTemporaryMDNode ::+  Ptr MDNode -> IO ()++foreign import ccall unsafe "LLVM_General_GetMDNodeNumOperands" getMDNodeNumOperands ::+  Ptr MDNode -> IO CUInt++foreign import ccall unsafe "LLVMGetMDNodeOperands" getMDNodeOperands ::+  Ptr MDNode -> Ptr (Ptr Value) -> IO ()++foreign import ccall unsafe "LLVM_General_MDNodeIsFunctionLocal" mdNodeIsFunctionLocal ::+  Ptr MDNode -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_GetNamedMetadataName" getNamedMetadataName ::+  Ptr NamedMetadata -> Ptr CUInt -> IO (Ptr CChar)++foreign import ccall unsafe "LLVM_General_GetNamedMetadataNumOperands" getNamedMetadataNumOperands ::+  Ptr NamedMetadata -> IO CUInt++foreign import ccall unsafe "LLVM_General_GetNamedMetadataOperands" getNamedMetadataOperands ::+  Ptr NamedMetadata -> Ptr (Ptr MDNode) -> IO ()++foreign import ccall unsafe "LLVM_General_NamedMetadataAddOperands" namedMetadataAddOperands' ::+  Ptr NamedMetadata -> Ptr (Ptr MDNode) -> CUInt -> IO ()++namedMetadataAddOperands nm (n, vs) = namedMetadataAddOperands' nm vs n
+ src/LLVM/General/Internal/FFI/MetadataC.cpp view
@@ -0,0 +1,71 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/Metadata.h"++#include "llvm-c/Core.h"++using namespace llvm;++extern "C" {++unsigned LLVM_General_GetMDKindNames(+	LLVMContextRef c,+	const char **s,+	unsigned *l,+	unsigned n+) {+	SmallVector<StringRef, 16> ns;+	unwrap(c)->getMDKindNames(ns);+	if (ns.size() <= n) {+		for(unsigned i=0; i < ns.size(); ++i) {+			s[i] = ns[i].data();+			l[i] = ns[i].size();+		}+	}+	return ns.size();+}++unsigned LLVM_General_GetMDNodeNumOperands(LLVMValueRef v) {+	return unwrap<MDNode>(v)->getNumOperands();+}++unsigned LLVM_General_MDNodeIsFunctionLocal(LLVMValueRef v) {+	return unwrap<MDNode>(v)->isFunctionLocal();+}++void LLVM_General_NamedMetadataAddOperands(+	NamedMDNode *n,+	LLVMValueRef *ops,+	unsigned nOps+) {+	for(unsigned i = 0; i != nOps; ++i) n->addOperand(unwrap<MDNode>(ops[i]));+}++const char *LLVM_General_GetNamedMetadataName(+	NamedMDNode *n,+	unsigned *len+) {+	StringRef s = n->getName();+	*len = s.size();+	return s.data();+}++unsigned LLVM_General_GetNamedMetadataNumOperands(NamedMDNode *n) {+	return n->getNumOperands();+}++void LLVM_General_GetNamedMetadataOperands(NamedMDNode *n, LLVMValueRef *dest) {+	for(unsigned i = 0; i != n->getNumOperands(); ++i)+		dest[i] = wrap(n->getOperand(i));+}++LLVMValueRef LLVM_General_CreateTemporaryMDNodeInContext(LLVMContextRef c) {+	return wrap(MDNode::getTemporary(*unwrap(c), ArrayRef<Value *>()));+}++void LLVM_General_DestroyTemporaryMDNode(LLVMValueRef v) {+	MDNode::deleteTemporary(unwrap<MDNode>(v));+}++}+
+ src/LLVM/General/Internal/FFI/Module.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls+  #-}++module LLVM.General.Internal.FFI.Module where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Context+import LLVM.General.Internal.FFI.Type++data Module++foreign import ccall unsafe "LLVMModuleCreateWithNameInContext" moduleCreateWithNameInContext ::+  CString -> Ptr Context -> IO (Ptr Module)++foreign import ccall unsafe "LLVMGetModuleContext" getModuleContext ::+  Ptr Module -> IO (Ptr Context)++foreign import ccall unsafe "LLVMDisposeModule" disposeModule ::+  Ptr Module -> IO ()++foreign import ccall unsafe "LLVMGetDataLayout" getDataLayout ::+  Ptr Module -> IO CString++foreign import ccall unsafe "LLVMSetDataLayout" setDataLayout ::+  Ptr Module -> CString -> IO ()++foreign import ccall unsafe "LLVMGetTarget" getTargetTriple ::+  Ptr Module -> IO CString++foreign import ccall unsafe "LLVMSetTarget" setTargetTriple ::+  Ptr Module -> CString -> IO ()++foreign import ccall unsafe "LLVM_General_GetModuleIdentifier" getModuleIdentifier ::+  Ptr Module -> IO CString++foreign import ccall unsafe "LLVMGetFirstGlobal" getFirstGlobal ::+  Ptr Module -> IO (Ptr GlobalVariable)++foreign import ccall unsafe "LLVMGetNextGlobal" getNextGlobal ::+  Ptr GlobalVariable -> IO (Ptr GlobalVariable)++foreign import ccall unsafe "LLVM_General_GetFirstAlias" getFirstAlias ::+  Ptr Module -> IO (Ptr GlobalAlias)++foreign import ccall unsafe "LLVM_General_GetNextAlias" getNextAlias ::+  Ptr GlobalAlias -> IO (Ptr GlobalAlias)++foreign import ccall unsafe "LLVMGetFirstFunction" getFirstFunction ::+  Ptr Module -> IO (Ptr Function)++foreign import ccall unsafe "LLVMGetNextFunction" getNextFunction ::+  Ptr Function -> IO (Ptr Function)++foreign import ccall unsafe "LLVM_General_GetFirstNamedMetadata" getFirstNamedMetadata ::+  Ptr Module -> IO (Ptr NamedMetadata)++foreign import ccall unsafe "LLVM_General_GetNextNamedMetadata" getNextNamedMetadata ::+  Ptr NamedMetadata -> IO (Ptr NamedMetadata)++foreign import ccall unsafe "LLVMAddGlobalInAddressSpace" addGlobalInAddressSpace ::+  Ptr Module -> Ptr Type -> CString -> CUInt -> IO (Ptr GlobalVariable)++foreign import ccall unsafe "LLVM_General_JustAddAlias" justAddAlias ::+  Ptr Module -> Ptr Type -> CString -> IO (Ptr GlobalAlias)+++foreign import ccall unsafe "LLVMAddFunction" addFunction ::+  Ptr Module -> CString -> Ptr Type -> IO (Ptr Function)++foreign import ccall unsafe "LLVM_General_GetOrAddNamedMetadata" getOrAddNamedMetadata ::+  Ptr Module -> CString -> IO (Ptr NamedMetadata)++foreign import ccall unsafe "LLVM_General_ModuleAppendInlineAsm" moduleAppendInlineAsm' ::+  Ptr Module -> Ptr CChar -> CUInt -> IO ()++newtype ModuleAsm a = ModuleAsm a++moduleAppendInlineAsm m (ModuleAsm (c, n)) = moduleAppendInlineAsm' m c n++foreign import ccall unsafe "LLVM_General_ModuleGetInlineAsm" moduleGetInlineAsm ::+  Ptr Module -> IO (ModuleAsm CString)
+ src/LLVM/General/Internal/FFI/ModuleC.cpp view
@@ -0,0 +1,58 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/Module.h"++#include "llvm-c/Core.h"+#include <iostream>++using namespace llvm;++extern "C" {++char *LLVM_General_GetModuleIdentifier(LLVMModuleRef val) {+	return strdup(unwrap(val)->getModuleIdentifier().c_str());+}++LLVMValueRef LLVM_General_GetFirstAlias(LLVMModuleRef m) {+	Module *mod = unwrap(m);+	Module::alias_iterator i = mod->alias_begin();+	return i == mod->alias_end() ? 0 : wrap(i);+}++LLVMValueRef LLVM_General_GetNextAlias(LLVMValueRef a) {+	GlobalAlias *alias = unwrap<GlobalAlias>(a);+	Module::alias_iterator i = alias;+	if (++i == alias->getParent()->alias_end()) return 0;+	return wrap(i);+}++LLVMValueRef LLVM_General_JustAddAlias(LLVMModuleRef m, LLVMTypeRef ty, const char *name) {+	return wrap(new GlobalAlias(unwrap(ty), GlobalValue::ExternalLinkage, name, 0, unwrap(m)));+}++NamedMDNode *LLVM_General_GetOrAddNamedMetadata(LLVMModuleRef m, const char *name) {+	return unwrap(m)->getOrInsertNamedMetadata(name);+}++NamedMDNode *LLVM_General_GetFirstNamedMetadata(LLVMModuleRef m) {+	Module *mod = unwrap(m);+	Module::named_metadata_iterator i = mod->named_metadata_begin();+	return i == mod->named_metadata_end() ? 0 : i;+}++NamedMDNode *LLVM_General_GetNextNamedMetadata(NamedMDNode *a) {+	Module::named_metadata_iterator i = a;+	if (++i == a->getParent()->named_metadata_end()) return 0;+	return i;+}++void LLVM_General_ModuleAppendInlineAsm(LLVMModuleRef m, const char *s, unsigned l) {+	unwrap(m)->appendModuleInlineAsm(StringRef(s,l));+}++const char *LLVM_General_ModuleGetInlineAsm(LLVMModuleRef m) {+	return unwrap(m)->getModuleInlineAsm().c_str();+}++}+
+ src/LLVM/General/Internal/FFI/PassManager.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE+  TemplateHaskell,+  ForeignFunctionInterface,+  EmptyDataDecls+  #-}++module LLVM.General.Internal.FFI.PassManager where++import Language.Haskell.TH++import Control.Monad++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.PtrHierarchy+import LLVM.General.Internal.FFI.Cleanup+import LLVM.General.Internal.FFI.Module+import LLVM.General.Internal.FFI.Target+import LLVM.General.Internal.FFI.Transforms++import qualified LLVM.General.Transforms as G++data PassManager++foreign import ccall unsafe "LLVMCreatePassManager" createPassManager ::+    IO (Ptr PassManager)++foreign import ccall unsafe "LLVMDisposePassManager" disposePassManager ::+    Ptr PassManager -> IO ()++foreign import ccall unsafe "LLVMRunPassManager" runPassManager ::+    Ptr PassManager -> Ptr Module -> IO CUInt++foreign import ccall unsafe "LLVMCreateFunctionPassManagerForModule" createFunctionPassManagerForModule ::+    Ptr Module -> IO (Ptr PassManager)++foreign import ccall unsafe "LLVMInitializeFunctionPassManager" initializeFunctionPassManager ::+    Ptr PassManager -> IO CUInt++foreign import ccall unsafe "LLVMRunFunctionPassManager" runFunctionPassManager ::+    Ptr PassManager -> Ptr Value -> IO CUInt++foreign import ccall unsafe "LLVMFinalizeFunctionPassManager" finalizeFunctionPassManager ::+    Ptr PassManager -> IO CUInt++$(do+  let declareForeign :: Name -> [Type] -> DecsQ+      declareForeign hName extraParams = do+        let n = nameBase hName+        foreignDecl +          (cName n)+          ("add" ++ n ++ "Pass")+          ([[t| Ptr PassManager |]] +           ++ [[t| Ptr TargetLowering |] | needsTargetLowering n]+           ++ map typeMapping extraParams)+          (tupleT 0)++  TyConI (DataD _ _ _ cons _) <- reify ''G.Pass+  liftM concat $ forM cons $ \con -> case con of+    RecC n l -> declareForeign n [ t | (_,_,t) <- l ]+    NormalC n [] -> declareForeign n []+    NormalC n _ -> error "pass descriptor constructors with fields need to be records"+ )++data PassManagerBuilder++foreign import ccall unsafe "LLVMPassManagerBuilderCreate" passManagerBuilderCreate ::+    IO (Ptr PassManagerBuilder) ++foreign import ccall unsafe "LLVMPassManagerBuilderDispose" passManagerBuilderDispose ::+    Ptr PassManagerBuilder -> IO ()++foreign import ccall unsafe "LLVMPassManagerBuilderSetOptLevel" passManagerBuilderSetOptLevel ::+    Ptr PassManagerBuilder -> CUInt -> IO () ++foreign import ccall unsafe "LLVMPassManagerBuilderSetSizeLevel" passManagerBuilderSetSizeLevel ::+    Ptr PassManagerBuilder -> CUInt -> IO ()++foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnitAtATime" passManagerBuilderSetDisableUnitAtATime ::+    Ptr PassManagerBuilder -> CUInt -> IO () ++foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableUnrollLoops" passManagerBuilderSetDisableUnrollLoops ::+    Ptr PassManagerBuilder -> CUInt -> IO ()++foreign import ccall unsafe "LLVMPassManagerBuilderSetDisableSimplifyLibCalls" passManagerBuilderSetDisableSimplifyLibCalls ::+    Ptr PassManagerBuilder -> CUInt -> IO () ++foreign import ccall unsafe "LLVMPassManagerBuilderUseInlinerWithThreshold" passManagerBuilderUseInlinerWithThreshold ::+    Ptr PassManagerBuilder -> CUInt -> IO ()++foreign import ccall unsafe "LLVMPassManagerBuilderPopulateFunctionPassManager" passManagerBuilderPopulateFunctionPassManager ::+    Ptr PassManagerBuilder -> Ptr PassManager -> IO () ++foreign import ccall unsafe "LLVMPassManagerBuilderPopulateModulePassManager" passManagerBuilderPopulateModulePassManager ::+    Ptr PassManagerBuilder -> Ptr PassManager -> IO ()++foreign import ccall unsafe "LLVMPassManagerBuilderPopulateLTOPassManager" passManagerBuilderPopulateLTOPassManager ::+    Ptr PassManagerBuilder -> Ptr PassManager -> CUChar -> CUChar -> IO ()
+ src/LLVM/General/Internal/FFI/PassManagerC.cpp view
@@ -0,0 +1,130 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"+#include "llvm/Transforms/Scalar.h"+#include "llvm/Transforms/IPO.h"+#include "llvm/Transforms/Vectorize.h"+#include "llvm/PassManager.h"++#include "llvm-c/Core.h"++using namespace llvm;++extern "C" {+typedef struct LLVMOpaqueVectorizationConfig *LLVMVectorizationConfigRef;+typedef struct LLVMOpaqueTargetLowering *LLVMTargetLoweringRef;+}++namespace llvm {+inline TargetLowering *unwrap(LLVMTargetLoweringRef P) { +	return reinterpret_cast<TargetLowering *>(P);+}++inline LLVMTargetLoweringRef wrap(const TargetLowering *P) { +	return reinterpret_cast<LLVMTargetLoweringRef>(const_cast<TargetLowering *>(P));+}+}++extern "C" {++#define LLVM_GENERAL_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(macro) \+	macro(BlockPlacement)			\+	macro(BreakCriticalEdges) \+	macro(DeadCodeElimination) \+	macro(DeadInstElimination) \+	macro(DemoteRegisterToMemory) \+	macro(LCSSA) \+	macro(LoopInstSimplify) \+	macro(LowerAtomic) \+	macro(LowerSwitch) \+	macro(MergeFunctions) \+	macro(PartialInlining) \+	macro(Sinking) \+	macro(StripDeadDebugInfo) \+	macro(StripDebugDeclare) \+	macro(StripNonDebugSymbols) \++#define ENUM_CASE(p)								\+void LLVM_General_Add ## p ## Pass(LLVMPassManagerRef PM) {	\+	unwrap(PM)->add(create ## p ## Pass());			\+}+LLVM_GENERAL_FOR_EACH_PASS_WITHOUT_LLVM_C_BINDING(ENUM_CASE)+#undef ENUM_CASE++void LLVM_General_AddCodeGenPreparePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T) {+	unwrap(PM)->add(createCodeGenPreparePass(unwrap(T)));+}+	+void LLVM_General_AddGlobalValueNumberingPass(LLVMPassManagerRef PM, LLVMBool noLoads) {+	unwrap(PM)->add(createGVNPass(noLoads));+}++void LLVM_General_AddInternalizePass(LLVMPassManagerRef PM, unsigned nExports, const char **exports) {+	std::vector<const char *> exportList(exports, exports + nExports);+	unwrap(PM)->add(createInternalizePass(exportList));+}++void LLVM_General_AddLoopStrengthReducePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T) {+	unwrap(PM)->add(createLoopStrengthReducePass(unwrap(T)));+}++void LLVM_General_AddLowerInvokePass(LLVMPassManagerRef PM, LLVMTargetLoweringRef T, LLVMBool expensiveEH) {+	unwrap(PM)->add(createLowerInvokePass(unwrap(T), expensiveEH));+}+	+void LLVM_General_AddSROAPass(LLVMPassManagerRef PM, LLVMBool RequiresDomTree) {+	unwrap(PM)->add(createSROAPass(RequiresDomTree));+}++void LLVM_General_AddBasicBlockVectorizePass(+	LLVMPassManagerRef PM,+	unsigned vectorBits,+	LLVMBool vectorizeBools,+	LLVMBool vectorizeInts,+	LLVMBool vectorizeFloats,+	LLVMBool vectorizePointers,+	LLVMBool vectorizeCasts,+	LLVMBool vectorizeMath,+	LLVMBool vectorizeFusedMultiplyAdd,+	LLVMBool vectorizeSelect,+	LLVMBool vectorizeCmp,+	LLVMBool vectorizeGetElementPtr,+	LLVMBool vectorizeMemoryOperations,+	LLVMBool alignedOnly,+	unsigned reqChainDepth,+	unsigned searchLimit,+	unsigned maxCandidatePairsForCycleCheck,+	LLVMBool splatBreaksChain,+	unsigned maxInstructions,+	unsigned maxIterations,+	LLVMBool powerOfTwoLengthsOnly,+	LLVMBool noMemoryOperationBoost,+	LLVMBool fastDependencyAnalysis+) {+	VectorizeConfig vectorizeConfig;+	vectorizeConfig.VectorBits = vectorBits;+	vectorizeConfig.VectorizeBools = vectorizeBools;+	vectorizeConfig.VectorizeInts = vectorizeInts;+	vectorizeConfig.VectorizeFloats = vectorizeFloats;+	vectorizeConfig.VectorizePointers = vectorizePointers;+	vectorizeConfig.VectorizeCasts = vectorizeCasts;+	vectorizeConfig.VectorizeMath = vectorizeMath;+	vectorizeConfig.VectorizeFMA = vectorizeFusedMultiplyAdd;+	vectorizeConfig.VectorizeSelect = vectorizeSelect;+	vectorizeConfig.VectorizeCmp = vectorizeCmp;+	vectorizeConfig.VectorizeGEP = vectorizeGetElementPtr;+	vectorizeConfig.VectorizeMemOps = vectorizeMemoryOperations;+	vectorizeConfig.AlignedOnly = alignedOnly;+	vectorizeConfig.ReqChainDepth = reqChainDepth;+	vectorizeConfig.SearchLimit = searchLimit;+	vectorizeConfig.MaxCandPairsForCycleCheck = maxCandidatePairsForCycleCheck;+	vectorizeConfig.SplatBreaksChain = splatBreaksChain;+	vectorizeConfig.MaxInsts = maxInstructions;+	vectorizeConfig.MaxIter = maxIterations;+	vectorizeConfig.Pow2LenOnly = powerOfTwoLengthsOnly;+	vectorizeConfig.NoMemOpBoost = noMemoryOperationBoost;+	vectorizeConfig.FastDep = fastDependencyAnalysis;	++	unwrap(PM)->add(createBBVectorizePass(vectorizeConfig));+}	++}
+ src/LLVM/General/Internal/FFI/PtrHierarchy.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  MultiParamTypeClasses,+  EmptyDataDecls,+  FunctionalDependencies,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | This module defines typeclasses to represent the relationships of an object-oriented inheritance hierarchy+module LLVM.General.Internal.FFI.PtrHierarchy where++import Foreign.Ptr++-- | a class to represent safe casting of pointers to objects of descendant-classes to ancestor-classes.+class DescendentOf a b where+    upCast :: Ptr b -> Ptr a+    upCast = castPtr++-- | trivial casts+instance DescendentOf a a where+    upCast = id++-- | a class to represent direct parent-child relationships+class ChildOf b c | c -> b++-- | ancestor-descentant relationships are build out of parent-child relationships+instance (DescendentOf a b, ChildOf b c) => DescendentOf a c++-- | <http://llvm.org/doxygen/classllvm_1_1Value.html>+data Value++-- | <http://llvm.org/doxygen/classllvm_1_1Constant.html>+data Constant++instance ChildOf User Constant++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalValue.html>+data GlobalValue++instance ChildOf Constant GlobalValue++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalVariable.html>+data GlobalVariable++instance ChildOf GlobalValue GlobalVariable++-- | <http://llvm.org/doxygen/classllvm_1_1GlobalAlias.html>+data GlobalAlias++instance ChildOf GlobalValue GlobalAlias++-- | <http://llvm.org/doxygen/classllvm_1_1Function.html>+data Function++instance ChildOf GlobalValue Function++-- | <http://llvm.org/doxygen/classllvm_1_1BasicBlock.html>+data BasicBlock++instance ChildOf Value BasicBlock++-- | <http://llvm.org/doxygen/classllvm_1_1Argument.html>+data Parameter++instance ChildOf Value Parameter++-- | <http://llvm.org/doxygen/classllvm_1_1Instruction.html>+data Instruction++instance ChildOf User Instruction++-- | <http://llvm.org/doxygen/classllvm_1_1User.html>+data User++instance ChildOf Value User++-- | <http://llvm.org/doxygen/classllvm_1_1MDNode.html>+data MDNode++instance ChildOf Value MDNode++-- | <http://llvm.org/doxygen/classllvm_1_1MDString.html>+data MDString++instance ChildOf Value MDString++-- | <http://llvm.org/doxygen/classllvm_1_1NamedMDNode.html>+data NamedMetadata++-- | <http://llvm.org/doxygen/classllvm_1_1InlineAsm.html>+data InlineAsm++instance ChildOf Value InlineAsm
+ src/LLVM/General/Internal/FFI/SMDiagnostic.h view
@@ -0,0 +1,15 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__SMDIAGNOSTIC__+#define __LLVM_GENERAL_INTERNAL_FFI__SMDIAGNOSTIC__++#define LLVM_GENERAL_FOR_EACH_DIAGNOSTIC_KIND(macro) \+	macro(Error) \+	macro(Warning) \+	macro(Note)++typedef enum {+#define ENUM_CASE(k) LLVMDiagnosticKind ## k,+LLVM_GENERAL_FOR_EACH_DIAGNOSTIC_KIND(ENUM_CASE)+#undef ENUM_CASE+} LLVMDiagnosticKind;++#endif
+ src/LLVM/General/Internal/FFI/SMDiagnostic.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls+  #-}++-- | FFI functions for handling the LLVM SMDiagnostic class+module LLVM.General.Internal.FFI.SMDiagnostic where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes++data SMDiagnostic++-- | allocate an SMDiagnostic object+foreign import ccall unsafe "LLVM_General_CreateSMDiagnostic" createSMDiagnostic ::+  IO (Ptr SMDiagnostic)++foreign import ccall unsafe "LLVM_General_DisposeSMDiagnostic" disposeSMDiagnostic ::+  Ptr SMDiagnostic -> IO ()++foreign import ccall unsafe "LLVM_General_GetSMDiagnosticKind" getSMDiagnosticKind ::+  Ptr SMDiagnostic -> IO DiagnosticKind++foreign import ccall unsafe "LLVM_General_GetSMDiagnosticLineNo" getSMDiagnosticLineNo ::+  Ptr SMDiagnostic -> IO CInt ++foreign import ccall unsafe "LLVM_General_GetSMDiagnosticColumnNo" getSMDiagnosticColumnNo ::+  Ptr SMDiagnostic -> IO CInt ++foreign import ccall unsafe "LLVM_General_GetSMDiagnosticFilename" getSMDiagnosticFilename ::+  Ptr SMDiagnostic -> IO CString ++foreign import ccall unsafe "LLVM_General_GetSMDiagnosticMessage" getSMDiagnosticMessage ::+  Ptr SMDiagnostic -> IO CString ++foreign import ccall unsafe "LLVM_General_GetSMDiagnosticLineContents" getSMDiagnosticLineContents ::+  Ptr SMDiagnostic -> IO CString +
+ src/LLVM/General/Internal/FFI/SMDiagnosticC.cpp view
@@ -0,0 +1,31 @@+#define __STDC_LIMIT_MACROS+#include "llvm/LLVMContext.h"++#include "llvm/Support/SourceMgr.h"+#include "llvm-c/Core.h"++#include "LLVM/General/Internal/FFI/SMDiagnostic.h"++using namespace llvm;++extern "C" {++SMDiagnostic *LLVM_General_CreateSMDiagnostic() { return new SMDiagnostic(); }+void LLVM_General_DisposeSMDiagnostic(SMDiagnostic *p) { delete p; }++LLVMDiagnosticKind LLVM_General_GetSMDiagnosticKind(SMDiagnostic *p) {+	switch(p->getKind()) {+#define ENUM_CASE(k) case SourceMgr::DK_ ## k: return LLVMDiagnosticKind ## k;+		LLVM_GENERAL_FOR_EACH_DIAGNOSTIC_KIND(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVMDiagnosticKind(0);+	}+}++int LLVM_General_GetSMDiagnosticLineNo(SMDiagnostic *p) { return p->getLineNo(); }+int LLVM_General_GetSMDiagnosticColumnNo(SMDiagnostic *p) { return p->getColumnNo(); }+const char *LLVM_General_GetSMDiagnosticFilename(SMDiagnostic *p) { return p->getFilename().c_str(); }+const char *LLVM_General_GetSMDiagnosticMessage(SMDiagnostic *p) { return p->getMessage().c_str(); }+const char *LLVM_General_GetSMDiagnosticLineContents(SMDiagnostic *p) { return p->getLineContents().c_str(); }++}
+ src/LLVM/General/Internal/FFI/Target.h view
@@ -0,0 +1,74 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__TARGET__H__+#define __LLVM_GENERAL_INTERNAL_FFI__TARGET__H__++#define LLVM_GENERAL_FOR_EACH_RELOC_MODEL(macro)	\+	macro(Default, Default)													\+	macro(Static, Static)														\+	macro(PIC, PIC_)																\+	macro(DynamicNoPic, DynamicNoPIC)++#define LLVM_GENERAL_FOR_EACH_CODE_MODEL(macro) \+	macro(Default)																\+	macro(JITDefault)															\+	macro(Small)																	\+	macro(Kernel)																	\+	macro(Medium)																	\+	macro(Large)++#define LLVM_GENERAL_FOR_EACH_CODE_GEN_OPT_LEVEL(macro) \+	macro(None)																						\+	macro(Less)																						\+	macro(Default)																				\+	macro(Aggressive)++#define LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(macro)	\+	macro(PrintMachineCode)																\+	macro(NoFramePointerElim)															\+	macro(NoFramePointerElimNonLeaf)											\+	macro(LessPreciseFPMADOption)													\+	macro(UnsafeFPMath)																		\+	macro(NoInfsFPMath)																		\+	macro(NoNaNsFPMath)																		\+	macro(HonorSignDependentRoundingFPMathOption)					\+	macro(UseSoftFloat)																		\+	macro(NoZerosInBSS)																		\+	macro(JITExceptionHandling)														\+	macro(JITEmitDebugInfo)																\+	macro(JITEmitDebugInfoToDisk)													\+	macro(GuaranteedTailCallOpt)													\+	macro(DisableTailCalls)																\+	macro(RealignStack)																		\+	macro(EnableFastISel)																	\+	macro(PositionIndependentExecutable)									\+	macro(EnableSegmentedStacks)													\+	macro(UseInitArray)++typedef enum {+#define ENUM_CASE(n) LLVM_General_TargetOptionFlag_ ## n,+	LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_TargetOptionFlag;++#define LLVM_GENERAL_FOR_EACH_FLOAT_ABI(macro)	\+	macro(Default)																\+	macro(Soft)																		\+	macro(Hard) ++typedef enum {+#define ENUM_CASE(n) LLVM_General_FloatABI_ ## n,+	LLVM_GENERAL_FOR_EACH_FLOAT_ABI(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_FloatABI;++#define LLVM_GENERAL_FOR_EACH_FP_OP_FUSION_MODE(macro)	\+	macro(Fast)																						\+	macro(Standard)																				\+	macro(Strict)++typedef enum {+#define ENUM_CASE(n) LLVM_General_FPOpFusionMode_ ## n,+	LLVM_GENERAL_FOR_EACH_FP_OP_FUSION_MODE(ENUM_CASE)+#undef ENUM_CASE+} LLVM_General_FPOpFusionMode;++#endif
+ src/LLVM/General/Internal/FFI/Target.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  GeneralizedNewtypeDeriving,+  EmptyDataDecls+  #-}++module LLVM.General.Internal.FFI.Target where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes++data Target++foreign import ccall unsafe "LLVM_General_InitializeNativeTarget" initializeNativeTarget ::+    IO LLVMBool++foreign import ccall unsafe "LLVM_General_LookupTarget" lookupTarget ::+    CString -> CString -> Ptr CString -> Ptr CString -> IO (Ptr Target)++data TargetOptions++foreign import ccall unsafe "LLVM_General_CreateTargetOptions" createTargetOptions ::+  IO (Ptr TargetOptions)++foreign import ccall unsafe "LLVM_General_SetTargetOptionFlag" setTargetOptionFlag ::+  Ptr TargetOptions -> TargetOptionFlag -> LLVMBool -> IO ()++foreign import ccall unsafe "LLVM_General_GetTargetOptionFlag" getTargetOptionsFlag ::+  Ptr TargetOptions -> TargetOptionFlag -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_SetStackAlignmentOverride" setStackAlignmentOverride ::+  Ptr TargetOptions -> CUInt -> IO ()++foreign import ccall unsafe "LLVM_General_GetStackAlignmentOverride" getStackAlignmentOverride ::+  Ptr TargetOptions -> IO CUInt++foreign import ccall unsafe "LLVM_General_SetTrapFuncName" setTrapFuncName ::+  Ptr TargetOptions -> CString -> IO ()++foreign import ccall unsafe "LLVM_General_GetTrapFuncName" getTrapFuncName ::+  Ptr TargetOptions -> IO CString++foreign import ccall unsafe "LLVM_General_SetFloatABIType" setFloatABIType ::+  Ptr TargetOptions -> FloatABIType -> IO ()++foreign import ccall unsafe "LLVM_General_GetFloatABIType" getFloatABIType ::+  Ptr TargetOptions -> IO FloatABIType++foreign import ccall unsafe "LLVM_General_SetAllowFPOpFusion" setAllowFPOpFusion ::+  Ptr TargetOptions -> FPOpFusionMode -> IO ()++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 ()++data TargetMachine++foreign import ccall unsafe "LLVM_General_CreateTargetMachine" createTargetMachine ::+    Ptr Target+    -> CString +    -> CString+    -> CString+    -> Ptr TargetOptions+    -> RelocModel+    -> CodeModel+    -> CodeGenOptLevel+    -> IO (Ptr TargetMachine)++foreign import ccall unsafe "LLVMDisposeTargetMachine" disposeTargetMachine ::+    Ptr TargetMachine -> IO ()++data TargetLowering++foreign import ccall unsafe "LLVM_General_GetTargetLowering" getTargetLowering ::+    Ptr TargetMachine -> IO (Ptr TargetLowering)
+ src/LLVM/General/Internal/FFI/TargetC.cpp view
@@ -0,0 +1,201 @@+#define __STDC_LIMIT_MACROS+#include "llvm/Support/TargetRegistry.h"+#include "llvm/Target/TargetMachine.h"+#include "llvm/ADT/Triple.h"+#include "llvm-c/Target.h"+#include "llvm-c/TargetMachine.h"+#include "llvm-c/Core.h"+#include "LLVM/General/Internal/FFI/Target.h"++using namespace llvm;++namespace llvm {+static Reloc::Model unwrap(LLVMRelocMode x) {+	switch(x) {+#define ENUM_CASE(x,y) case LLVMReloc ## x: return Reloc::y;+LLVM_GENERAL_FOR_EACH_RELOC_MODEL(ENUM_CASE)+#undef ENUM_CASE+	default: return Reloc::Model(0);+	}+}++static CodeModel::Model unwrap(LLVMCodeModel x) {+	switch(x) {+#define ENUM_CASE(x) case LLVMCodeModel ## x: return CodeModel::x;+LLVM_GENERAL_FOR_EACH_CODE_MODEL(ENUM_CASE)+#undef ENUM_CASE+	default: return CodeModel::Model(0);+	}+}++static CodeGenOpt::Level unwrap(LLVMCodeGenOptLevel x) {+	switch(x) {+#define ENUM_CASE(x) case LLVMCodeGenLevel ## x: return CodeGenOpt::x;+LLVM_GENERAL_FOR_EACH_CODE_GEN_OPT_LEVEL(ENUM_CASE)+#undef ENUM_CASE+	default: return CodeGenOpt::Level(0);+	}+}++static FloatABI::ABIType unwrap(LLVM_General_FloatABI x) {+	switch(x) {+#define ENUM_CASE(x) case LLVM_General_FloatABI_ ## x: return FloatABI::x;+LLVM_GENERAL_FOR_EACH_FLOAT_ABI(ENUM_CASE)+#undef ENUM_CASE+	default: return FloatABI::ABIType(0);+	}+}++static LLVM_General_FloatABI wrap(FloatABI::ABIType x) {+	switch(x) {+#define ENUM_CASE(x) case FloatABI::x: return LLVM_General_FloatABI_ ## x;+LLVM_GENERAL_FOR_EACH_FLOAT_ABI(ENUM_CASE)+#undef ENUM_CASE+	default: return LLVM_General_FloatABI(0);+	}+}++static FPOpFusion::FPOpFusionMode unwrap(LLVM_General_FPOpFusionMode x) {+	switch(x) {+#define ENUM_CASE(x) case LLVM_General_FPOpFusionMode_ ## x: return FPOpFusion::x;+LLVM_GENERAL_FOR_EACH_FP_OP_FUSION_MODE(ENUM_CASE)+#undef ENUM_CASE+	default: return FPOpFusion::FPOpFusionMode(0);+	}+}++static LLVM_General_FPOpFusionMode wrap(FPOpFusion::FPOpFusionMode x) {+	switch(x) {+#define ENUM_CASE(x) case FPOpFusion::x: return LLVM_General_FPOpFusionMode_ ## x;+LLVM_GENERAL_FOR_EACH_FP_OP_FUSION_MODE(ENUM_CASE)+#undef ENUM_CASE+	default: return  LLVM_General_FPOpFusionMode(0);+	}+}+}++extern "C" {++LLVMBool LLVM_General_InitializeNativeTarget() {+	return LLVMInitializeNativeTarget();+}++LLVMTargetRef LLVM_General_LookupTarget(+	const char *arch, +	const char *ctriple, +	const char **tripleOut, +	const char **cerror+) {+	std::string error;+	Triple triple(ctriple);+	if (const Target *result = TargetRegistry::lookupTarget(arch, triple, error)) {+		*tripleOut = strdup(triple.getTriple().c_str());+		return wrap(result);+	}+	*cerror = strdup(error.c_str());+	return 0;+}++TargetOptions *LLVM_General_CreateTargetOptions() {+	TargetOptions *to = new TargetOptions();+	to->SSPBufferSize = 0; // this field was left uninitialized in LLVM 3.2+	return to;+}++void LLVM_General_SetTargetOptionFlag(+	TargetOptions *to,+	LLVM_General_TargetOptionFlag f,+	unsigned v+) {+	switch(f) {+#define ENUM_CASE(op) case LLVM_General_TargetOptionFlag_ ## op: to->op = v ? 1 : 0; break;+	LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE)+#undef ENUM_CASE+	}+}++unsigned LLVM_General_GetTargetOptionFlag(+	TargetOptions *to,+	LLVM_General_TargetOptionFlag f+) {+	switch(f) {+#define ENUM_CASE(op) case LLVM_General_TargetOptionFlag_ ## op: return to->op;+	LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(ENUM_CASE)+#undef ENUM_CASE+	}+}++void LLVM_General_SetStackAlignmentOverride(TargetOptions *to, unsigned v) {+	to->StackAlignmentOverride = v;+}++unsigned LLVM_General_GetStackAlignmentOverride(TargetOptions *to) {+	return to->StackAlignmentOverride;+}++void LLVM_General_SetTrapFuncName(TargetOptions *to, const char *v) {+	to->TrapFuncName = v;+}++const char *LLVM_General_GetTrapFuncName(TargetOptions *to) {+	return to->TrapFuncName.c_str();+}++void LLVM_General_SetFloatABIType(TargetOptions *to, LLVM_General_FloatABI v) {+	to->FloatABIType = unwrap(v);+}++LLVM_General_FloatABI LLVM_General_GetFloatABIType(TargetOptions *to) {+	return wrap(to->FloatABIType);+}++void LLVM_General_SetAllowFPOpFusion(TargetOptions *to, LLVM_General_FPOpFusionMode v) {+	to->AllowFPOpFusion = unwrap(v);+}++LLVM_General_FPOpFusionMode LLVM_General_GetAllowFPOpFusion(TargetOptions *to) {+	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;+}+++LLVMTargetMachineRef LLVM_General_CreateTargetMachine(+	LLVMTargetRef target,+	const char *triple,+	const char *cpu,+	const char *features,+	const TargetOptions *targetOptions,+	LLVMRelocMode relocModel,+	LLVMCodeModel codeModel,+	LLVMCodeGenOptLevel codeGenOptLevel+) {+	return wrap(+		unwrap(target)->createTargetMachine(+			triple,+			cpu,+			features,+			*targetOptions, +			unwrap(relocModel),+			unwrap(codeModel),+			unwrap(codeGenOptLevel)+		)+	);+}+	+const TargetLowering *LLVM_General_GetTargetLowering(LLVMTargetMachineRef t) {+	return unwrap(t)->getTargetLowering();+}++}+
+ src/LLVM/General/Internal/FFI/Transforms.hs view
@@ -0,0 +1,62 @@+-- | Code used with Template Haskell to build the FFI for transform passes.+module LLVM.General.Internal.FFI.Transforms where++-- | does the constructor for this pass require a TargetLowering object+needsTargetLowering "CodeGenPrepare" = True+needsTargetLowering "LoopStrengthReduce" = True+needsTargetLowering "LowerInvoke" = True+needsTargetLowering _ = False++-- | Translate a Haskell name (used in the public Haskell interface, typically not abbreviated)+-- | for a pass into the (sometimes obscure, sometimes abbreviated) name used in the LLVM C interface.+-- | This translation includes, by choice of prefix, whether the C interface implementation is found in+-- | the LLVM distribution ("LLVM" prefix) or either not available or broken there and so implemented+-- | as part of this Haskell package ("LLVM_General_" prefix).+cName n = +    let core = case n of+            "AggressiveDeadCodeElimination" -> "AggressiveDCE"+            "AlwaysInline" -> "AlwaysInliner"+            "DeadInstructionElimination" -> "DeadInstElimination"+            "EarlyCommonSubexpressionElimination" -> "EarlyCSE"+            "FunctionAttributes" -> "FunctionAttrs"+            "GlobalDeadCodeElimination" -> "GlobalDCE"+            "InductionVariableSimplify" -> "IndVarSimplify"+            "InternalizeFunctions" -> "Internalize"+            "InterproceduralConstantPropagation" -> "IPConstantPropagation"+            "InterproceduralSparseConditionalConstantPropagation" -> "IPSCCP"+            "LoopClosedSingleStaticAssignment" -> "LCSSA"+            "LoopInvariantCodeMotion" -> "LICM"+            "LoopInstructionSimplify" -> "LoopInstSimplify"+            "MemcpyOptimization" -> "MemCpyOpt"+            "PruneExceptionHandling" -> "PruneEH"+            "ScalarReplacementOfAggregates" -> "SROA"+            "OldScalarReplacementOfAggregates" -> "ScalarReplAggregates"+            "SimplifyControlFlowGraph" -> "CFGSimplification"+            "SparseConditionalConstantPropagation" -> "SCCP"+            h -> h+        patchImpls = [+         "CodeGenPrepare",+         "GlobalValueNumbering",+         "InternalizeFunctions",+         "BasicBlockVectorize",+	 "BlockPlacement",+	 "BreakCriticalEdges",+	 "DeadCodeElimination",+	 "DeadInstructionElimination",+	 "DemoteRegisterToMemory",+	 "LoopClosedSingleStaticAssignment",+	 "LoopInstructionSimplify",+         "LoopStrengthReduce",+	 "LowerAtomic",+	 "LowerInvoke",+	 "LowerSwitch",+	 "MergeFunctions",+	 "PartialInlining",+         "ScalarReplacementOfAggregates",+	 "Sinking",+	 "StripDeadDebugInfo",+	 "StripDebugDeclare",+	 "StripNonDebugSymbols"+         ]+    in+      (if (n `elem` patchImpls) then "LLVM_General_" else "LLVM") ++ "Add" ++ core ++ "Pass"
+ src/LLVM/General/Internal/FFI/Type.h view
@@ -0,0 +1,22 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__TYPE__H__+#define __LLVM_GENERAL_INTERNAL_FFI__TYPE__H__++#define LLVM_GENERAL_FOR_EACH_TYPE_KIND(macro) \+	macro(Void) \+	macro(Half) \+	macro(Float) \+	macro(Double) \+	macro(X86_FP80) \+	macro(FP128) \+	macro(PPC_FP128) \+	macro(Label) \+	macro(Integer) \+	macro(Function) \+	macro(Struct) \+	macro(Array) \+	macro(Pointer) \+	macro(Vector) \+	macro(Metadata) \+	macro(X86_MMX) ++#endif
+ src/LLVM/General/Internal/FFI/Type.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls+  #-}++-- | Functions for handling the LLVM types+module LLVM.General.Internal.FFI.Type where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Context++-- | a blind type to correspond to llvm::Type+data Type++-- | <http://llvm.org/doxygen/group__LLVMCCoreType.html#ga112756467f0988613faa6043d674d843>+foreign import ccall unsafe "LLVMGetTypeKind" getTypeKind ::+  Ptr Type -> IO TypeKind++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeInt.html#gadfb8ba2f605f0860a4bf2e3c480ab6a2>+foreign import ccall unsafe "LLVMGetIntTypeWidth" getIntTypeWidth ::+  Ptr Type -> IO (CUInt)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFunction.html#ga2970f0f4d9ee8a0f811f762fb2fa7f82>+foreign import ccall unsafe "LLVMIsFunctionVarArg" isFunctionVarArg ::+  Ptr Type -> IO LLVMBool++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFunction.html#gacfa4594cbff421733add602a413cae9f>+foreign import ccall unsafe "LLVMGetReturnType" getReturnType ::+  Ptr Type -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFunction.html#ga44fa41d22ed1f589b8202272f54aad77>+foreign import ccall unsafe "LLVMCountParamTypes" countParamTypes ::+  Ptr Type -> IO CUInt++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFunction.html#ga83dd3a49a0f3f017f4233fc0d667bda2>+foreign import ccall unsafe "LLVMGetParamTypes" getParamTypes ::+  Ptr Type -> Ptr (Ptr Type) -> IO ()++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga0b03e26a2d254530a9b5c279cdf52257>+foreign import ccall unsafe "LLVMGetElementType" getElementType ::+  Ptr Type -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeInt.html#ga2e5db8cbc30daa156083f2c42989138d>+foreign import ccall unsafe "LLVMIntTypeInContext" intTypeInContext ::+  Ptr Context -> CUInt -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFunction.html#ga8b0c32e7322e5c6c1bf7eb95b0961707>+foreign import ccall unsafe "LLVMFunctionType" functionType' ::+  Ptr Type -> Ptr (Ptr Type) -> CUInt -> LLVMBool -> IO (Ptr Type)++functionType rt (n, ats) va = functionType' rt ats n va++newtype AddrSpace = AddrSpace CUInt+-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga299fe6147083678d0494b1b875f542fae>+foreign import ccall unsafe "LLVMPointerType" pointerType ::+  Ptr Type -> AddrSpace -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga124b162b69b5def41dde2fda3668cbd9>+foreign import ccall unsafe "LLVMGetPointerAddressSpace" getPointerAddressSpace ::+  Ptr Type -> IO AddrSpace++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga5ec731adf74fb40bc3b401956d0c6ff2>+foreign import ccall unsafe "LLVMVectorType" vectorType ::+  Ptr Type -> CUInt -> IO (Ptr Type)++-- | what <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#gabd1666e080f693e1af0b4018005cd927>+-- | would be if it supported 64-bit array sizes, as the C++ type does.+foreign import ccall unsafe "LLVM_General_ArrayType" arrayType ::+  Ptr Type -> CULong -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeStruct.html#gaff2af74740a22f7d18701f0d8c3e5a6f>+foreign import ccall unsafe "LLVMStructTypeInContext" structTypeInContext' ::+  Ptr Context -> Ptr (Ptr Type) -> CUInt -> LLVMBool -> IO (Ptr Type)++structTypeInContext ctx (n, ts) p = structTypeInContext' ctx ts n p++foreign import ccall unsafe "LLVM_General_StructCreateNamed" structCreateNamed ::+  Ptr Context -> CString -> IO (Ptr Type)++foreign import ccall unsafe "LLVMGetStructName" getStructName ::+  Ptr Type -> IO CString++foreign import ccall unsafe "LLVM_General_StructIsLiteral" structIsLiteral ::+  Ptr Type -> IO LLVMBool++foreign import ccall unsafe "LLVM_General_StructIsOpaque" structIsOpaque ::+  Ptr Type -> IO LLVMBool++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeStruct.html#ga3e940e660375ae0cbdde81c0d8ec91e3>+foreign import ccall unsafe "LLVMIsPackedStruct" isPackedStruct ::+  Ptr Type -> IO LLVMBool++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeStruct.html#gaf32e6d6bcec38b786efbef689b0dddf7>+foreign import ccall unsafe "LLVMCountStructElementTypes" countStructElementTypes ::+  Ptr Type -> IO CUInt++foreign import ccall unsafe "LLVMGetStructElementTypes" getStructElementTypes ::+  Ptr Type -> Ptr (Ptr Type) -> IO ()++foreign import ccall unsafe "LLVMStructSetBody" structSetBody' ::+  Ptr Type -> Ptr (Ptr Type) -> CUInt -> LLVMBool -> IO ()++structSetBody s (n,ts) p = structSetBody' s ts n p++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#gafb88a5ebd2a8062e105854910dc7ca17>+foreign import ccall unsafe "LLVMGetVectorSize" getVectorSize ::+  Ptr Type -> IO CUInt++-- | what <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga02dc08041a12265cb700ee469497df63>+-- | would be if it supported 64 bit lengths+foreign import ccall unsafe "LLVM_General_GetArrayLength" getArrayLength ::+  Ptr Type -> IO CULong++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeOther.html#ga1c78ca6d7bf279330b9195fa52f23828>+foreign import ccall unsafe "LLVMVoidTypeInContext" voidTypeInContext ::+  Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#ga3a5332a1d075602bccad7576d1a8e36f>+foreign import ccall unsafe "LLVMHalfTypeInContext" halfTypeInContext ::+  Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#ga529c83a8a5461e5beac19eb867216e3c>+foreign import ccall unsafe "LLVMFloatTypeInContext" floatTypeInContext ::+  Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#ga200527010747eab31b73d3e3f6d94935>+foreign import ccall unsafe "LLVMDoubleTypeInContext" doubleTypeInContext ::+  Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#ga24f77b84b625ed3dd516b52480606093>+foreign import ccall unsafe "LLVMX86FP80TypeInContext" x86FP80TypeInContext ::+  Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#ga1c02fb08f9ae12a719ed42099d42ccd8>+foreign import ccall unsafe "LLVMFP128TypeInContext" fP128TypeInContext ::+  Ptr Context -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreTypeFloat.html#gac2491184fc3d8631c7b264c067f2f761>+foreign import ccall unsafe "LLVMPPCFP128TypeInContext" ppcFP128TypeInContext ::+  Ptr Context -> IO (Ptr Type)
+ src/LLVM/General/Internal/FFI/TypeC.cpp view
@@ -0,0 +1,34 @@+#define __STDC_LIMIT_MACROS+#include "llvm-c/Core.h"+#include "llvm/Type.h"++using namespace llvm;++extern "C" {++LLVMTypeRef LLVM_General_StructCreateNamed(LLVMContextRef C, const char *Name) {+	if (Name) {+		return wrap(StructType::create(*unwrap(C), Name));+	} else {+		return wrap(StructType::create(*unwrap(C)));+	}+}++LLVMBool LLVM_General_StructIsLiteral(LLVMTypeRef t) {+	return unwrap<StructType>(t)->isLiteral();+}++LLVMBool LLVM_General_StructIsOpaque(LLVMTypeRef t) {+	return unwrap<StructType>(t)->isOpaque();+}++LLVMTypeRef LLVM_General_ArrayType(LLVMTypeRef ElementType, uint64_t ElementCount) {+	return wrap(ArrayType::get(unwrap(ElementType), ElementCount));+}++uint64_t LLVM_General_GetArrayLength(LLVMTypeRef ArrayTy) {+	return unwrap<ArrayType>(ArrayTy)->getNumElements();+}+++}
+ src/LLVM/General/Internal/FFI/User.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM User class+module LLVM.General.Internal.FFI.User where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.PtrHierarchy++-- | a blind type to correspond to llvm::Use+data Use++-- | test if a 'Value' is a 'User'+foreign import ccall unsafe "LLVMIsAUser" isAUser ::+    Ptr Value -> IO (Ptr User)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueUses.html#ga66a226d3d06ffada5c929656f4d97d35>+foreign import ccall unsafe "LLVMGetFirstUse" getFirstUse ::+    Ptr User -> IO (Ptr Use)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueUses.html#ga6ea72661bcca2b77bea57173317ec942>+foreign import ccall unsafe "LLVMGetNextUse" getNextUse ::+    Ptr Use -> IO (Ptr Use)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueUser.html#ga2ad633a6afc7906f1afe329f244240f6>+foreign import ccall unsafe "LLVMGetNumOperands" getNumOperands ::+    Ptr User -> IO CUInt++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueUser.html#ga799d58a361054323cb457945071cbfdb>+foreign import ccall unsafe "LLVMGetOperand" getOperand ::+    Ptr User -> CUInt -> IO (Ptr Value)+
+ src/LLVM/General/Internal/FFI/Value.h view
@@ -0,0 +1,35 @@+#ifndef __LLVM_GENERAL_INTERNAL_FFI__VALUE__H__+#define __LLVM_GENERAL_INTERNAL_FFI__VALUE__H__++#define LLVM_GENERAL_FOR_EACH_VALUE_SUBCLASS(macro) \+	macro(Argument) \+	macro(BasicBlock) \+	macro(Function) \+	macro(GlobalAlias) \+	macro(GlobalVariable) \+	macro(UndefValue) \+	macro(BlockAddress) \+	macro(ConstantExpr) \+	macro(ConstantAggregateZero) \+	macro(ConstantDataArray) \+	macro(ConstantDataVector) \+	macro(ConstantInt) \+	macro(ConstantFP) \+	macro(ConstantArray) \+	macro(ConstantStruct) \+	macro(ConstantVector) \+	macro(ConstantPointerNull) \+	macro(MDNode) \+	macro(MDString) \+	macro(InlineAsm) \+	macro(PseudoSourceValue) \+	macro(FixedStackPseudoSourceValue) \+	macro(Instruction)++typedef enum {+#define ENUM_CASE(class) LLVM ## class ## SubclassId,+LLVM_GENERAL_FOR_EACH_VALUE_SUBCLASS(ENUM_CASE)+#undef ENUM_CASE+} LLVMValueSubclassId;++#endif
+ src/LLVM/General/Internal/FFI/Value.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE+  ForeignFunctionInterface,+  EmptyDataDecls,+  MultiParamTypeClasses,+  FlexibleContexts,+  FlexibleInstances,+  UndecidableInstances,+  OverlappingInstances+  #-}++-- | FFI functions for handling the LLVM Value class+module LLVM.General.Internal.FFI.Value where++import Foreign.Ptr+import Foreign.C++import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Type +import LLVM.General.Internal.FFI.PtrHierarchy++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueGeneral.html#ga12179f46b79de8436852a4189d4451e0>+foreign import ccall unsafe "LLVMTypeOf" typeOf ::+  Ptr Value -> IO (Ptr Type)++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueGeneral.html#ga70948786725c43968d15225dd584e5a9>+foreign import ccall unsafe "LLVMGetValueName" getValueName ::+  Ptr Value -> IO CString++-- | <http://llvm.org/doxygen/group__LLVMCCoreValueGeneral.html#gac1f61f74d83d218d4943c018e8fd8d13>+foreign import ccall unsafe "LLVMSetValueName" setValueName ::+  Ptr Value -> CString -> IO ()++-- | This function exposes the ID returned by llvm::Value::getValueID()+-- | <http://llvm.org/doxygen/classllvm_1_1Value.html#a2983b7b4998ef5b9f51b18c01588af3c>. +foreign import ccall unsafe "LLVM_General_GetValueSubclassId" getValueSubclassId ::+  Ptr Value -> IO ValueSubclassId++foreign import ccall unsafe "LLVMReplaceAllUsesWith" replaceAllUsesWith ::+  Ptr Value -> Ptr Value -> IO ()
+ src/LLVM/General/Internal/FFI/ValueC.cpp view
@@ -0,0 +1,20 @@+#define __STDC_LIMIT_MACROS+#include "llvm-c/Core.h"+#include "llvm/Value.h"+#include "LLVM/General/Internal/FFI/Value.h"++using namespace llvm;++extern "C" {++LLVMValueSubclassId LLVM_General_GetValueSubclassId(LLVMValueRef v) {+	switch(unwrap(v)->getValueID()) {+#define VALUE_SUBCLASS_ID_CASE(class) case Value::class ## Val: return LLVM ## class ## SubclassId;+LLVM_GENERAL_FOR_EACH_VALUE_SUBCLASS(VALUE_SUBCLASS_ID_CASE)+#undef VALUE_SUBCLASS_ID_CASE+	default: break;+	}+	return LLVMValueSubclassId(0);+}++}
+ src/LLVM/General/Internal/FloatingPointPredicate.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE+  MultiParamTypeClasses,+  TemplateHaskell,+  FlexibleInstances+  #-}++module LLVM.General.Internal.FloatingPointPredicate where++import LLVM.General.Internal.Coding++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.AST.FloatingPointPredicate as A.FPPred++genCodingInstance' [t| A.FPPred.FloatingPointPredicate |] ''FFI.FCmpPredicate [+  (FFI.fCmpPredFalse, A.FPPred.False),+  (FFI.fCmpPredOEQ, A.FPPred.OEQ),+  (FFI.fCmpPredOGT, A.FPPred.OGT),+  (FFI.fCmpPredOGE, A.FPPred.OGE),+  (FFI.fCmpPredOLT, A.FPPred.OLT),+  (FFI.fCmpPredOLE, A.FPPred.OLE),+  (FFI.fCmpPredONE, A.FPPred.ONE),+  (FFI.fCmpPredORD, A.FPPred.ORD),+  (FFI.fCmpPredUNO, A.FPPred.UNO),+  (FFI.fCmpPredUEQ, A.FPPred.UEQ),+  (FFI.fCmpPredUGT, A.FPPred.UGT),+  (FFI.fCmpPredUGE, A.FPPred.UGE),+  (FFI.fCmpPredULT, A.FPPred.ULT),+  (FFI.fCmpPredULE, A.FPPred.ULE),+  (FFI.fCmpPredUNE, A.FPPred.UNE),+  (FFI.fcmpPredTrue, A.FPPred.True)+ ]
+ src/LLVM/General/Internal/Function.hs view
@@ -0,0 +1,40 @@+module LLVM.General.Internal.Function where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.AnyCont++import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.Function as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI++import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.Value+import LLVM.General.Internal.Coding+import LLVM.General.Internal.Attribute ()++import qualified LLVM.General.AST as A+import qualified LLVM.General.AST.Attribute as A.A++getFunctionAttrs :: Ptr FFI.Function -> IO [A.A.FunctionAttribute]+getFunctionAttrs = decodeM <=< FFI.getFunctionAttr++setFunctionAttrs :: Ptr FFI.Function -> [A.A.FunctionAttribute] -> IO ()+setFunctionAttrs f = FFI.addFunctionAttr f <=< encodeM ++getParameterAttrs :: Ptr FFI.Parameter -> IO [A.A.ParameterAttribute]+getParameterAttrs = decodeM <=< FFI.getAttribute++getParameters :: Ptr FFI.Function -> DecodeAST [A.Parameter]+getParameters f = scopeAnyCont $ do+  n <- liftIO (FFI.countParams f)+  ps <- allocaArray n+  liftIO $ FFI.getParams f ps+  params <- peekArray n ps+  forM params $ \param -> +    return A.Parameter +       `ap` typeOf param+       `ap` getLocalName param+       `ap` (liftIO $ getParameterAttrs param)+
+ src/LLVM/General/Internal/Global.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE+  TemplateHaskell,+  FlexibleInstances,+  MultiParamTypeClasses,+  FlexibleContexts+  #-}+module LLVM.General.Internal.Global where++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+import qualified LLVM.General.Internal.FFI.GlobalValue as FFI++import LLVM.General.Internal.Coding+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.EncodeAST++import qualified LLVM.General.AST.Linkage as A.L+import qualified LLVM.General.AST.Visibility as A.V++genCodingInstance' [t| A.L.Linkage |] ''FFI.Linkage [+  (FFI.linkageExternal, A.L.External),+  (FFI.linkageAvailableExternally, A.L.AvailableExternally),+  (FFI.linkageLinkOnceAny, A.L.LinkOnce),+  (FFI.linkageLinkOnceODR, A.L.LinkOnceODR),+  (FFI.linkageWeakAny, A.L.Weak),+  (FFI.linkageWeakODR, A.L.WeakODR),+  (FFI.linkageAppending, A.L.Appending),+  (FFI.linkageInternal, A.L.Internal),+  (FFI.linkagePrivate, A.L.Private),+  (FFI.linkageDLLImport, A.L.DLLImport),+  (FFI.linkageDLLExport, A.L.DLLExport),+  (FFI.linkageExternalWeak, A.L.ExternWeak),+  (FFI.linkageCommon, A.L.Common),+  (FFI.linkageLinkerPrivate, A.L.LinkerPrivate),+  (FFI.linkageLinkerPrivateWeak, A.L.LinkerPrivateWeak)+ ]++getLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.L.Linkage+getLinkage g = liftIO $ decodeM =<< FFI.getLinkage (FFI.upCast g)++setLinkage :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.L.Linkage -> EncodeAST ()+setLinkage g l = liftIO . FFI.setLinkage (FFI.upCast g) =<< encodeM l+                                                                       +genCodingInstance' [t| A.V.Visibility |] ''FFI.Visibility [+  (FFI.visibilityDefault, A.V.Default),+  (FFI.visibilityHidden, A.V.Hidden),+  (FFI.visibilityProtected, A.V.Protected)+ ]++getVisibility :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST A.V.Visibility+getVisibility g = liftIO $ decodeM =<< FFI.getVisibility (FFI.upCast g)++setVisibility :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> A.V.Visibility -> EncodeAST ()+setVisibility g v = liftIO . FFI.setVisibility (FFI.upCast g) =<< encodeM v++getSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe String)+getSection g = liftIO $ do+  s <- decodeM =<< FFI.getSection (FFI.upCast g)+  return $ if (s == "") then Nothing else Just s++setSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe String -> EncodeAST ()+setSection g s = scopeAnyCont $ do+  s <- encodeM (maybe "" id s)+  liftIO $ FFI.setSection (FFI.upCast g) s++setAlignment :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Word32 -> EncodeAST ()+setAlignment g i = liftIO $ FFI.setAlignment (FFI.upCast g) (fromIntegral i)++getAlignment :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST Word32+getAlignment g = liftIO $ fromIntegral <$> FFI.getAlignment (FFI.upCast g)
+ src/LLVM/General/Internal/InlineAssembly.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances+  #-}+module LLVM.General.Internal.InlineAssembly where+ +import Control.Monad+import Control.Monad.IO.Class++import Foreign.C+import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.InlineAssembly as FFI+import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.Module as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI++import qualified LLVM.General.AST as A (Definition(..))+import qualified LLVM.General.AST.InlineAssembly as A+import qualified LLVM.General.AST.Type as A++import LLVM.General.Internal.Coding +import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.Value++genCodingInstance' [t| A.Dialect |] ''FFI.AsmDialect [+   (FFI.asmDialectATT, A.ATTDialect),+   (FFI.asmDialectIntel, A.IntelDialect)+  ]++instance EncodeM EncodeAST A.InlineAssembly (Ptr FFI.InlineAsm) where+  encodeM (A.InlineAssembly {+             A.type' = t,+             A.assembly = assembly,+             A.constraints = constraints,+             A.hasSideEffects = hasSideEffects,+             A.alignStack = alignStack,+             A.dialect = dialect+           }) = do+    t <- encodeM t+    assembly <- encodeM assembly+    constraints <- encodeM constraints+    hasSideEffects <- encodeM hasSideEffects+    alignStack <- encodeM alignStack+    dialect <- encodeM dialect+    liftIO $ FFI.createInlineAsm t assembly constraints hasSideEffects alignStack dialect++instance DecodeM DecodeAST A.InlineAssembly (Ptr FFI.InlineAsm) where+  decodeM p = do+    return A.InlineAssembly+      `ap` (liftM (\(A.PointerType f _) -> f) (typeOf p))+      `ap` (decodeM =<< liftIO (FFI.getInlineAsmAssemblyString p))+      `ap` (decodeM =<< liftIO (FFI.getInlineAsmConstraintString p))+      `ap` (decodeM =<< liftIO (FFI.inlineAsmHasSideEffects p))+      `ap` (decodeM =<< liftIO (FFI.inlineAsmIsAlignStack p))+      `ap` (decodeM =<< liftIO (FFI.getInlineAsmDialect p))++instance DecodeM DecodeAST [A.Definition] (FFI.ModuleAsm CString) where+  decodeM (FFI.ModuleAsm s) = do+    s <- decodeM s+    let takeModIA "" = []+        takeModIA s =+          let (a,r) = break (== '\n') s+          in A.ModuleInlineAssembly a : takeModIA (dropWhile (== '\n') r)+    return $ takeModIA s+
+ src/LLVM/General/Internal/Instruction.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE +  TemplateHaskell,+  QuasiQuotes,+  TupleSections,+  MultiParamTypeClasses,+  FlexibleContexts,+  FlexibleInstances+  #-}+module LLVM.General.Internal.Instruction where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH+import qualified LLVM.General.Internal.InstructionDefs as ID++import Data.Functor+import Control.Monad+import Control.Monad.Trans+import Control.Monad.AnyCont+import Control.Monad.State+import Control.Monad.Phased++import Foreign.Ptr++import qualified Data.Map as Map+import qualified Data.List as List++import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.BinaryOperator as FFI+import qualified LLVM.General.Internal.FFI.Instruction as FFI+import qualified LLVM.General.Internal.FFI.Value as FFI+import qualified LLVM.General.Internal.FFI.User as FFI+import qualified LLVM.General.Internal.FFI.Builder as FFI+import qualified LLVM.General.Internal.FFI.Constant as FFI+import qualified LLVM.General.Internal.FFI.BasicBlock as FFI++import LLVM.General.Internal.Atomicity ()+import LLVM.General.Internal.Attribute ()+import LLVM.General.Internal.CallingConvention ()+import LLVM.General.Internal.Coding+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.Metadata ()+import LLVM.General.Internal.Operand ()+import LLVM.General.Internal.RMWOperation ()+import LLVM.General.Internal.Type+import LLVM.General.Internal.Value++import qualified LLVM.General.AST as A+import qualified LLVM.General.AST.Constant as A.C++callInstAttr i j = liftIO $ decodeM =<< FFI.getCallInstAttr i j++meta :: Ptr FFI.Instruction -> DecodeAST A.InstructionMetadata+meta i = do+  let getMetadata n = scopeAnyCont $ do+         ks <- allocaArray n+         ps <- allocaArray n+         n' <- liftIO $ FFI.getMetadata i ks ps n+         if (n' > n) +          then getMetadata n'+          else return zip `ap` decodeM (n', ks) `ap` decodeM (n', ps)+  getMetadata 4++instance DecodeM DecodeAST A.Terminator (Ptr FFI.Instruction) where+  decodeM i = scopeAnyCont $ do+    n <- liftIO $ FFI.getInstructionDefOpcode i+    nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i)+    md <- meta i+    let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n)+        successor n = decodeM =<< (liftIO $ FFI.isABasicBlock =<< FFI.getOperand (FFI.upCast i) n)+    case n of+      [ID.instrP|Ret|] -> do+        returnOperand' <- if nOps == 0 then return Nothing else Just <$> op 0+        return $ A.Ret { A.returnOperand = returnOperand', A.metadata' = md }+      [ID.instrP|Br|] -> do+        n <- liftIO $ FFI.getNumOperands (FFI.upCast i)+        case n of+          1 -> do+             dest <- successor 0+             return $ A.Br { A.dest = dest, A.metadata' = md }+          3 -> do+             condition <- op 0+             falseDest <- successor 1+             trueDest <- successor 2+             return $ A.CondBr {+               A.condition = condition,+               A.falseDest = falseDest, +               A.trueDest = trueDest,+               A.metadata' = md+             }+      [ID.instrP|Switch|] -> do+        op0 <- op 0+        dd <- successor 1+        let nCases = (nOps - 2) `div` 2+        values <- allocaArray nCases+        dests <- allocaArray nCases+        liftIO $ FFI.getSwitchCases i values dests+        cases <- return zip `ap` peekArray nCases values `ap` peekArray nCases dests+        dests <- forM cases $ \(c, d) -> return (,) `ap` decodeM c `ap` decodeM d+        return A.Switch {+          A.operand0' = op0,+          A.defaultDest = dd,+          A.dests = dests,+          A.metadata' = md+        }+      [ID.instrP|IndirectBr|] -> do+        op0 <- op 0+        let nDests = nOps - 1+        dests <- allocaArray nDests+        liftIO $ FFI.getIndirectBrDests i dests+        dests <- decodeM (nDests, dests)+        return A.IndirectBr {+           A.operand0' = op0,+           A.possibleDests = dests,+           A.metadata' = md+        }+      [ID.instrP|Invoke|] -> do+        cc <- decodeM =<< liftIO (FFI.getInstructionCallConv i)+        rAttrs <- callInstAttr i 0+        fv <- liftIO $ FFI.getCallInstCalledValue i+        f <- decodeM fv+        args <- forM [1..nOps-3] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j+        fAttrs <- decodeM =<< liftIO (FFI.getCallInstFunctionAttr i)+        rd <- successor (nOps - 2)+        ed <- successor (nOps - 1)+        return A.Invoke {+          A.callingConvention' = cc,+          A.returnAttributes' = rAttrs,+          A.function' = f,+          A.arguments' = args,+          A.functionAttributes' = fAttrs,+          A.returnDest = rd,+          A.exceptionDest = ed,+          A.metadata' = md+        }+      [ID.instrP|Resume|] -> do+        op0 <- op 0+        return A.Resume {+          A.operand0' = op0,+          A.metadata' = md+        }+      [ID.instrP|Unreachable|] -> do+        return A.Unreachable {+          A.metadata' = md+        }++instance EncodeM EncodeAST A.Terminator (Ptr FFI.Instruction) where+  encodeM t = scopeAnyCont $ do+    builder <- gets encodeStateBuilder+    s <- encodeM ""+    t' <- case t of+      A.Ret { A.returnOperand = r } -> do+        rv <- maybe (return nullPtr) encodeM r+        FFI.upCast <$> do liftIO $ FFI.buildRet builder rv+      A.Br { A.dest = d } -> do+        db <- encodeM d+        FFI.upCast <$> do liftIO $ FFI.buildBr builder db+      A.CondBr { A.condition = c, A.trueDest = t, A.falseDest = f } -> do+        cv <- encodeM c+        tb <- encodeM t+        fb <- encodeM f+        FFI.upCast <$> do liftIO $ FFI.buildCondBr builder cv tb fb+      A.Switch {+        A.operand0' = op0,+        A.defaultDest = dd,+        A.dests = ds+      } -> do+        op0' <- encodeM op0+        dd' <- encodeM dd+        i <- liftIO $ FFI.buildSwitch builder op0' dd' (fromIntegral $ length ds)+        forM ds $ \(v,d) -> do+          v' <- encodeM v+          d' <- encodeM d+          liftIO $ FFI.addCase i v' d'+        return $ FFI.upCast i+      A.IndirectBr { +        A.operand0' = op0,+        A.possibleDests = dests+      } -> do+        op0' <- encodeM op0+        i <- liftIO $ FFI.buildIndirectBr builder op0' (fromIntegral $ length dests)+        forM dests $ \dest -> do+          d <- encodeM dest+          liftIO $ FFI.addDestination i d+        return $ FFI.upCast i+      A.Invoke {+        A.callingConvention' = cc,+        A.returnAttributes' = rAttrs,+        A.function' = fun,+        A.arguments' = args,+        A.functionAttributes' = fAttrs,+        A.returnDest = rd,+        A.exceptionDest = ed+      } -> do+        fv <- encodeM fun+        rb <- encodeM rd+        eb <- encodeM ed+        let (argvs, argAttrs) = unzip args+        (n, argvs) <- encodeM argvs+        i <- liftIO $ FFI.buildInvoke builder fv argvs n rb eb s+        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+        cc <- encodeM cc+        liftIO $ FFI.setInstructionCallConv i cc+        return $ FFI.upCast i+      A.Resume { +        A.operand0' = op0+      } -> do+        op0' <- encodeM op0+        i <- liftIO $ FFI.buildResume builder op0'+        return $ FFI.upCast i+      A.Unreachable {+      } -> do+        i <- liftIO $ FFI.buildUnreachable builder+        return $ FFI.upCast i+    forM (A.metadata' t) $ \(k, mdn) -> do+      k <- encodeM k+      mdn <- encodeM mdn+      liftIO $ FFI.setMetadata t' k mdn+    return t'      ++$(do+  let findInstrFields s = Map.findWithDefault (error $ "instruction missing from AST: " ++ show s) s+                          ID.astInstructionRecs++  [d|+    instance DecodeM DecodeAST A.Instruction (Ptr FFI.Instruction) where+      decodeM i = scopeAnyCont $ do+        t <- typeOf i+        nOps <- liftIO $ FFI.getNumOperands (FFI.upCast i)+        let op n = decodeM =<< (liftIO $ FFI.getOperand (FFI.upCast i) n)+            cop n = decodeM =<< (liftIO $ FFI.isAConstant =<< FFI.getOperand (FFI.upCast i) n)+            get_nsw b = liftIO $ decodeM =<< FFI.hasNoSignedWrap b+            get_nuw b = liftIO $ decodeM =<< FFI.hasNoUnsignedWrap b+            get_exact b = liftIO $ decodeM =<< FFI.isExact b++        n <- liftIO $ FFI.getInstructionDefOpcode i+        $(+          let fieldDecoders :: String -> String -> ([String], TH.ExpQ)+              fieldDecoders lrn s = case s of+                "b" -> ([], [| liftIO $ FFI.isABinaryOperator (FFI.upCast i) |])+                "nsw" -> (["b"], [| get_nsw $(TH.dyn "b") |])+                "nuw" -> (["b"], [| get_nuw $(TH.dyn "b") |])+                "exact" -> (["b"], [| get_exact $(TH.dyn "b") |])+                "operand0" -> ([], [| op 0 |])+                "operand1" -> ([], [| op 1 |])+                "address" -> ([], [| op 0 |])+                "value" -> ([], [| op 1 |])+                "expected" -> ([], [| op 1 |])+                "replacement" -> ([], [| op 2 |])+                "condition'" -> ([], [| op 0 |])+                "trueValue" -> ([], [| op 1 |])+                "falseValue" -> ([], [| op 2 |])+                "argList" -> ([], [| op 0 |])+                "vector" -> ([], [| op 0 |])+                "element" -> ([], [| op 1 |])+                "index" -> ([], case lrn of "ExtractElement" -> [| op 1 |]; "InsertElement" -> [| op 2 |])+                "personalityFunction" -> ([], [| op 0 |])+                "mask" -> ([], [| cop 2 |])+                "aggregate" -> ([], [| op 0 |])+                "metadata" -> ([], [| meta i |])+                "iPredicate" -> ([], [| decodeM =<< liftIO (FFI.getICmpPredicate i) |])+                "fpPredicate" -> ([], [| decodeM =<< liftIO (FFI.getFCmpPredicate i) |])+                "isTailCall" -> ([], [| decodeM =<< liftIO (FFI.isTailCall i) |])+                "callingConvention" -> ([], [| decodeM =<< liftIO (FFI.getInstructionCallConv i) |])+                "returnAttributes" -> ([], [| callInstAttr i 0 |])+                "f" -> ([], [| liftIO $ FFI.getCallInstCalledValue i |])+                "function" -> (["f"], [| decodeM $(TH.dyn "f") |])+                "arguments" -> ([], [| forM [1..nOps-1] $ \j -> return (,) `ap` op (j-1) `ap` callInstAttr i j |])+                "clauses" -> +                  ([], [| forM [1..nOps-1] $ \j -> do+                          v <- liftIO $ FFI.getOperand (FFI.upCast i) j+                          c <- decodeM =<< (liftIO $ FFI.isAConstant v)+                          t <- typeOf v+                          return $ case t of { A.ArrayType _ _ -> A.Filter; _ -> A.Catch} $ c |])+                "functionAttributes" ->+                    ([], [| decodeM =<< liftIO (FFI.getCallInstFunctionAttr i) |])+                "type'" -> ([], [| return t |])+                "incomingValues" ->+                    ([], [| do+                            n <- liftIO $ FFI.countIncoming i+                            forM [0..n-1] $ \m -> do+                              iv <- decodeM =<< (liftIO $ FFI.getIncomingValue i m)+                              ib <- decodeM =<< (liftIO $ FFI.getIncomingBlock i m)+                              return (iv,ib) |])+                "allocatedType" -> ([], [| decodeM =<< liftIO (FFI.getAllocatedType i) |])+                "numElements" -> +                    ([], [| do+                            n <- decodeM =<< (liftIO $ FFI.getAllocaNumElements i)+                            return $ case n of+                              A.ConstantOperand (A.C.Int { A.C.integerValue = 1 }) -> Nothing+                              _ -> Just n+                              |])                +                "alignment" -> ([], [| decodeM =<< liftIO (FFI.getInstrAlignment i) |])+                "maybeAtomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |])+                "atomicity" -> ([], [| decodeM =<< liftIO (FFI.getAtomicity i) |])+                "volatile" -> ([], [| decodeM =<< liftIO (FFI.getVolatile i) |])+                "inBounds" -> ([], [| decodeM =<< liftIO (FFI.getInBounds (FFI.upCast i)) |])+                "indices" -> ([], [| mapM op [1..nOps-1] |])+                "indices'" ->+                  ([], [| do+                          n <- liftIO $ FFI.countInstStructureIndices i+                          a <- allocaArray n+                          liftIO $ FFI.getInstStructureIndices i a+                          decodeM (n, a) |])+                "rmwOperation" -> ([], [| decodeM =<< liftIO (FFI.getAtomicRMWOperation i) |])+                "cleanup" -> ([], [| decodeM =<< liftIO (FFI.isCleanup i) |])+                _ -> ([], [| error $ "unrecognized instruction field or depenency thereof: " ++ show s |])+          in+          TH.caseE [| n |] [ +            TH.match opcodeP (TH.normalB (TH.doE handlerBody)) []+            | (lrn, iDef) <- Map.toList ID.instructionDefs,+              ID.instructionKind iDef /= ID.Terminator,+              let opcodeP = TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef)+                  handlerBody = +                    let TH.RecC fullName fields = findInstrFields lrn+                        (fieldNames,_,_) = unzip3 fields+                        allNames ns = List.nub $ [ d | n <- ns, d <- allNames . fst . fieldDecoders lrn $ n ] ++ ns+                    in+                      [ +                       TH.bindS (TH.varP (TH.mkName n)) (snd . fieldDecoders lrn $ n)+                       | n <- allNames . map TH.nameBase $ fieldNames +                      ] ++ [ +                       TH.noBindS [| +                        return $(TH.recConE +                                 fullName+                                 [ (f,) <$> (TH.varE . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])+                        |]+                      ]+                ]+         )++    instance EncodeM EncodeAST A.Instruction (Ptr FFI.Instruction) where+      encodeM o = scopeAnyCont $ do+        builder <- gets encodeStateBuilder+        s <- encodeM ""+        $(+          [|+            case o of+              A.ICmp { +                A.iPredicate = pred, +                A.operand0 = op0, +                A.operand1 = op1, +                A.metadata = [] +              } -> do+                op0' <- encodeM op0+                op1' <- encodeM op1+                pred <- encodeM pred+                i <- liftIO $ FFI.buildICmp builder pred op0' op1' s+                return $ FFI.upCast i+              A.FCmp {+                A.fpPredicate = pred, +                A.operand0 = op0, +                A.operand1 = op1, +                A.metadata = [] +              } -> do+                op0' <- encodeM op0+                op1' <- encodeM op1+                pred <- encodeM pred+                i <- liftIO $ FFI.buildFCmp builder pred op0' op1' s+                return $ FFI.upCast i+              A.Phi { A.type' = t, A.incomingValues = ivs } -> do+                 t' <- encodeM t+                 i <- liftIO $ FFI.buildPhi builder t' s+                 defer+                 let (ivs3, bs3) = unzip ivs+                 ivs3' <- encodeM ivs3+                 bs3' <- encodeM bs3+                 liftIO $ FFI.addIncoming i ivs3' bs3'+                 return $ FFI.upCast i+              A.Call {+                A.isTailCall = tc,+                A.callingConvention = cc,+                A.returnAttributes = rAttrs,+                A.function = f,+                A.arguments = args,+                A.functionAttributes = fAttrs,+                A.metadata = []+              } -> 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 $ FFI.upCast i+              A.Select { A.condition' = c, A.trueValue = t, A.falseValue = f } -> do+                c' <- encodeM c+                t' <- encodeM t+                f' <- encodeM f+                i <- liftIO $ FFI.buildSelect builder c' t' f' s+                return $ FFI.upCast i+              A.VAArg { A.argList = al, A.type' = t } -> do+                al' <- encodeM al+                t' <- encodeM t+                i <- liftIO $ FFI.buildVAArg builder al' t' s+                return $ FFI.upCast i+              A.ExtractElement { A.vector = v, A.index = idx } -> do+                v' <- encodeM v+                idx' <- encodeM idx+                i <- liftIO $ FFI.buildExtractElement builder v' idx' s+                return $ FFI.upCast i+              A.InsertElement { A.vector = v, A.element = e, A.index = idx } -> do+                v' <- encodeM v+                e' <- encodeM e+                idx' <- encodeM idx+                i <- liftIO $ FFI.buildInsertElement builder v' e' idx' s+                return $ FFI.upCast i+              A.ShuffleVector { A.operand0 = o0, A.operand1 = o1, A.mask = mask } -> do+                o0' <- encodeM o0+                o1' <- encodeM o1+                mask' <- encodeM mask+                i <- liftIO $ FFI.buildShuffleVector builder o0' o1' mask' s+                return $ FFI.upCast i+              A.ExtractValue { A.aggregate = a, A.indices' = is } -> do+                a' <- encodeM a+                (n, is') <- encodeM is+                i <- liftIO $ FFI.buildExtractValue builder a' is' n s+                return $ FFI.upCast i+              A.InsertValue { A.aggregate = a, A.element = e, A.indices' = is } -> do+                a' <- encodeM a+                e' <- encodeM e+                (n, is') <- encodeM is+                i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s+                return $ FFI.upCast 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 $ FFI.upCast i+              A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do +                 alt' <- encodeM alt+                 n' <- maybe (return nullPtr) encodeM n+                 i <- liftIO $ FFI.buildAlloca builder alt' n' s+                 unless (alignment == 0) $ liftIO $ FFI.setInstrAlignment i (fromIntegral alignment)+                 return $ FFI.upCast i+              A.Load {+                A.volatile = vol,+                A.address = a,+                A.alignment = al,+                A.maybeAtomicity = mat,+                A.metadata = []+              } -> do+                 a' <- encodeM a+                 al <- encodeM al+                 vol <- encodeM vol+                 (ss, mo) <- encodeM mat+                 i <- liftIO $ FFI.buildLoad builder a' al vol mo ss s+                 return $ FFI.upCast i+              A.Store { +                A.volatile = vol, +                A.address = a, +                A.value = v, +                A.maybeAtomicity = mat, +                A.alignment = al, +                A.metadata = []+              } -> do+                 a' <- encodeM a+                 v' <- encodeM v+                 al <- encodeM al+                 vol <- encodeM vol+                 (ss, mo) <- encodeM mat+                 i <- liftIO $ FFI.buildStore builder a' v' al vol mo ss s+                 return $ FFI.upCast i+              A.GetElementPtr { A.address = a, A.indices = is, A.inBounds = ib } -> do+                 a' <- encodeM a+                 (n, is') <- encodeM is+                 i <- liftIO $ FFI.buildGetElementPtr builder a' is' n s+                 when ib $ do+                   ib <- encodeM ib +                   liftIO $ FFI.setInBounds i ib+                 return $ FFI.upCast i+              A.Fence { A.atomicity = at } -> do+                 (ss, mo) <- encodeM at+                 i <- liftIO $ FFI.buildFence builder mo ss s+                 return $ FFI.upCast i+              A.CmpXchg { +                A.volatile = vol, +                A.address = a, A.expected = e, A.replacement = r,+                A.atomicity = at,+                A.metadata = []+              } -> 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 $ FFI.upCast i+              A.AtomicRMW {+                A.volatile = vol,+                A.rmwOperation = rmwOp,+                A.address = a,+                A.value = v,+                A.atomicity = at,+                A.metadata = []+              } -> 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 $ FFI.upCast 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 [| unless (List.null $(TH.dyn s)) $ error "can't handle metadata yet" |]]+                         _ -> 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 $ FFI.upCast $(TH.dyn "i") |]+                           ]+                          )+                         ]+                    )++           |]+         )+   |]+ )+++instance DecodeM DecodeAST a (Ptr FFI.Instruction) => DecodeM DecodeAST (A.Named a) (Ptr FFI.Instruction) where+  decodeM i = do+    t <- typeOf i+    (if t == A.VoidType then (return A.Do) else (return (A.:=) `ap` getLocalName i)) `ap` (do defer; decodeM i)++instance EncodeM EncodeAST a (Ptr FFI.Instruction) => EncodeM EncodeAST (A.Named a) (Ptr FFI.Instruction) where+  encodeM (A.Do o) = encodeM o+  encodeM (n A.:= o) = do+    i <- encodeM o+    let v = FFI.upCast i+    n' <- encodeM n+    liftIO $ FFI.setValueName v n'+    defineLocal n v+    return i++
+ src/LLVM/General/Internal/InstructionDefs.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE+  TemplateHaskell+  #-}++module LLVM.General.Internal.InstructionDefs (+  astInstructionRecs,+  astConstantRecs,+  instructionDefs,+  ID.InstructionKind(..),+  ID.InstructionDef(..),+  instrP,+  innerJoin,+  outerJoin+  ) where++import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH.Quote as TH++import Data.Map (Map)+import qualified Data.Map as Map++import qualified LLVM.General.Internal.FFI.InstructionDefs as ID++import qualified LLVM.General.AST.Instruction as A+import qualified LLVM.General.AST.Constant as A.C++$(do+   let ctorRecs t = do+         TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify t+         TH.dataToExpQ (const Nothing) $ [ (TH.nameBase n, rec) | rec@(TH.RecC n _) <- cons ]++   [d| +      astInstructionRecs = Map.fromList $(ctorRecs ''A.Instruction)+      astConstantRecs = Map.fromList $(ctorRecs ''A.C.Constant)+    |]+ )++instructionDefs = Map.fromList [ ((refName . ID.cAPIName $ i), i) | i <- ID.instructionDefs ]+  where+    refName "AtomicCmpXchg" = "CmpXchg"+    refName "PHI" = "Phi"+    refName x = x++innerJoin :: Ord k => Map k a -> Map k b -> Map k (a,b)+innerJoin = Map.mergeWithKey (\_ a b -> Just (a,b)) (const Map.empty) (const Map.empty)+       +outerJoin :: Ord k => Map k a -> Map k b -> Map k (Maybe a, Maybe b)+outerJoin = Map.mergeWithKey +            (\_ a b -> Just (Just a, Just b))+            (Map.map $ \a -> (Just a, Nothing))+            (Map.map $ \b -> (Nothing, Just b))++instrP = TH.QuasiQuoter { +  TH.quoteExp = undefined,+  TH.quotePat = let m = Map.fromList [ (ID.cAPIName i, ID.cppOpcode i) | i <- ID.instructionDefs ]+             in TH.dataToPatQ (const Nothing) . (m Map.!),+  TH.quoteType = undefined,+  TH.quoteDec = undefined+ }
+ src/LLVM/General/Internal/IntegerPredicate.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances+  #-}++module LLVM.General.Internal.IntegerPredicate where++import LLVM.General.Internal.Coding++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.AST.IntegerPredicate as A.IPred++genCodingInstance' [t| A.IPred.IntegerPredicate |] ''FFI.ICmpPredicate [+  (FFI.iCmpPredEQ, A.IPred.EQ),+  (FFI.iCmpPredNE, A.IPred.NE),+  (FFI.iCmpPredUGT, A.IPred.UGT),+  (FFI.iCmpPredUGE, A.IPred.UGE),+  (FFI.iCmpPredULT, A.IPred.ULT),+  (FFI.iCmpPredULE, A.IPred.ULE),+  (FFI.iCmpPredSGT, A.IPred.SGT),+  (FFI.iCmpPredSGE, A.IPred.SGE),+  (FFI.iCmpPredSLT, A.IPred.SLT),+  (FFI.iCmpPredSLE, A.IPred.SLE)+ ]
+ src/LLVM/General/Internal/Metadata.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE+  MultiParamTypeClasses,+  FlexibleInstances+  #-}+module LLVM.General.Internal.Metadata where++import Control.Monad.State+import Control.Monad.AnyCont++import Foreign.Ptr++import qualified Foreign.Marshal.Array as FMA+import qualified Data.Array as Array++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.Metadata as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI++import LLVM.General.Internal.Context+import LLVM.General.Internal.Coding+import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.Value ()++instance EncodeM EncodeAST String FFI.MDKindID where+  encodeM s = do+    Context c <- gets encodeStateContext+    s <- encodeM s+    liftIO $ FFI.getMDKindIDInContext c s++getMetadataKindNames :: Context -> DecodeAST ()+getMetadataKindNames (Context c) = scopeAnyCont $ do+  let g n = do+        ps <- allocaArray n+        ls <- allocaArray n+        n' <- liftIO $ FFI.getMDKindNames c ps ls n+        if n' > n+         then g n'+         else do+           csls <- return zip+                   `ap` liftIO (FMA.peekArray (fromIntegral n') ps)+                   `ap` liftIO (FMA.peekArray (fromIntegral n') ls)+           mapM decodeM csls+  strs <- g 16+  modify $ \s -> s { metadataKinds = Array.listArray (0, fromIntegral (length strs) - 1) strs }++instance DecodeM DecodeAST String FFI.MDKindID where+  decodeM (FFI.MDKindID k) = gets $ (Array.! (fromIntegral k)) . metadataKinds++instance DecodeM DecodeAST String (Ptr FFI.MDString) where+  decodeM p = do+    np <- alloca+    s <- liftIO $ FFI.getMDString p np+    n <- peek np+    decodeM (s, n)
+ src/LLVM/General/Internal/Module.hs view
@@ -0,0 +1,281 @@+{-#+  LANGUAGE+  TupleSections,+  ScopedTypeVariables+  #-}++-- | This Haskell module is for/of functions for handling LLVM modules.+module LLVM.General.Internal.Module where++import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Phased+import Control.Monad.AnyCont+import Control.Applicative+import Control.Exception++import Foreign.Ptr+import Foreign.Marshal.Alloc (free)++import qualified LLVM.General.Internal.FFI.Assembly as FFI+import qualified LLVM.General.Internal.FFI.Builder as FFI+import qualified LLVM.General.Internal.FFI.Function as FFI+import qualified LLVM.General.Internal.FFI.GlobalAlias as FFI+import qualified LLVM.General.Internal.FFI.GlobalValue as FFI+import qualified LLVM.General.Internal.FFI.GlobalVariable as FFI+import qualified LLVM.General.Internal.FFI.Iterate as FFI+import qualified LLVM.General.Internal.FFI.Module as FFI+import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Value as FFI+import qualified LLVM.General.Internal.FFI.Metadata as FFI++import LLVM.General.Internal.BasicBlock+import LLVM.General.Internal.Coding+import LLVM.General.Internal.Context+import LLVM.General.Internal.DataLayout+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.Diagnostic+import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.Function+import LLVM.General.Internal.Global+import LLVM.General.Internal.Metadata+import LLVM.General.Internal.Operand+import LLVM.General.Internal.Type+import LLVM.General.Internal.Value++import LLVM.General.Diagnostic++import qualified LLVM.General.AST as A+import qualified LLVM.General.AST.DataLayout as A+import qualified LLVM.General.AST.AddrSpace as A+import qualified LLVM.General.AST.Global as A.G++-- | <http://llvm.org/doxygen/classllvm_1_1Module.html>+newtype Module = Module (Ptr FFI.Module)++-- | parse 'Module' from LLVM assembly+withModuleFromString :: Context -> String -> (Module -> IO a) -> IO (Either Diagnostic a)+withModuleFromString (Context c) s f = flip runAnyContT return $ do+  s <- encodeM s+  liftIO $ withSMDiagnostic $ \smDiag -> do+    m <- FFI.getModuleFromAssemblyInContext c s smDiag+    if m == nullPtr then+      Left <$> getDiagnostic smDiag+     else+      Right <$> finally (f (Module m)) (FFI.disposeModule m)++-- | generate LLVM assembly from a 'Module'+moduleString :: Module -> IO String+moduleString (Module m) = bracket (FFI.getModuleAssembly m) free $ decodeM++setTargetTriple :: Ptr FFI.Module -> String -> IO ()+setTargetTriple m t = flip runAnyContT return $ do+  t <- encodeM t+  liftIO $ FFI.setTargetTriple m t++getTargetTriple :: Ptr FFI.Module -> IO (Maybe String)+getTargetTriple m = do+  s <- decodeM =<< liftIO (FFI.getTargetTriple m)+  return $ if s == "" then Nothing else Just s++setDataLayout :: Ptr FFI.Module -> A.DataLayout -> IO ()+setDataLayout m dl = flip runAnyContT return $ do+  s <- encodeM (dataLayoutToString dl)+  liftIO $ FFI.setDataLayout m s++getDataLayout :: Ptr FFI.Module -> IO (Maybe A.DataLayout)+getDataLayout m = parseDataLayout <$> (decodeM =<< FFI.getDataLayout m)++-- | Build a 'Module' from a 'LLVM.General.AST.Module'.+withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> IO (Either String a)+withModuleFromAST context@(Context c) (A.Module moduleId dataLayout triple definitions) f = do+  let makeModule = flip runAnyContT return $ do+                     moduleId <- encodeM moduleId+                     liftIO $ FFI.moduleCreateWithNameInContext moduleId c+  bracket makeModule FFI.disposeModule $ \m -> do+    maybe (return ()) (setDataLayout m) dataLayout+    maybe (return ()) (setTargetTriple m) triple+    r <- runEncodeAST context $ forInterleavedM definitions $ \d -> case d of+      A.TypeDefinition n t -> do+        t' <- createNamedType n+        defineType n t'+        defer+        maybe (return ()) (setNamedType t') t++      A.MetadataNodeDefinition i os -> do+        replicateM_ 2 defer+        t <- liftIO $ FFI.createTemporaryMDNodeInContext c+        defineMDNode i t+        defer+        n <- encodeM (A.MetadataNode os)+        liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)+        defineMDNode i n+        liftIO $ FFI.destroyTemporaryMDNode t++      A.NamedMetadataDefinition n ids -> do+        replicateM_ 4 defer+        n <- encodeM n+        ids <- encodeM (map A.MetadataNodeReference ids)+        nm <- liftIO $ FFI.getOrAddNamedMetadata m n+        liftIO $ FFI.namedMetadataAddOperands nm ids++      A.ModuleInlineAssembly s -> do+        s <- encodeM s+        liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s)++      A.GlobalDefinition g -> do+        replicateM_ 2 defer+        g' :: Ptr FFI.GlobalValue <- case g of+          g@(A.GlobalVariable { A.G.name = n }) -> do+            typ <- encodeM (A.G.type' g)+            g' <- liftIO $ withName n $ \gName -> +                      FFI.addGlobalInAddressSpace m typ gName +                             (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g))+            defineGlobal n g'+            liftIO $ do+              tl <- encodeM (A.G.isThreadLocal g)+              FFI.setThreadLocal g' tl+              hua <- encodeM (A.G.hasUnnamedAddr g)+              FFI.setUnnamedAddr (FFI.upCast g') hua+              ic <- encodeM (A.G.isConstant g)+              FFI.setGlobalConstant g' ic+            defer+            maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)+            setSection g' (A.G.section g)+            setAlignment g' (A.G.alignment g)+            return (FFI.upCast g')+          (a@A.G.GlobalAlias { A.G.name = n }) -> do+            typ <- encodeM (A.G.type' a)+            a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ name+            defineGlobal n a'+            defer+            (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a)+            return (FFI.upCast a')+          (A.Function _ _ cc rAttrs resultType fName (args,isVarArgs) attrs _ _ blocks) -> do+            typ <- encodeM $ A.FunctionType resultType (map (\(A.Parameter t _ _) -> t) args) isVarArgs+            f <- liftIO . withName fName $ \fName -> FFI.addFunction m fName typ+            defineGlobal fName f+            cc <- encodeM cc+            liftIO $ FFI.setFunctionCallConv f cc+            rAttrs <- encodeM rAttrs+            liftIO $ FFI.addFunctionRetAttr f rAttrs+            liftIO $ setFunctionAttrs f attrs+            setSection f (A.G.section g)+            setAlignment f (A.G.alignment g)+            encodeScope $ do+              forM blocks $ \(A.BasicBlock bName _ _) -> do+                b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName+                defineBasicBlock fName bName b+              defer+              let nParams = length args+              ps <- allocaArray nParams+              liftIO $ FFI.getParams f ps+              params <- peekArray nParams ps+              forM (zip args params) $ \(A.Parameter _ n attrs, p) -> do+                defineLocal n p+                n <- encodeM n+                liftIO $ FFI.setValueName (FFI.upCast p) n+                attrs <- encodeM attrs+                liftIO $ FFI.addAttribute p attrs+                return ()+              forInterleavedM blocks $ \(A.BasicBlock bName namedInstrs term) -> do+                b <- encodeM bName+                (do builder <- gets encodeStateBuilder; liftIO $ FFI.positionBuilderAtEnd builder b)+                (mapM encodeM namedInstrs :: EncodeAST [Ptr FFI.Instruction])+                encodeM term :: EncodeAST (Ptr FFI.Instruction)+            return (FFI.upCast f)+        setLinkage g' (A.G.linkage g)+        setVisibility g' (A.G.visibility g)++    either (return . Left) (const $ Right <$> f (Module m)) r++-- | Get a 'LLVM.General.AST.Module' from a 'Module'.+moduleAST :: Module -> IO A.Module+moduleAST (Module mod) = runDecodeAST $ do+  c <- return Context `ap` liftIO (FFI.getModuleContext mod)+  getMetadataKindNames c+  return A.Module +   `ap` (liftIO $ bracket (FFI.getModuleIdentifier mod) free decodeM)+   `ap` (liftIO $ getDataLayout mod)+   `ap` (liftIO $ do+           s <- decodeM <=< FFI.getTargetTriple $ mod+           return $ if s == "" then Nothing else Just s)+   `ap` (+     do+       gs <- map A.GlobalDefinition . concat <$> runInterleaved [+          do+            ffiGlobals <- liftIO $ FFI.getXs (FFI.getFirstGlobal mod) FFI.getNextGlobal+            forM ffiGlobals $ \g -> do+              A.PointerType t as <- typeOf g+              return A.GlobalVariable+               `ap` getGlobalName g+               `ap` getLinkage g+               `ap` getVisibility g+               `ap` (liftIO $ decodeM =<< FFI.isThreadLocal g)+               `ap` return as+               `ap` (liftIO $ decodeM =<< FFI.hasUnnamedAddr (FFI.upCast g))+               `ap` (liftIO $ decodeM =<< FFI.isGlobalConstant g)+               `ap` return t+               `ap` (do+                      defer+                      i <- liftIO $ FFI.getInitializer g+                      if i == nullPtr then return Nothing else Just <$> decodeM i)+               `ap` getSection g+               `ap` getAlignment g,++          do+            ffiAliases <- liftIO $ FFI.getXs (FFI.getFirstAlias mod) FFI.getNextAlias+            forM ffiAliases $ \a -> do+              return A.G.GlobalAlias+               `ap` (do n <- getGlobalName a; defer; return n)+               `ap` getLinkage a+               `ap` getVisibility a+               `ap` typeOf a+               `ap` (decodeM =<< (liftIO $ FFI.getAliasee a)),++          do+            ffiFunctions <- liftIO $ FFI.getXs (FFI.getFirstFunction mod) FFI.getNextFunction+            forM ffiFunctions $ \f -> localScope $ do+              A.PointerType (A.FunctionType returnType _ isVarArg) _ <- typeOf f+              return A.Function+                 `ap` getLinkage f+                 `ap` getVisibility f+                 `ap` (liftIO $ decodeM =<< FFI.getFunctionCallConv f)+                 `ap` (liftIO $ decodeM =<< FFI.getFunctionRetAttr f)+                 `ap` return returnType+                 `ap` (getGlobalName f)+                 `ap` ((, isVarArg) <$> getParameters f)+                 `ap` (liftIO $ getFunctionAttrs f)+                 `ap` getSection f+                 `ap` getAlignment f+                 `ap` (do+                       ffiBasicBlocks <- liftIO $ FFI.getXs (FFI.getFirstBasicBlock f) FFI.getNextBasicBlock+                       runInterleaved . flip map ffiBasicBlocks $ \b -> +                           return A.BasicBlock+                            `ap` (do n <- getLocalName b; defer; return n)+                            `iap` getNamedInstructions b+                            `iap` getBasicBlockTerminator b+                     )+        ]++       tds <- getStructDefinitions++       ias <- decodeM =<< liftIO (FFI.moduleGetInlineAsm mod)++       nmds <- do+         ffiNamedMetadataNodes <- liftIO $ FFI.getXs (FFI.getFirstNamedMetadata mod) FFI.getNextNamedMetadata+         forM ffiNamedMetadataNodes $ \nm -> scopeAnyCont $ do+              n <- liftIO $ FFI.getNamedMetadataNumOperands nm+              os <- allocaArray n+              liftIO $ FFI.getNamedMetadataOperands nm os+              l <- alloca+              cs <- liftIO $ FFI.getNamedMetadataName nm l+              l <- peek l+              return A.NamedMetadataDefinition+                 `ap` decodeM (cs, l)+                 `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
@@ -0,0 +1,96 @@+{-# LANGUAGE+  MultiParamTypeClasses,+  FlexibleInstances+  #-}+module LLVM.General.Internal.Operand where++import Data.Functor+import Control.Monad.State+import Control.Monad.AnyCont++import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.Constant as FFI+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 LLVM.General.Internal.Coding+import LLVM.General.Internal.Constant ()+import LLVM.General.Internal.Context+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.EncodeAST+import LLVM.General.Internal.InlineAssembly ()+import LLVM.General.Internal.Metadata ()++import qualified LLVM.General.AST as A++instance DecodeM DecodeAST A.Operand (Ptr FFI.Value) where+  decodeM v = do+    c <- liftIO $ FFI.isAConstant v+    if (c /= nullPtr) +     then+      return A.ConstantOperand `ap` decodeM c+     else+      do+        mds <- liftIO $ FFI.isAMDString v+        if mds /= nullPtr +         then return A.MetadataStringOperand `ap` decodeM mds+         else+           do+             mdn <- liftIO $ FFI.isAMDNode v+             if mdn /= nullPtr+              then return A.MetadataNodeOperand `ap` decodeM mdn+              else+                return A.LocalReference `ap` getLocalName v++instance DecodeM DecodeAST A.CallableOperand (Ptr FFI.Value) where+  decodeM v = do+    ia <- liftIO $ FFI.isAInlineAsm v+    if ia /= nullPtr+     then liftM Left (decodeM ia)+     else liftM Right (decodeM v)++instance EncodeM EncodeAST A.Operand (Ptr FFI.Value) where+  encodeM (A.ConstantOperand c) = (FFI.upCast :: Ptr FFI.Constant -> Ptr FFI.Value) <$> encodeM c+  encodeM (A.LocalReference n) = referLocal n+  encodeM (A.MetadataStringOperand s) = do+    Context c <- gets encodeStateContext+    s <- encodeM s+    liftM FFI.upCast $ liftIO $ FFI.mdStringInContext c s+  encodeM (A.MetadataNodeOperand mdn) = (FFI.upCast :: Ptr FFI.MDNode -> Ptr FFI.Value) <$> encodeM mdn++instance EncodeM EncodeAST A.CallableOperand (Ptr FFI.Value) where+  encodeM (Right o) = encodeM o+  encodeM (Left i) = liftM (FFI.upCast :: Ptr FFI.InlineAsm -> Ptr FFI.Value) (encodeM i)++instance EncodeM EncodeAST A.MetadataNode (Ptr FFI.MDNode) where+  encodeM (A.MetadataNode ops) = scopeAnyCont $ do+    Context c <- gets encodeStateContext+    ops <- encodeM ops+    liftIO $ FFI.createMDNodeInContext c ops+  encodeM (A.MetadataNodeReference n) = referMDNode n++instance DecodeM DecodeAST [A.Operand] (Ptr FFI.MDNode) where+  decodeM p = scopeAnyCont $ do+    n <- liftIO $ FFI.getMDNodeNumOperands p+    ops <- allocaArray n+    liftIO $ FFI.getMDNodeOperands p ops+    decodeM (n, ops)++instance DecodeM DecodeAST A.MetadataNode (Ptr FFI.MDNode) where+  decodeM p = scopeAnyCont $ do+    fl <- decodeM =<< liftIO (FFI.mdNodeIsFunctionLocal p)+    if fl+     then+       return A.MetadataNode `ap` decodeM p+     else+       return A.MetadataNodeReference `ap` getMetadataNodeID p++getMetadataDefinitions :: DecodeAST [A.Definition]+getMetadataDefinitions = fix $ \continue -> do+  mdntd <- takeMetadataNodeToDefine+  flip (maybe (return [])) mdntd $ \(mid, p) -> do+    return (:)+      `ap` (return A.MetadataNodeDefinition `ap` return mid `ap` decodeM p)+      `ap` continue
+ src/LLVM/General/Internal/PassManager.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE+  TemplateHaskell,+  FlexibleInstances+  #-}++module LLVM.General.Internal.PassManager where++import qualified Language.Haskell.TH as TH++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Applicative++import Control.Monad.AnyCont++import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.PassManager as FFI+import qualified LLVM.General.Internal.FFI.Transforms as FFI++import LLVM.General.Internal.Module+import LLVM.General.Internal.Target+import LLVM.General.Internal.Coding+import LLVM.General.Transforms++-- | <http://llvm.org/doxygen/classllvm_1_1PassManager.html>+newtype PassManager = PassManager (Ptr FFI.PassManager)++-- | There are different ways to get a 'PassManager'. This class embodies them.+class PassManagerSpecification s where+    -- | make a 'PassManager'+    createPassManager :: s -> IO (Ptr FFI.PassManager)++-- | This type is a high-level specification of a set of passes. It uses the same+-- collection of passes chosen by the LLVM team in the command line tool 'opt'.  The fields+-- of this spec are much like typical compiler command-line flags - e.g. -O\<n\>, etc.+data CuratedPassSetSpec = CuratedPassSetSpec {+    optLevel :: Maybe Int,+    sizeLevel :: Maybe Int,+    unitAtATime :: Maybe Bool,+    simplifyLibCalls :: Maybe Bool,+    useInlinerWithThreshold :: Maybe Int+  }++-- | Helper to make a 'CuratedPassSetSpec'+defaultCuratedPassSetSpec = CuratedPassSetSpec {+    optLevel = Nothing,+    sizeLevel = Nothing,+    unitAtATime = Nothing,+    simplifyLibCalls = Nothing,+    useInlinerWithThreshold = Nothing+  }++instance PassManagerSpecification CuratedPassSetSpec where+  createPassManager s = bracket FFI.passManagerBuilderCreate FFI.passManagerBuilderDispose $ \b -> do+    let handleOption g m = maybe (return ()) (g b . fromIntegral . fromEnum) (m s)+    handleOption FFI.passManagerBuilderSetOptLevel optLevel+    handleOption FFI.passManagerBuilderSetSizeLevel sizeLevel+    handleOption FFI.passManagerBuilderSetDisableUnitAtATime (liftM not . unitAtATime)+    handleOption FFI.passManagerBuilderSetDisableSimplifyLibCalls (liftM not . simplifyLibCalls)+    handleOption FFI.passManagerBuilderUseInlinerWithThreshold useInlinerWithThreshold+    pm <- FFI.createPassManager+    FFI.passManagerBuilderPopulateModulePassManager b pm+    return pm++data PassSetSpec = PassSetSpec [Pass] (Maybe TargetLowering)++instance PassManagerSpecification PassSetSpec where+  createPassManager (PassSetSpec ps tl') = flip runAnyContT return $ do+    let tl = maybe nullPtr (\(TargetLowering tl) -> tl) tl'+    pm <- liftIO $ FFI.createPassManager+    forM ps $ \p -> $(+      do+        TH.TyConI (TH.DataD _ _ _ cons _) <- TH.reify ''Pass+        TH.caseE [| p |] $ flip map cons $ \con -> do+          let+            (n, fns) = case con of+                          TH.RecC n fs -> (n, [ TH.nameBase fn | (fn, _, _) <- fs ])+                          TH.NormalC n [] -> (n, [])+            actions = +              [ TH.bindS (TH.varP . TH.mkName $ fn) [| encodeM $(TH.dyn fn) |] | fn <- fns ]+              ++ [+               TH.noBindS [|+                 liftIO $(+                   foldl1 TH.appE+                   (map TH.dyn $+                      ["FFI.add" ++ TH.nameBase n ++ "Pass", "pm"]+                      ++ ["tl" | FFI.needsTargetLowering (TH.nameBase n)]+                      ++ fns)+                  )+                 |]+               ]+          TH.match (TH.conP n $ map (TH.varP . TH.mkName) fns) (TH.normalB (TH.doE actions)) []+     )+    return pm++instance PassManagerSpecification [Pass] where+  createPassManager ps = createPassManager (PassSetSpec ps Nothing)++instance PassManagerSpecification ([Pass], TargetLowering) where+  createPassManager (ps, tl) = createPassManager (PassSetSpec ps (Just tl))++-- | bracket the creation of a 'PassManager'+withPassManager :: PassManagerSpecification s => s -> (PassManager -> IO a) -> IO a+withPassManager s = bracket (createPassManager s) FFI.disposePassManager . (. PassManager)++-- | run the passes in a 'PassManager' on a 'Module', modifying the 'Module'.+runPassManager :: PassManager -> Module -> IO Bool+runPassManager (PassManager p) (Module m) = toEnum . fromIntegral <$> FFI.runPassManager p m
+ src/LLVM/General/Internal/RMWOperation.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances+  #-}++module LLVM.General.Internal.RMWOperation where++import LLVM.General.AST.RMWOperation++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI++import LLVM.General.Internal.Coding++genCodingInstance' [t| RMWOperation |] ''FFI.RMWOperation [+  (FFI.rmwOperationXchg, Xchg),+  (FFI.rmwOperationAdd, Add),+  (FFI.rmwOperationSub, Sub),+  (FFI.rmwOperationAnd, And),+  (FFI.rmwOperationNand, Nand),+  (FFI.rmwOperationOr, Or),+  (FFI.rmwOperationXor, Xor),+  (FFI.rmwOperationMax, Max),+  (FFI.rmwOperationMin, Min),+  (FFI.rmwOperationUMax, UMax),+  (FFI.rmwOperationUMin, UMin)+ ]
+ src/LLVM/General/Internal/String.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE+  MultiParamTypeClasses,+  FlexibleInstances,+  UndecidableInstances+  #-}+module LLVM.General.Internal.String where++import Control.Arrow+import Control.Monad+import Foreign.C (CString, CChar)+import Foreign.Ptr+import Control.Monad.AnyCont+import Control.Monad.IO.Class++import LLVM.General.Internal.Coding++import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++instance (MonadAnyCont IO e) => EncodeM e String CString where+  encodeM s = anyContToM (BS.useAsCString . T.encodeUtf8 . T.pack $ s)++instance (Integral i, MonadAnyCont IO e) => EncodeM e String (Ptr CChar, i) where+  encodeM s = anyContToM ((. (. second fromIntegral)) . BS.useAsCStringLen . T.encodeUtf8 . T.pack $ s)++instance (MonadIO d) => DecodeM d String CString where+  decodeM = liftIO . liftM (T.unpack . T.decodeUtf8) . BS.packCString++instance (Integral i, MonadIO d) => DecodeM d String (Ptr CChar, i) where+  decodeM = liftIO . liftM (T.unpack . T.decodeUtf8) . BS.packCStringLen . second fromIntegral
+ src/LLVM/General/Internal/Target.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE+  TemplateHaskell,+  FlexibleInstances,+  MultiParamTypeClasses,+  TupleSections,+  RecordWildCards+  #-}+module LLVM.General.Internal.Target where++import Control.Monad+import Control.Exception+import Data.Functor+import Control.Monad.IO.Class+import Control.Monad.AnyCont++import Foreign.Ptr+import Foreign.Marshal.Alloc (free)++import LLVM.General.Internal.Coding+import LLVM.General.Internal.String ()++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.Target as FFI++import qualified LLVM.General.Relocation as Reloc+import qualified LLVM.General.Target.Options as TO+import qualified LLVM.General.CodeModel as CodeModel+import qualified LLVM.General.CodeGenOpt as CodeGenOpt++genCodingInstance' [t| Reloc.Model |] ''FFI.RelocModel [+  (FFI.relocModelDefault, Reloc.Default),+  (FFI.relocModelStatic, Reloc.Static),+  (FFI.relocModelPIC, Reloc.PIC),+  (FFI.relocModelDynamicNoPic, Reloc.DynamicNoPIC)+ ]++genCodingInstance' [t| CodeModel.Model |] ''FFI.CodeModel [+  (FFI.codeModelDefault,CodeModel.Default),+  (FFI.codeModelJITDefault, CodeModel.JITDefault),+  (FFI.codeModelSmall, CodeModel.Small),+  (FFI.codeModelKernel, CodeModel.Kernel),+  (FFI.codeModelMedium, CodeModel.Medium),+  (FFI.codeModelLarge, CodeModel.Large)+ ]++genCodingInstance' [t| CodeGenOpt.Level |] ''FFI.CodeGenOptLevel [+  (FFI.codeGenOptLevelNone, CodeGenOpt.None),+  (FFI.codeGenOptLevelLess, CodeGenOpt.Less),+  (FFI.codeGenOptLevelDefault, CodeGenOpt.Default),+  (FFI.codeGenOptLevelAggressive, CodeGenOpt.Aggressive)+ ]++genCodingInstance' [t| TO.FloatABI |] ''FFI.FloatABIType [+  (FFI.floatABIDefault, TO.FloatABIDefault),+  (FFI.floatABISoft, TO.FloatABISoft),+  (FFI.floatABIHard, TO.FloatABIHard)+ ]++genCodingInstance' [t| TO.FloatingPointOperationFusionMode |] ''FFI.FPOpFusionMode [+  (FFI.fpOpFusionModeFast, TO.FloatingPointOperationFusionFast),+  (FFI.fpOpFusionModeStandard, TO.FloatingPointOperationFusionStandard),+  (FFI.fpOpFusionModeStrict, TO.FloatingPointOperationFusionStrict)+ ]++newtype Target = Target (Ptr FFI.Target)++-- | Find a Target given an architecture and/or a \"triple\".+-- | <http://llvm.org/doxygen/structllvm_1_1TargetRegistry.html#a3105b45e546c9cc3cf78d0f2ec18ad89>+lookupTarget :: +  Maybe String -- ^ arch+  -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu+  -> IO (Either String (Target, String))+lookupTarget arch triple = flip runAnyContT return $ do+  cErrorP <- alloca+  cNewTripleP <- alloca+  arch <- encodeM (maybe "" id arch)+  triple <- encodeM triple+  target <- liftIO $ FFI.lookupTarget arch triple cNewTripleP cErrorP+  let readString p = do+        s <- peek p+        r <- decodeM s+        liftIO $ free s+        return r+  if (target == nullPtr) then+     Left <$> readString cErrorP+   else+     Right . (Target target, ) <$> readString cNewTripleP++-- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>+newtype TargetOptions = TargetOptions (Ptr FFI.TargetOptions)++-- | bracket creation and destruction of a 'TargetOptions' object+withTargetOptions :: (TargetOptions -> IO a) -> IO a+withTargetOptions = bracket FFI.createTargetOptions FFI.disposeTargetOptions . (. TargetOptions)++-- | set all target options+pokeTargetOptions :: TO.Options -> TargetOptions -> IO ()+pokeTargetOptions hOpts (TargetOptions cOpts) = do+  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),+    (FFI.targetOptionFlagNoNaNsFPMath, TO.noNaNsFloatingPointMath),+    (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),+    (FFI.targetOptionFlagDisableTailCalls, TO.disableTailCalls),+    (FFI.targetOptionFlagEnableFastISel, TO.enableFastInstructionSelection),+    (FFI.targetOptionFlagPositionIndependentExecutable, TO.positionIndependentExecutable),+    (FFI.targetOptionFlagEnableSegmentedStacks, TO.enableSegmentedStacks),+    (FFI.targetOptionFlagUseInitArray, TO.useInitArray),+    (FFI.targetOptionFlagRealignStack, TO.realignStack) +   ]+  FFI.setStackAlignmentOverride cOpts =<< encodeM (TO.stackAlignmentOverride hOpts)+  flip runAnyContT return $ do+    n <- encodeM (TO.trapFunctionName hOpts)+    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 +  printMachineCode+    <- gof FFI.targetOptionFlagPrintMachineCode+  noFramePointerElimination+    <- gof FFI.targetOptionFlagNoFramePointerElim+  noFramePointerEliminationNonLeaf+    <- gof FFI.targetOptionFlagNoFramePointerElimNonLeaf+  lessPreciseFloatingPointMultiplyAddOption+    <- gof FFI.targetOptionFlagLessPreciseFPMADOption+  unsafeFloatingPointMath+    <- gof FFI.targetOptionFlagUnsafeFPMath+  noInfinitiesFloatingPointMath+    <- gof FFI.targetOptionFlagNoInfsFPMath+  noNaNsFloatingPointMath+    <- gof FFI.targetOptionFlagNoNaNsFPMath+  honorSignDependentRoundingFloatingPointMathOption+    <- gof FFI.targetOptionFlagHonorSignDependentRoundingFPMathOption+  useSoftFloat+    <- gof FFI.targetOptionFlagUseSoftFloat+  noZerosInBSS+    <- gof FFI.targetOptionFlagNoZerosInBSS+  jITExceptionHandling+    <- gof FFI.targetOptionFlagJITExceptionHandling+  jITEmitDebugInfo+    <- gof FFI.targetOptionFlagJITEmitDebugInfo+  jITEmitDebugInfoToDisk+    <- gof FFI.targetOptionFlagJITEmitDebugInfoToDisk+  guaranteedTailCallOptimization+    <- gof FFI.targetOptionFlagGuaranteedTailCallOpt+  disableTailCalls+    <- gof FFI.targetOptionFlagDisableTailCalls+  enableFastInstructionSelection+    <- gof FFI.targetOptionFlagEnableFastISel+  positionIndependentExecutable+    <- gof FFI.targetOptionFlagPositionIndependentExecutable+  enableSegmentedStacks+    <- 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 :: +    Target+    -> String -- ^ triple+    -> String -- ^ cpu+    -> String -- ^ features+    -> TargetOptions+    -> Reloc.Model+    -> CodeModel.Model+    -> CodeGenOpt.Level+    -> (TargetMachine -> IO a)+    -> IO a+withTargetMachine+  (Target target)+  triple+  cpu+  features+  (TargetOptions targetOptions)+  relocModel+  codeModel+  codeGenOptLevel = runAnyContT $ do+  triple <- encodeM triple+  cpu <- encodeM cpu+  features <- encodeM features+  relocModel <- encodeM relocModel+  codeModel <- encodeM codeModel+  codeGenOptLevel <- encodeM codeGenOptLevel+  anyContT $ bracket (+      FFI.createTargetMachine+         target+         triple+         cpu+         features+         targetOptions+         relocModel+         codeModel+         codeGenOptLevel+      )+      FFI.disposeTargetMachine+      . (. TargetMachine)++-- | <http://llvm.org/doxygen/classllvm_1_1TargetLowering.html>+newtype TargetLowering = TargetLowering (Ptr FFI.TargetLowering)++-- | get the 'TargetLowering' of a 'TargetMachine'+getTargetLowering :: TargetMachine -> IO TargetLowering+getTargetLowering (TargetMachine tm) = TargetLowering <$> FFI.getTargetLowering tm
+ src/LLVM/General/Internal/Type.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE+  QuasiQuotes,+  FlexibleInstances,+  MultiParamTypeClasses+  #-}+module LLVM.General.Internal.Type where++import Control.Applicative+import Control.Monad.State+import Control.Monad.AnyCont++import qualified Data.Set as Set++import Foreign.Ptr++import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.Type as FFI++import qualified LLVM.General.AST as A+import qualified LLVM.General.AST.AddrSpace as A++import LLVM.General.Internal.Context+import LLVM.General.Internal.Coding+import LLVM.General.Internal.DecodeAST+import LLVM.General.Internal.EncodeAST++getStructure :: Ptr FFI.Type -> DecodeAST A.Type+getStructure t = scopeAnyCont $ do+  return A.StructureType +   `ap` (decodeM =<< liftIO (FFI.isPackedStruct t))+   `ap` do+       n <- liftIO (FFI.countStructElementTypes t)+       ts <- allocaArray n+       liftIO $ FFI.getStructElementTypes t ts+       decodeM (n, ts)++getStructDefinitions :: DecodeAST [A.Definition]+getStructDefinitions = do+  let getStructDefinition t = do+       opaque <- decodeM =<< liftIO (FFI.structIsOpaque t)+       if opaque then return Nothing else Just <$> getStructure t+  flip fix Set.empty $ \continue done -> do+    t <- takeTypeToDefine+    flip (maybe (return [])) t $ \t -> do+      if t `Set.member` done+        then+          continue done+        else+          return (:)+            `ap` (return A.TypeDefinition `ap` getTypeName t `ap` getStructDefinition t)+            `ap` (continue $ Set.insert t done)++isArrayType :: Ptr FFI.Type -> IO Bool+isArrayType t = do+  k <- liftIO $ FFI.getTypeKind t+  return $ k == FFI.typeKindArray+              +instance Monad m => EncodeM m A.AddrSpace FFI.AddrSpace where+  encodeM (A.AddrSpace a) = return FFI.AddrSpace `ap` encodeM a++instance Monad m => DecodeM m A.AddrSpace FFI.AddrSpace where+  decodeM (FFI.AddrSpace a) = return A.AddrSpace `ap` decodeM a++instance EncodeM EncodeAST A.Type (Ptr FFI.Type) where+  encodeM f = scopeAnyCont $ do+    Context context <- gets encodeStateContext+    case f of+      A.IntegerType bits -> do+        bits <- encodeM bits+        liftIO $ FFI.intTypeInContext context bits+      A.FunctionType returnTypeAST argTypeASTs isVarArg -> do+        returnType <- encodeM returnTypeAST+        argTypes <- encodeM argTypeASTs+        isVarArg <- encodeM isVarArg+        liftIO $ FFI.functionType returnType argTypes isVarArg+      A.PointerType elementType addressSpace -> do+        e <- encodeM elementType+        a <- encodeM addressSpace+        liftIO $ FFI.pointerType e a+      A.VoidType -> liftIO $ FFI.voidTypeInContext context+      A.FloatingPointType 16 A.IEEE -> liftIO $ FFI.halfTypeInContext context+      A.FloatingPointType 32 A.IEEE -> liftIO $ FFI.floatTypeInContext context+      A.FloatingPointType 64 A.IEEE -> liftIO $ FFI.doubleTypeInContext context+      A.FloatingPointType 80 A.DoubleExtended -> liftIO $ FFI.x86FP80TypeInContext context+      A.FloatingPointType 128 A.IEEE -> liftIO $ FFI.fP128TypeInContext context+      A.FloatingPointType 128 A.PairOfFloats -> liftIO $ FFI.ppcFP128TypeInContext context+      A.FloatingPointType _ _ -> fail $ "unsupported floating point type: " ++ show f+      A.VectorType sz e -> do+        e <- encodeM e+        sz <- encodeM sz+        liftIO $ FFI.vectorType e sz+      A.ArrayType sz e -> do+        e <- encodeM e+        sz <- encodeM sz+        liftIO $ FFI.arrayType e sz+      A.StructureType packed ets -> do+        ets <- encodeM ets+        packed <- encodeM packed+        liftIO $ FFI.structTypeInContext context ets packed+      A.NamedTypeReference n -> lookupNamedType n++instance DecodeM DecodeAST A.Type (Ptr FFI.Type) where+  decodeM t = scopeAnyCont $ do+    k <- liftIO $ FFI.getTypeKind t+    case k of+      [FFI.typeKindP|Void|] -> return A.VoidType+      [FFI.typeKindP|Integer|] -> A.IntegerType <$> (decodeM =<< liftIO (FFI.getIntTypeWidth t))+      [FFI.typeKindP|Function|] -> +          return A.FunctionType+               `ap` (decodeM =<< liftIO (FFI.getReturnType t))+               `ap` (do+                      n <- liftIO (FFI.countParamTypes t)+                      ts <- allocaArray n+                      liftIO $ FFI.getParamTypes t ts+                      decodeM (n, ts)+                   )+               `ap` (decodeM =<< liftIO (FFI.isFunctionVarArg t))+      [FFI.typeKindP|Pointer|] ->+          return A.PointerType+             `ap` (decodeM =<< liftIO (FFI.getElementType t))+             `ap` (decodeM =<< liftIO (FFI.getPointerAddressSpace t))+      [FFI.typeKindP|Half|] -> return $ A.FloatingPointType 16 A.IEEE+      [FFI.typeKindP|Float|] -> return $ A.FloatingPointType 32 A.IEEE+      [FFI.typeKindP|Double|] -> return $ A.FloatingPointType 64 A.IEEE+      [FFI.typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE+      [FFI.typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended+      [FFI.typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats+      [FFI.typeKindP|Vector|] -> +        return A.VectorType+         `ap` (decodeM =<< liftIO (FFI.getVectorSize t))+         `ap` (decodeM =<< liftIO (FFI.getElementType t))+      [FFI.typeKindP|Struct|] -> do+        let ifM c a b = c >>= \x -> if x then a else b+        ifM (decodeM =<< liftIO (FFI.structIsLiteral t)) +            (getStructure t)+            (saveNamedType t >> return A.NamedTypeReference `ap` getTypeName t)++      [FFI.typeKindP|Array|] -> +        return A.ArrayType+         `ap` (decodeM =<< liftIO (FFI.getArrayLength t))+         `ap` (decodeM =<< liftIO (FFI.getElementType t))+      _ -> error $ "unhandled type kind " ++ show k++createNamedType :: A.Name -> EncodeAST (Ptr FFI.Type)+createNamedType n = do+  Context c <- gets encodeStateContext+  n <- case n of { A.Name n -> encodeM n; _ -> return nullPtr }+  liftIO $ FFI.structCreateNamed c n+  ++setNamedType :: Ptr FFI.Type -> A.Type -> EncodeAST ()+setNamedType t (A.StructureType packed ets) = do+  ets <- encodeM ets+  packed <- encodeM packed+  liftIO $ FFI.structSetBody t ets packed++      +
+ src/LLVM/General/Internal/Value.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE+  FlexibleContexts,+  FlexibleInstances,+  MultiParamTypeClasses+  #-}+module LLVM.General.Internal.Value where++import Control.Monad.State++import Foreign.Ptr++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.DecodeAST+import LLVM.General.Internal.Type () +import LLVM.General.Internal.Constant () ++import qualified LLVM.General.AST.Type as A++typeOf :: FFI.DescendentOf FFI.Value v => Ptr v -> DecodeAST A.Type+typeOf = decodeM <=< liftIO . FFI.typeOf . FFI.upCast+
+ src/LLVM/General/Module.hs view
@@ -0,0 +1,11 @@+-- | A 'Module' holds a C++ LLVM IR module. 'Module's may be converted to or from strings or Haskell ASTs, or+-- added to an 'LLVM.General.ExecutionEngine' and so JIT compiled to get funciton pointers.+module LLVM.General.Module (+    Module,+    withModuleFromAST,+    moduleAST,+    withModuleFromString,+    moduleString+  ) where++import LLVM.General.Internal.Module
+ src/LLVM/General/PassManager.hs view
@@ -0,0 +1,19 @@+-- | A 'PassManager' holds collection of passes, to be run on 'Module's.+-- Build one with 'createPassManager':+-- +--  * from a 'CuratedPassSetSpec' if you want optimization but not to play with your compiler+--+--  * from a ['LLVM.General.Transform.Pass'] if you do want to play with your compiler+--+--  * from a (['LLVM.General.Transform.Pass'], 'LLVM.General.Target.TargetLowering') if you+--    want to provide target-specific information (e.g. instruction costs) to the few passes+--    that use it (see comments on 'LLVM.General.Transforms.Pass').+module LLVM.General.PassManager (+  PassManager,+  PassManagerSpecification,+  CuratedPassSetSpec(..), defaultCuratedPassSetSpec,+  withPassManager,+  runPassManager+  ) where++import LLVM.General.Internal.PassManager
+ src/LLVM/General/Relocation.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | Relocations, used in specifying TargetMachine+module LLVM.General.Relocation where++import Data.Data++-- | <http://llvm.org/doxygen/namespacellvm_1_1Reloc.html>+data Model +    = Default+    | Static+    | PIC+    | DynamicNoPIC+    deriving (Eq, Read, Show, Typeable, Data)
+ src/LLVM/General/Target.hs view
@@ -0,0 +1,13 @@+-- | 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 (+   lookupTarget,+   TargetOptions,+   withTargetOptions, peekTargetOptions, pokeTargetOptions,+   withTargetMachine,+   getTargetLowering+ ) where++import LLVM.General.Internal.Target+
+ src/LLVM/General/Target/Options.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE+  DeriveDataTypeable +  #-}+-- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>+module LLVM.General.Target.Options where++import Data.Data+import Data.Word++-- | <http://llvm.org/doxygen/namespacellvm_1_1FloatABI.html#aea077c52d84934aabf9445cef9eab2e2>+data FloatABI+  = FloatABIDefault+  | FloatABISoft+  | FloatABIHard+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data)++-- | <http://llvm.org/doxygen/namespacellvm_1_1FPOpFusion.html#a9c71bae9f02af273833fde586d529fc5>+data FloatingPointOperationFusionMode+  = FloatingPointOperationFusionFast+  | FloatingPointOperationFusionStandard+  | FloatingPointOperationFusionStrict+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data)++-- | The options of a 'LLVM.General.Target.TargetOptions'+-- <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>+data Options = Options {+  printMachineCode :: Bool,+  noFramePointerElimination :: Bool,+  noFramePointerEliminationNonLeaf :: Bool,+  lessPreciseFloatingPointMultiplyAddOption :: Bool,+  unsafeFloatingPointMath :: Bool,+  noInfinitiesFloatingPointMath :: Bool,+  noNaNsFloatingPointMath :: Bool,+  honorSignDependentRoundingFloatingPointMathOption :: Bool,+  useSoftFloat :: Bool,+  noZerosInBSS :: Bool,+  jITExceptionHandling :: Bool,+  jITEmitDebugInfo :: Bool,+  jITEmitDebugInfoToDisk :: Bool,+  guaranteedTailCallOptimization :: Bool,+  disableTailCalls :: Bool,+  realignStack :: Bool,+  enableFastInstructionSelection :: Bool,+  positionIndependentExecutable :: Bool,+  enableSegmentedStacks :: Bool,+  useInitArray :: Bool,+  stackAlignmentOverride :: Word32,+  trapFunctionName :: String,+  floatABIType :: FloatABI,+  allowFloatingPointOperationFusion :: FloatingPointOperationFusionMode,+  stackSmashingProtectionBufferSize :: Word32+  }+  deriving (Eq, Ord, Read, Show)+
+ src/LLVM/General/Transforms.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE+  DeriveDataTypeable+  #-}+-- | This module provides an enumeration of the various transformation (e.g. optimization) passes+-- provided by LLVM. They can be used to create a 'LLVM.General.PassManager.PassManager' to, in turn,+-- run the passes on 'LLVM.General.Module.Module's. If you don't know what passes you want, consider+-- instead using 'LLVM.General.PassManager.CuratedPassSetSpec'.+module LLVM.General.Transforms where++import Data.Data+import Data.Int+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+-- 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'+  | CodeGenPrepare+  | ConstantPropagation+  | CorrelatedValuePropagation+  | DeadCodeElimination+  | DeadInstructionElimination+  | DeadStoreElimination+  | DemoteRegisterToMemory+  | EarlyCommonSubexpressionElimination+  | GlobalValueNumbering { noLoads :: Bool }+  | InductionVariableSimplify+  | InstructionCombining+  | JumpThreading+  | LoopClosedSingleStaticAssignment+  | LoopInvariantCodeMotion+  | LoopDeletion+  | LoopIdiom+  | LoopInstructionSimplify+  | LoopRotate+  -- | can use a 'LLVM.General.Target.TargetLowering'+  | LoopStrengthReduce+  | LoopUnroll { loopUnrollThreshold :: Int32, count :: Int32, allowPartial :: Int32 }+  | LoopUnswitch { optimizeForSize :: Bool }+  | LowerAtomic+  -- | can use a 'LLVM.General.Target.TargetLowering'+  | LowerInvoke { useExpensiveExceptionHandlingSupport :: Bool } +  | LowerSwitch+  | LowerExpectIntrinsic+  | MemcpyOptimization+  | PromoteMemoryToRegister+  | Reassociate+  | ScalarReplacementOfAggregates { requiresDominatorTree :: Bool }+  | OldScalarReplacementOfAggregates { +      oldScalarReplacementOfAggregatesThreshold :: Int32, +      useDominatorTree :: Bool, +      structMemberThreshold :: Int32,+      arrayElementThreshold :: Int32,+      scalarLoadThreshold :: Int32+    }+  | SparseConditionalConstantPropagation+  | SimplifyLibCalls+  | SimplifyControlFlowGraph+  | Sinking+  | TailCallElimination++  -- here begin the Interprocedural passes+  | AlwaysInline { insertLifetime :: Bool }+  | ArgumentPromotion+  | ConstantMerge+  | FunctionAttributes+  | FunctionInlining { +      functionInliningThreshold :: Int32+    }+  | GlobalDeadCodeElimination+  | InternalizeFunctions { exportList :: [String] }+  | InterproceduralConstantPropagation+  | InterproceduralSparseConditionalConstantPropagation+  | MergeFunctions+  | PartialInlining+  | PruneExceptionHandling+  | StripDeadDebugInfo+  | StripDebugDeclare+  | StripNonDebugSymbols+  | StripSymbols { onlyDebugInfo :: Bool }++  -- here begin the vectorization passes+  | BasicBlockVectorize { +    vectorBits :: Word32,+    vectorizeBools :: Bool,+    vectorizeInts :: Bool,+    vectorizeFloats :: Bool,+    vectorizePointers :: Bool,+    vectorizeCasts :: Bool,+    vectorizeMath :: Bool,+    vectorizeFusedMultiplyAdd :: Bool,+    vectorizeSelect :: Bool,+    vectorizeCmp :: Bool,+    vectorizeGetElementPtr :: Bool,+    vectorizeMemoryOperations :: Bool,+    alignedOnly :: Bool,+    requiredChainDepth :: Word32,+    searchLimit :: Word32,+    maxCandidatePairsForCycleCheck :: Word32,+    splatBreaksChain :: Bool,+    maxInstructions :: Word32,+    maxIterations :: Word32,+    powerOfTwoLengthsOnly :: Bool,+    noMemoryOperationBoost :: Bool,+    fastDependencyAnalysis :: Bool+    }+  | LoopVectorize+  deriving (Eq, Ord, Read, Show, Typeable, Data)++-- | Defaults for the 'BasicBlockVectorize' pass - copied from the C++ code to keep these defaults+-- constant. (The C++ defaults are modifiable through global objects used for command-line processing,+-- in a design apparently oblivious to uses of LLVM besides the standard command-line tools).+defaultVectorizeBasicBlocks = BasicBlockVectorize {+    vectorBits = 128,+    vectorizeBools = True,+    vectorizeInts = True,+    vectorizeFloats = True,+    vectorizePointers = True,+    vectorizeCasts = True,+    vectorizeMath = True,+    vectorizeFusedMultiplyAdd = True,+    vectorizeSelect = True,+    vectorizeCmp = True,+    vectorizeGetElementPtr = True,+    vectorizeMemoryOperations = True,+    alignedOnly = True,++    requiredChainDepth = 6,+    searchLimit = 400,+    maxCandidatePairsForCycleCheck = 200,+    splatBreaksChain = False,+    maxInstructions = 500,+    maxIterations = 0,+    powerOfTwoLengthsOnly = False,+    noMemoryOperationBoost = False,+    fastDependencyAnalysis = False+  }
+ test/LLVM/General/Test/Constants.hs view
@@ -0,0 +1,170 @@+module LLVM.General.Test.Constants where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Control.Monad+import Data.Functor+import Data.Maybe+import Foreign.Ptr+import Data.Word++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.Diagnostic+import LLVM.General.AST+import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.Global as G+import qualified LLVM.General.AST.Constant as C+import qualified LLVM.General.AST.Float as F+import qualified LLVM.General.AST.IntegerPredicate as IPred++tests = testGroup "Constants" [+  testCase name $ strCheck mAST mStr+  | (name, type', value, str) <- [+    (+      "integer",+      IntegerType 32,+      C.Int 32 1,+      "global i32 1"+    ), (+      "wide integer",+      IntegerType 65,+      C.Int 65 1,+      "global i65 1"+    ), (+      "big wide integer",+      IntegerType 66,+      C.Int 66 20000000000000000000,+      "global i66 20000000000000000000"+    ), (+      "negative wide integer",+      IntegerType 65,+      C.Int 65 36893488147419103231,+      "global i65 -1"+    ), (+      "half",+      FloatingPointType 16 IEEE,+      C.Float (F.Half 0x1234),+      "global half 0xH1234"+    ), (+      "float",+      FloatingPointType 32 IEEE,+      C.Float (F.Single 1),+      "global float 1.000000e+00"+    ), (+      "double",+      FloatingPointType 64 IEEE,+      C.Float (F.Double 1),+      "global double 1.000000e+00"+    ), (+      "quad",+      FloatingPointType 128 IEEE,+      C.Float (F.Quadruple 0x0007000600050004 0x0003000200010000),+      "global fp128 0xL00030002000100000007000600050004" -- yes, this order is weird+    ), (+      "quad 1.0",+      FloatingPointType 128 IEEE,+      C.Float (F.Quadruple 0x3fff000000000000 0x0000000000000000),+      "global fp128 0xL00000000000000003FFF000000000000" -- yes, this order is weird+    ), (+      "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",+      FloatingPointType 128 PairOfFloats,+      C.Float (F.PPC_FP128 0x0007000600050004 0x0003000200010000),+      "global ppc_fp128 0xM????????????????"+-}+    ), (+      "struct",+      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 (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 [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 (IntegerType 32),+      C.Vector [C.Int 32 i | i <- [1,2,1]],+      "global <3 x i32> <i32 1, i32 2, i32 1>"+    ), (+      "binop/cast",+      IntegerType 64,+      C.Add (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 64)) (C.Int 64 2),+      "global i64 add (i64 ptrtoint (i32* @1 to i64), i64 2)"+    ), (+      "icmp",+      IntegerType 1,+      C.ICmp IPred.SGE (C.GlobalReference (UnName 1)) (C.GlobalReference (UnName 2)),+      "global i1 icmp sge (i32* @1, i32* @2)"+    ), (+      "getelementptr",+      PointerType (IntegerType 32) (AddrSpace 0),+      C.GetElementPtr True (C.GlobalReference (UnName 1)) [C.Int 64 27],+      "global i32* getelementptr inbounds (i32* @1, i64 27)"+    ), (+      "selectvalue",+      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",+      IntegerType 32,+      C.ExtractElement+         (C.BitCast+             (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.+      "extractvalue",+      IntegerType 8,+      C.ExtractValue+        (C.Select (C.PtrToInt (C.GlobalReference (UnName 1)) (IntegerType 1)) +         (C.Array (IntegerType 8) [C.Int 8 0])+         (C.Array (IntegerType 8) [C.Int 8 1]))+        [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)"+-}+    )+   ],+   let mAST = Module "<string>" Nothing Nothing [+             GlobalDefinition $ globalVariableDefaults {+               G.name = UnName 0, G.type' = type', G.initializer = Just value +             },+             GlobalDefinition $ globalVariableDefaults {+               G.name = UnName 1, G.type' = IntegerType 32, G.initializer = Nothing +             },+             GlobalDefinition $ globalVariableDefaults {+               G.name = UnName 2, G.type' = IntegerType 32, G.initializer = Nothing +             }+           ]+       mStr = "; ModuleID = '<string>'\n\n@0 = " ++ str ++ "\n\+              \@1 = external global i32\n\+              \@2 = external global i32\n"+ ]
+ test/LLVM/General/Test/DataLayout.hs view
@@ -0,0 +1,29 @@+module LLVM.General.Test.DataLayout where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import qualified Data.Set as Set++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.AST+import LLVM.General.AST.DataLayout+import qualified LLVM.General.AST.Global as G++tests = testGroup "DataLayout" [+  testCase name $ strCheck (Module "<string>" mdl Nothing []) ("; ModuleID = '<string>'\n" ++ sdl)+  | (name, mdl, sdl) <- [+   ("none",Nothing, "")+  ] ++ [+   (name, Just mdl, "target datalayout = \"" ++ sdl ++ "\"\n")+   | (name, mdl, sdl) <- [+    ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e"),+    ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E"),+    ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32")+   ]+  ]+ ]
+ test/LLVM/General/Test/ExecutionEngine.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module LLVM.General.Test.ExecutionEngine where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import Control.Monad+import Data.Functor+import Data.Maybe++import Foreign.Ptr+import Data.Word++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.ExecutionEngine+import LLVM.General.AST+import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.IntegerPredicate as IPred++import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.Global as G+import qualified LLVM.General.AST.Constant as C++foreign import ccall "dynamic" mkIO32Stub :: FunPtr (Word32 -> IO Word32) -> (Word32 -> IO Word32)++tests = testGroup "ExecutionEngine" [++  testCase "runSomething" $ withContext $ \context -> withExecutionEngine context $ \executionEngine -> do+    let mAST = Module "runSomethingModule" Nothing Nothing [+                GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+                              Parameter (IntegerType 32) (Name "foo") []+                             ],False) [] +                 Nothing 0+                 [+                  BasicBlock (UnName 0) [] (+                    Do $ Ret (Just (ConstantOperand (C.Int 32 42))) []+                   )+                 ]+                ]+    s <- withModuleFromAST context mAST $ \m -> do+          withModuleInEngine executionEngine m $ do+            Just p <- findFunction executionEngine (Name "foo")+            (mkIO32Stub ((castPtrToFunPtr p) :: FunPtr (Word32 -> IO Word32))) 7+    s @?= Right 42+ ]
+ test/LLVM/General/Test/Global.hs view
@@ -0,0 +1,40 @@+module LLVM.General.Test.Global where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.AST+import qualified LLVM.General.AST.Global as G++tests = testGroup "Global" [+  testGroup "Alignment" [+    testCase name $ withContext $ \context -> do+      let ast = Module "<string>" Nothing Nothing [ GlobalDefinition g ]+      Right ast' <- withModuleFromAST context ast moduleAST+      ast' @?= ast+    | a <- [0,1],+      s <- [Nothing, Just "foo"],+      g <- [+       globalVariableDefaults {+        G.name = UnName 0,+        G.type' = IntegerType 32,+        G.alignment = a,+        G.section = s+        },+       functionDefaults {+         G.returnType = VoidType,+         G.name = UnName 0,+         G.parameters = ([], False),+         G.alignment = a,+         G.section = s+       }+       ],+      let+          gn (G.Function {}) = "function"+          gn (G.GlobalVariable {}) = "variable"+          name = gn g ++ ", align " ++ show a ++ (maybe "" ("  section " ++ ) s)+   ]+ ]
+ test/LLVM/General/Test/InlineAssembly.hs view
@@ -0,0 +1,76 @@+module LLVM.General.Test.InlineAssembly where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import LLVM.General.Context+import LLVM.General.Module++import LLVM.General.AST+import LLVM.General.AST.InlineAssembly as IA+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Constant as C+import qualified LLVM.General.AST.Global as G++tests = testGroup "InlineAssembly" [+  testCase "expression" $ do+    let ast = Module "<string>" Nothing Nothing [+                GlobalDefinition $ +                  Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo")+                    ([Parameter (IntegerType 32) (Name "x") []],False)+                    [] Nothing 0 [+                      BasicBlock (UnName 0) [+                        UnName 1 := Call {+                          isTailCall = False,+                          callingConvention = CC.C,+                          returnAttributes = [],+                          function = Left $ InlineAssembly {+                                       IA.type' = FunctionType (IntegerType 32) [IntegerType 32] False,+                                       assembly = "bswap $0",+                                       constraints = "=r,r",+                                       hasSideEffects = False,+                                       alignStack = False,+                                       dialect = ATTDialect+                                     },+                          arguments = [+                            (LocalReference (Name "x"), [])+                           ],+                          functionAttributes = [],+                          metadata = []+                        }+                      ] (+                        Do $ Ret (Just (LocalReference (UnName 1))) []+                      )+                    ]++              ]+        s = "; ModuleID = '<string>'\n\+             \\n\+             \define i32 @foo(i32 %x) {\n\+             \  %1 = call i32 asm \"bswap $0\", \"=r,r\"(i32 %x)\n\+             \  ret i32 %1\n\+             \}\n"+    strCheck ast s,++  testCase "module" $ do+    let ast = Module "<string>" Nothing Nothing [+                ModuleInlineAssembly "foo",+                ModuleInlineAssembly "bar",+                GlobalDefinition $ globalVariableDefaults {+                  G.name = UnName 0,+                  G.type' = IntegerType 32+                }+              ]+        s = "; ModuleID = '<string>'\n\+             \\n\+             \module asm \"foo\"\n\+             \module asm \"bar\"\n\+             \\n\+             \@0 = external global i32\n"+    strCheck ast s+ ]
+ test/LLVM/General/Test/Instructions.hs view
@@ -0,0 +1,777 @@+module LLVM.General.Test.Instructions where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Control.Monad+import Data.Functor+import Data.Maybe+import Foreign.Ptr+import Data.Word++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.Diagnostic+import LLVM.General.AST+import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.IntegerPredicate as IPred+import qualified LLVM.General.AST.FloatingPointPredicate as FPPred+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.Global as G+import qualified LLVM.General.AST.Constant as C+import qualified LLVM.General.AST.RMWOperation as RMWOp++tests = testGroup "Instructions" [+  testGroup "regular" [+    testCase name $ do+      let mAST = Module "<string>" Nothing Nothing [+            GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+                  Parameter (IntegerType 32) (UnName 0) [],+                  Parameter (FloatingPointType 32 IEEE) (UnName 1) [],+                  Parameter (PointerType (IntegerType 32) (AddrSpace 0)) (UnName 2) [],+                  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) [] Nothing 0 [+              BasicBlock (UnName 7) [+                namedInstr+               ] (+                Do $ Ret Nothing []+               )+             ]+            ]+          mStr = "; ModuleID = '<string>'\n\+                 \\n\+                 \define void @0(i32, float, i32*, i64, i1, <2 x i32>, { i32, i32 }) {\n\+                 \  " ++ namedInstrS ++ "\n\+                 \  ret void\n\+                 \}\n"+      strCheck mAST mStr+    | let a = LocalReference . UnName,+      (name, namedInstr, namedInstrS) <- (+        [+         (name, UnName 8 := instr, "%8 = " ++ instrS)+         | (name, instr, instrS) <- [+          ("add",+           Add {+             nsw = False,+             nuw = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "add i32 %0, %0"),+          ("nsw",+           Add {+             nsw = True,+             nuw = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "add nsw i32 %0, %0"),+          ("nuw",+           Add {+             nsw = False,+             nuw = True,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "add nuw i32 %0, %0"),+          ("fadd",+           FAdd {+             operand0 = a 1,+             operand1 = a 1,+             metadata = [] +           },+           "fadd float %1, %1"),+          ("sub",+           Sub {+             nsw = False,+             nuw = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "sub i32 %0, %0"),+          ("fsub",+           FSub {+             operand0 = a 1,+             operand1 = a 1,+             metadata = [] +           },+           "fsub float %1, %1"),+          ("mul",+           Mul {+             nsw = False,+             nuw = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "mul i32 %0, %0"),+          ("fmul",+           FMul {+             operand0 = a 1,+             operand1 = a 1,+             metadata = [] +           },+           "fmul float %1, %1"),+          ("udiv",+           UDiv {+             exact = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "udiv i32 %0, %0"),+          ("exact",+           UDiv {+             exact = True,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "udiv exact i32 %0, %0"),+          ("sdiv",+           SDiv {+             exact = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "sdiv i32 %0, %0"),+          ("fdiv",+           FDiv {+             operand0 = a 1,+             operand1 = a 1,+             metadata = [] +           },+           "fdiv float %1, %1"),+          ("urem",+           URem {+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "urem i32 %0, %0"),+          ("srem",+           SRem {+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "srem i32 %0, %0"),+          ("frem",+           FRem {+             operand0 = a 1,+             operand1 = a 1,+             metadata = [] +           },+           "frem float %1, %1"),+          ("shl",+           Shl {+             nsw = False,+             nuw = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "shl i32 %0, %0"),+          ("ashr",+           AShr {+             exact = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "ashr i32 %0, %0"),+          ("lshr",+           LShr {+             exact = False,+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "lshr i32 %0, %0"),+          ("and",+           And {+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "and i32 %0, %0"),+          ("or",+           Or {+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "or i32 %0, %0"),+          ("xor",+           Xor {+             operand0 = a 0,+             operand1 = a 0,+             metadata = [] +           },+           "xor i32 %0, %0"),++          ("alloca",+           Alloca {+             allocatedType = IntegerType 32,+             numElements = Nothing,+             alignment = 0,+             metadata = [] +           },+           "alloca i32"),+          ("load",+           Load {+             volatile = False,+             address = a 2,+             maybeAtomicity = Nothing,+             alignment = 0,+             metadata = [] +           },+           "load i32* %2"),+          ("volatile",+           Load {+             volatile = True,+             address = a 2,+             maybeAtomicity = Nothing,+             alignment = 0,+             metadata = [] +           },+           "load volatile i32* %2"),+          ("acquire",+           Load {+             volatile = False,+             address = a 2,+             maybeAtomicity = Just (Atomicity { crossThread = True, memoryOrdering = Acquire }),+             alignment = 1,+             metadata = [] +           },+           "load atomic i32* %2 acquire, align 1"),+          ("singlethread",+           Load {+             volatile = False,+             address = a 2,+             maybeAtomicity = Just (Atomicity { crossThread = False, memoryOrdering = Monotonic }),+             alignment = 1,+             metadata = [] +           },+           "load atomic i32* %2 singlethread monotonic, align 1"),+          ("GEP",+           GetElementPtr {+             inBounds = False,+             address = a 2,+             indices = [ a 0 ],+             metadata = [] +           },+           "getelementptr i32* %2, i32 %0"),+          ("inBounds",+           GetElementPtr {+             inBounds = True,+             address = a 2,+             indices = [ a 0 ],+             metadata = [] +           },+           "getelementptr inbounds i32* %2, i32 %0"),+          ("cmpxchg",+           CmpXchg {+             volatile = False,+             address = a 2,+             expected = a 0,+             replacement = a 0,+             atomicity = Atomicity { crossThread = True, memoryOrdering = Monotonic },+             metadata = [] +           },+           "cmpxchg i32* %2, i32 %0, i32 %0 monotonic"),+          ("atomicrmw",+           AtomicRMW {+             volatile = False,+             rmwOperation = RMWOp.UMax,+             address = a 2,+             value = a 0,+             atomicity = Atomicity { crossThread = True, memoryOrdering = Release },+             metadata = []+           },+           "atomicrmw umax i32* %2, i32 %0 release"),++          ("trunc",+           Trunc {+             operand0 = a 0,+             type' = IntegerType 16,+             metadata = [] +           },+           "trunc i32 %0 to i16"),+          ("zext",+           ZExt {+             operand0 = a 0,+             type' = IntegerType 64,+             metadata = [] +           },+           "zext i32 %0 to i64"),+          ("sext",+           SExt {+             operand0 = a 0,+             type' = IntegerType 64,+             metadata = [] +           },+           "sext i32 %0 to i64"),+          ("fptoui",+           FPToUI {+             operand0 = a 1,+             type' = IntegerType 64,+             metadata = [] +           },+           "fptoui float %1 to i64"),+          ("fptosi",+           FPToSI {+             operand0 = a 1,+             type' = IntegerType 64,+             metadata = [] +           },+           "fptosi float %1 to i64"),+          ("uitofp",+           UIToFP {+             operand0 = a 0,+             type' = FloatingPointType 32 IEEE,+             metadata = [] +           },+           "uitofp i32 %0 to float"),+          ("sitofp",+           SIToFP {+             operand0 = a 0,+             type' = FloatingPointType 32 IEEE,+             metadata = [] +           },+           "sitofp i32 %0 to float"),+          ("fptrunc",+           FPTrunc {+             operand0 = a 1,+             type' = FloatingPointType 16 IEEE,+             metadata = [] +           },+           "fptrunc float %1 to half"),+          ("fpext",+           FPExt {+             operand0 = a 1,+             type' = FloatingPointType 64 IEEE,+             metadata = [] +           },+           "fpext float %1 to double"),+          ("ptrtoint",+           PtrToInt {+             operand0 = a 2,+             type' = IntegerType 32,+             metadata = [] +           },+           "ptrtoint i32* %2 to i32"),+          ("inttoptr",+           IntToPtr {+             operand0 = a 0,+             type' = PointerType (IntegerType 32) (AddrSpace 0),+             metadata = [] +           },+           "inttoptr i32 %0 to i32*"),+          ("bitcast",+           BitCast {+             operand0 = a 0,+             type' = FloatingPointType 32 IEEE,+             metadata = [] +           },+           "bitcast i32 %0 to float"),+          ("select",+           Select {+             condition' = a 4,+             trueValue = a 0,+             falseValue = a 0,+             metadata = []+           },+           "select i1 %4, i32 %0, i32 %0"),+          ("vaarg",+           VAArg {+             argList = a 2,+             type' = IntegerType 16,+             metadata = []+           },+           "va_arg i32* %2, i16"),+          ("extractelement",+           ExtractElement {+             vector = a 5,+             index = a 0,+             metadata = []+           },+           "extractelement <2 x i32> %5, i32 %0"),+          ("insertelement",+           InsertElement {+             vector = a 5,+             element = a 0,+             index = a 0,+             metadata = []+           },+           "insertelement <2 x i32> %5, i32 %0, i32 %0"),+          ("shufflevector",+           ShuffleVector {+             operand0 = a 5,+             operand1 = a 5,+             mask = C.Vector [ C.Int 32 p | p <- [0..1] ],+             metadata = []+           },+           "shufflevector <2 x i32> %5, <2 x i32> %5, <2 x i32> <i32 0, i32 1>"),+          ("extractvalue",+           ExtractValue {+             aggregate = a 6,+             indices' = [0],+             metadata = []+           },+           "extractvalue { i32, i32 } %6, 0"),+          ("insertvalue",+           InsertValue {+             aggregate = a 6,+             element = a 0,+             indices' = [0],+             metadata = []+           },+           "insertvalue { i32, i32 } %6, i32 %0, 0")+         ] ++ [+          ("landingpad-" ++ n,+           LandingPad {+             type' = StructureType False [ +                PointerType (IntegerType 8) (AddrSpace 0),+                IntegerType 32+               ],+             personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)),+             cleanup = cp,+             clauses = cls,+             metadata = []+           },+           "landingpad { i8*, i32 } personality void (i32, float, i32*, i64, i1, <2 x i32>, { i32, i32 })* @0" ++ s)+          | (clsn,cls,clss) <- [+           ("catch",+            [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))],+            "\n          catch i8* null"),+           ("filter",+            [Filter (C.Null (ArrayType 1 (PointerType (IntegerType 8) (AddrSpace 0))))],+            "\n          filter [1 x i8*] zeroinitializer")+          ],+          (cpn, cp, cps) <- [ ("-cleanup", True, "\n          cleanup"), ("", False, "") ],+          let s = cps ++ clss+              n = clsn ++ cpn+         ] ++ [+          ("icmp-" ++ ps,+           ICmp { iPredicate = p, operand0 = a 0, operand1 = a 0, metadata = [] },+           "icmp " ++ ps ++ " i32 %0, %0")+           | (ps, p) <- [+           ("eq", IPred.EQ),+           ("ne", IPred.NE),+           ("ugt", IPred.UGT),+           ("uge", IPred.UGE),+           ("ult", IPred.ULT),+           ("ule", IPred.ULE),+           ("sgt", IPred.SGT),+           ("sge", IPred.SGE),+           ("slt", IPred.SLT),+           ("sle", IPred.SLE)+          ]+         ] ++ [+          ("fcmp-" ++ ps,+           FCmp { fpPredicate = p, operand0 = a 1, operand1 = a 1, metadata = [] },+           "fcmp " ++ ps ++ " float %1, %1")+           | (ps, p) <- [+           ("false", FPPred.False),+           ("oeq", FPPred.OEQ),+           ("ogt", FPPred.OGT),+           ("oge", FPPred.OGE),+           ("olt", FPPred.OLT),+           ("ole", FPPred.OLE),+           ("one", FPPred.ONE),+           ("ord", FPPred.ORD),+           ("uno", FPPred.UNO),+           ("ueq", FPPred.UEQ),+           ("ugt", FPPred.UGT),+           ("uge", FPPred.UGE),+           ("ult", FPPred.ULT),+           ("ule", FPPred.ULE),+           ("une", FPPred.UNE),+           ("true", FPPred.True)+          ]+         ]+        ] ++ [+         ("store",+          Do $ Store {+            volatile = False,+            address = a 0,+            value = a 2,+            maybeAtomicity = Nothing,+            alignment = 0,+            metadata = [] +          },+          "store i32 %0, i32* %2"),+         ("fence",+          Do $ Fence {+            atomicity = Atomicity { crossThread = True, memoryOrdering = Acquire },+            metadata = [] +          },+          "fence acquire"),+          ("call",+           Do $ Call {+             isTailCall = False,+             callingConvention = CC.C,+             returnAttributes = [],+             function = Right (ConstantOperand (C.GlobalReference (UnName 0))),+             arguments = [ (LocalReference (UnName i), []) | i <- [0..6] ],+             functionAttributes = [],+             metadata = []+           },+           "call void @0(i32 %0, float %1, i32* %2, i64 %3, i1 %4, <2 x i32> %5, { i32, i32 } %6)")+        ]+      )+   ],+  testGroup "terminators" [+    testCase name $ strCheck mAST mStr+    | (name, mAST, mStr) <- [+     (+       "ret",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 0) [+           ] (+            Do $ Ret Nothing []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0() {\n\+       \  ret void\n\+       \}\n"+     ), (+       "br",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 0) [] (+            Do $ Br (Name "foo") []+           ),+          BasicBlock (Name "foo") [] (+            Do $ Ret Nothing []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0() {\n\+       \  br label %foo\n\+       \\n\+       \foo:                                              ; preds = %0\n\+       \  ret void\n\+       \}\n"+     ), (+       "condbr",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+             ],False) [] Nothing 0+         [+          BasicBlock (Name "bar") [] (+            Do $ CondBr (ConstantOperand (C.Int 1 1)) (Name "foo") (Name "bar") []+           ),+          BasicBlock (Name "foo") [] (+            Do $ Ret Nothing []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0() {\n\+       \bar:\n\+       \  br i1 true, label %foo, label %bar\n\+       \\n\+       \foo:                                              ; preds = %bar\n\+       \  ret void\n\+       \}\n"+     ), (+       "switch",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 0) [] (+            Do $ Switch {+              operand0' = ConstantOperand (C.Int 16 2),+              defaultDest = Name "foo",+              dests = [+               (C.Int 16 0, UnName 0),+               (C.Int 16 2, Name "foo"),+               (C.Int 16 3, UnName 0)+              ],+              metadata' = []+           }+          ),+          BasicBlock (Name "foo") [] (+            Do $ Ret Nothing []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0() {\n\+       \; <label>:0\n\+       \  switch i16 2, label %foo [\n\+       \    i16 0, label %0\n\+       \    i16 2, label %foo\n\+       \    i16 3, label %0\n\+       \  ]\n\+       \\n\+       \foo:                                              ; preds = %0, %0\n\+       \  ret void\n\+       \}\n"+     ), (+       "indirectbr",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ globalVariableDefaults {+          G.name = UnName 0,+          G.type' = PointerType (IntegerType 8) (AddrSpace 0),+          G.initializer = Just (C.BlockAddress (Name "foo") (UnName 2))+        },+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (Name "foo") ([+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 0) [+            UnName 1 := Load {+                     volatile = False,+                     address = ConstantOperand (C.GlobalReference (UnName 0)),+                     maybeAtomicity = Nothing,+                     alignment = 0,+                     metadata = [] +                   }+          ] (+            Do $ IndirectBr {+              operand0' = LocalReference (UnName 1),+              possibleDests = [UnName 2],+              metadata' = []+           }+          ),+          BasicBlock (UnName 2) [] (+            Do $ Ret Nothing []+           )+         ]+        ],+--       \  indirectbr i8* null, [label %foo]\n\+       "; ModuleID = '<string>'\n\+       \\n\+       \@0 = global i8* blockaddress(@foo, %2)\n\+       \\n\+       \define void @foo() {\n\+       \  %1 = load i8** @0\n\+       \  indirectbr i8* %1, [label %2]\n\+       \\n\+       \; <label>:2                                       ; preds = %0\n\+       \  ret void\n\+       \}\n"+     ), (+       "invoke",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+                  Parameter (IntegerType 32) (UnName 0) [],+                  Parameter (IntegerType 16) (UnName 1) []+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 2) [] (+            Do $ Invoke {+             callingConvention' = CC.C,+             returnAttributes' = [],+             function' = Right (ConstantOperand (C.GlobalReference (UnName 0))),+             arguments' = [+              (ConstantOperand (C.Int 32 4), []),+              (ConstantOperand (C.Int 16 8), [])+             ],+             functionAttributes' = [],+             returnDest = Name "foo",+             exceptionDest = Name "bar",+             metadata' = []+            }+           ),+          BasicBlock (Name "foo") [] (+            Do $ Ret Nothing []+           ),+          BasicBlock (Name "bar") [+           UnName 3 := LandingPad {+             type' = StructureType False [ +                PointerType (IntegerType 8) (AddrSpace 0),+                IntegerType 32+               ],+             personalityFunction = ConstantOperand (C.GlobalReference (UnName 0)),+             cleanup = True,+             clauses = [Catch (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))],+             metadata = []+           }+           ] (+            Do $ Ret Nothing []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0(i32, i16) {\n\+       \  invoke void @0(i32 4, i16 8)\n\+       \          to label %foo unwind label %bar\n\+       \\n\+       \foo:                                              ; preds = %2\n\+       \  ret void\n\+       \\n\+       \bar:                                              ; preds = %2\n\+       \  %3 = landingpad { i8*, i32 } personality void (i32, i16)* @0\n\+       \          cleanup\n\+       \          catch i8* null\n\+       \  ret void\n\+       \}\n"+     ), (+       "resume",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 0) [] (+            Do $ Resume (ConstantOperand (C.Int 32 1)) []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0() {\n\+       \  resume i32 1\n\+       \}\n"+     ), (+       "unreachable",+       Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (VoidType) (UnName 0) ([+             ],False) [] Nothing 0+         [+          BasicBlock (UnName 0) [] (+            Do $ Unreachable []+           )+         ]+        ],+       "; ModuleID = '<string>'\n\+       \\n\+       \define void @0() {\n\+       \  unreachable\n\+       \}\n"+     )+    ]+   ]+ ]
+ test/LLVM/General/Test/Metadata.hs view
@@ -0,0 +1,138 @@+module LLVM.General.Test.Metadata where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import LLVM.General.AST 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+import qualified LLVM.General.AST.Constant as C+import LLVM.General.AST.Global as G++tests = testGroup "Metadata" [+  testCase "local" $ do+    let ast = Module "<string>" Nothing Nothing [+         GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = IntegerType 32 },+         GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+            ],False)+          [] +          Nothing 0         +          [+           BasicBlock (UnName 0) [+              UnName 1 := Load {+                         volatile = False,+                         address = ConstantOperand (C.GlobalReference (UnName 0)),+                         maybeAtomicity = Nothing,+                         A.alignment = 0,+                         metadata = []+                       }+              ] (+              Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [+                (+                  "my-metadatum", +                  MetadataNode [+                   LocalReference (UnName 1),+                   MetadataStringOperand "super hyper"+                  ]+                )+              ]+            )+          ]+         ]+    let s = "; ModuleID = '<string>'\n\+            \\n\+            \@0 = external global i32\n\+            \\n\+            \define i32 @foo() {\n\+            \  %1 = load i32* @0\n\+            \  ret i32 0, !my-metadatum !{i32 %1, metadata !\"super hyper\"}\n\+            \}\n"+    strCheck ast s,++  testCase "global" $ do+    let ast = Module "<string>" Nothing Nothing [+         GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+            ],False)+          [] +          Nothing 0         +          [+           BasicBlock (UnName 0) [+              ] (+              Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [+                ("my-metadatum", MetadataNodeReference (MetadataNodeID 0))+              ]+            )+          ],+          MetadataNodeDefinition (MetadataNodeID 0) [ ConstantOperand (C.Int 32 1) ]+         ]+    let s = "; ModuleID = '<string>'\n\+            \\n\+            \define i32 @foo() {\n\+            \  ret i32 0, !my-metadatum !0\n\+            \}\n\+            \\n\+            \!0 = metadata !{i32 1}\n"+    strCheck ast s,++  testCase "named" $ do+    let ast = Module "<string>" Nothing Nothing [+          NamedMetadataDefinition "my-module-metadata" [MetadataNodeID 0],+          MetadataNodeDefinition (MetadataNodeID 0) [ ConstantOperand (C.Int 32 1) ]+         ]+    let s = "; ModuleID = '<string>'\n\+            \\n\+            \!my-module-metadata = !{!0}\n\+            \\n\+            \!0 = metadata !{i32 1}\n"+    strCheck ast s,++  testGroup "cyclic" [+    testCase "metadata-only" $ do+      let ast = Module "<string>" Nothing Nothing [+            NamedMetadataDefinition "my-module-metadata" [MetadataNodeID 0],+            MetadataNodeDefinition (MetadataNodeID 0) [+              MetadataNodeOperand (MetadataNodeReference (MetadataNodeID 1)) +             ],+            MetadataNodeDefinition (MetadataNodeID 1) [+              MetadataNodeOperand (MetadataNodeReference (MetadataNodeID 0)) +             ]+           ]+      let s = "; ModuleID = '<string>'\n\+              \\n\+              \!my-module-metadata = !{!0}\n\+              \\n\+              \!0 = metadata !{metadata !1}\n\+              \!1 = metadata !{metadata !0}\n"+      strCheck ast s,++    testCase "metadata-global" $ do+      let ast = Module "<string>" Nothing Nothing [+           GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([+              ],False)+            [] +            Nothing 0         +            [+             BasicBlock (UnName 0) [+              ] (+                Do $ Ret Nothing [ ("my-metadatum", MetadataNodeReference (MetadataNodeID 0)) ]+              )+            ],+            MetadataNodeDefinition (MetadataNodeID 0) [+              ConstantOperand (C.GlobalReference (Name "foo"))+             ]+           ]+      let s = "; ModuleID = '<string>'\n\+              \\n\+              \define void @foo() {\n\+              \  ret void, !my-metadatum !0\n\+              \}\n\+              \\n\+              \!0 = metadata !{void ()* @foo}\n"+      strCheck ast s+   ]++ ]
+ test/LLVM/General/Test/Module.hs view
@@ -0,0 +1,281 @@+module LLVM.General.Test.Module where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Data.Bits+import Data.Functor++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.Diagnostic+import LLVM.General.AST+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.IntegerPredicate as IPred++import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.Global as G+import qualified LLVM.General.AST.Constant as C++handString = "; ModuleID = '<string>'\n\+    \\n\+    \%0 = type { i32, %1*, %0* }\n\+    \%1 = type opaque\n\+    \\n\+    \@0 = global i32 1\n\+    \@1 = external protected addrspace(3) global i32, section \"foo\"\n\+    \@2 = unnamed_addr global i8 2\n\+    \@3 = external global %0\n\+    \@4 = external global [4294967296 x i32]\n\+    \@.argyle = thread_local global i32 0\n\+    \\n\+    \@three = alias private i32 addrspace(3)* @1\n\+    \@two = alias i32 addrspace(3)* @three\n\+    \\n\+    \define i32 @bar() {\n\+    \  %1 = call zeroext i32 @foo(i32 inreg 1, i8 signext 4) nounwind uwtable readnone\n\+    \  ret i32 %1\n\+    \}\n\+    \\n\+    \define zeroext i32 @foo(i32 inreg %x, i8 signext %y) nounwind uwtable readnone {\n\+    \  %1 = mul nsw i32 %x, %x\n\+    \  br label %here\n\+    \\n\+    \here:                                             ; preds = %0\n\+    \  %go = icmp eq i32 %1, %x\n\+    \  br i1 %go, label %there, label %elsewhere\n\+    \\n\+    \there:                                            ; preds = %here\n\+    \  %2 = add nsw i32 %1, 3\n\+    \  br label %elsewhere\n\+    \\n\+    \elsewhere:                                        ; preds = %there, %here\n\+    \  %r = phi i32 [ 2, %there ], [ 57, %here ]\n\+    \  ret i32 %r\n\+    \}\n"++handAST = Module "<string>" Nothing Nothing [+      TypeDefinition (UnName 0) (+         Just $ StructureType False [+           IntegerType 32,+           PointerType (NamedTypeReference (UnName 1)) (AddrSpace 0),+           PointerType (NamedTypeReference (UnName 0)) (AddrSpace 0)+          ]),+      TypeDefinition (UnName 1) Nothing,+      GlobalDefinition $ globalVariableDefaults {+        G.name = UnName 0,+        G.type' = IntegerType 32,+        G.initializer = Just (C.Int 32 1)+      },+      GlobalDefinition $ globalVariableDefaults {+        G.name = UnName 1,+        G.visibility = V.Protected,+        G.type' = IntegerType 32,+        G.addrSpace = AddrSpace 3,+        G.section = Just "foo"+      },+      GlobalDefinition $ globalVariableDefaults {+        G.name = UnName 2,+        G.hasUnnamedAddr = True,+        G.type' = IntegerType 8,+        G.initializer = Just (C.Int 8 2)+      },+      GlobalDefinition $ globalVariableDefaults {+        G.name = UnName 3,+        G.type' = NamedTypeReference (UnName 0)+      },+      GlobalDefinition $ globalVariableDefaults {+        G.name = UnName 4,+        G.type' = ArrayType (1 `shift` 32) (IntegerType 32)+      },+      GlobalDefinition $ globalVariableDefaults {+        G.name = Name ".argyle",+        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 (IntegerType 32) (AddrSpace 3),+        G.aliasee = C.GlobalReference (UnName 1)+      },+      GlobalDefinition $ globalAliasDefaults {+        G.name = Name "two",+        G.type' = PointerType (IntegerType 32) (AddrSpace 3),+        G.aliasee = C.GlobalReference (Name "three")+      },+      GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "bar") ([],False) [] Nothing 0 [+        BasicBlock (UnName 0) [+         UnName 1 := Call {+           isTailCall = False,+           callingConvention = CC.C,+           returnAttributes = [A.ZeroExt],+           function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+           arguments = [+            (ConstantOperand (C.Int 32 1), [A.InReg]),+            (ConstantOperand (C.Int 8 4), [A.SignExt])+           ],+           functionAttributes = [A.NoUnwind, A.ReadNone, A.UWTable],+           metadata = []+         }+       ] (+         Do $ Ret (Just (LocalReference (UnName 1))) []+       )+      ],+      GlobalDefinition $ Function L.External V.Default CC.C [A.ZeroExt] (IntegerType 32) (Name "foo") ([+          Parameter (IntegerType 32) (Name "x") [A.InReg],+          Parameter (IntegerType 8) (Name "y") [A.SignExt]+         ],False)+         [A.NoUnwind, A.ReadNone, A.UWTable] Nothing 0 +       [+        BasicBlock (UnName 0) [+         UnName 1 := Mul {+           nsw = True,+           nuw = False,+           operand0 = LocalReference (Name "x"),+           operand1 = LocalReference (Name "x"),+           metadata = []+         }+         ] (+           Do $ Br (Name "here") []+         ),+        BasicBlock (Name "here") [+         Name "go" := ICmp {+           iPredicate = IPred.EQ,+           operand0 = LocalReference (UnName 1),+           operand1 = LocalReference (Name "x"),+           metadata = []+         }+         ] (+            Do $ CondBr {+              condition = LocalReference (Name "go"),+              trueDest = Name "there",+              falseDest = Name "elsewhere",+              metadata' = []+            }+         ),+        BasicBlock (Name "there") [+         UnName 2 := Add {+           nsw = True,+           nuw = False,+           operand0 = LocalReference (UnName 1),+           operand1 = ConstantOperand (C.Int 32 3),+           metadata = []+         }+         ] (+           Do $ Br (Name "elsewhere") []+         ),+        BasicBlock (Name "elsewhere") [+         Name "r" := Phi {+           type' = IntegerType 32,+           incomingValues = [+             (ConstantOperand (C.Int 32 2), Name "there"),+             (ConstantOperand (C.Int 32 57), Name "here")+           ],+           metadata = []+         }+         ] (+           Do $ Ret (Just (LocalReference (Name "r"))) []+         )+       ]+      ]++tests = testGroup "Module" [+  testGroup "withModuleFromString" [+    testCase "basic" $ withContext $ \context -> do+      z <- withModuleFromString' context handString (const $ return 0)+      z @?= 0,+    testCase "numbering" $ withContext $ \context -> do+      let s = "@0 = global i32 3\+              \define i32 @1(i32 %x) {\n\+              \  %1 = mul i32 %x, %x\n\+              \  %2 = add i32 %1, 3\n\+              \  ret i32 %2\n\+              \}\n"+      z <- withModuleFromString' context s (const $ return 0)+      z @?= 0+   ],++  testCase "handStringIsCanonical" $ withContext $ \context -> do+    s <- withModuleFromString' context handString moduleString+    s @?= handString,++  testCase "moduleAST" $ withContext $ \context -> do+    ast <- withModuleFromString' context handString moduleAST+    ast @?= handAST,+    +  testCase "withModuleFromAST" $ withContext $ \context -> do+   s <- withModuleFromAST context handAST moduleString+   s @?= Right handString,++  testCase "triple" $ withContext $ \context -> do+   let hAST = "; ModuleID = '<string>'\n\+              \target triple = \"x86_64-unknown-linux\"\n"+   ast <- withModuleFromString' context hAST moduleAST+   ast @?= defaultModule { moduleTargetTriple = Just "x86_64-unknown-linux" },++  testGroup "regression" [+    testCase "set flag on constant expr" $ withContext $ \context -> do+      let ast = Module "<string>" Nothing Nothing [+           GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+               Parameter (IntegerType 32) (Name "x") []+              ],False)+              [] Nothing 0 +            [+             BasicBlock (UnName 0) [+              UnName 1 := Mul {+                nsw = True,+                nuw = False,+                operand0 = ConstantOperand (C.Int 32 1),+                operand1 = ConstantOperand (C.Int 32 1),+                metadata = []+              }+              ] (+                Do $ Br (Name "here") []+              ),+             BasicBlock (Name "here") [+              ] (+                Do $ Ret (Just (LocalReference (UnName 1))) []+              )+            ]+           ]+      t <- withModuleFromAST context ast $ \_ -> return True+      t @?= Right True+   ],++  testGroup "failures" [+    testCase "bad block reference" $ withContext $ \context -> do+      let badAST = Module "<string>" Nothing Nothing [+           GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+               Parameter (IntegerType 32) (Name "x") []+              ],False)+              [] Nothing 0 +            [+             BasicBlock (UnName 0) [+              UnName 1 := Mul {+                nsw = True,+                nuw = False,+                operand0 = ConstantOperand (C.Int 32 1),+                operand1 = ConstantOperand (C.Int 32 1),+                metadata = []+              }+              ] (+                Do $ Br (Name "not here") []+              ),+             BasicBlock (Name "here") [+              ] (+                Do $ Ret (Just (LocalReference (UnName 1))) []+              )+            ]+           ]+      t <- withModuleFromAST context badAST $ \_ -> return True+      t @?= Left "reference to undefined block: Name \"not here\""+   ]+ ]
+ test/LLVM/General/Test/Optimization.hs view
@@ -0,0 +1,327 @@+module LLVM.General.Test.Optimization where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import Data.Functor+import qualified Data.Map as Map++import LLVM.General.Module+import LLVM.General.Context+import LLVM.General.PassManager+import LLVM.General.Transforms+import LLVM.General.Target++import LLVM.General.AST as A+import LLVM.General.AST.Type+import LLVM.General.AST.Name+import LLVM.General.AST.AddrSpace+import LLVM.General.AST.DataLayout+import qualified LLVM.General.AST.IntegerPredicate as IPred+import qualified LLVM.General.AST.Linkage as L+import qualified LLVM.General.AST.Visibility as V+import qualified LLVM.General.AST.CallingConvention as CC+import qualified LLVM.General.AST.Attribute as A+import qualified LLVM.General.AST.Global as G+import qualified LLVM.General.AST.Constant as C++import qualified LLVM.General.Relocation as R+import qualified LLVM.General.CodeModel as CM+import qualified LLVM.General.CodeGenOpt as CGO++handAST = +  Module "<string>" Nothing Nothing [+      GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+          Parameter (IntegerType 32) (Name "x") []+         ],False)+        [A.NoUnwind, A.ReadNone, A.UWTable] +        Nothing 0+        [+        BasicBlock (UnName 0) [+         UnName 1 := Mul {+           nsw = False,+           nuw = False,+           operand0 = ConstantOperand (C.Int 32 6),+           operand1 = ConstantOperand (C.Int 32 7),+           metadata = []+         }+         ] (+           Do $ Br (Name "here") []+         ),+        BasicBlock (Name "here") [+         Name "go" := ICmp {+           iPredicate = IPred.EQ,+           operand0 = LocalReference (UnName 1),+           operand1 = ConstantOperand (C.Int 32 42),+           metadata = []+         }+         ] (+            Do $ CondBr {+              condition = LocalReference (Name "go"),+              trueDest = Name "take",+              falseDest = Name "done",+              metadata' = []+            }+         ),+        BasicBlock (Name "take") [+         UnName 2 := Sub {+           nsw = False,+           nuw = False,+           operand0 = LocalReference (Name "x"),+           operand1 = LocalReference (Name "x"),+           metadata = []+         }+         ] (+           Do $ Br (Name "done") []+         ),+        BasicBlock (Name "done") [+         Name "r" := Phi {+           type' = IntegerType 32,+           incomingValues = [+             (LocalReference (UnName 2), Name "take"),+             (ConstantOperand (C.Int 32 57), Name "here")+           ],+           metadata = []+         }+         ] (+           Do $ Ret (Just (LocalReference (Name "r"))) []+         )+       ]+      ]++optimize :: PassManagerSpecification s => s -> A.Module -> IO A.Module+optimize s m = do+  mOut <- withContext $ \context -> withModuleFromAST context m $ \mIn' -> do+                  withPassManager s $ \pm -> runPassManager pm mIn'+                  moduleAST mIn'+  either fail return mOut++tests = testGroup "Optimization" [+  testCase "curated" $ do+    mOut <- optimize defaultCuratedPassSetSpec handAST++    mOut @?= Module "<string>" Nothing Nothing [+      GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+          Parameter (IntegerType 32) (Name "x") []+         ],False)+       [A.NoUnwind, A.ReadNone, A.UWTable] +       Nothing 0         +       [+        BasicBlock (Name "here") [+           ] (+           Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []+         )+       ]+      ],++  testGroup "individual" [+    testCase "ConstantPropagation" $ do+      mOut <- optimize [ConstantPropagation] handAST++      mOut @?= Module "<string>" Nothing Nothing [+        GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+            Parameter (IntegerType 32) (Name "x") []+           ],False)+         [A.NoUnwind, A.ReadNone, A.UWTable] +         Nothing 0         +         [+          BasicBlock (UnName 0) [] (Do $ Br (Name "here") []),+          BasicBlock (Name "here") [] (+             Do $ CondBr {+               condition = ConstantOperand (C.Int 1 1),+               trueDest = Name "take", +               falseDest = Name "done",+               metadata' = []+             }+          ),+          BasicBlock (Name "take") [+           UnName 1 := Sub {+             nsw = False,+             nuw = False,+             operand0 = LocalReference (Name "x"),+             operand1 = LocalReference (Name "x"),+             metadata = []+            }+          ] (+           Do $ Br (Name "done") []+          ),+          BasicBlock (Name "done") [+           Name "r" := Phi {type' = IntegerType 32, incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")], metadata = []}+          ] (+            Do $ Ret (Just (LocalReference (Name "r"))) []+          )+         ]+        ],++    testCase "BasicBlockVectorization" $ do+      let+        mIn = Module "<string>" Nothing Nothing [+         GlobalDefinition $ Function L.External V.Default CC.C [] (FloatingPointType 64 IEEE) (Name "foo") ([+             Parameter (FloatingPointType 64 IEEE) (Name "a1") [],+             Parameter (FloatingPointType 64 IEEE) (Name "a2") [],+             Parameter (FloatingPointType 64 IEEE) (Name "b1") [],+             Parameter (FloatingPointType 64 IEEE) (Name "b2") []+            ],False)+          [] +          Nothing 0         +          [+           BasicBlock (UnName 0) [+             Name "x1" := FSub { +                        operand0 = LocalReference (Name "a1"), +                        operand1 = LocalReference (Name "b1"),+                        metadata = []+                      },+             Name "x2" := FSub { +                        operand0 = LocalReference (Name "a2"), +                        operand1 = LocalReference (Name "b2"),+                        metadata = []+                      },+             Name "y1" := FMul { +                        operand0 = LocalReference (Name "x1"), +                        operand1 = LocalReference (Name "a1"),+                        metadata = []+                      },+             Name "y2" := FMul { +                        operand0 = LocalReference (Name "x2"), +                        operand1 = LocalReference (Name "a2"),+                        metadata = []+                      },+             Name "z1" := FAdd { +                        operand0 = LocalReference (Name "y1"), +                        operand1 = LocalReference (Name "b1"),+                        metadata = []+                      },+             Name "z2" := FAdd { +                        operand0 = LocalReference (Name "y2"), +                        operand1 = LocalReference (Name "b2"),+                        metadata = []+                      },+             Name "r" := FMul {+                        operand0 = LocalReference (Name "z1"), +                        operand1 = LocalReference (Name "z2"),+                        metadata = []+                      }+           ] (Do $ Ret (Just (LocalReference (Name "r"))) [])+          ]+         ]+      mOut <- optimize [ +               defaultVectorizeBasicBlocks {+                 vectorizePointers = False,+                 requiredChainDepth = 3+               },+               InstructionCombining,+               GlobalValueNumbering False+              ] mIn+      mOut @?= Module "<string>" Nothing Nothing [+       GlobalDefinition $ Function +        L.External V.Default CC.C [] (FloatingPointType 64 IEEE) (Name "foo") ([+              Parameter (FloatingPointType 64 IEEE) (Name "a1") [],+              Parameter (FloatingPointType 64 IEEE) (Name "a2") [],+              Parameter (FloatingPointType 64 IEEE) (Name "b1") [],+              Parameter (FloatingPointType 64 IEEE) (Name "b2") []+             ],False)+             []+             Nothing 0+          [+           BasicBlock (UnName 0) [+             Name "x1.v.i1.1" := InsertElement {+               vector = ConstantOperand (C.Undef (VectorType 2 (FloatingPointType 64 IEEE))),+               element = LocalReference (Name "b1"),+               index = ConstantOperand (C.Int 32 0),+               metadata = []+              },+             Name "x1.v.i1.2" := InsertElement {+               vector = LocalReference (Name "x1.v.i1.1"),+               element = LocalReference (Name "b2"),+               index = ConstantOperand (C.Int 32 1),+               metadata = []+              },+             Name "x1.v.i0.1" := InsertElement {+               vector = ConstantOperand (C.Undef (VectorType 2 (FloatingPointType 64 IEEE))),+               element = LocalReference (Name "a1"),+               index = ConstantOperand (C.Int 32 0),+               metadata = []+              },+             Name "x1.v.i0.2" := InsertElement {+               vector = LocalReference (Name "x1.v.i0.1"),+               element = LocalReference (Name "a2"),+               index = ConstantOperand (C.Int 32 1),+               metadata = []+              },+             Name "x1" := FSub {+               operand0 = LocalReference (Name "x1.v.i0.2"),+               operand1 = LocalReference (Name "x1.v.i1.2"),+               metadata = []+              },+             Name "y1" := FMul {+               operand0 = LocalReference (Name "x1"),+               operand1 = LocalReference (Name "x1.v.i0.2"),+               metadata = []+              },+             Name "z1" := FAdd {+               operand0 = LocalReference (Name "y1"),+               operand1 = LocalReference (Name "x1.v.i1.2"),+               metadata = []+              },+             Name "z1.v.r1" := ExtractElement {+               vector = LocalReference (Name "z1"),+               index = ConstantOperand (C.Int 32 0),+               metadata = []+              },+             Name "z1.v.r2" := ExtractElement {+               vector = LocalReference (Name "z1"),+               index = ConstantOperand (C.Int 32 1),+               metadata = []+              },+             Name "r" := FMul {+               operand0 = LocalReference (Name "z1.v.r1"),+               operand1 = LocalReference (Name "z1.v.r2"),+               metadata = []+              }+            ] (+             Do $ Ret (Just (LocalReference (Name "r"))) []+            )+          ]+        ],+      +    testCase "LowerInvoke" $ do+      -- This test doesn't test much about what LowerInvoke does, just that it seems to work.+      -- The pass seems to be quite deeply dependent on weakly documented presumptions about+      -- how unwinding works (as is the invoke instruction)+      withContext $ \context -> do+        let triple = "x86_64-apple-darwin"+        Right (target, _) <- lookupTarget Nothing triple+        withTargetOptions $ \targetOptions -> do+          withTargetMachine target triple "" "" targetOptions+                            R.Default CM.Default CGO.Default $ \targetMachine -> do+            targetLowering <- getTargetLowering targetMachine+            withPassManager ([LowerInvoke False], targetLowering) $ \passManager -> do+              let astIn = +                    Module "<string>" Nothing Nothing [+                     GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+                           Parameter (IntegerType 32) (Name "x") []+                          ],False) [] Nothing 0 [+                            BasicBlock (Name "here") [+                            ] (+                              Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []+                            )+                          ]+                     ] +              Right astOut <- withModuleFromAST context astIn $ \mIn -> do+                runPassManager passManager mIn+                moduleAST mIn+              astOut @?= Module "<string>" Nothing Nothing [+                      GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([+                          Parameter (IntegerType 32) (Name "x") []+                        ],False) [] Nothing 0 [+                         BasicBlock (Name "here") [+                         ] (+                           Do $ Ret (Just (ConstantOperand (C.Int 32 0))) []+                         )+                        ],+                       GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "abort") ([],False)+                               [] Nothing 0 []+                      ]+   ]+ ]
+ test/LLVM/General/Test/Support.hs view
@@ -0,0 +1,27 @@+module LLVM.General.Test.Support where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import Data.Functor++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.Diagnostic++withModuleFromString' c s f  = do+  e <- withModuleFromString c s f+  case e of+    Right r -> return r+    Left d -> do+           let e = diagnosticDisplay d+           putStrLn e+           fail e++strCheck mAST mStr = withContext $ \context -> do+  a <- withModuleFromString' context mStr moduleAST+  s <- either error id <$> withModuleFromAST context mAST moduleString+  (a,s) @?= (mAST, mStr)++
+ test/LLVM/General/Test/Target.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE+  RecordWildCards+  #-}+module LLVM.General.Test.Target where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.QuickCheck.Property++import Control.Monad++import LLVM.General.Target+import LLVM.General.Target.Options++instance Arbitrary FloatABI where+  arbitrary = elements [minBound .. maxBound]++instance Arbitrary FloatingPointOperationFusionMode where+  arbitrary = elements [minBound .. maxBound]++instance Arbitrary Options where+  arbitrary = do+    printMachineCode <- arbitrary+    noFramePointerElimination <- arbitrary+    noFramePointerEliminationNonLeaf <- arbitrary+    lessPreciseFloatingPointMultiplyAddOption <- arbitrary+    unsafeFloatingPointMath <- arbitrary+    noInfinitiesFloatingPointMath <- arbitrary+    noNaNsFloatingPointMath <- arbitrary+    honorSignDependentRoundingFloatingPointMathOption <- arbitrary+    useSoftFloat <- arbitrary+    noZerosInBSS <- arbitrary+    jITExceptionHandling <- arbitrary+    jITEmitDebugInfo <- arbitrary+    jITEmitDebugInfoToDisk <- arbitrary+    guaranteedTailCallOptimization <- arbitrary+    disableTailCalls <- arbitrary+    realignStack <- arbitrary+    enableFastInstructionSelection <- arbitrary+    positionIndependentExecutable <- arbitrary+    enableSegmentedStacks <- arbitrary+    useInitArray <- arbitrary+    stackAlignmentOverride <- arbitrary+    trapFunctionName <- elements [ "foo", "bar", "baz" ]+    floatABIType <- arbitrary+    allowFloatingPointOperationFusion <- arbitrary+    stackSmashingProtectionBufferSize <- arbitrary+    return Options { .. }++tests = testGroup "Target" [+  testGroup "Options" [+     testGroup "regressions" [+       testCase "hurm" $ do+         withTargetOptions $ \to -> do+           let o = Options {printMachineCode = True, noFramePointerElimination = False, noFramePointerEliminationNonLeaf = True, lessPreciseFloatingPointMultiplyAddOption = True, unsafeFloatingPointMath = True, noInfinitiesFloatingPointMath = True, noNaNsFloatingPointMath = False, honorSignDependentRoundingFloatingPointMathOption = True, useSoftFloat = True, noZerosInBSS = False, jITExceptionHandling = True, jITEmitDebugInfo = True, jITEmitDebugInfoToDisk = False, guaranteedTailCallOptimization = False, disableTailCalls = False, realignStack = False, enableFastInstructionSelection = True, positionIndependentExecutable = True, enableSegmentedStacks = False, useInitArray = True, stackAlignmentOverride = 9432851444, trapFunctionName = "baz", floatABIType = FloatABISoft, allowFloatingPointOperationFusion = FloatingPointOperationFusionStrict, stackSmashingProtectionBufferSize = 2650013862}+           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'+   ]+ ]
+ test/LLVM/General/Test/Tests.hs view
@@ -0,0 +1,28 @@+module LLVM.General.Test.Tests where++import Test.Framework++import qualified LLVM.General.Test.Constants as Constants+import qualified LLVM.General.Test.DataLayout as DataLayout+import qualified LLVM.General.Test.ExecutionEngine as ExecutionEngine+import qualified LLVM.General.Test.Global as Global+import qualified LLVM.General.Test.InlineAssembly as InlineAssembly+import qualified LLVM.General.Test.Instructions as Instructions+import qualified LLVM.General.Test.Metadata as Metadata+import qualified LLVM.General.Test.Module as Module+import qualified LLVM.General.Test.Optimization as Optimization+import qualified LLVM.General.Test.Target as Target+++tests = testGroup "llvm-general" [+    Constants.tests,+    DataLayout.tests,+    ExecutionEngine.tests,+    Global.tests,+    InlineAssembly.tests,+    Instructions.tests,+    Metadata.tests,+    Module.tests,+    Optimization.tests,+    Target.tests+  ]
+ test/Test.hs view
@@ -0,0 +1,6 @@+import Test.Framework+import qualified LLVM.General.Test.Tests as LLVM.General++main = defaultMain [+        LLVM.General.tests+  ]