packages feed

llvm-general 3.2.1.0 → 3.2.2.0

raw patch · 23 files changed

+312/−230 lines, 23 files

Files

llvm-general.cabal view
@@ -1,5 +1,5 @@ name: llvm-general-version: 3.2.1.0+version: 3.2.2.0 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet <fgthb0@greynode.net>@@ -33,7 +33,7 @@   type: git   location: git://github.com/bscarlet/llvm-general.git   branch: llvm-3.2-  tag: v3.2.1.0+  tag: v3.2.2.0  flag shared-llvm   description: link against llvm shared rather than static library@@ -186,7 +186,8 @@     test-framework-quickcheck2 >= 0.3.0.1,     QuickCheck >= 2.5.1.1,     llvm-general >= 0.1,-    containers >= 0.4.2.1+    containers >= 0.4.2.1,+    mtl >= 2.0.1.0   hs-source-dirs: test   main-is: Test.hs   other-modules:
src/Control/Monad/AnyCont.hs view
@@ -5,12 +5,12 @@   #-} module Control.Monad.AnyCont (     MonadAnyCont(..),+    ScopeAnyCont(..),     AnyContT(..),-    LiftAnyCont(..),+    MonadTransAnyCont(..),     runAnyContT,     withAnyContT,-    mapAnyContT,-    anyContT+    mapAnyContT   ) where  import Control.Monad.Trans.AnyCont
src/Control/Monad/AnyCont/Class.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE   RankNTypes,   MultiParamTypeClasses,-  FunctionalDependencies,   FlexibleInstances,   UndecidableInstances   #-}@@ -13,30 +12,44 @@ import Control.Monad.Trans.Error as Error import Control.Monad.Trans.State as State -class MonadAnyCont b m | m -> b where-  anyContToM :: (forall r . (a -> b r) -> b r) -> m a+class ScopeAnyCont m where   scopeAnyCont :: m a -> m a -instance Monad m => MonadAnyCont m (AnyContT m) where-  anyContToM = AnyCont.anyContT+class MonadAnyCont b m where+  anyContToM :: (forall r . (a -> b r) -> b r) -> m a+++instance MonadTransAnyCont b m => MonadAnyCont b (AnyContT m) where+  anyContToM c = AnyCont.anyContT (liftAnyCont c)++instance Monad m => ScopeAnyCont (AnyContT m) where   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 (StateT s m) where   anyContToM = lift . anyContToM++instance ScopeAnyCont m => ScopeAnyCont (StateT s m) where   scopeAnyCont = StateT . (scopeAnyCont .) . runStateT -class LiftAnyCont b m where++instance (Error e, Monad m, MonadAnyCont b m) => MonadAnyCont b (ErrorT e m) where+  anyContToM = lift . anyContToM++instance ScopeAnyCont m => ScopeAnyCont (ErrorT e m) where+  scopeAnyCont = mapErrorT scopeAnyCont+++++class MonadTransAnyCont b m where   liftAnyCont :: (forall r . (a -> b r) -> b r) -> (forall r . (a -> m r) -> m r) -instance LiftAnyCont b b where+instance MonadTransAnyCont b b where   liftAnyCont c = c -instance LiftAnyCont b m => LiftAnyCont b (StateT s m) where-  liftAnyCont c = \q -> StateT $ \s -> (liftAnyCont c (($ s) . runStateT . q))+instance MonadTransAnyCont b m => MonadTransAnyCont b (StateT s m) where+  liftAnyCont c = (\c q -> StateT $ \s -> c $ ($ s) . runStateT . q) (liftAnyCont c) -instance LiftAnyCont b m => LiftAnyCont b (ErrorT e m) where-  liftAnyCont c = \q -> ErrorT (liftAnyCont c (runErrorT . q))+instance MonadTransAnyCont b m => MonadTransAnyCont b (ErrorT e m) where+  liftAnyCont c = (\c q -> ErrorT . c $ runErrorT . q) (liftAnyCont c)
src/LLVM/General/Internal/Coding.hs view
@@ -126,3 +126,8 @@ instance Monad m => DecodeM m Int CInt where   decodeM = return . fromIntegral +instance Monad m => EncodeM m Word64 Word64 where+  encodeM = return++instance Monad m => DecodeM m Word64 Word64 where+  decodeM = return
src/LLVM/General/Internal/DecodeAST.hs view
@@ -61,12 +61,10 @@     Functor,     Monad,     MonadIO,-    MonadState DecodeState+    MonadState DecodeState,+    MonadAnyCont IO,+    ScopeAnyCont   )--instance MonadAnyCont IO DecodeAST where-  anyContToM c = DecodeAST (anyContToM (liftAnyCont c))-  scopeAnyCont = DecodeAST . scopeAnyCont . unDecodeAST  runDecodeAST :: DecodeAST a -> IO a runDecodeAST d = flip evalStateT initialDecode . flip runAnyContT return . unDecodeAST $ d
src/LLVM/General/Internal/EncodeAST.hs view
@@ -46,13 +46,11 @@        Monad,        MonadIO,        MonadState EncodeState,-       MonadError String+       MonadError String,+       MonadAnyCont IO,+       ScopeAnyCont      ) -instance MonadAnyCont IO EncodeAST where-  anyContToM c = EncodeAST (anyContToM (liftAnyCont c))-  scopeAnyCont = EncodeAST . scopeAnyCont . unEncodeAST- lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) lookupNamedType n = do   t <- gets $ Map.lookup n . encodeStateNamedTypes@@ -61,8 +59,8 @@ defineType :: A.Name -> Ptr FFI.Type -> EncodeAST () defineType n t = modify $ \s -> s { encodeStateNamedTypes = Map.insert n t (encodeStateNamedTypes s) } -runEncodeAST :: Context -> EncodeAST a -> IO (Either String a)-runEncodeAST context@(Context ctx) (EncodeAST a) = +runEncodeAST :: Context -> EncodeAST a -> ErrorT String IO a+runEncodeAST context@(Context ctx) (EncodeAST a) = ErrorT $      bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do       let initEncodeState = EncodeState {                encodeStateBuilder = builder,
src/LLVM/General/Internal/ExecutionEngine.hs view
@@ -10,6 +10,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.AnyCont+import Control.Monad.Error  import Data.Word import Foreign.Ptr@@ -66,14 +67,14 @@   liftIO initializeNativeTarget   outExecutionEngine <- alloca   outErrorCStringPtr <- alloca-  Module dummyModule <- maybe (anyContT $ liftM (either undefined id)+  Module dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runErrorT                                    . withModuleFromAST c (A.Module "" Nothing Nothing []))                         (return . Module) m   r <- liftIO $ createEngine outExecutionEngine dummyModule outErrorCStringPtr   when (r /= 0) $ do-    s <- anyContT $ bracket (peek outErrorCStringPtr) free+    s <- anyContToM $ bracket (peek outErrorCStringPtr) free     fail =<< decodeM s-  executionEngine <- anyContT $ bracket (peek outExecutionEngine) FFI.disposeExecutionEngine+  executionEngine <- anyContToM $ bracket (peek outExecutionEngine) FFI.disposeExecutionEngine   liftIO $ removeModule executionEngine dummyModule   liftIO $ f executionEngine
src/LLVM/General/Internal/FFI/Constant.hs view
@@ -18,6 +18,7 @@ import Control.Monad import Data.Function import qualified Data.Map as Map+import Data.Word  import Foreign.Ptr import Foreign.C@@ -44,7 +45,7 @@   Ptr Value -> IO (Ptr Constant)  foreign import ccall unsafe "LLVM_General_GetConstantIntWords" getConstantIntWords ::-  Ptr Constant -> Ptr CUInt -> IO (Ptr CULong)+  Ptr Constant -> Ptr CUInt -> IO (Ptr Word64)  foreign import ccall unsafe "LLVM_General_ConstFloatDoubleValue" constFloatDoubleValue ::   Ptr Constant -> IO CDouble@@ -61,15 +62,15 @@   Ptr Constant -> CUInt -> IO (Ptr Constant)  foreign import ccall unsafe "LLVMConstIntOfArbitraryPrecision" constantIntOfArbitraryPrecision' ::-  Ptr Type -> CUInt -> Ptr CULong -> IO (Ptr Constant)+  Ptr Type -> CUInt -> Ptr Word64 -> 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)+  Ptr Context -> CUInt -> Ptr Word64 -> LLVMBool -> IO (Ptr Constant)  foreign import ccall unsafe "LLVM_General_GetConstantFloatWords" getConstantFloatWords ::-  Ptr Constant -> Ptr CULong -> IO ()+  Ptr Constant -> Ptr Word64 -> IO ()  foreign import ccall unsafe "LLVMConstVector" constantVector' ::   Ptr (Ptr Constant) -> CUInt -> IO (Ptr Constant)
src/LLVM/General/Internal/FFI/LLVMCTypes.hsc view
@@ -149,6 +149,11 @@ #define CGOL_Rec(n) { #n, LLVMCodeGenLevel ## n }, #{inject CODE_GEN_OPT_LEVEL, CodeGenOptLevel, CodeGenOptLevel, codeGenOptLevel, CGOL_Rec} +newtype CodeGenFileType = CodeGenFileType CUInt+  deriving (Eq, Read, Show, Typeable, Data)+#define CGFT_Rec(n) { #n, LLVM ## n ## File },+#{inject CODE_GEN_FILE_TYPE, CodeGenFileType, CodeGenFileType, codeGenFileType, CGFT_Rec}+ newtype FloatABIType = FloatABIType CUInt   deriving (Eq, Read, Show, Typeable, Data) #define FAT_Rec(n) { #n, LLVM_General_FloatABI_ ## n },
src/LLVM/General/Internal/FFI/Module.hs view
@@ -2,14 +2,14 @@   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.LLVMCTypes+import LLVM.General.Internal.FFI.PtrHierarchy import LLVM.General.Internal.FFI.Type  data Module@@ -89,4 +89,4 @@   Ptr Module -> IO (ModuleAsm CString)  foreign import ccall unsafe "LLVM_General_WriteBitcodeToFile" writeBitcodeToFile ::-  Ptr Module -> CString -> Ptr CString -> IO Int+  Ptr Module -> CString -> Ptr CString -> IO LLVMBool
src/LLVM/General/Internal/FFI/Target.h view
@@ -21,6 +21,10 @@ 	macro(Default)																				\ 	macro(Aggressive) +#define LLVM_GENERAL_FOR_EACH_CODE_GEN_FILE_TYPE(macro)	\+	macro(Assembly)                                       \+	macro(Object)+ #define LLVM_GENERAL_FOR_EACH_TARGET_OPTION_FLAG(macro)	\ 	macro(PrintMachineCode)																\ 	macro(NoFramePointerElim)															\
src/LLVM/General/Internal/FFI/Target.hs view
@@ -3,13 +3,13 @@   GeneralizedNewtypeDeriving,   EmptyDataDecls   #-}- module LLVM.General.Internal.FFI.Target where  import Foreign.Ptr import Foreign.C  import LLVM.General.Internal.FFI.LLVMCTypes+import LLVM.General.Internal.FFI.Module  data Target @@ -61,25 +61,29 @@   Ptr TargetOptions -> IO CUInt  foreign import ccall unsafe "LLVM_General_DisposeTargetOptions" disposeTargetOptions ::-    Ptr TargetOptions -> IO ()+  Ptr TargetOptions -> IO ()  data TargetMachine  foreign import ccall unsafe "LLVM_General_CreateTargetMachine" createTargetMachine ::-    Ptr Target-    -> CString -    -> CString-    -> CString-    -> Ptr TargetOptions-    -> RelocModel-    -> CodeModel-    -> CodeGenOptLevel-    -> IO (Ptr TargetMachine)+  Ptr Target+  -> CString +  -> CString+  -> CString+  -> Ptr TargetOptions+  -> RelocModel+  -> CodeModel+  -> CodeGenOptLevel+  -> IO (Ptr TargetMachine)  foreign import ccall unsafe "LLVMDisposeTargetMachine" disposeTargetMachine ::-    Ptr TargetMachine -> IO ()+  Ptr TargetMachine -> IO () +foreign import ccall unsafe "LLVMTargetMachineEmitToFile" targetMachineEmitToFile ::+  Ptr TargetMachine -> Ptr Module -> CString -> CodeGenFileType -> Ptr CString -> IO LLVMBool+ data TargetLowering  foreign import ccall unsafe "LLVM_General_GetTargetLowering" getTargetLowering ::-    Ptr TargetMachine -> IO (Ptr TargetLowering)+  Ptr TargetMachine -> IO (Ptr TargetLowering)+
src/LLVM/General/Internal/FFI/Type.hs view
@@ -8,6 +8,7 @@  import Foreign.Ptr import Foreign.C+import Data.Word  import LLVM.General.Internal.FFI.LLVMCTypes import LLVM.General.Internal.FFI.Context@@ -69,7 +70,7 @@ -- | what <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#gabd1666e080f693e1af0b4018005cd927> -- | would be if it supported 64-bit array sizes, as the C++ type does. foreign import ccall unsafe "LLVM_General_ArrayType" arrayType ::-  Ptr Type -> CULong -> IO (Ptr Type)+  Ptr Type -> Word64 -> IO (Ptr Type)  -- | <http://llvm.org/doxygen/group__LLVMCCoreTypeStruct.html#gaff2af74740a22f7d18701f0d8c3e5a6f> foreign import ccall unsafe "LLVMStructTypeInContext" structTypeInContext' ::@@ -112,7 +113,7 @@ -- | what <http://llvm.org/doxygen/group__LLVMCCoreTypeSequential.html#ga02dc08041a12265cb700ee469497df63> -- | would be if it supported 64 bit lengths foreign import ccall unsafe "LLVM_General_GetArrayLength" getArrayLength ::-  Ptr Type -> IO CULong+  Ptr Type -> IO Word64  -- | <http://llvm.org/doxygen/group__LLVMCCoreTypeOther.html#ga1c78ca6d7bf279330b9195fa52f23828> foreign import ccall unsafe "LLVMVoidTypeInContext" voidTypeInContext ::
src/LLVM/General/Internal/Module.hs view
@@ -1,14 +1,15 @@ {-#   LANGUAGE   TupleSections,-  ScopedTypeVariables+  ScopedTypeVariables,+  FlexibleInstances   #-}- -- | This Haskell module is for/of functions for handling LLVM modules. module LLVM.General.Internal.Module where  import Control.Monad.Trans import Control.Monad.State+import Control.Monad.Error import Control.Monad.AnyCont import Control.Applicative import Control.Exception@@ -23,10 +24,12 @@ import qualified LLVM.General.Internal.FFI.GlobalValue as FFI import qualified LLVM.General.Internal.FFI.GlobalVariable as FFI import qualified LLVM.General.Internal.FFI.Iterate as FFI+import qualified LLVM.General.Internal.FFI.LLVMCTypes as FFI+import qualified LLVM.General.Internal.FFI.Metadata as FFI import qualified LLVM.General.Internal.FFI.Module as FFI import qualified LLVM.General.Internal.FFI.PtrHierarchy as FFI+import qualified LLVM.General.Internal.FFI.Target as FFI import qualified LLVM.General.Internal.FFI.Value as FFI-import qualified LLVM.General.Internal.FFI.Metadata as FFI  import LLVM.General.Internal.BasicBlock import LLVM.General.Internal.Coding@@ -37,11 +40,12 @@ import LLVM.General.Internal.EncodeAST import LLVM.General.Internal.Function import LLVM.General.Internal.Global+import LLVM.General.Internal.Instruction () import LLVM.General.Internal.Metadata import LLVM.General.Internal.Operand+import LLVM.General.Internal.Target import LLVM.General.Internal.Type import LLVM.General.Internal.Value-import LLVM.General.Internal.Instruction ()  import LLVM.General.Diagnostic @@ -53,33 +57,47 @@ -- | <http://llvm.org/doxygen/classllvm_1_1Module.html> newtype Module = Module (Ptr FFI.Module) +instance Error (Either String Diagnostic) where+    strMsg = Left+ -- | parse 'Module' from LLVM assembly-withModuleFromString :: Context -> String -> (Module -> IO a) -> IO (Either Diagnostic a)+withModuleFromString :: Context -> String -> (Module -> IO a) -> ErrorT (Either String Diagnostic) IO 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)+  smDiag <- anyContToM withSMDiagnostic+  m <- anyContToM $ bracket (FFI.getModuleFromAssemblyInContext c s smDiag) FFI.disposeModule+  when (m == nullPtr) $ throwError . Right =<< liftIO (getDiagnostic smDiag)+  liftIO $ f (Module m)  -- | generate LLVM assembly from a 'Module' moduleString :: Module -> IO String moduleString (Module m) = bracket (FFI.getModuleAssembly m) free $ decodeM  -- | generate LLVM bitcode from a 'Module'-writeBitcodeToFile :: FilePath -> Module -> IO ()+writeBitcodeToFile :: FilePath -> Module -> ErrorT String IO () writeBitcodeToFile path (Module m) = flip runAnyContT return $ do   msgPtr <- alloca   path <- encodeM path-  result <- liftIO $ FFI.writeBitcodeToFile m path msgPtr-  when (result /= 0) $ do-    msg <- anyContT $ bracket (peek msgPtr) free-    fail =<< decodeM msg+  result <- decodeM =<< (liftIO $ FFI.writeBitcodeToFile m path msgPtr)+  when result $ fail =<< (decodeM =<< (anyContToM $ bracket (peek msgPtr) free)) -setTargetTriple :: Ptr FFI.Module -> String -> IO ()-setTargetTriple m t = flip runAnyContT return $ do+emitToFile :: FFI.CodeGenFileType -> TargetMachine -> FilePath -> Module -> ErrorT String IO ()+emitToFile fileType (TargetMachine tm) path (Module m) = flip runAnyContT return $ do+  msgPtr <- alloca+  path <- encodeM path+  result <- decodeM =<< (liftIO $ FFI.targetMachineEmitToFile tm m path fileType msgPtr)+  when result $ fail =<< decodeM =<< anyContToM (bracket (peek msgPtr) free)++-- | write target-specific assembly directly into a file+writeAssemblyToFile :: TargetMachine -> FilePath -> Module -> ErrorT String IO ()+writeAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly++-- | write target-specific object code directly into a file+writeObjectToFile :: TargetMachine -> FilePath -> Module -> ErrorT String IO ()+writeObjectToFile = emitToFile FFI.codeGenFileTypeObject++setTargetTriple :: Ptr FFI.Module -> String -> EncodeAST ()+setTargetTriple m t = do   t <- encodeM t   liftIO $ FFI.setTargetTriple m t @@ -88,8 +106,8 @@   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+setDataLayout :: Ptr FFI.Module -> A.DataLayout -> EncodeAST ()+setDataLayout m dl = do   s <- encodeM (dataLayoutToString dl)   liftIO $ FFI.setDataLayout m s @@ -100,118 +118,118 @@  -- | 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) -> 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-    let sequencePhases :: EncodeAST [EncodeAST (EncodeAST (EncodeAST (EncodeAST ())))] -> EncodeAST ()-        sequencePhases l = (l >>= (sequence >=> sequence >=> sequence >=> sequence)) >> (return ())+withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> ErrorT String IO a+withModuleFromAST context@(Context c) (A.Module moduleId dataLayout triple definitions) f = runEncodeAST context $ do+  moduleId <- encodeM moduleId+  m <- anyContToM $ bracket (FFI.moduleCreateWithNameInContext moduleId c) FFI.disposeModule+  maybe (return ()) (setDataLayout m) dataLayout+  maybe (return ()) (setTargetTriple m) triple+  let sequencePhases :: EncodeAST [EncodeAST (EncodeAST (EncodeAST (EncodeAST ())))] -> EncodeAST ()+      sequencePhases l = (l >>= (sequence >=> sequence >=> sequence >=> sequence)) >> (return ()) -    r <- runEncodeAST context $ sequencePhases $ forM definitions $ \d -> case d of-      A.TypeDefinition n t -> do-        t' <- createNamedType n-        defineType n t'-        return $ do-          maybe (return ()) (setNamedType t') t-          return . return . return $ return ()+  sequencePhases $ forM definitions $ \d -> case d of+   A.TypeDefinition n t -> do+     t' <- createNamedType n+     defineType n t'+     return $ do+       maybe (return ()) (setNamedType t') t+       return . return . return $ return () -      A.MetadataNodeDefinition i os -> return . return $ do-        t <- liftIO $ FFI.createTemporaryMDNodeInContext c-        defineMDNode i t-        return $ do-          n <- encodeM (A.MetadataNode os)-          liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)-          defineMDNode i n-          liftIO $ FFI.destroyTemporaryMDNode t-          return $ return ()+   A.MetadataNodeDefinition i os -> return . return $ do+     t <- liftIO $ FFI.createTemporaryMDNodeInContext c+     defineMDNode i t+     return $ do+       n <- encodeM (A.MetadataNode os)+       liftIO $ FFI.replaceAllUsesWith (FFI.upCast t) (FFI.upCast n)+       defineMDNode i n+       liftIO $ FFI.destroyTemporaryMDNode t+       return $ return () -      A.NamedMetadataDefinition n ids -> return . return . return . return $ do-        n <- encodeM n-        ids <- encodeM (map A.MetadataNodeReference ids)-        nm <- liftIO $ FFI.getOrAddNamedMetadata m n-        liftIO $ FFI.namedMetadataAddOperands nm ids-        return ()+   A.NamedMetadataDefinition n ids -> return . return . return . return $ do+     n <- encodeM n+     ids <- encodeM (map A.MetadataNodeReference ids)+     nm <- liftIO $ FFI.getOrAddNamedMetadata m n+     liftIO $ FFI.namedMetadataAddOperands nm ids+     return () -      A.ModuleInlineAssembly s -> do-        s <- encodeM s-        liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s)-        return . return . return . return $ return ()+   A.ModuleInlineAssembly s -> do+     s <- encodeM s+     liftIO $ FFI.moduleAppendInlineAsm m (FFI.ModuleAsm s)+     return . return . return . return $ return () -      A.GlobalDefinition g -> return . phase $ do-        eg' :: EncodeAST (Ptr FFI.GlobalValue) <- case g of-          g@(A.GlobalVariable { A.G.name = n }) -> do-            typ <- encodeM (A.G.type' g)-            g' <- liftIO $ withName n $ \gName -> -                      FFI.addGlobalInAddressSpace m typ gName -                             (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g))-            defineGlobal n g'-            liftIO $ do-              tl <- encodeM (A.G.isThreadLocal g)-              FFI.setThreadLocal g' tl-              hua <- encodeM (A.G.hasUnnamedAddr g)-              FFI.setUnnamedAddr (FFI.upCast g') hua-              ic <- encodeM (A.G.isConstant g)-              FFI.setGlobalConstant g' ic-            return $ do-              maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)-              setSection g' (A.G.section g)-              setAlignment g' (A.G.alignment g)-              return (FFI.upCast g')-          (a@A.G.GlobalAlias { A.G.name = n }) -> do-            typ <- encodeM (A.G.type' a)-            a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ name-            defineGlobal n a'-            return $ do-              (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a)-              return (FFI.upCast a')-          (A.Function _ _ cc rAttrs resultType fName (args,isVarArgs) attrs _ _ 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)-            forM blocks $ \(A.BasicBlock bName _ _) -> do-              b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName-              defineBasicBlock fName bName b-            phase $ do-              let nParams = length args-              ps <- allocaArray nParams-              liftIO $ FFI.getParams f ps-              params <- peekArray nParams ps-              forM (zip args params) $ \(A.Parameter _ n attrs, p) -> do-                defineLocal n p-                n <- encodeM n-                liftIO $ FFI.setValueName (FFI.upCast p) n-                attrs <- encodeM attrs-                liftIO $ FFI.addAttribute p attrs-                return ()-              finishInstrs <- forM blocks $ \(A.BasicBlock bName namedInstrs term) -> do-                b <- encodeM bName-                (do-                  builder <- gets encodeStateBuilder-                  liftIO $ FFI.positionBuilderAtEnd builder b)-                finishes <- mapM encodeM namedInstrs :: EncodeAST [EncodeAST ()]-                (encodeM term :: EncodeAST (Ptr FFI.Instruction))-                return (sequence_ finishes)-              sequence_ finishInstrs-              return (FFI.upCast f)-        return $ do-          g' <- eg'-          setLinkage g' (A.G.linkage g)-          setVisibility g' (A.G.visibility g)-          return $ return ()-          -    either (return . Left) (const $ Right <$> f (Module m)) r+   A.GlobalDefinition g -> return . phase $ do+     eg' :: EncodeAST (Ptr FFI.GlobalValue) <- case g of+       g@(A.GlobalVariable { A.G.name = n }) -> do+         typ <- encodeM (A.G.type' g)+         g' <- liftIO $ withName n $ \gName -> +                   FFI.addGlobalInAddressSpace m typ gName +                          (fromIntegral ((\(A.AddrSpace a) -> a) $ A.G.addrSpace g))+         defineGlobal n g'+         liftIO $ do+           tl <- encodeM (A.G.isThreadLocal g)+           FFI.setThreadLocal g' tl+           hua <- encodeM (A.G.hasUnnamedAddr g)+           FFI.setUnnamedAddr (FFI.upCast g') hua+           ic <- encodeM (A.G.isConstant g)+           FFI.setGlobalConstant g' ic+         return $ do+           maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)+           setSection g' (A.G.section g)+           setAlignment g' (A.G.alignment g)+           return (FFI.upCast g')+       (a@A.G.GlobalAlias { A.G.name = n }) -> do+         typ <- encodeM (A.G.type' a)+         a' <- liftIO $ withName n $ \name -> FFI.justAddAlias m typ name+         defineGlobal n a'+         return $ do+           (liftIO . FFI.setAliasee a') =<< encodeM (A.G.aliasee a)+           return (FFI.upCast a')+       (A.Function _ _ cc rAttrs resultType fName (args,isVarArgs) attrs _ _ 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)+         forM blocks $ \(A.BasicBlock bName _ _) -> do+           b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext c f bName+           defineBasicBlock fName bName b+         phase $ do+           let nParams = length args+           ps <- allocaArray nParams+           liftIO $ FFI.getParams f ps+           params <- peekArray nParams ps+           forM (zip args params) $ \(A.Parameter _ n attrs, p) -> do+             defineLocal n p+             n <- encodeM n+             liftIO $ FFI.setValueName (FFI.upCast p) n+             unless (null attrs) $+                    do attrs <- encodeM attrs+                       liftIO $ FFI.addAttribute p attrs+                       return ()+             return ()+           finishInstrs <- forM blocks $ \(A.BasicBlock bName namedInstrs term) -> do+             b <- encodeM bName+             (do+               builder <- gets encodeStateBuilder+               liftIO $ FFI.positionBuilderAtEnd builder b)+             finishes <- mapM encodeM namedInstrs :: EncodeAST [EncodeAST ()]+             (encodeM term :: EncodeAST (Ptr FFI.Instruction))+             return (sequence_ finishes)+           sequence_ finishInstrs+           return (FFI.upCast f)+     return $ do+       g' <- eg'+       setLinkage g' (A.G.linkage g)+       setVisibility g' (A.G.visibility g)+       return $ return () +  liftIO $ f (Module m)     + -- | Get an LLVM.General.AST.'LLVM.General.AST.Module' from a LLVM.General.'Module' - i.e. -- raise C++ objects into an Haskell AST. moduleAST :: Module -> IO A.Module@@ -295,11 +313,8 @@               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` (decodeM $ FFI.getNamedMetadataName nm)                  `ap` liftM (map (\(A.MetadataNodeReference mid) -> mid)) (decodeM (n, os))                  mds <- getMetadataDefinitions
src/LLVM/General/Internal/String.hs view
@@ -11,6 +11,8 @@ import Foreign.Ptr import Control.Monad.AnyCont import Control.Monad.IO.Class+import Foreign.Storable (Storable)+import Foreign.Marshal.Alloc as F.M (alloca)  import LLVM.General.Internal.Coding @@ -18,14 +20,26 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T +newtype UTF8ByteString = UTF8ByteString { utf8Bytes :: BS.ByteString }++instance (Monad e) => EncodeM e String UTF8ByteString where+  encodeM = return . UTF8ByteString . T.encodeUtf8 . T.pack++instance (Monad d) => DecodeM d String UTF8ByteString where+  decodeM = return . T.unpack . T.decodeUtf8 . utf8Bytes++ instance (MonadAnyCont IO e) => EncodeM e String CString where-  encodeM s = anyContToM (BS.useAsCString . T.encodeUtf8 . T.pack $ s)+  encodeM s = anyContToM (BS.useAsCString . utf8Bytes =<< encodeM 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)+  encodeM s = anyContToM ((. (. second fromIntegral)) $ BS.useAsCStringLen . utf8Bytes =<< encodeM s)  instance (MonadIO d) => DecodeM d String CString where-  decodeM = liftIO . liftM (T.unpack . T.decodeUtf8) . BS.packCString+  decodeM = decodeM . UTF8ByteString <=< liftIO . 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+  decodeM = decodeM . UTF8ByteString <=< liftIO . BS.packCStringLen . second fromIntegral++instance (Integral i, Storable i, MonadIO d) => DecodeM d String (Ptr i -> IO (Ptr CChar)) where+  decodeM f = decodeM =<< (liftIO $ F.M.alloca $ \p -> (,) `liftM` f p `ap` peek p)
src/LLVM/General/Internal/Target.hs view
@@ -8,9 +8,9 @@ module LLVM.General.Internal.Target where  import Control.Monad+import Control.Monad.Error import Control.Exception import Data.Functor-import Control.Monad.IO.Class import Control.Monad.AnyCont  import Foreign.Ptr@@ -69,7 +69,7 @@ lookupTarget ::    Maybe String -- ^ arch   -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu-  -> IO (Either String (Target, String))+  -> ErrorT String IO (Target, String) lookupTarget arch triple = flip runAnyContT return $ do   cErrorP <- alloca   cNewTripleP <- alloca@@ -81,10 +81,8 @@         r <- decodeM s         liftIO $ free s         return r-  if (target == nullPtr) then-     Left <$> readString cErrorP-   else-     Right . (Target target, ) <$> readString cNewTripleP+  when (target == nullPtr) $ fail =<< readString cErrorP+  liftM (Target target, ) $ readString cNewTripleP  -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html> newtype TargetOptions = TargetOptions (Ptr FFI.TargetOptions)@@ -207,7 +205,7 @@   relocModel <- encodeM relocModel   codeModel <- encodeM codeModel   codeGenOptLevel <- encodeM codeGenOptLevel-  anyContT $ bracket (+  anyContToM $ bracket (       FFI.createTargetMachine          target          triple
src/LLVM/General/Module.hs view
@@ -1,12 +1,15 @@ -- | 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 function pointers.+-- added to an 'LLVM.General.ExecutionEngine.ExecutionEngine' and so JIT compiled to get function pointers. module LLVM.General.Module (     Module,     withModuleFromAST,     moduleAST,-    writeBitcodeToFile,     withModuleFromString,-    moduleString+    moduleString,++    writeBitcodeToFile,+    writeAssemblyToFile,+    writeObjectToFile   ) where  import LLVM.General.Internal.Module
test/LLVM/General/Test/ExecutionEngine.hs view
@@ -8,6 +8,8 @@ import Test.Framework.Providers.HUnit import Test.HUnit +import LLVM.General.Test.Support+ import Control.Monad import Data.Functor import Data.Maybe@@ -47,11 +49,11 @@                ]               ] -  s <- withModuleFromAST context mAST $ \m -> do+  s <- withModuleFromAST' context mAST $ \m -> do         withModuleInEngine executionEngine m $ \em -> do           Just p <- getFunction em (Name "_foo")           (mkIO32Stub ((castFunPtr p) :: FunPtr (Word32 -> IO Word32))) 7-  s @?= Right 42+  s @?= 42  tests = testGroup "ExecutionEngine" [   testCase "run something with JIT" $ testJIT (\c -> withJIT c 2)
test/LLVM/General/Test/Global.hs view
@@ -4,6 +4,8 @@ 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@@ -13,7 +15,7 @@   testGroup "Alignment" [     testCase name $ withContext $ \context -> do       let ast = Module "<string>" Nothing Nothing [ GlobalDefinition g ]-      Right ast' <- withModuleFromAST context ast moduleAST+      ast' <- withModuleFromAST' context ast moduleAST       ast' @?= ast     | a <- [0,1],       s <- [Nothing, Just "foo"],
test/LLVM/General/Test/Instructions.hs view
@@ -575,8 +575,8 @@                \  %1 = load i32* @0, align 1\n\                \  ret i32 %1\n\                \}\n"-    s <- withContext $ \context -> withModuleFromAST context mAST moduleString-    s @?= Right mStr,+    s <- withContext $ \context -> withModuleFromAST' context mAST moduleString+    s @?= mStr,        testGroup "terminators" [     testCase name $ strCheck mAST mStr
test/LLVM/General/Test/Module.hs view
@@ -6,6 +6,7 @@  import LLVM.General.Test.Support +import Control.Monad.Error import Data.Bits import Data.Word import Data.Functor@@ -13,6 +14,7 @@ import LLVM.General.Context import LLVM.General.Module import LLVM.General.Diagnostic+import LLVM.General.Target import LLVM.General.AST import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.IntegerPredicate as IPred@@ -24,6 +26,10 @@ import qualified LLVM.General.AST.Global as G import qualified LLVM.General.AST.Constant as C +import qualified LLVM.General.Relocation as R+import qualified LLVM.General.CodeModel as CM+import qualified LLVM.General.CodeGenOpt as CGO+ handString = "; ModuleID = '<string>'\n\     \\n\     \%0 = type { i32, %1*, %0* }\n\@@ -213,8 +219,8 @@     ast @?= handAST,        testCase "withModuleFromAST" $ withContext $ \context -> do-   s <- withModuleFromAST context handAST moduleString-   s @?= Right handString,+   s <- withModuleFromAST' context handAST moduleString+   s @?= handString,    testCase "triple" $ withContext $ \context -> do    let hAST = "; ModuleID = '<string>'\n\@@ -247,8 +253,8 @@               )             ]            ]-      t <- withModuleFromAST context ast $ \_ -> return True-      t @?= Right True,+      t <- withModuleFromAST' context ast $ \_ -> return True+      t @?= True,      testCase "Phi node finishes" $ withContext $ \context -> do       let ast = Module "<string>" Nothing Nothing [@@ -327,8 +333,8 @@                   ]                 }                ]-          Right s <- withModuleFromAST context ast moduleString-          Right m <- withModuleFromString context s moduleAST+          s <- withModuleFromAST' context ast moduleString+          m <- withModuleFromString' context s moduleAST           m @?= ast    ],         @@ -357,7 +363,7 @@               )             ]            ]-      t <- withModuleFromAST context badAST $ \_ -> return True+      t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True       t @?= Left "reference to undefined block: Name \"not here\""    ]  ]
test/LLVM/General/Test/Optimization.hs view
@@ -4,6 +4,8 @@ import Test.Framework.Providers.HUnit import Test.HUnit +import LLVM.General.Test.Support+ import Data.Functor import qualified Data.Map as Map @@ -91,11 +93,9 @@       ]  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+optimize s m = withContext $ \context -> withModuleFromAST' context m $ \mIn' -> do+  withPassManager s $ \pm -> runPassManager pm mIn'+  moduleAST mIn'  tests = testGroup "Optimization" [   testCase "curated" $ do@@ -291,7 +291,7 @@       -- how unwinding works (as is the invoke instruction)       withContext $ \context -> do         let triple = "x86_64-apple-darwin"-        Right (target, _) <- lookupTarget Nothing triple+        (target, _) <- failInIO $ lookupTarget Nothing triple         withTargetOptions $ \targetOptions -> do           withTargetMachine target triple "" "" targetOptions                             R.Default CM.Default CGO.Default $ \targetMachine -> do@@ -308,7 +308,7 @@                             )                           ]                      ] -              Right astOut <- withModuleFromAST context astIn $ \mIn -> do+              astOut <- withModuleFromAST' context astIn $ \mIn -> do                 runPassManager passManager mIn                 moduleAST mIn               astOut @?= Module "<string>" Nothing Nothing [
test/LLVM/General/Test/Support.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE+  TypeSynonymInstances,+  FlexibleInstances+  #-} module LLVM.General.Test.Support where  import Test.Framework@@ -5,23 +9,30 @@ import Test.HUnit  import Data.Functor+import Control.Monad+import Control.Monad.Error  import LLVM.General.Context import LLVM.General.Module import LLVM.General.Diagnostic -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+class FailInIO f where+  errorToString :: f -> String +failInIO :: FailInIO f => ErrorT f IO a -> IO a+failInIO = either (fail . errorToString) return <=< runErrorT++instance FailInIO String where+  errorToString = id++instance FailInIO (Either String Diagnostic) where+  errorToString = either id diagnosticDisplay++withModuleFromString' c s f  = failInIO $ withModuleFromString c s f+withModuleFromAST' c a f = failInIO $ withModuleFromAST c a f+ strCheck mAST mStr = withContext $ \context -> do   a <- withModuleFromString' context mStr moduleAST-  s <- either error id <$> withModuleFromAST context mAST moduleString+  s <- withModuleFromAST' context mAST moduleString   (a,s) @?= (mAST, mStr) -