llvm-hs 4.0.1.0 → 4.1.0.0

raw patch · 58 files changed

+808/−473 lines, 58 filesdep +attoparsecdep +exceptionsdep −parsecdep ~llvm-hs-puresetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, exceptions

Dependencies removed: parsec

Dependency ranges changed: llvm-hs-pure

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• Setup.hs +32/−8
• llvm-hs.cabal +11/−6
• src/Control/Monad/Trans/AnyCont.hs +4/−0
• src/LLVM/CodeGenOpt.hs +1/−1
• src/LLVM/CodeModel.hs +1/−1
• src/LLVM/Diagnostic.hs +1/−1
• src/LLVM/Exception.hs +64/−0
• src/LLVM/Internal/Analysis.hs +5/−5
• src/LLVM/Internal/Attribute.hs +3/−3
• src/LLVM/Internal/Coding.hs +2/−2
• src/LLVM/Internal/CommandLine.hs +1/−1
• src/LLVM/Internal/Constant.hs +15/−9
• src/LLVM/Internal/DecodeAST.hs +4/−3
• src/LLVM/Internal/EncodeAST.hs +19/−16
• src/LLVM/Internal/ExecutionEngine.hs +7/−7
• src/LLVM/Internal/FFI/AttributeC.cpp +2/−2
• src/LLVM/Internal/FFI/DataLayout.hs +4/−0
• src/LLVM/Internal/FFI/LLVMCTypes.hsc +35/−32
• src/LLVM/Internal/FFI/ShortByteString.hs +44/−0
• src/LLVM/Internal/Function.hs +3/−3
• src/LLVM/Internal/Global.hs +12/−10
• src/LLVM/Internal/Inject.hs +0/−11
• src/LLVM/Internal/InlineAssembly.hs +6/−8
• src/LLVM/Internal/Instruction.hs +31/−32
• src/LLVM/Internal/MemoryBuffer.hs +5/−6
• src/LLVM/Internal/Metadata.hs +3/−3
• src/LLVM/Internal/Module.hs +63/−58
• src/LLVM/Internal/OrcJIT/CompileOnDemandLayer.hs +4/−4
• src/LLVM/Internal/OrcJIT/IRCompileLayer.hs +1/−1
• src/LLVM/Internal/PassManager.hs +8/−4
• src/LLVM/Internal/RawOStream.hs +20/−32
• src/LLVM/Internal/String.hs +31/−2
• src/LLVM/Internal/Target.hs +44/−38
• src/LLVM/Internal/Type.hs +18/−17
• src/LLVM/Relocation.hs +1/−1
• src/LLVM/Target/Options.hs +2/−2
• src/LLVM/Transforms.hs +4/−3
• test/LLVM/Test/Analysis.hs +3/−3
• test/LLVM/Test/CallingConvention.hs +5/−1
• test/LLVM/Test/Constants.hs +3/−1
• test/LLVM/Test/DataLayout.hs +39/−20
• test/LLVM/Test/ExecutionEngine.hs +4/−2
• test/LLVM/Test/FunctionAttribute.hs +103/−0
• test/LLVM/Test/Global.hs +7/−2
• test/LLVM/Test/InlineAssembly.hs +1/−0
• test/LLVM/Test/Instructions.hs +19/−14
• test/LLVM/Test/Instrumentation.hs +4/−3
• test/LLVM/Test/Linking.hs +4/−3
• test/LLVM/Test/Metadata.hs +1/−40
• test/LLVM/Test/Module.hs +27/−16
• test/LLVM/Test/ObjectCode.hs +6/−8
• test/LLVM/Test/Optimization.hs +8/−6
• test/LLVM/Test/OrcJIT.hs +5/−4
• test/LLVM/Test/Support.hs +9/−16
• test/LLVM/Test/Target.hs +28/−2
• test/LLVM/Test/Tests.hs +2/−0
• test/Test.hs +1/−0

@@ -0,0 +1,18 @@+## 4.1.0 (2017-05-17)++* Switch most of the API from `String` to `ByteString`.+* Switch from ExceptT to using exceptions.+  See `LLVM.Exception` for an overview of the exceptions potentially thrown.++## 4.0.1++* Fix linking of system libraries++## 4.0.0 (initial release, changes in comparison to llvm-general)++* Move modules from `LLVM.General*` to `LLVM.*`+* Support for LLVM 4.0+* Improved support for LLVM’s exception handling instructions+* `-fshared-llvm` is now supported on windows (thanks to @RyanGLScott)+* Default to `-fshared-llvm`+* Expose `LLVM.Internal.*` modules.

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP, FlexibleInstances #-} import Control.Exception (SomeException, try) import Control.Monad import Data.Functor@@ -18,15 +18,27 @@ import System.Environment import Distribution.System +#ifdef MIN_VERSION_Cabal+#if MIN_VERSION_Cabal(2,0,0)+#define MIN_VERSION_Cabal_2_0_0+#endif+#endif+ -- define these selectively in C files (we are _not_ using HsFFI.h), -- rather than universally in the ccOptions, because HsFFI.h currently defines them -- without checking they're already defined and so causes warnings. uncheckedHsFFIDefines = ["__STDC_LIMIT_MACROS"] -llvmVersion = Version [4,0] []+#ifndef MIN_VERSION_Cabal_2_0_0+mkVersion ver = Version ver []+versionNumbers = versionBranch+mkFlagName = FlagName+#endif +llvmVersion = mkVersion [4,0]+ llvmConfigNames = [-  "llvm-config-" ++ (intercalate "." . map show . versionBranch $ llvmVersion),+  "llvm-config-" ++ (intercalate "." . map show . versionNumbers $ llvmVersion),   "llvm-config"  ] @@ -138,8 +150,8 @@       [llvmVersion] <- liftM lines $ llvmConfig ["--version"]       let getLibs = liftM (map (fromJust . stripPrefix "-l") . words) . llvmConfig           flags    = configConfigurationsFlags configFlags-          linkFlag = case lookup (FlagName "shared-llvm") flags of-                       Nothing     -> "--link-static"+          linkFlag = case lookup (mkFlagName "shared-llvm") flags of+                       Nothing     -> "--link-shared"                        Just shared -> if shared then "--link-shared" else "--link-static"       libs       <- getLibs ["--libs", linkFlag]       systemLibs <- getLibs ["--system-libs", linkFlag]@@ -166,18 +178,30 @@      hookedPreProcessors =       let origHookedPreprocessors = hookedPreProcessors origUserHooks+#ifdef MIN_VERSION_Cabal_2_0_0+          newHsc buildInfo localBuildInfo componentLocalBuildInfo =+#else           newHsc buildInfo localBuildInfo =+#endif               PreProcessor {-                  platformIndependent = platformIndependent (origHsc buildInfo localBuildInfo),+                  platformIndependent = platformIndependent (origHsc buildInfo),                   runPreProcessor = \inFiles outFiles verbosity -> do                       llvmConfig <- getLLVMConfig (configFlags localBuildInfo)                       llvmCFlags <- do                           rawLlvmCFlags <- llvmConfig ["--cflags"]                           return . filter (not . isIgnoredCFlag) $ words rawLlvmCFlags                       let buildInfo' = buildInfo { ccOptions = "-Wno-variadic-macros" : llvmCFlags }-                      runPreProcessor (origHsc buildInfo' localBuildInfo) inFiles outFiles verbosity+                      runPreProcessor (origHsc buildInfo') inFiles outFiles verbosity               }-              where origHsc = fromMaybe ppHsc2hs (lookup "hsc" origHookedPreprocessors)+              where origHsc buildInfo =+                      fromMaybe+                        ppHsc2hs+                        (lookup "hsc" origHookedPreprocessors)+                        buildInfo+                        localBuildInfo+#ifdef MIN_VERSION_Cabal_2_0_0+                        componentLocalBuildInfo+#endif       in [("hsc", newHsc)] ++ origHookedPreprocessors,      buildHook = \packageDescription localBuildInfo userHooks buildFlags -> do

@@ -1,5 +1,5 @@ name: llvm-hs-version: 4.0.1.0+version: 4.1.0.0 license: BSD3 license-file: LICENSE author: Anthony Cowley, Stephen Diehl, Moritz Kiefer <moritz.kiefer@purelyfunctional.org>, Benjamin S. Scarlet@@ -36,6 +36,7 @@   src/LLVM/Internal/FFI/Type.h   src/LLVM/Internal/FFI/Value.h tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2+extra-source-files: CHANGELOG.md  source-repository head   type: git@@ -61,7 +62,7 @@  library   build-tools: llvm-config-  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-incomplete-patterns -fno-warn-missing-signatures -fno-warn-unused-matches -fno-warn-unused-do-bind -fno-warn-type-defaults+  ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-incomplete-patterns -fno-warn-missing-signatures -fno-warn-unused-matches   if flag(semigroups)     build-depends:       base >= 4.7 && < 4.9,@@ -70,6 +71,8 @@     build-depends:       base >= 4.9 && < 5   build-depends:+    attoparsec >= 0.13,+    exceptions >= 0.8,     utf8-string >= 0.3.7,     bytestring >= 0.9.1.10,     transformers >= 0.3 && < 0.6,@@ -77,14 +80,14 @@     mtl >= 2.1.3,     template-haskell >= 2.5.0.0,     containers >= 0.4.2.1,-    parsec >= 3.1.3,     array >= 0.4.0.0,-    llvm-hs-pure == 4.0.0.0+    llvm-hs-pure == 4.1.0.0   hs-source-dirs: src   extensions:     NoImplicitPrelude     TupleSections     DeriveDataTypeable+    DeriveGeneric     EmptyDataDecls     FlexibleContexts     FlexibleInstances@@ -98,6 +101,7 @@     LLVM.CommandLine     LLVM.Context     LLVM.Diagnostic+    LLVM.Exception     LLVM.ExecutionEngine     LLVM.Internal.Analysis     LLVM.Internal.Atomicity@@ -117,7 +121,6 @@     LLVM.Internal.FloatingPointPredicate     LLVM.Internal.Function     LLVM.Internal.Global-    LLVM.Internal.Inject     LLVM.Internal.InlineAssembly     LLVM.Internal.Instruction     LLVM.Internal.InstructionDefs@@ -171,6 +174,7 @@     LLVM.Internal.FFI.PassManager     LLVM.Internal.FFI.PtrHierarchy     LLVM.Internal.FFI.RawOStream+    LLVM.Internal.FFI.ShortByteString     LLVM.Internal.FFI.SMDiagnostic     LLVM.Internal.FFI.Target     LLVM.Internal.FFI.Threading@@ -239,7 +243,7 @@     tasty-quickcheck >= 0.8,     QuickCheck >= 2.5.1.1,     llvm-hs,-    llvm-hs-pure == 4.0.0.0,+    llvm-hs-pure == 4.1.0.0,     containers >= 0.4.2.1,     mtl >= 2.1,     transformers >= 0.3.0.0,@@ -258,6 +262,7 @@     LLVM.Test.Constants     LLVM.Test.DataLayout     LLVM.Test.ExecutionEngine+    LLVM.Test.FunctionAttribute     LLVM.Test.Global     LLVM.Test.InlineAssembly     LLVM.Test.Instructions

@@ -5,6 +5,7 @@  import LLVM.Prelude +import Control.Monad.Catch import Control.Monad.Cont  newtype AnyContT m a = AnyContT { unAnyContT :: forall r . ContT r m a }@@ -26,6 +27,9 @@  instance MonadTrans AnyContT where   lift ma = AnyContT (lift ma)++instance MonadThrow m => MonadThrow (AnyContT m) where+  throwM = lift . throwM  runAnyContT :: AnyContT m a -> (forall r . (a -> m r) -> m r) runAnyContT = runContT . unAnyContT

@@ -9,4 +9,4 @@     | Less     | Default     | Aggressive-    deriving (Eq, Ord, Read, Show, Typeable, Data)+    deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)

@@ -11,4 +11,4 @@     | Kernel     | Medium     | Large-    deriving (Eq, Read, Show, Typeable, Data)+    deriving (Eq, Read, Show, Typeable, Data, Generic)

@@ -12,7 +12,7 @@   = ErrorKind   | WarningKind   | NoteKind-  deriving (Eq, Ord, Read, Show, Typeable, Data)+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)  -- | A 'Diagnostic' described a problem during parsing of LLVM IR data Diagnostic = Diagnostic {

@@ -0,0 +1,64 @@+{-|+This module lists all of the exceptions thrown by 'llvm-hs' itself.+Note that other exceptions can potentially be thrown+by the underlying libraries, e.g., for functions doing file IO.+-}+module LLVM.Exception where++import LLVM.Prelude++import Control.Monad.Catch++-- | Indicates an error during the translation of the AST provided by+-- 'llvm-hs-pure' to LLVM’s internal representation.+data EncodeException =+  EncodeException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception EncodeException++-- | Indicates an error during the parsing of a module. This is used+-- for errors encountered when parsing LLVM’s human readable assembly+-- format and when parsing the binary bitcode format.+data ParseFailureException =+  ParseFailureException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception ParseFailureException++-- | Indicates an error during the linking of two modules.+data LinkException =+  LinkException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception LinkException++-- | Indicates an error during the creation of a+-- <http://llvm.org/docs/doxygen/html/classllvm_1_1raw__fd__ostream.html raw_fd_ostream>.+-- This could be caused by a nonexisting file path.+data FdStreamException =+  FdStreamException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception FdStreamException++-- | Indicates an error during a call to 'LLVM.Internal.Module.targetMachineEmit'.+data TargetMachineEmitException =+  TargetMachineEmitException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception TargetMachineEmitException++-- | Indicates a failure to find the target.+data LookupTargetException =+  LookupTargetException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception LookupTargetException++-- | Indicates an error during the verification of a module.+data VerifyException =+  VerifyException !String+  deriving (Show, Eq, Ord, Typeable)++instance Exception VerifyException

@@ -3,9 +3,8 @@ import LLVM.Prelude  import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.IO.Class-import Control.Monad.Trans.Except  import qualified LLVM.Internal.FFI.Analysis as FFI import qualified LLVM.Internal.FFI.LLVMCTypes as FFI@@ -13,12 +12,13 @@ import LLVM.Internal.Module import LLVM.Internal.Coding +import LLVM.Exception+ -- | Run basic sanity checks on a 'Module'. Note that the same checks will trigger assertions -- within LLVM if LLVM was built with them turned on, before this function can be is called.-verify :: Module -> ExceptT String IO ()+verify :: Module -> IO () verify m = flip runAnyContT return $ do   errorPtr <- alloca   m' <- readModule m   result <- decodeM =<< (liftIO $ FFI.verifyModule m' FFI.verifierFailureActionReturnStatus errorPtr)-  when result $ throwError =<< decodeM errorPtr-+  when result $ throwM . VerifyException =<< decodeM errorPtr

