llvm-general 3.3.13.0 → 3.3.13.1

raw patch · 21 files changed

+227/−114 lines, 21 filesdep ~llvm-generaldep ~mtldep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: llvm-general, mtl, transformers

API changes (from Hackage documentation)

Files

• llvm-general.cabal +8/−8
• src/Control/Monad/AnyCont/Class.hs +6/−6
• src/LLVM/General/Internal/Analysis.hs +3/−3
• src/LLVM/General/Internal/Context.hs +4/−1
• src/LLVM/General/Internal/DataLayout.hs +1/−1
• src/LLVM/General/Internal/EncodeAST.hs +16/−14
• src/LLVM/General/Internal/ExecutionEngine.hs +7/−5
• src/LLVM/General/Internal/Inject.hs +9/−0
• src/LLVM/General/Internal/Instruction.hs +3/−3
• src/LLVM/General/Internal/MemoryBuffer.hs +7/−4
• src/LLVM/General/Internal/Module.hs +29/−25
• src/LLVM/General/Internal/RawOStream.hs +13/−10
• src/LLVM/General/Internal/Target.hs +7/−7
• src/LLVM/General/Internal/Type.hs +2/−1
• test/LLVM/General/Test/Analysis.hs +5/−5
• test/LLVM/General/Test/DataLayout.hs +94/−0
• test/LLVM/General/Test/Instrumentation.hs +3/−3
• test/LLVM/General/Test/Linking.hs +2/−2
• test/LLVM/General/Test/Module.hs +4/−4
• test/LLVM/General/Test/Support.hs +3/−3
• test/LLVM/General/Test/Target.hs +1/−9

