diff --git a/llvm-general.cabal b/llvm-general.cabal --- a/llvm-general.cabal +++ b/llvm-general.cabal @@ -1,5 +1,5 @@ name: llvm-general -version: 3.2.7.1 +version: 3.2.7.2 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -16,7 +16,7 @@ handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell. . - For haddock, see . + For haddock, see . extra-source-files: src/LLVM/General/Internal/FFI/Analysis.h src/LLVM/General/Internal/FFI/Function.h @@ -37,7 +37,7 @@ type: git location: git://github.com/bscarlet/llvm-general.git branch: llvm-3.2 - tag: v3.2.7.1 + tag: v3.2.7.2 flag shared-llvm description: link against llvm shared rather than static library @@ -52,7 +52,7 @@ ghc-options: -fwarn-unused-imports build-depends: base >= 4.5.0.0 && < 5, - text >= 0.11.2.1, + utf8-string >= 0.3.7, bytestring >= 0.9.1.10, transformers >= 0.3.0.0, mtl >= 2.0.1.0, @@ -61,7 +61,7 @@ parsec >= 3.1.3, array >= 0.4.0.0, setenv >= 0.1.0, - llvm-general-pure == 3.2.7.1 + llvm-general-pure == 3.2.7.2 extra-libraries: stdc++ hs-source-dirs: src extensions: @@ -184,8 +184,8 @@ HUnit >= 1.2.4.2, test-framework-quickcheck2 >= 0.3.0.1, QuickCheck >= 2.5.1.1, - llvm-general == 3.2.7.1, - llvm-general-pure == 3.2.7.1, + llvm-general == 3.2.7.2, + llvm-general-pure == 3.2.7.2, containers >= 0.4.2.1, mtl >= 2.0.1.0 hs-source-dirs: test @@ -197,7 +197,6 @@ other-modules: LLVM.General.Test.Analysis LLVM.General.Test.Constants - LLVM.General.Test.DataLayout LLVM.General.Test.ExecutionEngine LLVM.General.Test.Global LLVM.General.Test.InlineAssembly diff --git a/src/LLVM/General/Internal/DataLayout.hs b/src/LLVM/General/Internal/DataLayout.hs --- a/src/LLVM/General/Internal/DataLayout.hs +++ b/src/LLVM/General/Internal/DataLayout.hs @@ -1,24 +1,15 @@ module LLVM.General.Internal.DataLayout where -import Text.ParserCombinators.Parsec - import Control.Monad.Error import Control.Monad.AnyCont import Control.Exception -import Data.Word -import Data.Functor - import Foreign.Ptr -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set - import qualified LLVM.General.Internal.FFI.DataLayout as FFI import LLVM.General.AST.DataLayout -import LLVM.General.AST.AddrSpace +import LLVM.General.DataLayout import LLVM.General.Internal.Coding import LLVM.General.Internal.String () @@ -28,78 +19,3 @@ dls <- encodeM (dataLayoutToString dl) liftIO $ bracket (FFI.createDataLayout dls) FFI.disposeDataLayout f -dataLayoutToString :: DataLayout -> String -dataLayoutToString dl = - let sTriple :: (Word32, AlignmentInfo) -> String - sTriple (s, ai) = show s ++ ":" ++ show (abiAlignment ai) ++ (maybe "" (\p -> ":" ++ show p) (preferredAlignment ai)) - atChar at = case at of - IntegerAlign -> "i" - VectorAlign -> "v" - FloatAlign -> "f" - AggregateAlign -> "a" - StackAlign -> "s" - in - List.intercalate "-" ( - (case endianness dl of Just BigEndian -> ["E"]; Just LittleEndian -> ["e"]; _ -> []) - ++ - (maybe [] (\s -> ["S" ++ show s]) (stackAlignment dl)) - ++ - [ "p" ++ (if a == 0 then "" else show a) ++ ":" ++ sTriple t | (AddrSpace a, t) <- Map.toList . pointerLayouts $ dl] - ++ - [ atChar at ++ sTriple (s, ai) | ((at, s), ai) <- Map.toList . typeLayouts $ dl ] - ++ - (maybe [] (\ns -> ["n" ++ (List.intercalate ":" (map show . Set.toList $ ns))]) (nativeSizes dl)) - ) - -parseDataLayout :: String -> Maybe DataLayout -parseDataLayout "" = Nothing -parseDataLayout s = - let - num :: Parser Word32 - num = read <$> many digit - triple :: Parser (Word32, AlignmentInfo) - triple = do - s <- num - char ':' - abi <- num - pref <- optionMaybe $ do - char ':' - num - return (s, (AlignmentInfo abi pref)) - parseSpec :: Parser (DataLayout -> DataLayout) - parseSpec = choice [ - do - char 'e' - return $ \dl -> dl { endianness = Just LittleEndian }, - do - char 'E' - return $ \dl -> dl { endianness = Just BigEndian }, - do - char 'S' - n <- num - return $ \dl -> dl { stackAlignment = Just n }, - do - char 'p' - a <- AddrSpace <$> option 0 (read <$> many1 digit) - char ':' - t <- triple - return $ \dl -> dl { pointerLayouts = Map.insert a t (pointerLayouts dl) }, - do - at <- choice [ - char 'i' >> return IntegerAlign, - char 'v' >> return VectorAlign, - char 'f' >> return FloatAlign, - char 'a' >> return AggregateAlign, - char 's' >> return StackAlign - ] - (sz,ai) <- triple - return $ \dl -> dl { typeLayouts = Map.insert (at,sz) ai (typeLayouts dl) }, - do - char 'n' - ns <- num `sepBy` (char ':') - return $ \dl -> dl { nativeSizes = Just (Set.fromList ns) } - ] - in - case parse (parseSpec `sepBy` (char '-')) "" s of - Left _ -> error $ "ill formed data layout: " ++ show s - Right fs -> Just $ foldr ($) defaultDataLayout fs diff --git a/src/LLVM/General/Internal/FFI/BuilderC.cpp b/src/LLVM/General/Internal/FFI/BuilderC.cpp --- a/src/LLVM/General/Internal/FFI/BuilderC.cpp +++ b/src/LLVM/General/Internal/FFI/BuilderC.cpp @@ -92,7 +92,7 @@ ) { LoadInst *i = unwrap(b)->CreateAlignedLoad(unwrap(p), align, isVolatile, name); i->setOrdering(unwrap(atomicOrdering)); - i->setSynchScope(unwrap(synchScope)); + if (atomicOrdering != LLVMNotAtomicAtomicOrdering) i->setSynchScope(unwrap(synchScope)); return wrap(i); } @@ -109,7 +109,7 @@ StoreInst *i = unwrap(b)->CreateAlignedStore(unwrap(v), unwrap(p), align, isVolatile); i->setName(name); i->setOrdering(unwrap(atomicOrdering)); - i->setSynchScope(unwrap(synchScope)); + if (atomicOrdering != LLVMNotAtomicAtomicOrdering) i->setSynchScope(unwrap(synchScope)); return wrap(i); } diff --git a/src/LLVM/General/Internal/Module.hs b/src/LLVM/General/Internal/Module.hs --- a/src/LLVM/General/Internal/Module.hs +++ b/src/LLVM/General/Internal/Module.hs @@ -33,7 +33,6 @@ import LLVM.General.Internal.BasicBlock import LLVM.General.Internal.Coding import LLVM.General.Internal.Context -import LLVM.General.Internal.DataLayout import LLVM.General.Internal.DecodeAST import LLVM.General.Internal.Diagnostic import LLVM.General.Internal.EncodeAST @@ -46,6 +45,7 @@ import LLVM.General.Internal.Type import LLVM.General.Internal.Value +import LLVM.General.DataLayout import LLVM.General.Diagnostic import qualified LLVM.General.AST as A diff --git a/src/LLVM/General/Internal/String.hs b/src/LLVM/General/Internal/String.hs --- a/src/LLVM/General/Internal/String.hs +++ b/src/LLVM/General/Internal/String.hs @@ -20,16 +20,15 @@ import LLVM.General.Internal.Coding import qualified Data.ByteString as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.ByteString.UTF8 as BSUTF8 newtype UTF8ByteString = UTF8ByteString { utf8Bytes :: BS.ByteString } instance (Monad e) => EncodeM e String UTF8ByteString where - encodeM = return . UTF8ByteString . T.encodeUtf8 . T.pack + encodeM = return . UTF8ByteString . BSUTF8.fromString instance (Monad d) => DecodeM d String UTF8ByteString where - decodeM = return . T.unpack . T.decodeUtf8 . utf8Bytes + decodeM = return . BSUTF8.toString . utf8Bytes instance (MonadAnyCont IO e) => EncodeM e String CString where diff --git a/src/LLVM/General/Internal/Target.hs b/src/LLVM/General/Internal/Target.hs --- a/src/LLVM/General/Internal/Target.hs +++ b/src/LLVM/General/Internal/Target.hs @@ -20,7 +20,7 @@ import LLVM.General.Internal.Coding import LLVM.General.Internal.String () -import LLVM.General.Internal.DataLayout +import LLVM.General.DataLayout import LLVM.General.AST.DataLayout diff --git a/test/LLVM/General/Test/Analysis.hs b/test/LLVM/General/Test/Analysis.hs --- a/test/LLVM/General/Test/Analysis.hs +++ b/test/LLVM/General/Test/Analysis.hs @@ -31,7 +31,9 @@ tests = testGroup "Analysis" [ testGroup "Verifier" [ - testCase "Module" $ withContext $ \context -> do +{- + -- this test will cause an assertion if LLVM is compiled with assertions on. + testCase "Module" $ do let ast = Module "" Nothing Nothing [ GlobalDefinition $ Function L.External V.Default CC.C [] VoidType (Name "foo") ([ Parameter (IntegerType 32) (Name "x") [] @@ -56,12 +58,51 @@ ) ] ] - Left s <- withModuleFromAST' context ast $ runErrorT . verify + Left s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify s @?= "Call parameter type does not match function signature!\n\ \i8 1\n\ \ i32 call void @foo(i8 1)\n\ \Broken module found, compilation terminated.\n\ - \Broken module found, compilation terminated.\n" - | False -- this test will cause an assertion if LLVM is compiled with assertions on. + \Broken module found, compilation terminated.\n", +-} + + testGroup "regression" [ + testCase "load synchronization" $ do + let str = "; ModuleID = ''\n\ + \\n\ + \define double @my_function2(double* %input_0) {\n\ + \foo:\n\ + \ %tmp_input_w0 = getelementptr inbounds double* %input_0, i64 0\n\ + \ %0 = load double* %tmp_input_w0, align 8\n\ + \ ret double %0\n\ + \}\n" + ast = + Module "" Nothing Nothing [ + GlobalDefinition $ Function L.External V.Default CC.C [] (FloatingPointType 64 IEEE) (Name "my_function2") ([ + Parameter (PointerType (FloatingPointType 64 IEEE) (AddrSpace 0)) (Name "input_0") [] + ],False) [] Nothing 0 [ + BasicBlock (Name "foo") [ + Name "tmp_input_w0" := GetElementPtr { + inBounds = True, + address = LocalReference (Name "input_0"), + indices = [ConstantOperand (C.Int 64 0)], + metadata = [] + }, + UnName 0 := Load { + volatile = False, + address = LocalReference (Name "tmp_input_w0"), + maybeAtomicity = Nothing, + alignment = 8, + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference (UnName 0))) [] + ) + ] + ] + strCheck ast str + s <- withContext $ \context -> withModuleFromAST' context ast $ runErrorT . verify + s @?= Right () + ] ] ] diff --git a/test/LLVM/General/Test/DataLayout.hs b/test/LLVM/General/Test/DataLayout.hs deleted file mode 100644 --- a/test/LLVM/General/Test/DataLayout.hs +++ /dev/null @@ -1,94 +0,0 @@ -module LLVM.General.Test.DataLayout where - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit - -import LLVM.General.Test.Support - -import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Map as Map - -import LLVM.General.Context -import LLVM.General.Module -import LLVM.General.AST -import LLVM.General.AST.DataLayout -import LLVM.General.AST.AddrSpace -import qualified LLVM.General.AST.Global as G - -m s = "; ModuleID = ''\n" ++ s -t s = "target datalayout = \"" ++ s ++ "\"\n" - -tests = testGroup "DataLayout" [ - testCase name $ strCheckC (Module "" mdl Nothing []) (m sdl) (m sdlc) - | (name, mdl, sdl, sdlc) <- [ - ("none", Nothing, "", "") - ] ++ [ - (name, Just mdl, t sdl, t (fromMaybe sdl msdlc)) - | (name, mdl, sdl, msdlc) <- [ - ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e", Nothing), - ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E", Nothing), - ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32", Nothing), - ( - "no pref", - defaultDataLayout { - pointerLayouts = - Map.singleton - (AddrSpace 0) - ( - 8, - AlignmentInfo { - abiAlignment = 64, - preferredAlignment = Nothing - } - ) - }, - "p:8:64", - Nothing - ), ( - "no pref", - defaultDataLayout { - pointerLayouts = - Map.singleton - (AddrSpace 1) - ( - 8, - AlignmentInfo { - abiAlignment = 32, - preferredAlignment = Just 64 - } - ) - }, - "p1:8:32:64", - Nothing - ), ( - "big", - DataLayout { - endianness = Just LittleEndian, - stackAlignment = Just 128, - pointerLayouts = Map.fromList [ - (AddrSpace 0, (64, AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64})) - ], - typeLayouts = Map.fromList [ - ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), - ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), - ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 16}), - ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), - ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), - ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), - ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), - ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), - ((AggregateAlign, 0), AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 64}), - ((StackAlign, 0), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}) - ], - nativeSizes = Just (Set.fromList [8,16,32,64]) - }, - "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128", - Just "e-S128-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-v64:64:64-v128:128:128-f32:32:32-f64:64:64-f80:128:128-a0:0:64-s0:64:64-n8:16:32:64" - ) - ] - ] - ]