@@ -86,7 +86,7 @@       A.FA.AlwaysInline -> FFI.functionAttributeKindAlwaysInline       A.FA.MinimizeSize -> FFI.functionAttributeKindMinSize       A.FA.OptimizeForSize -> FFI.functionAttributeKindOptimizeForSize-      A.FA.OptimizeNone -> FFI.functionAttributeKindOptimizeForSize+      A.FA.OptimizeNone -> FFI.functionAttributeKindOptimizeNone       A.FA.WriteOnly -> FFI.functionAttributeKindWriteOnly       A.FA.ArgMemOnly -> FFI.functionAttributeKindArgMemOnly       A.FA.StackProtect -> FFI.functionAttributeKindStackProtect@@ -165,7 +165,7 @@            [functionAttributeKindP|AlwaysInline|] -> return A.FA.AlwaysInline            [functionAttributeKindP|MinSize|] -> return A.FA.MinimizeSize            [functionAttributeKindP|OptimizeForSize|] -> return A.FA.OptimizeForSize-           [functionAttributeKindP|OptimizeNone|] -> return A.FA.OptimizeForSize+           [functionAttributeKindP|OptimizeNone|] -> return A.FA.OptimizeNone            [functionAttributeKindP|StackProtect|] -> return A.FA.StackProtect            [functionAttributeKindP|StackProtectReq|] -> return A.FA.StackProtectReq            [functionAttributeKindP|StackProtectStrong|] -> return A.FA.StackProtectStrong@@ -206,7 +206,7 @@   encodeM (index, as) = scopeAnyCont $ do     ab <- allocaAttrBuilder     builds <- mapM encodeM as-    forM builds ($ ab) :: EncodeAST [()]+    void (forM builds ($ ab) :: EncodeAST [()])     Context context <- gets encodeStateContext     liftIO $ FFI.getAttributeSet context index ab 

@@ -95,11 +95,11 @@ instance Monad m => EncodeM m (Maybe Word) (FFI.NothingAsMinusOne Word) where   encodeM = return . FFI.NothingAsMinusOne . maybe (-1) fromIntegral -instance Monad m => EncodeM m (Maybe Word) (CUInt, FFI.LLVMBool) where+instance Monad m => EncodeM m (Maybe Word32) (CUInt, FFI.LLVMBool) where   encodeM (Just a) = liftM2 (,) (encodeM a) (encodeM True)   encodeM Nothing = return (0,) `ap` (encodeM False) -instance Monad m => DecodeM m (Maybe Word) (CUInt, FFI.LLVMBool) where+instance Monad m => DecodeM m (Maybe Word32) (CUInt, FFI.LLVMBool) where   decodeM (a, isJust) = do     isJust' <- decodeM isJust     if isJust'

@@ -16,7 +16,7 @@ -- Sadly, there is occasionally some configuration one would like to control -- in LLVM which are accessible only as command line flags setting global state, -- as if the command line tools were the only use of LLVM. Very sad.-parseCommandLineOptions :: [String] -> Maybe String -> IO ()+parseCommandLineOptions :: [ShortByteString] -> Maybe ShortByteString -> IO () parseCommandLineOptions args overview = flip runAnyContT return $ do   args <- encodeM args   overview <- maybe (return nullPtr) encodeM overview

@@ -164,18 +164,24 @@         words <- decodeM (n, wsp)         return $ A.C.Int (A.typeBits t) (foldr (\b a -> (a `shiftL` 64) .|. fromIntegral b) 0 (words :: [Word64]))       [valueSubclassIdP|ConstantFP|] -> do-        let A.FloatingPointType nBits fmt = t+        let A.FloatingPointType fpt = t+        let nBits = case fpt of+                A.HalfFP      -> 16+                A.FloatFP     -> 32+                A.DoubleFP    -> 64+                A.FP128FP     -> 128+                A.X86_FP80FP  -> 80+                A.PPC_FP128FP -> 128         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+          case fpt of+            A.HalfFP      -> A.F.Half <$> peek (castPtr ws)+            A.FloatFP     -> A.F.Single <$> peek (castPtr ws)+            A.DoubleFP    -> A.F.Double <$> peek (castPtr ws)+            A.FP128FP     -> A.F.Quadruple <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0+            A.X86_FP80FP  -> A.F.X86_FP80 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0+            A.PPC_FP128FP -> A.F.PPC_FP128 <$> peekByteOff (castPtr ws) 8 <*> peekByteOff (castPtr ws) 0           )       [valueSubclassIdP|ConstantPointerNull|] -> return $ A.C.Null t       [valueSubclassIdP|ConstantAggregateZero|] -> return $ A.C.Null t