@@ -1,5 +1,5 @@ name: llvm-general-version: 3.3.13.0+version: 3.3.13.1 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net>@@ -15,8 +15,6 @@ 	it uses an ADT to represent LLVM IR (<http://llvm.org/docs/LangRef.html>), and so offers two advantages: it 	handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not 	only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell.-  .-  For haddock, see <http://bscarlet.github.io/llvm-general/3.3.13.0/doc/html/llvm-general/index.html>. extra-source-files:   src/LLVM/General/Internal/FFI/Analysis.h   src/LLVM/General/Internal/FFI/BinaryOperator.h@@ -40,7 +38,7 @@   type: git   location: git://github.com/bscarlet/llvm-general.git   branch: llvm-3.3-  tag: v3.3.13.0+  tag: llvm-general-v3.3.13.1  flag shared-llvm   description: link against llvm shared rather than static library@@ -57,8 +55,8 @@     base >= 4.5.0.0 && < 5,     utf8-string >= 0.3.7,     bytestring >= 0.9.1.10,-    transformers >= 0.3.0.0,-    mtl >= 2.0.1.0,+    transformers >= 0.4.0.0,+    mtl >= 2.2.1,     template-haskell >= 2.5.0.0,     containers >= 0.4.2.1,     parsec >= 3.1.3,@@ -115,6 +113,7 @@     LLVM.General.Internal.FloatingPointPredicate     LLVM.General.Internal.Function     LLVM.General.Internal.Global+    LLVM.General.Internal.Inject     LLVM.General.Internal.InlineAssembly     LLVM.General.Internal.Instruction     LLVM.General.Internal.InstructionDefs@@ -202,10 +201,10 @@     HUnit >= 1.2.4.2,     test-framework-quickcheck2 >= 0.3.0.1,     QuickCheck >= 2.5.1.1,-    llvm-general == 3.3.13.0,+    llvm-general == 3.3.13.1,     llvm-general-pure == 3.3.13.0,     containers >= 0.4.2.1,-    mtl >= 2.0.1.0+    mtl >= 2.2.1   hs-source-dirs: test   extensions:     TupleSections@@ -215,6 +214,7 @@   other-modules:     LLVM.General.Test.Analysis     LLVM.General.Test.Constants+    LLVM.General.Test.DataLayout     LLVM.General.Test.ExecutionEngine     LLVM.General.Test.Global     LLVM.General.Test.InlineAssembly

@@ -8,7 +8,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.AnyCont (AnyContT) import qualified Control.Monad.Trans.AnyCont as AnyCont-import Control.Monad.Trans.Error as Error+import Control.Monad.Trans.Except as Except import Control.Monad.Trans.State as State  class ScopeAnyCont m where@@ -32,11 +32,11 @@   scopeAnyCont = StateT . (scopeAnyCont .) . runStateT  -instance (Error e, Monad m, MonadAnyCont b m) => MonadAnyCont b (ErrorT e m) where+instance (Monad m, MonadAnyCont b m) => MonadAnyCont b (ExceptT e m) where   anyContToM x = lift $ anyContToM x -instance ScopeAnyCont m => ScopeAnyCont (ErrorT e m) where-  scopeAnyCont = mapErrorT scopeAnyCont+instance ScopeAnyCont m => ScopeAnyCont (ExceptT e m) where+  scopeAnyCont = mapExceptT scopeAnyCont   @@ -50,5 +50,5 @@ instance MonadTransAnyCont b m => MonadTransAnyCont b (StateT s m) where   liftAnyCont c = (\c q -> StateT $ \s -> c $ ($ s) . runStateT . q) (liftAnyCont c) -instance MonadTransAnyCont b m => MonadTransAnyCont b (ErrorT e m) where-  liftAnyCont c = (\c q -> ErrorT . c $ runErrorT . q) (liftAnyCont c)+instance MonadTransAnyCont b m => MonadTransAnyCont b (ExceptT e m) where+  liftAnyCont c = (\c q -> ExceptT . c $ runExceptT . q) (liftAnyCont c)

@@ -1,6 +1,6 @@ module LLVM.General.Internal.Analysis where -import Control.Monad.Error+import Control.Monad.Except import Control.Monad.AnyCont  import qualified LLVM.General.Internal.FFI.Analysis as FFI@@ -11,9 +11,9 @@  -- | Run basic sanity checks on a 'Module'. Note that the same checks will trigger assertions -- within LLVM if LLVM was built with them turned on, before this function can be is called.-verify :: Module -> ErrorT String IO ()+verify :: Module -> ExceptT String IO () verify (Module m) = flip runAnyContT return $ do   errorPtr <- alloca   result <- decodeM =<< (liftIO $ FFI.verifyModule m FFI.verifierFailureActionReturnStatus errorPtr)-  when result $ fail =<< decodeM errorPtr+  when result $ throwError =<< decodeM errorPtr 

@@ -2,6 +2,8 @@  import Control.Exception +import Control.Concurrent+ import Foreign.Ptr  import qualified LLVM.General.Internal.FFI.Context as FFI@@ -13,4 +15,5 @@  -- | Create a Context, run an action (to which it is provided), then destroy the Context. withContext :: (Context -> IO a) -> IO a-withContext = bracket FFI.contextCreate FFI.contextDispose . (. Context)+withContext = runBound . bracket FFI.contextCreate FFI.contextDispose . (. Context)+  where runBound = if rtsSupportsBoundThreads then runInBoundThread else id

@@ -1,6 +1,6 @@ module LLVM.General.Internal.DataLayout where -import Control.Monad.Error+import Control.Monad.Except import Control.Monad.AnyCont import Control.Exception 

@@ -5,9 +5,10 @@   #-} module LLVM.General.Internal.EncodeAST where +import Control.Applicative import Control.Exception import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.AnyCont  import Foreign.Ptr@@ -41,9 +42,10 @@       encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type)     } -newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ErrorT String (StateT EncodeState IO)) a }+newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ExceptT String (StateT EncodeState IO)) a }     deriving (        Functor,+       Applicative,        Monad,        MonadIO,        MonadState EncodeState,@@ -55,13 +57,13 @@ lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) lookupNamedType n = do   t <- gets $ Map.lookup n . encodeStateNamedTypes-  maybe (fail $ "reference to undefined type: " ++ show n) return t+  maybe (throwError $ "reference to undefined type: " ++ show n) return t  defineType :: A.Name -> Ptr FFI.Type -> EncodeAST () defineType n t = modify $ \s -> s { encodeStateNamedTypes = Map.insert n t (encodeStateNamedTypes s) } -runEncodeAST :: Context -> EncodeAST a -> ErrorT String IO a-runEncodeAST context@(Context ctx) (EncodeAST a) = ErrorT $ +runEncodeAST :: Context -> EncodeAST a -> ExceptT String IO a+runEncodeAST context@(Context ctx) (EncodeAST a) = ExceptT $      bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do       let initEncodeState = EncodeState {                encodeStateBuilder = builder,@@ -73,7 +75,7 @@               encodeStateMDNodes = Map.empty,               encodeStateNamedTypes = Map.empty             }-      flip evalStateT initEncodeState . runErrorT . flip runAnyContT return $ a+      flip evalStateT initEncodeState . runExceptT . flip runAnyContT return $ a  withName :: A.Name -> (CString -> IO a) -> IO a withName (A.Name n) = withCString n@@ -117,14 +119,14 @@   mop <- gets $ Map.lookup n . r   maybe f return mop -failAsUndefined :: Show n => String -> n -> EncodeAST a-failAsUndefined m n = fail $ "reference to undefined " ++ m ++ ": " ++ show n+undefinedReference :: Show n => String -> n -> EncodeAST a+undefinedReference m n = throwError $ "reference to undefined " ++ m ++ ": " ++ show n -referOrFail :: (Show n, Ord n) => (EncodeState -> Map n (Ptr p)) -> String -> n -> EncodeAST (Ptr p)-referOrFail r m n = refer r n $ failAsUndefined m n+referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n (Ptr p)) -> String -> n -> EncodeAST (Ptr p)+referOrThrow r m n = refer r n $ undefinedReference m n -referGlobal = referOrFail encodeStateGlobals "global"-referMDNode = referOrFail encodeStateMDNodes "metadata node"+referGlobal = referOrThrow encodeStateGlobals "global"+referMDNode = referOrThrow encodeStateMDNodes "metadata node"  defineBasicBlock :: A.Name -> A.Name -> Ptr FFI.BasicBlock -> EncodeAST () defineBasicBlock fn n b = modify $ \s -> s {@@ -133,8 +135,8 @@ }  instance EncodeM EncodeAST A.Name (Ptr FFI.BasicBlock) where-  encodeM = referOrFail encodeStateBlocks "block"+  encodeM = referOrThrow encodeStateBlocks "block"  getBlockForAddress :: A.Name -> A.Name -> EncodeAST (Ptr FFI.BasicBlock)-getBlockForAddress fn n = referOrFail encodeStateAllBlocks "blockaddress" (fn, n)+getBlockForAddress fn n = referOrThrow encodeStateAllBlocks "blockaddress" (fn, n) 

@@ -9,7 +9,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.AnyCont-import Control.Monad.Error+import Control.Monad.Except  import Data.Word import Data.IORef@@ -68,7 +68,7 @@   liftIO initializeNativeTarget   outExecutionEngine <- alloca   outErrorCStringPtr <- alloca-  Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runErrorT+  Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runExceptT                                    . withModuleFromAST c (A.Module "" Nothing Nothing []))                         (return . Module) m   r <- liftIO $ createEngine outExecutionEngine dummyModule outErrorCStringPtr@@ -86,9 +86,10 @@   -> Word -- ^ optimization level   -> (JIT -> IO a)   -> IO a-withJIT c opt = -    withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))-    . (. JIT)+withJIT c opt f = FFI.linkInJIT >> withJIT' f+  where withJIT' =+         withExecutionEngine c Nothing (\e m -> FFI.createJITCompilerForModule e m (fromIntegral opt))+         . (. JIT)  instance ExecutionEngine JIT (FunPtr ()) where   withModuleInEngine (JIT e) m f = withModuleInEngine e m (\(ExecutableModule e m) -> f (ExecutableModule (JIT e) m))@@ -116,6 +117,7 @@   -> (MCJIT -> IO a)   -> IO a withMCJIT c opt cm fpe fisel f = do+  FFI.linkInMCJIT   let createMCJITCompilerForModule e m s = do         size <- FFI.getMCJITCompilerOptionsSize         allocaBytes (fromIntegral size) $ \p -> do

@@ -0,0 +1,9 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.General.Internal.Inject where++class Inject a b where+  inject :: a -> b++instance Inject a a where+  inject = id+

@@ -14,7 +14,7 @@  import Data.Functor import Control.Monad-import Control.Monad.Trans+import Control.Monad.Except import Control.Monad.AnyCont import Control.Monad.State @@ -451,12 +451,12 @@                 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+                  when isArray $ throwError $ "Catch clause cannot take an array: " ++ show c                   liftIO $ FFI.addClause i cn                 A.Filter a -> do                   cn <- encodeM a                   isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)-                  unless isArray $ fail $ "filter clause must take an array: " ++ show c+                  unless isArray $ throwError $ "filter clause must take an array: " ++ show c                   liftIO $ FFI.addClause i cn             when cl $ do               cl <- encodeM cl

@@ -6,14 +6,15 @@  import Control.Exception import Control.Monad+import Control.Monad.Except import Control.Monad.AnyCont-import Control.Monad.IO.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Foreign.Ptr  import LLVM.General.Internal.Coding import LLVM.General.Internal.String+import LLVM.General.Internal.Inject import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.General.Internal.FFI.MemoryBuffer as FFI @@ -21,7 +22,7 @@   = Bytes { name :: String,  content :: BS.ByteString }   | File { pathName :: String } -instance (Monad e, MonadIO e, MonadAnyCont IO e) => EncodeM e Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where+instance (Inject String e, MonadError e m, Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where   encodeM spec = liftM FFI.OwnerTransfered $ do     case spec of       Bytes name content -> do@@ -34,10 +35,12 @@         mbPtr <- alloca         msgPtr <- alloca         result <- decodeM =<< (liftIO $ FFI.createMemoryBufferWithContentsOfFile pathName mbPtr msgPtr)-        when result $ fail =<< decodeM msgPtr+        when result $ do+          msg <- decodeM msgPtr+          throwError (inject (msg :: String))         peek mbPtr           -instance (Monad e, MonadIO e, MonadAnyCont IO e) => EncodeM e Specification (Ptr FFI.MemoryBuffer) where+instance (Inject String e, MonadError e m, Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (Ptr FFI.MemoryBuffer) where   encodeM spec = do     FFI.OwnerTransfered mb <- encodeM spec     anyContToM $ bracket (return mb) FFI.disposeMemoryBuffer

@@ -9,7 +9,7 @@  import Control.Monad.Trans import Control.Monad.State-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.AnyCont import Control.Applicative import Control.Exception@@ -45,6 +45,7 @@ import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Function import LLVM.General.Internal.Global+import LLVM.General.Internal.Inject import LLVM.General.Internal.Instruction () import qualified LLVM.General.Internal.MemoryBuffer as MB  import LLVM.General.Internal.Metadata@@ -70,8 +71,8 @@ newtype File = File FilePath   deriving (Eq, Ord, Read, Show) -instance Error (Either String Diagnostic) where-    strMsg = Left+instance Inject String (Either String Diagnostic) where+    inject = Left  genCodingInstance [t| Bool |] ''FFI.LinkerMode [   (FFI.linkerModeDestroySource, False),@@ -86,15 +87,16 @@   Bool -- ^ True to leave the right module unmodified, False to cannibalize it (for efficiency's sake).   -> Module -- ^ The module into which to link   -> Module -- ^ The module to link into the other (and cannibalize or not)-  -> ErrorT String IO ()+  -> ExceptT String IO () linkModules preserveRight (Module m) (Module m') = flip runAnyContT return $ do   preserveRight <- encodeM preserveRight   msgPtr <- alloca   result <- decodeM =<< (liftIO $ FFI.linkModules m m' preserveRight msgPtr)-  when result $ fail =<< decodeM msgPtr+  when result $ throwError =<< decodeM msgPtr  class LLVMAssemblyInput s where-  llvmAssemblyMemoryBuffer :: (MonadIO e, MonadAnyCont IO e) => s -> e (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer))+  llvmAssemblyMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)+                              => s -> m (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer))  instance LLVMAssemblyInput (String, String) where   llvmAssemblyMemoryBuffer (id, s) = do@@ -108,7 +110,8 @@   llvmAssemblyMemoryBuffer (File p) = encodeM (MB.File p)  -- | parse 'Module' from LLVM assembly-withModuleFromLLVMAssembly :: LLVMAssemblyInput s => Context -> s -> (Module -> IO a) -> ErrorT (Either String Diagnostic) IO a+withModuleFromLLVMAssembly :: LLVMAssemblyInput s+                              => Context -> s -> (Module -> IO a) -> ExceptT (Either String Diagnostic) IO a withModuleFromLLVMAssembly (Context c) s f = flip runAnyContT return $ do   mb <- llvmAssemblyMemoryBuffer s   smDiag <- anyContToM withSMDiagnostic@@ -129,12 +132,13 @@   return s  -- | write LLVM assembly for a 'Module' to a file-writeLLVMAssemblyToFile :: File -> Module -> ErrorT String IO ()+writeLLVMAssemblyToFile :: File -> Module -> ExceptT String IO () writeLLVMAssemblyToFile (File path) (Module m) = flip runAnyContT return $ do   withFileRawOStream path False False $ liftIO . FFI.writeLLVMAssembly m  class BitcodeInput b where-  bitcodeMemoryBuffer :: (MonadIO e, MonadAnyCont IO e) => b -> e (Ptr FFI.MemoryBuffer)+  bitcodeMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)+                         => b -> m (Ptr FFI.MemoryBuffer)  instance BitcodeInput (String, BS.ByteString) where   bitcodeMemoryBuffer (s, bs) = encodeM (MB.Bytes s bs)@@ -143,51 +147,53 @@   bitcodeMemoryBuffer (File p) = encodeM (MB.File p)  -- | parse 'Module' from LLVM bitcode-withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ErrorT String IO a+withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ExceptT String IO a withModuleFromBitcode (Context c) b f = flip runAnyContT return $ do   mb <- bitcodeMemoryBuffer b   msgPtr <- alloca   m <- anyContToM $ bracket (FFI.parseBitcode c mb msgPtr) FFI.disposeModule-  when (m == nullPtr) $ fail =<< decodeM msgPtr+  when (m == nullPtr) $ throwError =<< decodeM msgPtr   liftIO $ f (Module m)  -- | generate LLVM bitcode from a 'Module' moduleBitcode :: Module -> IO BS.ByteString-moduleBitcode (Module m) = withBufferRawOStream (liftIO . FFI.writeBitcode m)+moduleBitcode (Module m) = do+  r <- runExceptT $ withBufferRawOStream (liftIO . FFI.writeBitcode m)+  either fail return r  -- | write LLVM bitcode from a 'Module' into a file-writeBitcodeToFile :: File -> Module -> ErrorT String IO ()+writeBitcodeToFile :: File -> Module -> ExceptT String IO () writeBitcodeToFile (File path) (Module m) = flip runAnyContT return $ do   withFileRawOStream path False True $ liftIO . FFI.writeBitcode m -targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ErrorT String IO ()+targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawOStream -> ExceptT String IO () targetMachineEmit fileType (TargetMachine tm) (Module m) os = flip runAnyContT return $ do   msgPtr <- alloca   r <- decodeM =<< (liftIO $ FFI.targetMachineEmit tm m fileType msgPtr os)-  when r $ fail =<< decodeM msgPtr+  when r $ throwError =<< decodeM msgPtr -emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ErrorT String IO ()+emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ExceptT String IO () emitToFile fileType tm (File path) m = flip runAnyContT return $ do   withFileRawOStream path False True $ targetMachineEmit fileType tm m -emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ErrorT String IO BS.ByteString+emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ExceptT String IO BS.ByteString emitToByteString fileType tm m = flip runAnyContT return $ do   withBufferRawOStream $ targetMachineEmit fileType tm m  -- | write target-specific assembly directly into a file-writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ErrorT String IO ()+writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ExceptT String IO () writeTargetAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly  -- | produce target-specific assembly as a 'String'-moduleTargetAssembly :: TargetMachine -> Module -> ErrorT String IO String+moduleTargetAssembly :: TargetMachine -> Module -> ExceptT String IO String moduleTargetAssembly tm m = decodeM . UTF8ByteString =<< emitToByteString FFI.codeGenFileTypeAssembly tm m  -- | produce target-specific object code as a 'ByteString'-moduleObject :: TargetMachine -> Module -> ErrorT String IO BS.ByteString+moduleObject :: TargetMachine -> Module -> ExceptT String IO BS.ByteString moduleObject = emitToByteString FFI.codeGenFileTypeObject  -- | write target-specific object code directly into a file-writeObjectToFile :: TargetMachine -> File -> Module -> ErrorT String IO ()+writeObjectToFile :: TargetMachine -> File -> Module -> ExceptT String IO () writeObjectToFile = emitToFile FFI.codeGenFileTypeObject  setTargetTriple :: Ptr FFI.Module -> String -> EncodeAST ()@@ -208,11 +214,9 @@ getDataLayout :: Ptr FFI.Module -> IO (Maybe A.DataLayout) getDataLayout m = parseDataLayout <$> (decodeM =<< FFI.getDataLayout m) -type P a = a -> a- -- | Build an LLVM.General.'Module' from a LLVM.General.AST.'LLVM.General.AST.Module' - i.e. -- lower an AST from Haskell into C++ objects.-withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> ErrorT String IO a+withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> ExceptT String IO a withModuleFromAST context@(Context c) (A.Module moduleId dataLayout triple definitions) f = runEncodeAST context $ do   moduleId <- encodeM moduleId   m <- anyContToM $ bracket (FFI.moduleCreateWithNameInContext moduleId c) FFI.disposeModule@@ -317,7 +321,7 @@              return (sequence_ finishes)            sequence_ finishInstrs            locals <- gets $ Map.toList . encodeStateLocals-           forM [ n | (n, ForwardValue _) <- locals ] $ \n -> failAsUndefined "local" n+           forM [ n | (n, ForwardValue _) <- locals ] $ \n -> undefinedReference "local" n            return (FFI.upCast f)      return $ do        g' <- eg'

@@ -1,7 +1,7 @@ module LLVM.General.Internal.RawOStream where  import Control.Monad-import Control.Monad.Error+import Control.Monad.Except import Control.Monad.AnyCont  import Data.IORef@@ -11,14 +11,15 @@ import qualified  LLVM.General.Internal.FFI.RawOStream as FFI  import LLVM.General.Internal.Coding+import LLVM.General.Internal.Inject import LLVM.General.Internal.String ()  withFileRawOStream :: -  (MonadAnyCont IO m, MonadIO m) +  (Inject String e, MonadError e m, MonadAnyCont IO m, MonadIO m)    => String   -> Bool   -> Bool-  -> (Ptr FFI.RawOStream -> ErrorT String IO ())+  -> (Ptr FFI.RawOStream -> ExceptT String IO ())   -> m () withFileRawOStream path excl binary c = do   path <- encodeM path@@ -27,15 +28,17 @@   msgPtr <- alloca   errorRef <- liftIO $ newIORef undefined   succeeded <- decodeM =<< (liftIO $ FFI.withFileRawOStream path excl binary msgPtr $ \os -> do-                              r <- runErrorT (c os)+                              r <- runExceptT (c os)                               writeIORef errorRef r)-  unless succeeded $ fail =<< decodeM msgPtr+  unless succeeded $ do+    s <- decodeM msgPtr+    throwError $ inject (s :: String)   e <- liftIO $ readIORef errorRef-  either fail return e+  either (throwError . inject) return e  withBufferRawOStream :: -  (MonadIO m, DecodeM IO a (Ptr CChar, CSize))-  => (Ptr FFI.RawOStream -> ErrorT String IO ())+  (Inject String e, MonadError e m, MonadIO m, DecodeM IO a (Ptr CChar, CSize))+  => (Ptr FFI.RawOStream -> ExceptT String IO ())   -> m a withBufferRawOStream c = do   resultRef <- liftIO $ newIORef Nothing@@ -45,12 +48,12 @@         r <- decodeM (start, size)         writeIORef resultRef (Just r)       saveError os = do-        r <- runErrorT (c os)+        r <- runExceptT (c os)         writeIORef errorRef r   liftIO $ FFI.withBufferRawOStream saveBuffer saveError   e <- liftIO $ readIORef errorRef   case e of-    Left e -> fail e+    Left e -> throwError $ inject e     _ -> do       Just r <- liftIO $ readIORef resultRef       return r

@@ -7,12 +7,11 @@ module LLVM.General.Internal.Target where  import Control.Monad hiding (forM)-import Control.Monad.Error hiding (forM)+import Control.Monad.Except hiding (forM) import Control.Exception import Data.Functor import Data.Traversable (forM) import Control.Monad.AnyCont-import Data.Maybe  import Foreign.Ptr import Data.List (intercalate)@@ -88,14 +87,14 @@ lookupTarget ::    Maybe String -- ^ arch   -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu-  -> ErrorT String IO (Target, String)+  -> ExceptT String IO (Target, String) lookupTarget arch triple = flip runAnyContT return $ do   cErrorP <- alloca   cNewTripleP <- alloca   arch <- encodeM (maybe "" id arch)   triple <- encodeM triple   target <- liftIO $ FFI.lookupTarget arch triple cNewTripleP cErrorP-  when (target == nullPtr) $ fail =<< decodeM cErrorP+  when (target == nullPtr) $ throwError =<< decodeM cErrorP   liftM (Target target, ) $ decodeM cNewTripleP  -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>@@ -266,15 +265,16 @@    -- | 'DataLayout' to use for the given 'TargetMachine' getTargetMachineDataLayout :: TargetMachine -> IO DataLayout-getTargetMachineDataLayout (TargetMachine m) =-    fromMaybe (error "parseDataLayout failed") . parseDataLayout <$> (decodeM =<< (FFI.getTargetMachineDataLayout m))+getTargetMachineDataLayout (TargetMachine m) = do+  dl <- decodeM =<< FFI.getTargetMachineDataLayout m+  maybe (fail "parseDataLayout failed") return $ parseDataLayout dl  -- | Initialize all targets so they can be found by 'lookupTarget' initializeAllTargets :: IO () initializeAllTargets = FFI.initializeAllTargets  -- | Bracket creation and destruction of a 'TargetMachine' configured for the host-withDefaultTargetMachine :: (TargetMachine -> IO a) -> ErrorT String IO a+withDefaultTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a withDefaultTargetMachine f = do   liftIO $ initializeAllTargets   triple <- liftIO $ getDefaultTargetTriple

@@ -7,6 +7,7 @@ import Control.Applicative import Control.Monad.State import Control.Monad.AnyCont+import Control.Monad.Except  import qualified Data.Set as Set @@ -85,7 +86,7 @@       A.FloatingPointType 80 A.DoubleExtended -> liftIO $ FFI.x86FP80TypeInContext context       A.FloatingPointType 128 A.IEEE -> liftIO $ FFI.fP128TypeInContext context       A.FloatingPointType 128 A.PairOfFloats -> liftIO $ FFI.ppcFP128TypeInContext context-      A.FloatingPointType _ _ -> fail $ "unsupported floating point type: " ++ show f+      A.FloatingPointType _ _ -> throwError $ "unsupported floating point type: " ++ show f       A.VectorType sz e -> do         e <- encodeM e         sz <- encodeM sz

@@ -6,7 +6,7 @@  import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Except  import LLVM.General.Module import LLVM.General.Context@@ -39,14 +39,14 @@                 Parameter i32 (Name "x") []                ],False)              [] -             Nothing 0         +             Nothing 0 Nothing                       [               BasicBlock (UnName 0) [                 UnName 1 := Call {                   isTailCall = False,                   callingConvention = CC.C,                   returnAttributes = [],-                  function = Right (ConstantOperand (C.GlobalReference (Name "foo"))),+                  function = Right (ConstantOperand (C.GlobalReference (A.T.FunctionType A.T.void [A.T.i32] False) (Name "foo"))),                   arguments = [                    (ConstantOperand (C.Int 8 1), [])                   ],@@ -58,7 +58,7 @@               )              ]             ]-      Left s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify+      Left s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify       s @?= "Call parameter type does not match function signature!\n\             \i8 1\n\             \ i32  call void @foo(i8 1)\n\@@ -106,7 +106,7 @@                 }               ]        strCheck ast str-       s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify+       s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify        s @?= Right ()      ]    ]

@@ -0,0 +1,94 @@+module LLVM.General.Test.DataLayout where++import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++import LLVM.General.Test.Support++import Data.Maybe+import qualified Data.Set as Set+import qualified Data.Map as Map++import LLVM.General.Context+import LLVM.General.Module+import LLVM.General.AST+import LLVM.General.AST.DataLayout+import LLVM.General.AST.AddrSpace+import qualified LLVM.General.AST.Global as G++m s = "; ModuleID = '<string>'\n" ++ s+t s = "target datalayout = \"" ++ s ++ "\"\n"++tests = testGroup "DataLayout" [+  testCase name $ strCheckC (Module "<string>" mdl Nothing []) (m sdl) (m sdlc)+  | (name, mdl, sdl, sdlc) <- [+   ("none", Nothing, "", "")+  ] ++ [+   (name, Just mdl, t sdl, t (fromMaybe sdl msdlc))+   | (name, mdl, sdl, msdlc) <- [+    ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e", Nothing),+    ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E", Nothing),+    ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32", Nothing),+    (+     "no pref",+     defaultDataLayout {+       pointerLayouts = +         Map.singleton+         (AddrSpace 0) +         (+          8,+          AlignmentInfo {+            abiAlignment = 64,+            preferredAlignment = Nothing+          }+         )+     },+     "p:8:64",+     Nothing+    ), (+     "no pref",+     defaultDataLayout {+       pointerLayouts = +         Map.singleton+         (AddrSpace 1) +         (+          8,+          AlignmentInfo {+            abiAlignment = 32,+            preferredAlignment = Just 64+          }+         )+     },+     "p1:8:32:64",+     Nothing+    ), (+     "big",+     DataLayout {+       endianness = Just LittleEndian,+       stackAlignment = Just 128,+       pointerLayouts = Map.fromList [+         (AddrSpace 0, (64, AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}))+        ],+       typeLayouts = Map.fromList [+         ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}),+         ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}),+         ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 16}),+         ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}),+         ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}),+         ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}),+         ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}),+         ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}),+         ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}),+         ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}),+         ((AggregateAlign, 0), AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 64}),+         ((StackAlign, 0), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64})+        ],+       nativeSizes = Just (Set.fromList [8,16,32,64])+     },+     "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128",+     Just "e-S128-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-v64:64:64-v128:128:128-f32:32:32-f64:64:64-f80:128:128-a0:0:64-s0:64:64-n8:16:32:64"+    )+   ]+  ]+ ]

@@ -6,7 +6,7 @@  import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Except import Data.Functor import qualified Data.List as List import qualified Data.Set as Set@@ -134,8 +134,8 @@     testCase n $ do       triple <- getProcessTargetTriple       withTargetLibraryInfo triple $ \tli -> do-        Right dl <- runErrorT $ withDefaultTargetMachine getTargetMachineDataLayout-        Right ast <- runErrorT ast+        Right dl <- runExceptT $ withDefaultTargetMachine getTargetMachineDataLayout+        Right ast <- runExceptT ast         ast' <- instrument (defaultPassSetSpec { transforms = [p], dataLayout = Just dl, targetLibraryInfo = Just tli }) ast         let names ast = [ n | GlobalDefinition d <- moduleDefinitions ast, Name n <- return (G.name d) ]         (names ast') `List.intersect` (names ast) @?= names ast

@@ -6,7 +6,7 @@  import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Except import Data.Functor import qualified Data.Set as Set import qualified Data.Map as Map@@ -61,7 +61,7 @@     Module { moduleDefinitions = defs } <- withContext $ \context ->        withModuleFromAST' context ast0 $ \m0 ->         withModuleFromAST' context ast1 $ \m1 -> do-          runErrorT $ linkModules False m0 m1+          runExceptT $ linkModules False m0 m1           moduleAST m0     [ n | GlobalDefinition g <- defs, let Name n = G.name g ] @?= [ "private0", "external0", "external1" ]  ]

@@ -6,7 +6,7 @@  import LLVM.General.Test.Support -import Control.Monad.Error+import Control.Monad.Except import Data.Bits import Data.Word import Data.Functor@@ -327,7 +327,7 @@               }             ]       strCheck ast s-      s' <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify+      s' <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify       s' @?= Right (),     testCase "set flag on constant expr" $ withContext $ \context -> do       let ast = Module "<string>" Nothing Nothing [@@ -484,7 +484,7 @@                ]              }            ]-      t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True+      t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True       t @?= Left "reference to undefined block: Name \"not here\"",      testCase "multiple" $ withContext $ \context -> do@@ -514,7 +514,7 @@                ]              }            ]-      t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True+      t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True       t @?= Left "reference to undefined local: Name \"unknown\""    ]  ]

@@ -6,7 +6,7 @@  import Data.Functor import Control.Monad-import Control.Monad.Error+import Control.Monad.Except  import LLVM.General.Context import LLVM.General.Module@@ -16,8 +16,8 @@ class FailInIO f where   errorToString :: f -> String -failInIO :: FailInIO f => ErrorT f IO a -> IO a-failInIO = either (fail . errorToString) return <=< runErrorT+failInIO :: FailInIO f => ExceptT f IO a -> IO a+failInIO = either (fail . errorToString) return <=< runExceptT  instance FailInIO String where   errorToString = id

@@ -53,15 +53,7 @@  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+     testProperty "basic" $ \options -> ioProperty $ do        withTargetOptions $ \to -> do          pokeTargetOptions options to          options' <- peekTargetOptions to