@@ -1,7 +1,8 @@ {-# LANGUAGE   GeneralizedNewtypeDeriving,   MultiParamTypeClasses,-  UndecidableInstances+  UndecidableInstances,+  OverloadedStrings   #-} module LLVM.Internal.DecodeAST where @@ -44,10 +45,10 @@     typesToDefine :: Seq (Ptr FFI.Type),     metadataNodesToDefine :: Seq (A.MetadataNodeID, Ptr FFI.MDNode),     metadataNodes :: Map (Ptr FFI.MDNode) A.MetadataNodeID,-    metadataKinds :: Array Word String,+    metadataKinds :: Array Word ShortByteString,     parameterAttributeSets :: Map FFI.ParameterAttributeSet [A.A.ParameterAttribute],     functionAttributeSetIDs :: Map FFI.FunctionAttributeSet A.A.GroupID,-    comdats :: Map (Ptr FFI.COMDAT) (String, A.COMDAT.SelectionKind)+    comdats :: Map (Ptr FFI.COMDAT) (ShortByteString, A.COMDAT.SelectionKind)   } initialDecode = DecodeState {     globalVarNum = Map.empty,

@@ -1,25 +1,27 @@ {-# LANGUAGE   GeneralizedNewtypeDeriving,   MultiParamTypeClasses,-  UndecidableInstances+  UndecidableInstances,+  OverloadedStrings   #-} module LLVM.Internal.EncodeAST where  import LLVM.Prelude -import Control.Exception import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.State-import Control.Monad.Trans.Except  import Foreign.Ptr import Foreign.C +import qualified LLVM.Internal.FFI.ShortByteString as ShortByteString+import qualified Data.ByteString.Short as ShortByteString+ import Data.Map (Map) import qualified Data.Map as Map -import qualified LLVM.Internal.FFI.Attribute as FFI  +import qualified LLVM.Internal.FFI.Attribute as FFI import qualified LLVM.Internal.FFI.Builder as FFI import qualified LLVM.Internal.FFI.GlobalValue as FFI import qualified LLVM.Internal.FFI.PtrHierarchy as FFI@@ -27,6 +29,7 @@  import qualified LLVM.AST as A import qualified LLVM.AST.Attribute as A.A+import LLVM.Exception  import LLVM.Internal.Context import LLVM.Internal.Coding@@ -46,17 +49,17 @@       encodeStateMDNodes :: Map A.MetadataNodeID (Ptr FFI.MDNode),       encodeStateNamedTypes :: Map A.Name (Ptr FFI.Type),       encodeStateAttributeGroups :: Map A.A.GroupID FFI.FunctionAttributeSet,-      encodeStateCOMDATs :: Map String (Ptr FFI.COMDAT)+      encodeStateCOMDATs :: Map ShortByteString (Ptr FFI.COMDAT)     } -newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (ExceptT String (StateT EncodeState IO)) a }+newtype EncodeAST a = EncodeAST { unEncodeAST :: AnyContT (StateT EncodeState IO) a }     deriving (        Functor,        Applicative,        Monad,        MonadIO,        MonadState EncodeState,-       MonadError String,+       MonadThrow,        MonadAnyCont IO,        ScopeAnyCont      )@@ -64,13 +67,13 @@ lookupNamedType :: A.Name -> EncodeAST (Ptr FFI.Type) lookupNamedType n = do   t <- gets $ Map.lookup n . encodeStateNamedTypes-  maybe (throwError $ "reference to undefined type: " ++ show n) return t+  maybe (throwM . EncodeException $ "reference to undefined type: " ++ show n) return t  defineType :: A.Name -> Ptr FFI.Type -> EncodeAST () defineType n t = modify $ \s -> s { encodeStateNamedTypes = Map.insert n t (encodeStateNamedTypes s) } -runEncodeAST :: Context -> EncodeAST a -> ExceptT String IO a-runEncodeAST context@(Context ctx) (EncodeAST a) = ExceptT $+runEncodeAST :: Context -> EncodeAST a -> IO a+runEncodeAST context@(Context ctx) (EncodeAST a) =     bracket (FFI.createBuilderInContext ctx) FFI.disposeBuilder $ \builder -> do       let initEncodeState = EncodeState {               encodeStateBuilder = builder,@@ -84,15 +87,15 @@               encodeStateAttributeGroups = Map.empty,               encodeStateCOMDATs = Map.empty             }-      flip evalStateT initEncodeState . runExceptT . flip runAnyContT return $ a+      flip evalStateT initEncodeState . flip runAnyContT return $ a  withName :: A.Name -> (CString -> IO a) -> IO a-withName (A.Name n) = withCString n+withName (A.Name n) = ShortByteString.useAsCString n withName (A.UnName _) = withCString ""  instance MonadAnyCont IO m => EncodeM m A.Name CString where   encodeM (A.Name n) = encodeM n-  encodeM _ = encodeM ""+  encodeM _ = encodeM ShortByteString.empty  phase :: EncodeAST a -> EncodeAST (EncodeAST a) phase p = do@@ -126,7 +129,7 @@ defineAttributeGroup :: A.A.GroupID -> FFI.FunctionAttributeSet -> EncodeAST () defineAttributeGroup gid attrs = modify $ \b -> b { encodeStateAttributeGroups = Map.insert gid attrs (encodeStateAttributeGroups b) } -defineCOMDAT :: String -> Ptr FFI.COMDAT -> EncodeAST ()+defineCOMDAT :: ShortByteString -> Ptr FFI.COMDAT -> EncodeAST () defineCOMDAT name cd = modify $ \b -> b { encodeStateCOMDATs = Map.insert name cd (encodeStateCOMDATs b) }  refer :: (Show n, Ord n) => (EncodeState -> Map n v) -> n -> EncodeAST v -> EncodeAST v@@ -135,7 +138,7 @@   maybe f return mop  undefinedReference :: Show n => String -> n -> EncodeAST a-undefinedReference m n = throwError $ "reference to undefined " ++ m ++ ": " ++ show n+undefinedReference m n = throwM . EncodeException $ "reference to undefined " ++ m ++ ": " ++ show n  referOrThrow :: (Show n, Ord n) => (EncodeState -> Map n v) -> String -> n -> EncodeAST v referOrThrow r m n = refer r n $ undefinedReference m n

@@ -1,6 +1,7 @@ {-# LANGUAGE   MultiParamTypeClasses,   FunctionalDependencies,+  OverloadedStrings,   RankNTypes   #-} module LLVM.Internal.ExecutionEngine where@@ -10,7 +11,6 @@ import Control.Exception import Control.Monad.IO.Class import Control.Monad.AnyCont-import Control.Monad.Trans.Except  import Data.IORef import Foreign.Ptr@@ -70,8 +70,8 @@   liftIO initializeNativeTarget   outExecutionEngine <- alloca   outErrorCStringPtr <- alloca-  dummyModule <- maybe (anyContToM $ liftM (either undefined id) . runExceptT-                            . withModuleFromAST c (A.Module "" "" Nothing Nothing []))+  dummyModule <- maybe (anyContToM $+                          withModuleFromAST c (A.Module "" "" Nothing Nothing []))                  (liftIO . newModule) m   dummyModule' <- readModule dummyModule   r <- liftIO $ createEngine outExecutionEngine dummyModule' outErrorCStringPtr@@ -106,10 +106,10 @@         size <- FFI.getMCJITCompilerOptionsSize         allocaBytes (fromIntegral size) $ \p -> do           FFI.initializeMCJITCompilerOptions p size-          maybe (return ()) (FFI.setMCJITCompilerOptionsOptLevel p <=< encodeM) opt-          maybe (return ()) (FFI.setMCJITCompilerOptionsCodeModel p <=< encodeM) cm-          maybe (return ()) (FFI.setMCJITCompilerOptionsNoFramePointerElim p <=< encodeM) fpe-          maybe (return ()) (FFI.setMCJITCompilerOptionsEnableFastISel p <=< encodeM) fisel+          traverse_ (FFI.setMCJITCompilerOptionsOptLevel p <=< encodeM) opt+          traverse_ (FFI.setMCJITCompilerOptionsCodeModel p <=< encodeM) cm+          traverse_ (FFI.setMCJITCompilerOptionsNoFramePointerElim p <=< encodeM) fpe+          traverse_ (FFI.setMCJITCompilerOptionsEnableFastISel p <=< encodeM) fisel           FFI.createMCJITCompilerForModule e m p size s   t <- newIORef (Deferred $ \mod f -> do m' <- readModule mod                                          withExecutionEngine c (Just m') createMCJITCompilerForModule f)

@@ -115,9 +115,9 @@ 	ab.addStackAlignmentAttr(v); } -void LLVM_Hs_AttrBuilderAddAllocSize(AttrBuilder &ab, unsigned x, LLVMBool optionalIsThere, unsigned y) {+void LLVM_Hs_AttrBuilderAddAllocSize(AttrBuilder &ab, unsigned x, unsigned y, LLVMBool optionalIsThere) {     if (optionalIsThere) {-        ab.addAllocSizeAttr(x, y);+        ab.addAllocSizeAttr(x, Optional<unsigned>(y));     } else {         ab.addAllocSizeAttr(x, Optional<unsigned>());     }

@@ -10,6 +10,7 @@ import Foreign.Ptr  import LLVM.Internal.FFI.LLVMCTypes+import LLVM.Internal.FFI.PtrHierarchy  data DataLayout @@ -24,3 +25,6 @@  foreign import ccall unsafe "LLVMCopyStringRepOfTargetData" dataLayoutToString ::   Ptr DataLayout -> IO (OwnerTransfered CString)++foreign import ccall unsafe "LLVMABISizeOfType" getTypeAllocSize ::+  Ptr DataLayout -> Ptr Type -> IO Word64

@@ -59,6 +59,9 @@  newtype LLVMBool = LLVMBool CUInt +-- | If an FFI function returns a value wrapped in 'OwnerTransfered',+-- this value needs to be freed after it has been processed. Usually+-- this is done automatically in the 'DecodeM' instance. newtype OwnerTransfered a = OwnerTransfered a   deriving (Storable) @@ -69,10 +72,10 @@   deriving (Storable)  newtype CPPOpcode = CPPOpcode CUInt-  deriving (Eq, Ord, Show, Typeable, Data)+  deriving (Eq, Ord, Show, Typeable, Data, Generic)  newtype ICmpPredicate = ICmpPredicate CUInt-  deriving (Eq, Ord, Show, Typeable, Data)+  deriving (Eq, Ord, Show, Typeable, Data, Generic) #{enum ICmpPredicate, ICmpPredicate,  iCmpPredEQ = LLVMIntEQ,  iCmpPredNE = LLVMIntNE,@@ -87,7 +90,7 @@ }  newtype FCmpPredicate = FCmpPredicate CUInt-  deriving (Eq, Ord, Show, Typeable, Data)+  deriving (Eq, Ord, Show, Typeable, Data, Generic) #{enum FCmpPredicate, FCmpPredicate,  fCmpPredFalse = LLVMRealPredicateFalse,  fCmpPredOEQ = LLVMRealOEQ,@@ -111,117 +114,117 @@   deriving (Storable)  newtype FastMathFlags = FastMathFlags CUInt-  deriving (Eq, Ord, Show, Typeable, Data, Num, Bits)+  deriving (Eq, Ord, Show, Typeable, Data, Num, Bits, Generic) #define FMF_Rec(n,l) { #n, LLVM ## n, }, #{inject FAST_MATH_FLAG, FastMathFlags, FastMathFlags, fastMathFlags, FMF_Rec}  newtype MemoryOrdering = MemoryOrdering CUInt-  deriving (Eq, Typeable, Data)+  deriving (Eq, Typeable, Data, Generic) #define MO_Rec(n) { #n, LLVMAtomicOrdering ## n }, #{inject ATOMIC_ORDERING, MemoryOrdering, MemoryOrdering, memoryOrdering, MO_Rec}  newtype UnnamedAddr = UnnamedAddr CUInt-  deriving (Eq, Typeable, Data)+  deriving (Eq, Typeable, Data, Generic) #define UA_Rec(n) { #n, LLVMUnnamedAddr ## n }, #{inject UNNAMED_ADDR, UnnamedAddr, UnnamedAddr, unnamedAddr, UA_Rec}  newtype SynchronizationScope = SynchronizationScope CUInt-  deriving (Eq, Typeable, Data)+  deriving (Eq, Typeable, Data, Generic) #define SS_Rec(n) { #n, LLVM ## n ## SynchronizationScope }, #{inject SYNCRONIZATION_SCOPE, SynchronizationScope, SynchronizationScope, synchronizationScope, SS_Rec}  newtype TailCallKind = TailCallKind CUInt-  deriving (Eq, Typeable, Data)+  deriving (Eq, Typeable, Data, Generic) #define TCK_Rec(n) { #n, LLVM_Hs_TailCallKind_ ## n }, #{inject TAIL_CALL_KIND, TailCallKind, TailCallKind, tailCallKind, TCK_Rec}  newtype Linkage = Linkage CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define VIS_Rec(n) { #n, LLVM ## n ## Visibility }, #{inject VISIBILITY, Visibility, Visibility, visibility, VIS_Rec}  newtype COMDATSelectionKind = COMDATSelectionKind CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define CSK(n) { #n, LLVM_Hs_COMDAT_Selection_Kind_ ## n }, #{inject COMDAT_SELECTION_KIND, COMDATSelectionKind, COMDATSelectionKind, comdatSelectionKind, CSK}  newtype DLLStorageClass = DLLStorageClass CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define DLLSC_Rec(n) { #n, LLVM ## n ## StorageClass }, #{inject DLL_STORAGE_CLASS, DLLStorageClass, DLLStorageClass, dllStorageClass, DLLSC_Rec}  newtype CallingConvention = CallingConvention CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define CC_Rec(l, n) { #l, LLVM_Hs_CallingConvention_ ## l }, #{inject CALLING_CONVENTION, CallingConvention, CallingConvention, callingConvention, CC_Rec}  newtype ThreadLocalMode = ThreadLocalMode CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define TLS_Rec(n) { #n, LLVM ## n }, #{inject THREAD_LOCAL_MODE, ThreadLocalMode, ThreadLocalMode, threadLocalMode, TLS_Rec}  newtype ValueSubclassId = ValueSubclassId CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define RMWOp_Rec(n) { #n, LLVMAtomicRMWBinOp ## n }, #{inject RMW_OPERATION, RMWOperation, RMWOperation, rmwOperation, RMWOp_Rec}  newtype RelocModel = RelocModel CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #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)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define FAT_Rec(n) { #n, LLVM_Hs_FloatABI_ ## n }, #{inject FLOAT_ABI, FloatABIType, FloatABIType, floatABI, FAT_Rec}  newtype FPOpFusionMode = FPOpFusionMode CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define FPOFM_Rec(n) { #n, LLVM_Hs_FPOpFusionMode_ ## n }, #{inject FP_OP_FUSION_MODE, FPOpFusionMode, FPOpFusionMode, fpOpFusionMode, FPOFM_Rec}  newtype TargetOptionFlag = TargetOptionFlag CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define TOF_Rec(n) { #n, LLVM_Hs_TargetOptionFlag_ ## n }, #{inject TARGET_OPTION_FLAG, TargetOptionFlag, TargetOptionFlag, targetOptionFlag, TOF_Rec}  newtype TypeKind = TypeKind CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define TK_Rec(n) { #n, LLVM ## n ## TypeKind }, #{inject TYPE_KIND, TypeKind, TypeKind, typeKind, TK_Rec} @@ -236,31 +239,31 @@ #define OR_FF F #define OR(x,y) OR_ ## x ## y newtype ParameterAttributeKind = ParameterAttributeKind CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define PAK_Rec(n,p,r,f) IF(OR(p,r))({ #n COMMA LLVM_Hs_AttributeKind_ ## n} COMMA) #{inject ATTRIBUTE_KIND, ParameterAttributeKind, ParameterAttributeKind, parameterAttributeKind, PAK_Rec}  newtype FunctionAttributeKind = FunctionAttributeKind CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define FAK_Rec(n,p,r,f) IF(f)({ #n COMMA LLVM_Hs_AttributeKind_ ## n} COMMA) #{inject ATTRIBUTE_KIND, FunctionAttributeKind, FunctionAttributeKind, functionAttributeKind, FAK_Rec}  newtype FloatSemantics = FloatSemantics CUInt-  deriving (Eq, Read, Show, Typeable, Data)+  deriving (Eq, Read, Show, Typeable, Data, Generic) #define FS_Rec(n) { #n, LLVMFloatSemantics ## n }, #{inject FLOAT_SEMANTICS, FloatSemantics, FloatSemantics, floatSemantics, FS_Rec}  newtype VerifierFailureAction = VerifierFailureAction CUInt-  deriving (Eq, Read, Show, Bits, Typeable, Data, Num)+  deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Generic) #define VFA_Rec(n) { #n, LLVM ## n ## Action }, #{inject VERIFIER_FAILURE_ACTION, VerifierFailureAction, VerifierFailureAction, verifierFailureAction, VFA_Rec}  newtype LibFunc = LibFunc CUInt-  deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable)+  deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable, Generic) #define LF_Rec(n) { #n, LLVMLibFunc__ ## n }, #{inject LIB_FUNC, LibFunc, LibFunc, libFunc__, LF_Rec}  newtype JITSymbolFlags = JITSymbolFlags CUInt-  deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable)+  deriving (Eq, Read, Show, Bits, Typeable, Data, Num, Storable, Generic) #define SF_Rec(n) { #n, LLVMJITSymbolFlag ## n }, #{inject JIT_SYMBOL_FLAG, JITSymbolFlags, JITSymbolFlags, jitSymbolFlags, SF_Rec}

@@ -0,0 +1,44 @@+module LLVM.Internal.FFI.ShortByteString+  ( packCString+  , packCStringLen+  , useAsCString+  , useAsCStringLen+  ) where++import LLVM.Prelude++import Data.ByteString.Internal (c_strlen)+import Data.ByteString.Short.Internal+import qualified Data.ByteString.Short as ByteString+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Storable++{-# INLINABLE packCString #-}+packCString :: CString -> IO ShortByteString+packCString cstr = do+    len <- c_strlen cstr+    packCStringLen (cstr, fromIntegral len)++{-# INLINABLE packCStringLen #-}+packCStringLen :: CStringLen -> IO ShortByteString+packCStringLen (cstr, len) | len >= 0 = createFromPtr cstr len+packCStringLen (_, len) =+    error ("negative length: " ++ show len)++{-# INLINABLE useAsCString #-}+useAsCString :: ShortByteString -> (CString -> IO a) -> IO a+useAsCString bs action =+ allocaBytes (l+1) $ \buf -> do+     copyToPtr bs 0 buf (fromIntegral l)+     pokeByteOff buf l (0::Word8)+     action buf+ where l = ByteString.length bs++{-# INLINABLE useAsCStringLen #-}+useAsCStringLen :: ShortByteString -> (CStringLen -> IO a) -> IO a+useAsCStringLen bs action =+ allocaBytes l $ \buf -> do+     copyToPtr bs 0 buf (fromIntegral l)+     action (buf, l)+ where l = ByteString.length bs

@@ -43,10 +43,10 @@        `ap` getLocalName param        `ap` (return $ Map.findWithDefault [] i attrs)   -getGC :: Ptr FFI.Function -> DecodeAST (Maybe String)+getGC :: Ptr FFI.Function -> DecodeAST (Maybe ShortByteString) getGC f = scopeAnyCont $ decodeM =<< liftIO (FFI.getGC f) -setGC :: Ptr FFI.Function -> Maybe String -> EncodeAST ()+setGC :: Ptr FFI.Function -> Maybe ShortByteString -> EncodeAST () setGC f gc = scopeAnyCont $ liftIO . FFI.setGC f =<< encodeM gc   getPrefixData :: Ptr FFI.Function -> DecodeAST (Maybe A.Constant)@@ -57,7 +57,7 @@    else return Nothing  setPrefixData :: Ptr FFI.Function -> Maybe A.Constant -> EncodeAST ()-setPrefixData f = maybe (return ()) (liftIO . FFI.setPrefixData f <=< encodeM)+setPrefixData f = traverse_ (liftIO . FFI.setPrefixData f <=< encodeM)  getPersonalityFn :: Ptr FFI.Function -> DecodeAST (Maybe A.Constant) getPersonalityFn f = do

@@ -1,6 +1,7 @@ {-# LANGUAGE   TemplateHaskell,-  MultiParamTypeClasses+  MultiParamTypeClasses,+  OverloadedStrings   #-} module LLVM.Internal.Global where @@ -70,7 +71,7 @@ setDLLStorageClass :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe A.DLL.StorageClass -> EncodeAST () setDLLStorageClass g sc = liftIO . FFI.setDLLStorageClass (FFI.upCast g) =<< encodeM sc -getSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe String)+getSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe ShortByteString) getSection g = do   sectionLengthPtr <- alloca   sectionNamePtr <- liftIO $ FFI.getSection (FFI.upCast g) sectionLengthPtr@@ -81,9 +82,9 @@          sectionName <- decodeM (sectionNamePtr, sectionLength)          return (Just sectionName) -setSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe String -> EncodeAST ()+setSection :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> Maybe ShortByteString -> EncodeAST () setSection g s = scopeAnyCont $ do-  s <- encodeM (maybe "" id s)+  s <- encodeM (fromMaybe "" s)   liftIO $ FFI.setSection (FFI.upCast g) s  genCodingInstance [t| A.COMDAT.SelectionKind |] ''FFI.COMDATSelectionKind [@@ -94,12 +95,13 @@   (FFI.comdatSelectionKindSameSize, A.COMDAT.SameSize)  ] -instance DecodeM DecodeAST (String, A.COMDAT.SelectionKind) (Ptr FFI.COMDAT) where-  decodeM c = return (,)-              `ap` (decodeM $ FFI.getCOMDATName c)-              `ap` (decodeM =<< liftIO (FFI.getCOMDATSelectionKind c))+instance DecodeM DecodeAST (ShortByteString, A.COMDAT.SelectionKind) (Ptr FFI.COMDAT) where+  decodeM c =+    (,)+      <$> decodeM (FFI.getCOMDATName c)+      <*> (decodeM =<< liftIO (FFI.getCOMDATSelectionKind c)) -getCOMDATName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe String)+getCOMDATName :: FFI.DescendentOf FFI.GlobalValue v => Ptr v -> DecodeAST (Maybe ShortByteString) getCOMDATName g = do   c <- liftIO $ FFI.getCOMDAT (FFI.upCast g)   if c == nullPtr@@ -113,7 +115,7 @@           modify $ \s -> s { comdats = Map.insert c cd cds }           return name -setCOMDAT :: FFI.DescendentOf FFI.GlobalObject v => Ptr v -> Maybe String -> EncodeAST ()+setCOMDAT :: FFI.DescendentOf FFI.GlobalObject v => Ptr v -> Maybe ShortByteString -> EncodeAST () setCOMDAT _ Nothing = return () setCOMDAT g (Just name) = do   cd <- referCOMDAT name

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

@@ -1,6 +1,7 @@ {-# LANGUAGE   TemplateHaskell,-  MultiParamTypeClasses+  MultiParamTypeClasses,+  OverloadedStrings   #-} module LLVM.Internal.InlineAssembly where  @@ -8,6 +9,8 @@  import Control.Monad.IO.Class +import qualified Data.ByteString.Char8 as ByteString+ import Foreign.C import Foreign.Ptr @@ -59,10 +62,5 @@  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-    +    s' <- decodeM s+    return . map A.ModuleInlineAssembly $ ByteString.lines s'

@@ -15,13 +15,13 @@ import LLVM.Internal.InstructionDefs (instrP)  import Control.Monad.AnyCont-import Control.Monad.Error.Class import Control.Monad.IO.Class import Control.Monad.State (gets)  import Foreign.Ptr  import Control.Exception (assert)+import Control.Monad.Catch import qualified Data.Map as Map import qualified Data.List as List import Data.List.NonEmpty (NonEmpty((:|)))@@ -52,6 +52,7 @@  import qualified LLVM.AST as A import qualified LLVM.AST.Constant as A.C+import LLVM.Exception  callInstAttributeSet :: Ptr FFI.Instruction -> DecodeAST MixedAttributeSet callInstAttributeSet = decodeM <=< liftIO . FFI.getCallSiteAttributeSet@@ -62,7 +63,7 @@          ks <- allocaArray n          ps <- allocaArray n          n' <- liftIO $ FFI.getMetadata i ks ps n-         if (n' > n) +         if (n' > n)           then getMetadata n'           else return zip `ap` decodeM (n', ks) `ap` decodeM (n', ps)   getMetadata 4@@ -96,7 +97,7 @@              trueDest <- successor 2              return $ A.CondBr {                A.condition = condition,-               A.falseDest = falseDest, +               A.falseDest = falseDest,                A.trueDest = trueDest,                A.metadata' = md              }@@ -133,7 +134,7 @@         f <- decodeM fv         args <- forM [1..nOps-3] $ \j -> do                   let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes attrs)-                  return (, pAttrs) `ap` op (j-1) +                  return (, pAttrs) `ap` op (j-1)         rd <- successor (nOps - 2)         ed <- successor (nOps - 1)         return A.Invoke {@@ -209,18 +210,18 @@         op0' <- encodeM op0         dd' <- encodeM dd         i <- liftIO $ FFI.buildSwitch builder op0' dd' (fromIntegral $ length ds)-        forM ds $ \(v,d) -> do+        forM_ ds $ \(v,d) -> do           v' <- encodeM v           d' <- encodeM d           liftIO $ FFI.addCase i v' d'         return $ FFI.upCast i-      A.IndirectBr { +      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+        forM_ dests $ \dest -> do           d <- encodeM dest           liftIO $ FFI.addDestination i d         return $ FFI.upCast i@@ -244,7 +245,7 @@         cc <- encodeM cc         liftIO $ FFI.setCallSiteCallingConvention i cc         return $ FFI.upCast i-      A.Resume { +      A.Resume {         A.operand0' = op0       } -> do         op0' <- encodeM op0@@ -280,7 +281,7 @@         mapM_ (liftIO . FFI.catchSwitchAddHandler i <=< encodeM) catchHandlers         return i     setMD t' (A.metadata' t)-    return t'      +    return t'  $(do   let findInstrFields s = Map.findWithDefault (error $ "instruction missing from AST: " ++ show s) s@@ -335,7 +336,7 @@                                          let pAttrs = Map.findWithDefault [] (j-1) (parameterAttributes $(TH.dyn "attrs"))                                          p <- op (j-1)                                          return (p, pAttrs) |])-                "clauses" -> +                "clauses" ->                   ([], [|do                           nClauses <- liftIO $ FFI.getNumClauses i                           -- We need to convert nClauses to a signed@@ -355,13 +356,13 @@                               ib <- decodeM =<< (liftIO $ FFI.getIncomingBlock i m)                               return (iv,ib) |])                 "allocatedType" -> ([], [| decodeM =<< liftIO (FFI.getAllocatedType i) |])-                "numElements" -> +                "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) |])@@ -391,17 +392,17 @@             | (lrn, iDef) <- Map.toList ID.instructionDefs,               ID.instructionKind iDef /= ID.Terminator,               let opcodeP = TH.dataToPatQ (const Nothing) (ID.cppOpcode iDef)-                  handlerBody = +                  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 +                       | n <- allNames . map TH.nameBase $ fieldNames+                      ] ++ [+                       TH.noBindS [|+                        return $(TH.recConE                                  fullName                                  [ (f,) <$> (TH.varE . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])                         |]@@ -415,7 +416,7 @@         let return' i = return (FFI.upCast i, return ())         s <- encodeM ""         (inst, act) <- case o of-          A.ICmp { +          A.ICmp {             A.iPredicate = pred,             A.operand0 = op0,             A.operand1 = op1@@ -459,7 +460,7 @@             (n, argvs) <- encodeM argvs             i <- liftIO $ FFI.buildCall builder fv argvs n s             attrs <- encodeM $ MixedAttributeSet fAttrs rAttrs (Map.fromList (zip [0..] argAttrs))-            liftIO $ FFI.setCallSiteAttributeSet i attrs     +            liftIO $ FFI.setCallSiteAttributeSet i attrs             tck <- encodeM tck             liftIO $ FFI.setTailCallKind i tck             cc <- encodeM cc@@ -504,30 +505,30 @@             (n, is') <- encodeM is             i <- liftIO $ FFI.buildInsertValue builder a' e' is' n s             return' i-          A.LandingPad { +          A.LandingPad {             A.type' = t,-            A.cleanup = cl, +            A.cleanup = cl,             A.clauses = cs           } -> do             t' <- encodeM t             i <- liftIO $ FFI.buildLandingPad builder t' (fromIntegral $ length cs) s-            forM cs $ \c -> +            forM_ cs $ \c ->               case c of                 A.Catch a -> do                   cn <- encodeM a                   isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)-                  when isArray $ throwError $ "Catch clause cannot take an array: " ++ show c+                  when isArray $ throwM . EncodeException $ "Catch clause cannot take an array: " ++ show c                   liftIO $ FFI.addClause i cn                 A.Filter a -> do                   cn <- encodeM a                   isArray <- liftIO $ isArrayType =<< FFI.typeOf (FFI.upCast cn)-                  unless isArray $ throwError $ "filter clause must take an array: " ++ show c+                  unless isArray $ throwM . EncodeException $ "filter clause must take an array: " ++ show c                   liftIO $ FFI.addClause i cn             when cl $ do               cl <- encodeM cl               liftIO $ FFI.setCleanup i cl             return' i-          A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do +          A.Alloca { A.allocatedType = alt, A.numElements = n, A.alignment = alignment } -> do              alt' <- encodeM alt              n' <- encodeM n              i <- liftIO $ FFI.buildAlloca builder alt' n' s@@ -544,7 +545,7 @@             i <- liftIO $ FFI.buildCatchPad builder catchSwitch' args' numArgs s             return' i           o -> $(TH.caseE [| o |] [-                   TH.match +                   TH.match                    (TH.recP fullName [ (f,) <$> (TH.varP . TH.mkName . TH.nameBase $ f) | f <- fieldNames ])                    (TH.normalB (TH.doE handlerBody))                    []@@ -561,11 +562,11 @@                      encodeMFields = map TH.nameBase fieldNames List.\\ [ "metadata" ]                      handlerBody = ([                        TH.bindS (if s == "fastMathFlags" then TH.tupP [] else TH.varP (TH.mkName s))-                           [| encodeM $(TH.dyn s) |] | s <- encodeMFields +                           [| encodeM $(TH.dyn s) |] | s <- encodeMFields                       ] ++ [                        TH.bindS (TH.varP (TH.mkName "i")) [| liftIO $ $(-                          foldl1 TH.appE . map TH.dyn $ -                           [ "FFI.build" ++ name, "builder" ] ++ (encodeMFields List.\\ [ "fastMathFlags" ]) ++ [ "s" ] +                          foldl1 TH.appE . map TH.dyn $+                           [ "FFI.build" ++ name, "builder" ] ++ (encodeMFields List.\\ [ "fastMathFlags" ]) ++ [ "s" ]                         ) |],                        TH.noBindS [| return' $(TH.dyn "i") |]                       ])@@ -603,5 +604,3 @@     liftIO $ FFI.setValueName v n'     defineLocal n v     return later--

@@ -6,17 +6,16 @@  import LLVM.Prelude -import Control.Exception import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.IO.Class import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Foreign.Ptr +import LLVM.Exception import LLVM.Internal.Coding import LLVM.Internal.String-import LLVM.Internal.Inject import qualified LLVM.Internal.FFI.LLVMCTypes as FFI import qualified LLVM.Internal.FFI.MemoryBuffer as FFI @@ -24,7 +23,7 @@   = Bytes { name :: String,  content :: BS.ByteString }   | File { pathName :: String } -instance (Inject String e, MonadError e m, Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer)) where+instance (MonadThrow 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@@ -39,10 +38,10 @@         result <- decodeM =<< (liftIO $ FFI.createMemoryBufferWithContentsOfFile pathName mbPtr msgPtr)         when result $ do           msg <- decodeM msgPtr-          throwError (inject (msg :: String))+          throwM (EncodeException msg)         peek mbPtr           -instance (Inject String e, MonadError e m, Monad m, MonadIO m, MonadAnyCont IO m) => EncodeM m Specification (Ptr FFI.MemoryBuffer) where+instance (MonadThrow 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

@@ -23,7 +23,7 @@ import LLVM.Internal.DecodeAST import LLVM.Internal.Value () -instance EncodeM EncodeAST String FFI.MDKindID where+instance EncodeM EncodeAST ShortByteString FFI.MDKindID where   encodeM s = do     Context c <- gets encodeStateContext     s <- encodeM s@@ -45,10 +45,10 @@   strs <- g 16   modify $ \s -> s { metadataKinds = Array.listArray (0, fromIntegral (length strs) - 1) strs } -instance DecodeM DecodeAST String FFI.MDKindID where+instance DecodeM DecodeAST ShortByteString FFI.MDKindID where   decodeM (FFI.MDKindID k) = gets $ (Array.! (fromIntegral k)) . metadataKinds -instance DecodeM DecodeAST String (Ptr FFI.MDString) where+instance DecodeM DecodeAST ShortByteString (Ptr FFI.MDString) where   decodeM p = do     np <- alloca     s <- liftIO $ FFI.getMDString p np

@@ -9,9 +9,8 @@  import LLVM.Prelude -import Control.Exception import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.Trans.Except import Control.Monad.State (gets) import Control.Monad.Trans@@ -20,6 +19,7 @@ import Foreign.C import Data.IORef import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as SBS import qualified Data.Map as Map  import qualified LLVM.Internal.FFI.Assembly as FFI@@ -47,7 +47,6 @@ import LLVM.Internal.EncodeAST import LLVM.Internal.Function import LLVM.Internal.Global-import LLVM.Internal.Inject import LLVM.Internal.Instruction () import qualified LLVM.Internal.MemoryBuffer as MB import LLVM.Internal.Metadata@@ -59,7 +58,7 @@ import LLVM.Internal.Value  import LLVM.DataLayout-import LLVM.Diagnostic+import LLVM.Exception  import qualified LLVM.AST as A import qualified LLVM.AST.DataLayout as A@@ -86,29 +85,27 @@ newtype File = File FilePath   deriving (Eq, Ord, Read, Show) -instance Inject String (Either String Diagnostic) where-    inject = Left- -- | link LLVM modules - move or copy parts of a source module into a -- destination module.  Note that this operation is not commutative - -- not only concretely (e.g. the destination module is modified, -- becoming the result) but abstractly (e.g. unused private globals in -- the source module do not appear in the result, but similar globals--- in the destination remain). The source module is destroyed.+-- in the destination remain). The source module is destroyed. May+-- throw a 'LinkException'. linkModules ::      Module -- ^ The module into which to link   -> Module -- ^ The module to link into the other (this module is destroyed)-  -> ExceptT String IO ()+  -> IO () linkModules dest src  = flip runAnyContT return $ do   dest' <- readModule dest   src' <- readModule src   result <- decodeM =<< liftIO (FFI.linkModules dest' src')   -- linkModules takes care of deleting the sourcemodule   liftIO $ deleteModule src-  when result (throwError "Couldn’t link modules")+  when result (throwM $ LinkException "Couldn’t link modules")  class LLVMAssemblyInput s where-  llvmAssemblyMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)+  llvmAssemblyMemoryBuffer :: (MonadThrow m, MonadIO m, MonadAnyCont IO m)                               => s -> m (FFI.OwnerTransfered (Ptr FFI.MemoryBuffer))  instance LLVMAssemblyInput (String, String) where@@ -116,30 +113,37 @@     UTF8ByteString bs <- encodeM s     encodeM (MB.Bytes id bs) +instance LLVMAssemblyInput (String, ByteString) where+  llvmAssemblyMemoryBuffer (id, s) = do+    encodeM (MB.Bytes id s)+ instance LLVMAssemblyInput String where   llvmAssemblyMemoryBuffer s = llvmAssemblyMemoryBuffer ("<string>", s) +instance LLVMAssemblyInput ByteString where+  llvmAssemblyMemoryBuffer s = llvmAssemblyMemoryBuffer ("<string>", s)+ instance LLVMAssemblyInput File where   llvmAssemblyMemoryBuffer (File p) = encodeM (MB.File p) --- | parse 'Module' from LLVM assembly+-- | parse 'Module' from LLVM assembly. May throw 'ParseFailureException'. withModuleFromLLVMAssembly :: LLVMAssemblyInput s-                              => Context -> s -> (Module -> IO a) -> ExceptT String IO a+                              => Context -> s -> (Module -> IO a) -> IO a withModuleFromLLVMAssembly (Context c) s f = flip runAnyContT return $ do   mb <- llvmAssemblyMemoryBuffer s   msgPtr <- alloca   m <- anyContToM $ bracket (newModule =<< FFI.parseLLVMAssembly c mb msgPtr) (FFI.disposeModule <=< readModule)   m' <- readModule m-  when (m' == nullPtr) $ throwError =<< decodeM msgPtr+  when (m' == nullPtr) $ throwM . ParseFailureException =<< decodeM msgPtr   liftIO $ f m  -- | generate LLVM assembly from a 'Module'-moduleLLVMAssembly :: Module -> IO String+moduleLLVMAssembly :: Module -> IO ByteString moduleLLVMAssembly m = do   resultRef <- newIORef Nothing   let saveBuffer :: Ptr CChar -> CSize -> IO ()       saveBuffer start size = do-        r <- decodeM (start, fromIntegral size)+        r <- decodeM (start, size)         writeIORef resultRef (Just r)   m' <- readModule m   FFI.withBufferRawPWriteStream saveBuffer $ FFI.writeLLVMAssembly m' . FFI.upCast@@ -147,13 +151,13 @@   return s  -- | write LLVM assembly for a 'Module' to a file-writeLLVMAssemblyToFile :: File -> Module -> ExceptT String IO ()+writeLLVMAssemblyToFile :: File -> Module -> IO () writeLLVMAssemblyToFile (File path) m = flip runAnyContT return $ do   m' <- readModule m-  withFileRawOStream path False True $ liftIO . (FFI.writeLLVMAssembly m')+  withFileRawOStream path False True $ FFI.writeLLVMAssembly m'  class BitcodeInput b where-  bitcodeMemoryBuffer :: (Inject String e, MonadError e m, MonadIO m, MonadAnyCont IO m)+  bitcodeMemoryBuffer :: (MonadThrow m, MonadIO m, MonadAnyCont IO m)                          => b -> m (Ptr FFI.MemoryBuffer)  instance BitcodeInput (String, BS.ByteString) where@@ -162,69 +166,71 @@ instance BitcodeInput File where   bitcodeMemoryBuffer (File p) = encodeM (MB.File p) --- | parse 'Module' from LLVM bitcode-withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> ExceptT String IO a+-- | parse 'Module' from LLVM bitcode. May throw 'ParseFailureException'.+withModuleFromBitcode :: BitcodeInput b => Context -> b -> (Module -> IO a) -> IO a withModuleFromBitcode (Context c) b f = flip runAnyContT return $ do   mb <- bitcodeMemoryBuffer b   msgPtr <- alloca   m <- anyContToM $ bracket (newModule =<< FFI.parseBitcode c mb msgPtr) (FFI.disposeModule <=< readModule)   m' <- readModule m-  when (m' == nullPtr) $ throwError =<< decodeM msgPtr+  when (m' == nullPtr) $ throwM . ParseFailureException =<< decodeM msgPtr   liftIO $ f m  -- | generate LLVM bitcode from a 'Module' moduleBitcode :: Module -> IO BS.ByteString moduleBitcode m = do   m' <- readModule m-  r <- runExceptT $ withBufferRawOStream (liftIO . FFI.writeBitcode m')-  either fail return r+  withBufferRawOStream (FFI.writeBitcode m')  -- | write LLVM bitcode from a 'Module' into a file-writeBitcodeToFile :: File -> Module -> ExceptT String IO ()+writeBitcodeToFile :: File -> Module -> IO () writeBitcodeToFile (File path) m = flip runAnyContT return $ do   m' <- readModule m-  withFileRawOStream path False False $ liftIO . FFI.writeBitcode m'+  withFileRawOStream path False False $ FFI.writeBitcode m' -targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawPWriteStream -> ExceptT String IO ()+-- | May throw 'TargetMachineEmitException'.+targetMachineEmit :: FFI.CodeGenFileType -> TargetMachine -> Module -> Ptr FFI.RawPWriteStream -> IO () targetMachineEmit fileType (TargetMachine tm) m os = flip runAnyContT return $ do   msgPtr <- alloca   m' <- readModule m   r <- decodeM =<< (liftIO $ FFI.targetMachineEmit tm m' os fileType msgPtr)-  when r $ throwError =<< decodeM msgPtr+  when r $ throwM . TargetMachineEmitException =<< decodeM msgPtr -emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> ExceptT String IO ()+-- | May throw 'FdStreamException' and 'TargetMachineEmitException'.+emitToFile :: FFI.CodeGenFileType -> TargetMachine -> File -> Module -> IO () emitToFile fileType tm (File path) m = flip runAnyContT return $ do   withFileRawPWriteStream path False False $ targetMachineEmit fileType tm m -emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> ExceptT String IO BS.ByteString+-- | May throw 'TargetMachineEmitException'.+emitToByteString :: FFI.CodeGenFileType -> TargetMachine -> Module -> IO BS.ByteString emitToByteString fileType tm m = flip runAnyContT return $ do   withBufferRawPWriteStream $ targetMachineEmit fileType tm m  -- | write target-specific assembly directly into a file-writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> ExceptT String IO ()+writeTargetAssemblyToFile :: TargetMachine -> File -> Module -> IO () writeTargetAssemblyToFile = emitToFile FFI.codeGenFileTypeAssembly --- | produce target-specific assembly as a 'String'-moduleTargetAssembly :: TargetMachine -> Module -> ExceptT String IO String-moduleTargetAssembly tm m = decodeM . UTF8ByteString =<< emitToByteString FFI.codeGenFileTypeAssembly tm m+-- | produce target-specific assembly as a 'ByteString'+moduleTargetAssembly :: TargetMachine -> Module -> IO ByteString+moduleTargetAssembly tm m = emitToByteString FFI.codeGenFileTypeAssembly tm m  -- | produce target-specific object code as a 'ByteString'-moduleObject :: TargetMachine -> Module -> ExceptT String IO BS.ByteString+moduleObject :: TargetMachine -> Module -> IO BS.ByteString moduleObject = emitToByteString FFI.codeGenFileTypeObject  -- | write target-specific object code directly into a file-writeObjectToFile :: TargetMachine -> File -> Module -> ExceptT String IO ()+writeObjectToFile :: TargetMachine -> File -> Module -> IO () writeObjectToFile = emitToFile FFI.codeGenFileTypeObject -setTargetTriple :: Ptr FFI.Module -> String -> EncodeAST ()+setTargetTriple :: Ptr FFI.Module -> ShortByteString -> EncodeAST () setTargetTriple m t = do   t <- encodeM t   liftIO $ FFI.setTargetTriple m t -getTargetTriple :: Ptr FFI.Module -> IO (Maybe String)+getTargetTriple :: Ptr FFI.Module -> IO (Maybe ShortByteString) getTargetTriple m = do   s <- decodeM =<< liftIO (FFI.getTargetTriple m)-  return $ if s == "" then Nothing else Just s+  return $ if SBS.null s then Nothing else Just s  setDataLayout :: Ptr FFI.Module -> A.DataLayout -> EncodeAST () setDataLayout m dl = do@@ -236,11 +242,9 @@   dlString <- decodeM =<< FFI.getDataLayout m   either fail return . runExcept . parseDataLayout A.BigEndian $ dlString --- | This function will call disposeModule after the callback--- exits. Calling 'deleteModule' prevents double free errors. As long--- as you only call functions provided by llvm-hs this should not--- be necessary since llvm-hs takes care of this.-withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> ExceptT String IO a+-- | Execute a function after encoding the module in LLVM’s internal representation.+-- May throw 'EncodeException'.+withModuleFromAST :: Context -> A.Module -> (Module -> IO a) -> IO a withModuleFromAST context@(Context c) (A.Module moduleId sourceFileName dataLayout triple definitions) f = runEncodeAST context $ do   moduleId <- encodeM moduleId   m <- anyContToM $ bracket (newModule =<< FFI.moduleCreateWithNameInContext moduleId c) (FFI.disposeModule <=< readModule)@@ -248,8 +252,8 @@   sourceFileName' <- encodeM sourceFileName   liftIO $ FFI.setSourceFileName ffiMod sourceFileName'   Context context <- gets encodeStateContext-  maybe (return ()) (setDataLayout ffiMod) dataLayout-  maybe (return ()) (setTargetTriple ffiMod) triple+  traverse_ (setDataLayout ffiMod) dataLayout+  traverse_ (setTargetTriple ffiMod) triple   let sequencePhases :: EncodeAST [EncodeAST (EncodeAST (EncodeAST (EncodeAST ())))] -> EncodeAST ()       sequencePhases l = (l >>= (sequence >=> sequence >=> sequence >=> sequence)) >> (return ())   sequencePhases $ forM definitions $ \d -> case d of@@ -257,7 +261,7 @@      t' <- createNamedType n      defineType n t'      return $ do-       maybe (return ()) (setNamedType t') t+       traverse_ (setNamedType t') t        return . return . return . return $ ()     A.COMDAT n csk -> do@@ -309,15 +313,14 @@            ic <- encodeM (A.G.isConstant g)            FFI.setGlobalConstant g' ic          return $ do-           maybe (return ()) ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)+           traverse_ ((liftIO . FFI.setInitializer g') <=< encodeM) (A.G.initializer g)            setSection g' (A.G.section g)            setCOMDAT g' (A.G.comdat g)            setAlignment g' (A.G.alignment g)            return (FFI.upCast g')        (a@A.G.GlobalAlias { A.G.name = n }) -> do-         let A.PointerType typ as = A.G.type' a-         typ <- encodeM typ-         as <- encodeM as+         typ <- encodeM (A.G.type' a)+         as <- encodeM (A.G.addrSpace a)          a' <- liftIO $ withName n $ \name -> FFI.justAddAlias ffiMod typ as name          defineGlobal n a'          liftIO $ do@@ -340,7 +343,7 @@          setAlignment f (A.G.alignment g)          setGC f gc          setPersonalityFn f personality-         forM blocks $ \(A.BasicBlock bName _ _) -> do+         forM_ blocks $ \(A.BasicBlock bName _ _) -> do            b <- liftIO $ withName bName $ \bName -> FFI.appendBasicBlockInContext context f bName            defineBasicBlock fName bName b          phase $ do@@ -348,7 +351,7 @@            ps <- allocaArray nParams            liftIO $ FFI.getParams f ps            params <- peekArray nParams ps-           forM (zip args params) $ \(A.Parameter _ n _, p) -> do+           forM_ (zip args params) $ \(A.Parameter _ n _, p) -> do              defineLocal n p              n <- encodeM n              liftIO $ FFI.setValueName (FFI.upCast p) n@@ -358,11 +361,11 @@                builder <- gets encodeStateBuilder                liftIO $ FFI.positionBuilderAtEnd builder b)              finishes <- mapM encodeM namedInstrs :: EncodeAST [EncodeAST ()]-             (encodeM term :: EncodeAST (Ptr FFI.Instruction))+             void (encodeM term :: EncodeAST (Ptr FFI.Instruction))              return (sequence_ finishes)            sequence_ finishInstrs            locals <- gets $ Map.toList . encodeStateLocals-           forM [ n | (n, ForwardValue _) <- locals ] $ \n -> undefinedReference "local" n+           forM_ [ n | (n, ForwardValue _) <- locals ] $ \n -> undefinedReference "local" n            return (FFI.upCast f)      return $ do        g' <- eg'@@ -389,10 +392,10 @@         <*> getVisibility g         <*> getDLLStorageClass g         <*> getThreadLocalMode g-        <*> return as         <*> (liftIO $ decodeM =<< FFI.getUnnamedAddr (FFI.upCast g))         <*> (liftIO $ decodeM =<< FFI.isGlobalConstant g)         <*> return t+        <*> return as         <*> (do i <- liftIO $ FFI.getInitializer g                 if i == nullPtr                   then return Nothing@@ -409,6 +412,7 @@   ffiAliases <- liftIO $ FFI.getXs (FFI.getFirstAlias mod) FFI.getNextAlias   fmap sequence . forM ffiAliases $ \a -> do     n <- getGlobalName a+    A.PointerType t as <- typeOf a     return $       A.G.GlobalAlias         <$> return n@@ -417,7 +421,8 @@         <*> getDLLStorageClass a         <*> getThreadLocalMode a         <*> (liftIO $ decodeM =<< FFI.getUnnamedAddr (FFI.upCast a))-        <*> typeOf a+        <*> return t+        <*> return as         <*> (decodeM =<< (liftIO $ FFI.getAliasee a))  -- This returns a nested DecodeAST to allow interleaving of different@@ -492,7 +497,7 @@     <*> (liftIO $ getDataLayout mod)     <*> (liftIO $ do            s <- decodeM =<< FFI.getTargetTriple mod-           return $ if s == "" then Nothing else Just s)+           return $ if SBS.null s then Nothing else Just s)     <*> (do       globalDefinitions <-         map A.GlobalDefinition . concat <$>

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} module LLVM.Internal.OrcJIT.CompileOnDemandLayer where  import LLVM.Prelude@@ -56,7 +56,7 @@     return . FFI.TargetAddress . fromIntegral . ptrToWordPtr . castFunPtrToPtr $ f'  withIndirectStubsManagerBuilder ::-  String {- ^ triple -} ->+  ShortByteString {- ^ triple -} ->   (IndirectStubsManagerBuilder -> IO a) ->   IO a withIndirectStubsManagerBuilder triple f = flip runAnyContT return $ do@@ -67,7 +67,7 @@   liftIO $ f (StubsMgr stubsMgr)  withJITCompileCallbackManager ::-  String {- ^ triple -} ->+  ShortByteString {- ^ triple -} ->   Maybe (IO ()) ->   (JITCompileCallbackManager -> IO a) ->   IO a@@ -109,7 +109,7 @@          FFI.disposeCompileOnDemandLayer  liftIO $ f (CompileOnDemandLayer cl baseLayer cleanup) -mangleSymbol :: CompileOnDemandLayer -> String -> IO MangledSymbol+mangleSymbol :: CompileOnDemandLayer -> ShortByteString -> IO MangledSymbol mangleSymbol (CompileOnDemandLayer _ bl _) symbol =   IRCompileLayer.mangleSymbol bl symbol 

@@ -36,7 +36,7 @@   cleanup <- anyContToM $ bracket (newIORef []) (sequence <=< readIORef)   liftIO $ f (IRCompileLayer cl dl cleanup) -mangleSymbol :: IRCompileLayer -> String -> IO MangledSymbol+mangleSymbol :: IRCompileLayer -> ShortByteString -> IO MangledSymbol mangleSymbol (IRCompileLayer _ dl _) symbol = flip runAnyContT return $ do   mangledSymbol <- alloca   symbol' <- encodeM symbol

@@ -9,10 +9,11 @@  import qualified Language.Haskell.TH as TH -import Control.Exception+import Control.Monad.AnyCont+import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Monad.AnyCont+import qualified Data.ByteString.Short as ByteString  import Foreign.C (CString) import Foreign.Ptr@@ -20,6 +21,7 @@ import qualified LLVM.Internal.FFI.PassManager as FFI import qualified LLVM.Internal.FFI.Transforms as FFI +import LLVM.Exception import LLVM.Internal.Module import LLVM.Internal.Target import LLVM.Internal.Coding@@ -84,8 +86,10 @@   targetMachine = Nothing } -instance (Monad m, MonadAnyCont IO m) => EncodeM m GCOVVersion CString where-  encodeM (GCOVVersion cs@[_,_,_,_]) = encodeM cs+instance (Monad m, MonadThrow m, MonadAnyCont IO m) => EncodeM m GCOVVersion CString where+  encodeM (GCOVVersion cs)+    | ByteString.length cs == 4 = encodeM cs+    | otherwise = throwM (EncodeException "GCOVVersion should consist of exactly 4 characters")  createPassManager :: PassSetSpec -> IO (Ptr FFI.PassManager) createPassManager pss = flip runAnyContT return $ do

@@ -3,77 +3,65 @@ import LLVM.Prelude  import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.IO.Class-import Control.Monad.Trans.Except  import Data.IORef import Foreign.C import Foreign.Ptr +import LLVM.Exception+ import qualified LLVM.Internal.FFI.RawOStream as FFI import qualified LLVM.Internal.FFI.PtrHierarchy as FFI  import LLVM.Internal.Coding-import LLVM.Internal.Inject import LLVM.Internal.String () +-- May throw 'FdStreamException'. withFileRawOStream ::-  (Inject String e, MonadError e m, MonadAnyCont IO m, MonadIO m)+  (MonadThrow m, MonadIO m, MonadAnyCont IO m)   => String   -> Bool   -> Bool-  -> (Ptr FFI.RawOStream -> ExceptT String IO ())+  -> (Ptr FFI.RawOStream -> IO ())   -> m () withFileRawOStream path excl text c =   withFileRawPWriteStream path excl text (c . FFI.upCast) +-- May throw 'FdStreamException'. withFileRawPWriteStream ::-  (Inject String e, MonadError e m, MonadAnyCont IO m, MonadIO m)+  (MonadThrow m, MonadIO m, MonadAnyCont IO m)   => String   -> Bool   -> Bool-  -> (Ptr FFI.RawPWriteStream -> ExceptT String IO ())+  -> (Ptr FFI.RawPWriteStream -> IO ())   -> m () withFileRawPWriteStream path excl text c = do   path <- encodeM path   excl <- encodeM excl   text <- encodeM text   msgPtr <- alloca-  errorRef <- liftIO $ newIORef undefined-  succeeded <- decodeM =<< (liftIO $ FFI.withFileRawPWriteStream path excl text msgPtr $ \os -> do-                              r <- runExceptT (c os)-                              writeIORef errorRef r)+  succeeded <- decodeM =<< (liftIO $ FFI.withFileRawPWriteStream path excl text msgPtr c)   unless succeeded $ do     s <- decodeM msgPtr-    throwError $ inject (s :: String)-  e <- liftIO $ readIORef errorRef-  either (throwError . inject) return e+    throwM $ FdStreamException s  withBufferRawOStream ::-  (Inject String e, MonadError e m, MonadIO m, DecodeM IO a (Ptr CChar, CSize))-  => (Ptr FFI.RawOStream -> ExceptT String IO ())+  (MonadIO m, DecodeM IO a (Ptr CChar, CSize))+  => (Ptr FFI.RawOStream -> IO ())   -> m a withBufferRawOStream c = withBufferRawPWriteStream (c . FFI.upCast)  withBufferRawPWriteStream ::-  (Inject String e, MonadError e m, MonadIO m, DecodeM IO a (Ptr CChar, CSize))-  => (Ptr FFI.RawPWriteStream -> ExceptT String IO ())+  (MonadIO m, DecodeM IO a (Ptr CChar, CSize))+  => (Ptr FFI.RawPWriteStream -> IO ())   -> m a-withBufferRawPWriteStream c = do-  resultRef <- liftIO $ newIORef Nothing-  errorRef <- liftIO $ newIORef undefined+withBufferRawPWriteStream c = liftIO $ do+  resultRef <- newIORef undefined   let saveBuffer :: Ptr CChar -> CSize -> IO ()       saveBuffer start size = do         r <- decodeM (start, size)-        writeIORef resultRef (Just r)-      saveError os = do-        r <- runExceptT (c os)-        writeIORef errorRef r-  liftIO $ FFI.withBufferRawPWriteStream saveBuffer saveError-  e <- liftIO $ readIORef errorRef-  case e of-    Left e -> throwError $ inject e-    _ -> do-      Just r <- liftIO $ readIORef resultRef-      return r+        writeIORef resultRef r+  FFI.withBufferRawPWriteStream saveBuffer c+  readIORef resultRef

@@ -21,6 +21,7 @@ import LLVM.Internal.Coding  import qualified Data.ByteString as BS+import qualified LLVM.Internal.FFI.ShortByteString as SBS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.UTF8 as BSUTF8 @@ -35,16 +36,41 @@ instance (MonadAnyCont IO e) => EncodeM e String CString where   encodeM s = anyContToM (BS.unsafeUseAsCString . utf8Bytes =<< encodeM (s ++ "\0")) +instance (MonadAnyCont IO e) => EncodeM e ByteString CString where+  encodeM s = anyContToM (BS.useAsCString s)++instance (MonadAnyCont IO e) => EncodeM e ShortByteString CString where+  encodeM s = anyContToM (SBS.useAsCString s)+ instance (Integral i, MonadAnyCont IO e) => EncodeM e String (Ptr CChar, i) where   encodeM s = anyContToM ((. (. second fromIntegral)) $ BS.useAsCStringLen . utf8Bytes =<< encodeM s) +instance (Integral i, MonadAnyCont IO e) => EncodeM e ByteString (Ptr CChar, i) where+  encodeM s =+    anyContToM (\cont -> BS.useAsCStringLen s (\(ptr, len) -> cont (ptr, fromIntegral len)))++instance (Integral i, MonadAnyCont IO e) => EncodeM e ShortByteString (Ptr CChar, i) where+  encodeM s =+    anyContToM (\cont -> SBS.useAsCStringLen s (\(ptr, len) -> cont (ptr, fromIntegral len)))+ instance (MonadIO d) => DecodeM d String CString where   decodeM = decodeM . UTF8ByteString <=< liftIO . BS.packCString +instance (MonadIO d) => DecodeM d ByteString CString where+  decodeM = liftIO . BS.packCString++instance (MonadIO d) => DecodeM d ShortByteString CString where+  decodeM = liftIO . SBS.packCString+ instance (MonadIO d) => DecodeM d String (OwnerTransfered CString) where   decodeM (OwnerTransfered s) = liftIO $ finally (decodeM s) (free s) -instance (MonadIO d) => DecodeM d String (Ptr (OwnerTransfered CString)) where+instance (MonadIO d) => DecodeM d ByteString (OwnerTransfered CString) where+  decodeM (OwnerTransfered s) = liftIO $ finally (decodeM s) (free s)++instance (MonadIO d) => DecodeM d ShortByteString (OwnerTransfered CString) where+  decodeM (OwnerTransfered s) = liftIO $ finally (decodeM s) (free s)+instance (MonadIO d, DecodeM IO s (OwnerTransfered CString)) =>DecodeM d s (Ptr (OwnerTransfered CString)) where   decodeM = liftIO . decodeM <=< peek  instance (Integral i, MonadIO d) => DecodeM d String (Ptr CChar, i) where@@ -53,7 +79,10 @@ instance (Integral i, MonadIO d) => DecodeM d BS.ByteString (Ptr CChar, i) where   decodeM = liftIO . BS.packCStringLen . second fromIntegral -instance (Integral i, Storable i, MonadIO d) => DecodeM d String (Ptr i -> IO (Ptr CChar)) where+instance (Integral i, MonadIO d) => DecodeM d ShortByteString (Ptr CChar, i) where+  decodeM = liftIO . SBS.packCStringLen . second fromIntegral++instance (Integral i, Storable i, MonadIO d, DecodeM d s (CString, i)) => DecodeM d s (Ptr i -> IO CString) where   decodeM f = decodeM =<< (liftIO $ F.M.alloca $ \p -> (,) `liftM` f p `ap` peek p)  instance (Monad e, EncodeM e String c) => EncodeM e (Maybe String) (NothingAsEmptyString c) where

@@ -2,30 +2,33 @@   TemplateHaskell,   MultiParamTypeClasses,   RecordWildCards,-  UndecidableInstances+  UndecidableInstances,+  OverloadedStrings   #-} module LLVM.Internal.Target where  import LLVM.Prelude -import Control.Exception import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Except -import Foreign.Ptr-import Foreign.C.String-import Data.List (intercalate)+import Data.Attoparsec.ByteString+import Data.Attoparsec.ByteString.Char8+import qualified Data.ByteString as ByteString+import Data.Char import Data.Map (Map) import qualified Data.Map as Map--import Text.ParserCombinators.Parsec hiding (many)+import Data.Monoid+import Foreign.C.String+import Foreign.Ptr  import LLVM.Internal.Coding import LLVM.Internal.String () import LLVM.Internal.LibraryFunction import LLVM.DataLayout+import LLVM.Exception  import LLVM.AST.DataLayout @@ -76,38 +79,41 @@ newtype Target = Target (Ptr FFI.Target)  -- | e.g. an instruction set extension-newtype CPUFeature = CPUFeature String+newtype CPUFeature = CPUFeature ByteString   deriving (Eq, Ord, Read, Show) -instance EncodeM e String es => EncodeM e (Map CPUFeature Bool) es where-  encodeM = encodeM . intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") ++ f) . Map.toList+instance EncodeM e ByteString es => EncodeM e (Map CPUFeature Bool) es where+  encodeM = encodeM . ByteString.intercalate "," . map (\(CPUFeature f, enabled) -> (if enabled then "+" else "-") <> f) . Map.toList -instance (Monad d, DecodeM d String es) => DecodeM d (Map CPUFeature Bool) es where+instance (Monad d, DecodeM d ByteString es) => DecodeM d (Map CPUFeature Bool) es where   decodeM es = do     s <- decodeM es     let flag = do-          en <- choice [char '-' >> return False, char '+' >> return True]-          s <- many1 (noneOf ",")+          en <- choice [char8 '-' >> return False, char8 '+' >> return True]+          s <- ByteString.pack <$> many1 (notWord8 (fromIntegral (ord ',')))           return (CPUFeature s, en)-        features = liftM Map.fromList (flag `sepBy` (char ','))-    case parse (do f <- features; eof; return f) "CPU Feature string" (s :: String) of+        features = liftM Map.fromList (flag `sepBy` (char8 ','))+    case parseOnly (do f <- features; endOfInput; return f) s of       Right features -> return features       Left _ -> fail "failure to parse CPUFeature string"                         -- | Find a 'Target' given an architecture and/or a \"triple\". -- | <http://llvm.org/doxygen/structllvm_1_1TargetRegistry.html#a3105b45e546c9cc3cf78d0f2ec18ad89>--- | Be sure to run either 'initializeAllTargets' or 'initializeNativeTarget' before expecting this to succeed, depending on what target(s) you want to use.+-- | Be sure to run either 'initializeAllTargets' or+-- 'initializeNativeTarget' before expecting this to succeed,+-- depending on what target(s) you want to use. May throw+-- 'LookupTargetException' if no target is found. lookupTarget ::-  Maybe String -- ^ arch-  -> String -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu-  -> ExceptT String IO (Target, String)+  Maybe ShortByteString -- ^ arch+  -> ShortByteString -- ^ \"triple\" - e.g. x86_64-unknown-linux-gnu+  -> IO (Target, ShortByteString) lookupTarget arch triple = flip runAnyContT return $ do   cErrorP <- alloca   cNewTripleP <- alloca   arch <- encodeM (maybe "" id arch)   triple <- encodeM triple   target <- liftIO $ FFI.lookupTarget arch triple cNewTripleP cErrorP-  when (target == nullPtr) $ throwError =<< decodeM cErrorP+  when (target == nullPtr) $ throwM . LookupTargetException =<< decodeM cErrorP   liftM (Target target, ) $ decodeM cNewTripleP  -- | <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>@@ -180,8 +186,8 @@ -- | bracket creation and destruction of a 'TargetMachine' withTargetMachine ::     Target-    -> String -- ^ triple-    -> String -- ^ cpu+    -> ShortByteString -- ^ triple+    -> ByteString -- ^ cpu     -> Map CPUFeature Bool -- ^ features     -> TargetOptions     -> Reloc.Model@@ -234,19 +240,19 @@   when failure $ fail "native target initialization failed"  -- | the target triple corresponding to the target machine-getTargetMachineTriple :: TargetMachine -> IO String+getTargetMachineTriple :: TargetMachine -> IO ShortByteString getTargetMachineTriple (TargetMachine m) = decodeM =<< FFI.getTargetMachineTriple m  -- | the default target triple that LLVM has been configured to produce code for-getDefaultTargetTriple :: IO String+getDefaultTargetTriple :: IO ShortByteString getDefaultTargetTriple = decodeM =<< FFI.getDefaultTargetTriple  -- | a target triple suitable for loading code into the current process-getProcessTargetTriple :: IO String+getProcessTargetTriple :: IO ShortByteString getProcessTargetTriple = decodeM =<< FFI.getProcessTargetTriple  -- | the LLVM name for the host CPU-getHostCPUName :: IO String+getHostCPUName :: IO ByteString getHostCPUName = decodeM FFI.getHostCPUName  -- | a space-separated list of LLVM feature names supported by the host CPU@@ -266,21 +272,21 @@ initializeAllTargets = FFI.initializeAllTargets  -- | Bracket creation and destruction of a 'TargetMachine' configured for the host-withHostTargetMachine :: (TargetMachine -> IO a) -> ExceptT String IO a+withHostTargetMachine :: (TargetMachine -> IO a) -> IO a withHostTargetMachine f = do-  liftIO $ initializeAllTargets-  triple <- liftIO $ getProcessTargetTriple-  cpu <- liftIO $ getHostCPUName-  features <- liftIO $ getHostCPUFeatures+  initializeAllTargets+  triple <- getProcessTargetTriple+  cpu <- getHostCPUName+  features <- getHostCPUFeatures   (target, _) <- lookupTarget Nothing triple-  liftIO $ withTargetOptions $ \options ->-      withTargetMachine target triple cpu features options Reloc.Default CodeModel.Default CodeGenOpt.Default f+  withTargetOptions $ \options ->+    withTargetMachine target triple cpu features options Reloc.Default CodeModel.Default CodeGenOpt.Default f  -- | <http://llvm.org/docs/doxygen/html/classllvm_1_1TargetLibraryInfo.html> newtype TargetLibraryInfo = TargetLibraryInfo (Ptr FFI.TargetLibraryInfo)  -- | Look up a 'LibraryFunction' by its standard name-getLibraryFunction :: TargetLibraryInfo -> String -> IO (Maybe LibraryFunction)+getLibraryFunction :: TargetLibraryInfo -> ShortByteString -> IO (Maybe LibraryFunction) getLibraryFunction (TargetLibraryInfo f) name = flip runAnyContT return $ do   libFuncP <- alloca :: AnyContT IO (Ptr FFI.LibFunc)   name <- (encodeM name :: AnyContT IO CString)@@ -288,7 +294,7 @@   forM (if r then Just libFuncP else Nothing) $ decodeM <=< peek  -- | Get a the current name to be emitted for a 'LibraryFunction'-getLibraryFunctionName :: TargetLibraryInfo -> LibraryFunction -> IO String+getLibraryFunctionName :: TargetLibraryInfo -> LibraryFunction -> IO ShortByteString getLibraryFunctionName (TargetLibraryInfo f) l = flip runAnyContT return $ do   l <- encodeM l   decodeM $ FFI.libFuncGetName f l@@ -297,7 +303,7 @@ setLibraryFunctionAvailableWithName ::   TargetLibraryInfo   -> LibraryFunction-  -> String -- ^ The function name to be emitted+  -> ShortByteString -- ^ The function name to be emitted   -> IO () setLibraryFunctionAvailableWithName (TargetLibraryInfo f) libraryFunction name = flip runAnyContT return $ do   name <- encodeM name@@ -306,7 +312,7 @@  -- | look up information about the library functions available on a given platform withTargetLibraryInfo ::-  String -- ^ triple+  ShortByteString -- ^ triple   -> (TargetLibraryInfo -> IO a)   -> IO a withTargetLibraryInfo triple f = flip runAnyContT return $ do

@@ -7,7 +7,7 @@ import LLVM.Prelude  import Control.Monad.AnyCont-import Control.Monad.Error.Class+import Control.Monad.Catch import Control.Monad.State  import qualified Data.Set as Set@@ -21,6 +21,7 @@  import qualified LLVM.AST as A import qualified LLVM.AST.AddrSpace as A+import LLVM.Exception  import LLVM.Internal.Context import LLVM.Internal.Coding@@ -81,13 +82,12 @@         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 _ _ -> throwError $ "unsupported floating point type: " ++ show f+      A.FloatingPointType A.HalfFP      -> liftIO $ FFI.halfTypeInContext context+      A.FloatingPointType A.FloatFP     -> liftIO $ FFI.floatTypeInContext context+      A.FloatingPointType A.DoubleFP    -> liftIO $ FFI.doubleTypeInContext context+      A.FloatingPointType A.X86_FP80FP  -> liftIO $ FFI.x86FP80TypeInContext context+      A.FloatingPointType A.FP128FP     -> liftIO $ FFI.fP128TypeInContext context+      A.FloatingPointType A.PPC_FP128FP -> liftIO $ FFI.ppcFP128TypeInContext context       A.VectorType sz e -> do         e <- encodeM e         sz <- encodeM sz@@ -124,12 +124,12 @@           return A.PointerType              `ap` (decodeM =<< liftIO (FFI.getElementType t))              `ap` (decodeM =<< liftIO (FFI.getPointerAddressSpace t))-      [typeKindP|Half|] -> return $ A.FloatingPointType 16 A.IEEE-      [typeKindP|Float|] -> return $ A.FloatingPointType 32 A.IEEE-      [typeKindP|Double|] -> return $ A.FloatingPointType 64 A.IEEE-      [typeKindP|FP128|] -> return $ A.FloatingPointType 128 A.IEEE-      [typeKindP|X86_FP80|] -> return $ A.FloatingPointType 80 A.DoubleExtended-      [typeKindP|PPC_FP128|] -> return $ A.FloatingPointType 128 A.PairOfFloats+      [typeKindP|Half|]      -> return $ A.FloatingPointType A.HalfFP+      [typeKindP|Float|]     -> return $ A.FloatingPointType A.FloatFP+      [typeKindP|Double|]    -> return $ A.FloatingPointType A.DoubleFP+      [typeKindP|FP128|]     -> return $ A.FloatingPointType A.FP128FP+      [typeKindP|X86_FP80|]  -> return $ A.FloatingPointType A.X86_FP80FP+      [typeKindP|PPC_FP128|] -> return $ A.FloatingPointType A.PPC_FP128FP       [typeKindP|Vector|] ->         return A.VectorType          `ap` (decodeM =<< liftIO (FFI.getVectorSize t))@@ -159,6 +159,7 @@   ets <- encodeM ets   packed <- encodeM packed   liftIO $ FFI.structSetBody t ets packed---+setNamedType _ ty =+  throwM+    (EncodeException+       ("A type definition requires a structure type but got: " ++ show ty))

@@ -9,4 +9,4 @@     | Static     | PIC     | DynamicNoPIC-    deriving (Eq, Read, Show, Typeable, Data)+    deriving (Eq, Read, Show, Typeable, Data, Generic)

@@ -8,14 +8,14 @@   = FloatABIDefault   | FloatABISoft   | FloatABIHard-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data)+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)  -- | <http://llvm.org/doxygen/namespacellvm_1_1FPOpFusion.html#a9c71bae9f02af273833fde586d529fc5> data FloatingPointOperationFusionMode   = FloatingPointOperationFusionFast   | FloatingPointOperationFusionStandard   | FloatingPointOperationFusionStrict-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data)+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)  -- | The options of a 'LLVM.Target.TargetOptions' -- <http://llvm.org/doxygen/classllvm_1_1TargetOptions.html>

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} -- | This module provides an enumeration of the various transformation (e.g. optimization) passes -- provided by LLVM. They can be used to create a 'LLVM.PassManager.PassManager' to, in turn, -- run the passes on 'LLVM.Module.Module's. If you don't know what passes you want, consider@@ -124,7 +125,7 @@     }   | ThreadSanitizer   | BoundsChecking-  deriving (Eq, Ord, Read, Show, Typeable, Data)+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)  -- | Defaults for the 'LoopVectorize' pass defaultLoopVectorize :: Pass@@ -164,8 +165,8 @@   }  -- | See <http://gcc.gnu.org/viewcvs/gcc/trunk/gcc/gcov-io.h?view=markup>.-newtype GCOVVersion = GCOVVersion String-  deriving (Eq, Ord, Read, Show, Typeable, Data)+newtype GCOVVersion = GCOVVersion ShortByteString+  deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)  -- | Defaults for 'GCOVProfiler'. defaultGCOVProfiler :: Pass

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Analysis where  import Test.Tasty@@ -57,7 +58,7 @@               )              ]             ]-      Left s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . 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,8 +107,7 @@                 }               ]        strCheck ast str-       s <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify-       s @?= Right ()+       withContext $ \context -> withModuleFromAST context ast verify      ]    ]  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.CallingConvention where  import Test.Tasty@@ -6,6 +7,7 @@ import LLVM.Test.Support  import Data.Maybe+import Data.Monoid import qualified Data.Set as Set import qualified Data.Map as Map @@ -16,6 +18,8 @@ import qualified LLVM.AST.CallingConvention as CC import qualified LLVM.AST.Global as G +import qualified Data.ByteString.Char8 as ByteString+ tests = testGroup "CallingConvention" [   testCase name $ strCheck (defaultModule {     moduleDefinitions = [@@ -28,7 +32,7 @@    }) ("; ModuleID = '<string>'\n\        \source_filename = \"<string>\"\n\        \\n\-       \declare" ++ (if name == "" then "" else (" " ++ name)) ++ " i32 @foo()\n")+       \declare" <> (if name == "" then "" else (" " <> ByteString.pack name)) <> " i32 @foo()\n")    | (name, cc) <- [    ("", CC.C),    ("fastcc", CC.Fast),

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Constants where  import Test.Tasty@@ -8,6 +9,7 @@ import Control.Monad import Data.Functor import Data.Maybe+import Data.Monoid import Foreign.Ptr import Data.Word @@ -178,7 +180,7 @@                G.name = UnName 2, G.type' = i32, G.initializer = Nothing               }            ]-       mStr = "; ModuleID = '<string>'\nsource_filename = \"<string>\"\n\n@0 = " ++ str ++ "\n\+       mStr = "; ModuleID = '<string>'\nsource_filename = \"<string>\"\n\n@0 = " <> str <> "\n\               \@1 = external global i32\n\               \@2 = external global i32\n"  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.DataLayout where  import Test.Tasty@@ -5,7 +6,9 @@  import LLVM.Test.Support +import Control.Monad.IO.Class import Data.Maybe+import Data.Monoid import qualified Data.Set as Set import qualified Data.Map as Map @@ -15,12 +18,31 @@ import LLVM.AST.DataLayout import LLVM.AST.AddrSpace import qualified LLVM.AST.Global as G+import LLVM.Internal.Coding+import LLVM.Internal.DataLayout+import LLVM.Internal.EncodeAST+import LLVM.Internal.FFI.DataLayout (getTypeAllocSize) -m s = "; ModuleID = '<string>'\nsource_filename = \"<string>\"\n" ++ s-t s = "target datalayout = \"" ++ s ++ "\"\n"+m s = "; ModuleID = '<string>'\nsource_filename = \"<string>\"\n" <> s+t s = "target datalayout = \"" <> s <> "\"\n" ddl = defaultDataLayout BigEndian -tests = testGroup "DataLayout" [+tests = testGroup "DataLayout" $+  testCase "getTypeAllocSize" (withContext $ \ctx -> runEncodeAST ctx $ do+    ty <- encodeM (IntegerType 8)+    liftIO $ do+      size <-+        withFFIDataLayout+          (ddl { typeLayouts = Map.singleton (IntegerAlign, 8) (AlignmentInfo 8 8) })+          (\dl -> getTypeAllocSize dl ty)+      size @?= 1+      size <-+        withFFIDataLayout+          (ddl { typeLayouts = Map.singleton (IntegerAlign, 8) (AlignmentInfo 32 32) })+          (\dl -> getTypeAllocSize dl ty)+      size @?= 4)+  :+  [   testCase name $ strCheckC (Module "<string>" "<string>" mdl Nothing []) (m sdl) (m sdlc)   | (name, mdl, sdl, sdlc) <- [    ("none", Nothing, "", "")@@ -38,10 +60,7 @@          (AddrSpace 0)           (           8,-          AlignmentInfo {-            abiAlignment = 64,-            preferredAlignment = Nothing-          }+          AlignmentInfo 64 64          )      },      "E-p:8:64",@@ -50,7 +69,7 @@      "no pref",      ddl {        pointerLayouts = -         Map.insert (AddrSpace 1) (8, AlignmentInfo 32 (Just 64)) (pointerLayouts ddl)+         Map.insert (AddrSpace 1) (8, AlignmentInfo 32 64) (pointerLayouts ddl)      },      "E-p1:8:32:64",      Nothing@@ -61,21 +80,21 @@        mangling = Just ELFMangling,        stackAlignment = Just 128,        pointerLayouts = Map.fromList [-         (AddrSpace 0, (8, AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 16}))+         (AddrSpace 0, (8, AlignmentInfo 8 16))         ],        typeLayouts = Map.fromList [-         ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}),-         ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 256}),-         ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 256}),-         ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}),-         ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}),-         ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}),-         ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256}),-         ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 256}),-         ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 256}),-         ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 256})+         ((IntegerAlign, 1), AlignmentInfo 8 256),+         ((IntegerAlign, 8), AlignmentInfo 8 256),+         ((IntegerAlign, 16), AlignmentInfo 16 256),+         ((IntegerAlign, 32), AlignmentInfo 32 256),+         ((IntegerAlign, 64), AlignmentInfo 64 256),+         ((VectorAlign, 64), AlignmentInfo 64 256),+         ((VectorAlign, 128), AlignmentInfo 128 256),+         ((FloatAlign, 32), AlignmentInfo 32 256),+         ((FloatAlign, 64), AlignmentInfo 64 256),+         ((FloatAlign, 80), AlignmentInfo 128 256)         ] `Map.union` typeLayouts ddl, -       aggregateLayout = AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 256},+       aggregateLayout = AlignmentInfo 0 256,        nativeSizes = Just (Set.fromList [8,16,32,64])      },      "e-m:e-p:8:8:16-i1:8:256-i8:8:256-i16:16:256-i32:32:256-i64:64:256-v64:64:256-v128:128:256-f32:32:256-f64:64:256-f80:128:256-a:0:256-n8:16:32:64-S128",

@@ -1,5 +1,7 @@ {-# LANGUAGE-  ForeignFunctionInterface+  FlexibleContexts,+  ForeignFunctionInterface,+  OverloadedStrings   #-} module LLVM.Test.ExecutionEngine where @@ -48,7 +50,7 @@                }               ] -  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

@@ -0,0 +1,103 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module LLVM.Test.FunctionAttribute where++import Test.Tasty+import Test.Tasty.QuickCheck                              hiding ( (.&.) )++import LLVM.Test.Support++import LLVM.AST.FunctionAttribute+import LLVM.Internal.Coding+import LLVM.Internal.Context+import LLVM.Internal.EncodeAST+import LLVM.Internal.DecodeAST+import qualified LLVM.Internal.FFI.Attribute              as FFI++import Control.Applicative+import Data.Bits+import Data.List+import Text.Show.Pretty+import Prelude+import qualified Data.ByteString.Short                    as B+++instance Arbitrary FunctionAttribute where+  arbitrary = oneof+    [ return NoReturn+    , return NoUnwind+    , return ReadNone+    , return ReadOnly+    , return NoInline+    , return NoRecurse+    , return AlwaysInline+    , return MinimizeSize+    , return OptimizeForSize+    , return OptimizeNone+    , return StackProtect+    , return StackProtectReq+    , return StackProtectStrong+    , return NoRedZone+    , return NoImplicitFloat+    , return Naked+    , return InlineHint+    , StackAlignment <$> elements (map (2^) [0..8 :: Int])+    , return ReturnsTwice+    , return UWTable+    , return NonLazyBind+    , return Builtin+    , return NoBuiltin+    , return Cold+    , return JumpTable+    , return NoDuplicate+    , return SanitizeAddress+    , return SanitizeThread+    , return SanitizeMemory+    , StringAttribute <$> (B.pack <$> arbitrary) <*> (B.pack <$> arbitrary)+    , suchThat (AllocSize <$> arbitrary <*> arbitrary) (/= AllocSize 0 (Just 0))+    , return WriteOnly+    , return ArgMemOnly+    , return Convergent+    , return InaccessibleMemOnly+    , return InaccessibleMemOrArgMemOnly+    , return SafeStack+    ]++  shrink = \case+    StackAlignment x    -> map StackAlignment (nub [ v | u <- shrink x, let v = ceilPow2 u, v /= x ])+    StringAttribute x y -> [ StringAttribute (B.pack x') y | x' <- shrink (B.unpack x) ]+                        ++ [ StringAttribute x (B.pack y') | y' <- shrink (B.unpack y) ]+    AllocSize x y       -> [ AllocSize x' y | x' <- shrink x, not (x' == 0 && y == Just 0) ]+                        ++ [ AllocSize x y' | y' <- shrink y, not (x == 0 && y' == Just 0) ]+    _                   -> []+++tests :: TestTree+tests =+  testGroup "FunctionAttribute"+    [ testProperty "round-trip"  $ \attr ->+        ioProperty $ withContext $ \ctx  -> do+          x <- runEncodeAST ctx (encodeM [attr] :: EncodeAST FFI.FunctionAttributeSet)+          y <- runDecodeAST (decodeM x :: DecodeAST [FunctionAttribute])+          return $ counterexample (unlines [ "expected: " ++ ppShow [attr]+                                           , "but got:  " ++ ppShow y+                                           ])+                                  ([attr] == y)+    ]+++isPow2 :: (Bits a, Num a) => a -> Bool+isPow2 0 = True+isPow2 1 = False+isPow2 n = n .&. (n - 1) == 0++ceilPow2 :: (Bits a, Integral a) => a -> a+ceilPow2 n+  | isPow2 n  = n+  | otherwise =+      let x = logBase 2 (fromIntegral n) :: Double+          y = floor x + 1+      in+      1 `shiftL` y+

@@ -1,8 +1,13 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Global where  import Test.Tasty import Test.Tasty.HUnit +import Data.Monoid+import qualified Data.ByteString.Char8 as ByteString+import Data.ByteString.Short (fromShort)+ import LLVM.Test.Support  import LLVM.Context@@ -15,7 +20,7 @@   testGroup "Alignment" [     testCase name $ withContext $ \context -> do       let ast = Module "<string>" "<string>" Nothing Nothing [ GlobalDefinition g ]-      ast' <- withModuleFromAST' context ast moduleAST+      ast' <- withModuleFromAST context ast moduleAST       ast' @?= ast     | a <- [0,1],       s <- [Nothing, Just "foo"],@@ -37,6 +42,6 @@       let           gn (G.Function {}) = "function"           gn (G.GlobalVariable {}) = "variable"-          name = gn g ++ ", align " ++ show a ++ (maybe "" ("  section " ++ ) s)+          name = gn g <> ", align " <> show a <> (maybe "" (("  section " <>) . ByteString.unpack . fromShort) s)    ]  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.InlineAssembly where  import Test.Tasty

@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module LLVM.Test.Instructions where  import Test.Tasty@@ -6,9 +8,12 @@ import LLVM.Test.Support  import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as ByteString import Data.Functor import Data.List.NonEmpty (NonEmpty((:|))) import Data.Maybe+import Data.Monoid import Foreign.Ptr import Data.Word @@ -50,7 +55,7 @@                  \source_filename = \"<string>\"\n\                  \\n\                  \define void @0(i32, float, i32*, i64, i1, <2 x i32>, { i32, i32 }) {\n\-                 \  " ++ namedInstrS ++ "\n\+                 \  " <> namedInstrS <> "\n\                  \  ret void\n\                  \}\n"       strCheck mAST mStr@@ -64,9 +69,9 @@            StructureType False [i32, i32]            ],       let a i = LocalReference (ts !! fromIntegral i) (UnName i),-      (name, namedInstr, namedInstrS) <- (+      (name, namedInstr, namedInstrS :: ByteString) <- (         [-         (name, UnName 8 := instr, "%8 = " ++ instrS)+         (name, UnName 8 := instr, "%8 = " <> instrS)          | (name, instr, instrS) <- [           ("add",            Add {@@ -482,7 +487,7 @@          ] ++ [           ("landingpad-" ++ n,            LandingPad {-             type' = StructureType False [ +             type' = StructureType False [                 ptr i8,                 i32                ],@@ -490,7 +495,7 @@              clauses = cls,              metadata = []            },-           "landingpad { i8*, i32 }" ++ s)+           "landingpad { i8*, i32 }" <> s)           | (clsn,cls,clss) <- [            ("catch",             [Catch (C.Null (ptr i8))],@@ -500,12 +505,12 @@             "\n          filter [1 x i8*] zeroinitializer")           ],           (cpn, cp, cps) <- [ ("-cleanup", True, "\n          cleanup"), ("", False, "") ],-          let s = cps ++ clss-              n = clsn ++ cpn+          let s = cps <> clss+              n = clsn <> cpn          ] ++ [-          ("icmp-" ++ ps,+          ("icmp-" ++ ByteString.unpack ps,            ICmp { iPredicate = p, operand0 = a 0, operand1 = a 0, metadata = [] },-           "icmp " ++ ps ++ " i32 %0, %0")+           "icmp " <> ps <> " i32 %0, %0")            | (ps, p) <- [            ("eq", IPred.EQ),            ("ne", IPred.NE),@@ -519,9 +524,9 @@            ("sle", IPred.SLE)           ]          ] ++ [-          ("fcmp-" ++ ps,+          ("fcmp-" ++ ByteString.unpack ps,            FCmp { fpPredicate = p, operand0 = a 1, operand1 = a 1, metadata = [] },-           "fcmp " ++ ps ++ " float %1, %1")+           "fcmp " <> ps <> " float %1, %1")            | (ps, p) <- [            ("false", FPPred.False),            ("oeq", FPPred.OEQ),@@ -549,13 +554,13 @@             value = a 0,             maybeAtomicity = Nothing,             alignment = 0,-            metadata = [] +            metadata = []           },           "store i32 %0, i32* %2"),          ("fence",           Do $ Fence {             atomicity = (CrossThread, Acquire),-            metadata = [] +            metadata = []           },           "fence acquire"),           ("call",@@ -613,7 +618,7 @@                \  %1 = load i32, i32* @0, align 1\n\                \  ret i32 %1\n\                \}\n"-    s <- withContext $ \context -> withModuleFromAST' context mAST moduleLLVMAssembly+    s <- withContext $ \context -> withModuleFromAST context mAST moduleLLVMAssembly     s @?= mStr,        testGroup "terminators" [

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Instrumentation where  import Test.Tasty@@ -33,7 +34,7 @@ import qualified LLVM.AST.Constant as C  instrument :: PassSetSpec -> A.Module -> IO A.Module-instrument s m = withContext $ \context -> withModuleFromAST' context m $ \mIn' -> do+instrument s m = withContext $ \context -> withModuleFromAST context m $ \mIn' -> do   withPassManager s $ \pm -> runPassManager pm mIn'   moduleAST mIn' @@ -142,8 +143,8 @@     testCase n $ do       triple <- getProcessTargetTriple        withTargetLibraryInfo triple $ \tli -> do-        Right dl <- runExceptT $ withHostTargetMachine getTargetMachineDataLayout-        Right ast <- runExceptT ast+        dl <- withHostTargetMachine getTargetMachineDataLayout+        ast <- 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

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Linking where  import Test.Tasty@@ -58,9 +59,9 @@         ]            Module { moduleDefinitions = defs } <- withContext $ \context -> -      withModuleFromAST' context ast0 $ \dest -> do-      withModuleFromAST' context ast0 $ \src -> do-        failInIO $ linkModules dest src+      withModuleFromAST context ast0 $ \dest -> do+      withModuleFromAST context ast0 $ \src -> do+        linkModules dest src         moduleAST dest     [ n | GlobalDefinition g <- defs, let Name n = G.name g ] @?= [ "private0", "external0" ]  ]

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Metadata where  import Test.Tasty@@ -15,46 +16,6 @@ import LLVM.AST.Global as G  tests = testGroup "Metadata" [-  -- testCase "local" $ do-  --   let ast = Module "<string>" Nothing Nothing [-  --         GlobalDefinition $ globalVariableDefaults { G.name = UnName 0, G.type' = i32 },-  --         GlobalDefinition $ functionDefaults {-  --           G.returnType = i32,-  --           G.name = Name "foo",-  --           G.basicBlocks = [-  --             BasicBlock (UnName 0) [-  --                UnName 1 := Load {-  --                           volatile = False,-  --                           address = ConstantOperand (C.GlobalReference (ptr i32) (UnName 0)),-  --                           maybeAtomicity = Nothing,-  --                           A.alignment = 0,-  --                           metadata = []-  --                         }-  --                ] (-  --                Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [-  --                  (-  --                    "my-metadatum", -  --                    MetadataNode [-  --                     Just $ MDValue $ LocalReference i32 (UnName 1),-  --                     Just $ MDString "super hyper",-  --                     Nothing-  --                    ]-  --                  )-  --                ]-  --              )-  --            ]-  --          }-  --        ]-  --   let s = "; ModuleID = '<string>'\n\-  --           \\n\-  --           \@0 = external global i32\n\-  --           \\n\-  --           \define i32 @foo() {\n\-  --           \  %1 = load i32, i32* @0\n\-  --           \  ret i32 0, !my-metadatum !{i32 %1, !\"super hyper\", null}\n\-  --           \}\n"-  --   strCheck ast s,-   testCase "global" $ do     let ast = Module "<string>" "<string>" Nothing Nothing [           GlobalDefinition $ functionDefaults {

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Module where  import Test.Tasty@@ -5,6 +6,7 @@  import LLVM.Test.Support +import Control.Exception import Control.Monad.Trans.Except import Data.Bits import Data.Word@@ -12,6 +14,7 @@ import qualified Data.Map as Map  import LLVM.Context+import LLVM.Exception import LLVM.Module import LLVM.Analysis import LLVM.Diagnostic@@ -132,18 +135,20 @@       GlobalDefinition $ globalAliasDefaults {          G.name = Name "three",          G.linkage = L.Private,-         G.type' = PointerType i32 (AddrSpace 3),+         G.type' = i32,+         G.addrSpace = AddrSpace 3,          G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (UnName 1)       },       GlobalDefinition $ globalAliasDefaults {         G.name = Name "two",         G.unnamedAddr = Just GlobalAddr,-        G.type' = PointerType i32 (AddrSpace 3),+        G.type' = i32,+        G.addrSpace = AddrSpace 3,         G.aliasee = C.GlobalReference (PointerType i32 (AddrSpace 3)) (Name "three")       },       GlobalDefinition $ globalAliasDefaults {         G.name = Name "one",-        G.type' = ptr i32,+        G.type' = i32,         G.aliasee = C.GlobalReference (ptr i32) (UnName 5),         G.threadLocalMode = Just TLS.InitialExec       },@@ -257,10 +262,10 @@               \  ret i32 0\n\               \}\n"       a <- withModuleFromLLVMAssembly' context s $ \m -> do-        (t, _) <- failInIO $ lookupTarget Nothing "x86_64-unknown-linux"+        (t, _) <- lookupTarget Nothing "x86_64-unknown-linux"         withTargetOptions $ \to -> do           withTargetMachine t "x86_64-unknown-linux" "" Map.empty to R.Default CM.Default CGO.Default $ \tm -> do-            failInIO $ moduleTargetAssembly tm m+            moduleTargetAssembly tm m       a @?= "\t.text\n\             \\t.file\t\"<string>\"\n\             \\t.globl\tmain\n\@@ -287,11 +292,11 @@     ast @?= handAST,        testCase "withModuleFromAST" $ withContext $ \context -> do-    s <- withModuleFromAST' context handAST moduleLLVMAssembly+    s <- withModuleFromAST context handAST moduleLLVMAssembly     s @?= handString,    testCase "bitcode" $ withContext $ \context -> do-    bs <- withModuleFromAST' context handAST moduleBitcode+    bs <- withModuleFromAST context handAST moduleBitcode     s <- withModuleFromBitcode' context bs moduleLLVMAssembly     s @?= handString, @@ -353,8 +358,7 @@               }             ]       strCheck ast s-      s' <- withContext $ \context -> withModuleFromAST' context ast $ runExceptT . verify-      s' @?= Right (),+      withContext $ \context -> withModuleFromAST context ast verify,      testCase "metadata type" $ withContext $ \context -> do       let s = "; ModuleID = '<string>'\n\@@ -400,7 +404,7 @@                 ]              }            ]-      t <- withModuleFromAST' context ast $ \_ -> return True+      t <- withModuleFromAST context ast $ \_ -> return True       t @?= True,      testCase "Phi node finishes" $ withContext $ \context -> do@@ -482,7 +486,7 @@                   ]                 }                ]-          s <- withModuleFromAST' context ast moduleLLVMAssembly+          s <- withModuleFromAST context ast moduleLLVMAssembly           m <- withModuleFromLLVMAssembly' context s moduleAST           m @?= ast, @@ -532,8 +536,8 @@                ]              }            ]-      t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True-      t @?= Left "reference to undefined block: Name \"not here\"",+      t <- try $ withModuleFromAST context badAST $ \_ -> return True+      t @?= Left (EncodeException "reference to undefined block: Name \"not here\""),      testCase "multiple" $ withContext $ \context -> do       let badAST = Module "<string>" "<string>" Nothing Nothing [@@ -562,13 +566,20 @@                ]              }            ]-      t <- runExceptT $ withModuleFromAST context badAST $ \_ -> return True-      t @?= Left "reference to undefined local: Name \"unknown\"",+      t <- try $ withModuleFromAST context badAST $ \_ -> return True+      t @?= Left (EncodeException "reference to undefined local: Name \"unknown\""),      testCase "sourceFileName" $ withContext $ \context -> do       let s = "; ModuleID = '<string>'\n\               \source_filename = \"filename\"\n"           ast = Module "<string>" "filename" Nothing Nothing []-      strCheck ast s+      strCheck ast s,++    testCase "badTypeDef" $ withContext $ \context -> do+      let badAST =+            Module "<string>" "<string>" Nothing Nothing+              [TypeDefinition (UnName 0) (Just VoidType)]+      t <- try $ withModuleFromAST context badAST $ \_ -> return ()+      t @?= Left (EncodeException "A type definition requires a structure type but got: VoidType")    ]  ]

@@ -24,12 +24,10 @@         withContext $ \ctx ->           withSystemTempFile "foo" $ \objFile handle -> do             hClose handle-            failInIO $-              withHostTargetMachine $ \machine ->-                failInIO $-                withModuleFromLLVMAssembly ctx ll $ \mdl -> do-                  obj <- failInIO $ moduleObject machine mdl-                  _ <- failInIO $ writeObjectToFile machine (File objFile) mdl-                  obj' <- ByteString.readFile objFile-                  obj @=? obj'+            withHostTargetMachine $ \machine ->+              withModuleFromLLVMAssembly ctx ll $ \mdl -> do+                obj <- moduleObject machine mdl+                _ <- writeObjectToFile machine (File objFile) mdl+                obj' <- ByteString.readFile objFile+                obj @=? obj'     ]

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module LLVM.Test.Optimization where  import Test.Tasty@@ -6,6 +7,7 @@ import LLVM.Test.Support  import Data.Functor+import Data.Monoid import qualified Data.Set as Set import qualified Data.Map as Map @@ -103,7 +105,7 @@    ]  optimize :: PassSetSpec -> A.Module -> IO A.Module-optimize pss m = withContext $ \context -> withModuleFromAST' context m $ \mIn' -> do+optimize pss m = withContext $ \context -> withModuleFromAST context m $ \mIn' -> do   withPassManager pss $ \pm -> runPassManager pm mIn'   moduleAST mIn' @@ -179,12 +181,12 @@            G.returnType = double,             G.name = Name "foo",             G.parameters = ([-              Parameter double (Name (l ++ n)) []+              Parameter double (Name (l <> n)) []                 | l <- [ "a", "b" ], n <- ["1", "2"]              ], False),             G.basicBlocks = [               BasicBlock (UnName 0) ([-                Name (l ++ n) := op NoFastMathFlags (LocalReference double (Name (o1 ++ n))) (LocalReference double (Name (o2 ++ n))) []+                Name (l <> n) := op NoFastMathFlags (LocalReference double (Name (o1 <> n))) (LocalReference double (Name (o2 <> n))) []                 | (l, op, o1, o2) <- [                    ("x", FSub, "a", "b"),                    ("y", FMul, "x", "a"),@@ -211,7 +213,7 @@             moduleName = "<string>",             moduleSourceFileName = "<string>",             moduleDataLayout = Just $ (defaultDataLayout BigEndian) { -              typeLayouts = Map.singleton (VectorAlign, 128) (AlignmentInfo 128 Nothing)+              typeLayouts = Map.singleton (VectorAlign, 128) (AlignmentInfo 128 128)              },             moduleTargetTriple = Just "x86_64",             moduleDefinitions = [@@ -256,7 +258,7 @@            }       mOut <- do         let triple = "x86_64"-        (target, _) <- failInIO $ lookupTarget Nothing triple+        (target, _) <- lookupTarget Nothing triple         withTargetOptions $ \targetOptions -> do           withTargetMachine target triple "" Map.empty targetOptions R.Default CM.Default CGO.Default $ \tm -> do             optimize (defaultPassSetSpec { @@ -286,7 +288,7 @@                      ]                    }                  ] -          astOut <- withModuleFromAST' context astIn $ \mIn -> do+          astOut <- withModuleFromAST context astIn $ \mIn -> do             runPassManager passManager mIn             moduleAST mIn           astOut @?= Module "<string>" "<string>" Nothing Nothing [

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} module LLVM.Test.OrcJIT where  import Test.Tasty@@ -6,6 +6,7 @@  import LLVM.Test.Support +import Data.ByteString (ByteString) import Data.Foldable import Data.IORef import Data.Word@@ -20,7 +21,7 @@ import qualified LLVM.OrcJIT.CompileOnDemandLayer as CODLayer import LLVM.Target -testModule :: String+testModule :: ByteString testModule =   "; ModuleID = '<string>'\n\   \source_filename = \"<string>\"\n\@@ -67,7 +68,7 @@   testGroup "OrcJit" [     testCase "eager compilation" $ do       withTestModule $ \mod ->-        failInIO $ withHostTargetMachine $ \tm ->+        withHostTargetMachine $ \tm ->           withObjectLinkingLayer $ \objectLayer ->             withIRCompileLayer objectLayer tm $ \compileLayer -> do               testFunc <- IRCompileLayer.mangleSymbol compileLayer "testFunc"@@ -83,7 +84,7 @@      testCase "lazy compilation" $ do       withTestModule $ \mod ->-        failInIO $ withHostTargetMachine $ \tm -> do+        withHostTargetMachine $ \tm -> do           triple <- getTargetMachineTriple tm           withObjectLinkingLayer $ \objectLayer ->             withIRCompileLayer objectLayer tm $ \baseLayer ->

@@ -1,8 +1,13 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}+ module LLVM.Test.Support where  import Test.Tasty import Test.Tasty.HUnit +import Data.ByteString (ByteString) import Data.Functor import Control.Monad import Control.Monad.Trans.Except@@ -12,21 +17,9 @@ import LLVM.Module import LLVM.Diagnostic -class FailInIO f where-  errorToString :: f -> String--failInIO :: FailInIO f => ExceptT f IO a -> IO a-failInIO = either (fail . errorToString) return <=< runExceptT--instance FailInIO String where-  errorToString = id--instance FailInIO (Either String Diagnostic) where-  errorToString = either id diagnosticDisplay--withModuleFromLLVMAssembly' c s f  = failInIO $ withModuleFromLLVMAssembly c s f-withModuleFromAST' c a f = failInIO $ withModuleFromAST c a f-withModuleFromBitcode' c a f = failInIO $ withModuleFromBitcode c ("<string>", a) f+withModuleFromLLVMAssembly' :: Context -> ByteString -> (Module -> IO a) -> IO a+withModuleFromLLVMAssembly' c s f  = withModuleFromLLVMAssembly c s f+withModuleFromBitcode' c a f = withModuleFromBitcode c ("<string>", a) f  assertEqPretty :: (Eq a, Show a) => a -> a -> Assertion assertEqPretty actual expected = do@@ -36,7 +29,7 @@  strCheckC mAST mStr mStrCanon = withContext $ \context -> do   a <- withModuleFromLLVMAssembly' context mStr moduleAST-  s <- withModuleFromAST' context mAST moduleLLVMAssembly+  s <- withModuleFromAST context mAST moduleLLVMAssembly   (a,s) `assertEqPretty` (mAST, mStrCanon)  strCheck mAST mStr = strCheckC mAST mStr mStr

@@ -1,5 +1,7 @@ {-# LANGUAGE-  RecordWildCards+  OverloadedStrings,+  RecordWildCards,+  ScopedTypeVariables   #-} module LLVM.Test.Target where @@ -9,8 +11,18 @@ import Test.QuickCheck import Test.QuickCheck.Property +import Control.Applicative import Control.Monad+import Control.Monad.IO.Class+import qualified Data.ByteString.Char8 as ByteString+import Data.Char+import Data.Map (Map)+import Foreign.C.String +import LLVM.Context+import LLVM.Internal.Coding+import LLVM.Internal.EncodeAST+import LLVM.Internal.DecodeAST import LLVM.Target import LLVM.Target.Options import LLVM.Target.LibraryFunction@@ -41,6 +53,12 @@     allowFloatingPointOperationFusion <- arbitrary     return Options { .. } +instance Arbitrary CPUFeature where+  arbitrary = CPUFeature . ByteString.pack <$>+    liftA2 (:)+      (suchThat arbitrary isAlphaNum)+      (suchThat arbitrary (all isAlphaNum))+ tests = testGroup "Target" [   testGroup "Options" [      testProperty "basic" $ \options -> ioProperty $ do@@ -67,5 +85,13 @@    ],   testCase "Host" $ do     features <- getHostCPUFeatures-    return ()+    return (),+  testGroup "CPUFeature" [+    testProperty "roundtrip" $ \cpuFeatures -> ioProperty $+        withContext $ \context -> runEncodeAST context $ do+          encodedFeatures :: CString <- (encodeM cpuFeatures)+          decodedFeatures :: Map CPUFeature Bool <- liftIO $ runDecodeAST (decodeM encodedFeatures)+          return (cpuFeatures == decodedFeatures)++   ]  ]

@@ -7,6 +7,7 @@ import qualified LLVM.Test.Constants as Constants import qualified LLVM.Test.DataLayout as DataLayout import qualified LLVM.Test.ExecutionEngine as ExecutionEngine+import qualified LLVM.Test.FunctionAttribute as FunctionAttribute import qualified LLVM.Test.Global as Global import qualified LLVM.Test.InlineAssembly as InlineAssembly import qualified LLVM.Test.Instructions as Instructions@@ -23,6 +24,7 @@     CallingConvention.tests,     Constants.tests,     DataLayout.tests,+    FunctionAttribute.tests,     ExecutionEngine.tests,     Global.tests,     InlineAssembly.tests,

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} import Test.Tasty import qualified LLVM.Test.Tests as LLVM import LLVM.CommandLine