diff --git a/Text/XML/Expat/Internal/IO.hs b/Text/XML/Expat/Internal/IO.hs --- a/Text/XML/Expat/Internal/IO.hs +++ b/Text/XML/Expat/Internal/IO.hs @@ -56,6 +56,7 @@ encodingToString ) where +import Control.Concurrent import Control.Exception (bracket) import Control.DeepSeq import Control.Monad @@ -200,6 +201,7 @@ return $ XMLParseError err loc data ExpatHandlers = ExpatHandlers + (FunPtr CXMLDeclarationHandler) (FunPtr CStartElementHandler) (FunPtr CEndElementHandler) (FunPtr CCharacterDataHandler) @@ -258,12 +260,13 @@ (xmlSetSkippedEntityHandler pp) mSkipH - return $ ExpatHandlers cStartH cEndH cCharH mExtH mSkipH + return $ ExpatHandlers cXMLDeclH cStartH cEndH cCharH mExtH mSkipH cStartCDataH cEndCDataH cProcessingInstructionH cCommentH unsafeReleaseHandlers :: ExpatHandlers -> IO () - unsafeReleaseHandlers (ExpatHandlers cStartH cEndH cCharH mcExtH mcSkipH + unsafeReleaseHandlers (ExpatHandlers cXMLDeclH cStartH cEndH cCharH mcExtH mcSkipH cStartCDataH cEndCDataH cProcessingInstructionH cCommentH) = do + freeHaskellFunPtr cXMLDeclH freeHaskellFunPtr cStartH freeHaskellFunPtr cEndH freeHaskellFunPtr cCharH @@ -280,13 +283,64 @@ cFromBool = fromBool doParseChunk :: ParserPtr -> BS.ByteString -> Bool -> IO (Bool) -doParseChunk a1 a2 a3 = +doParseChunk = ensureBoundThread $ \a1 a2 a3 -> withBStringLen a2 $ \(a2'1, a2'2) -> let {a3' = cFromBool a3} in doParseChunk'_ a1 a2'1 a2'2 a3' >>= \res -> let {res' = unStatus res} in return (res') +data WorkerIface = WorkerIface (MVar (ParserPtr, BS.ByteString, Bool)) (MVar Bool) + +workerIfaceRef :: IORef (Maybe WorkerIface) +{-# NOINLINE workerIfaceRef #-} +workerIfaceRef = unsafePerformIO $ newIORef Nothing + +-- If the calling thread is not bound, we delegate to a bound thread, because +-- otherwise we get a thread explosion (this is true in ghc-6.12.X). +-- See test/thread-leak/ directory for a test case. +ensureBoundThread :: (ParserPtr -> BS.ByteString -> Bool -> IO Bool) + -> ParserPtr + -> BS.ByteString + -> Bool + -> IO Bool +ensureBoundThread doit p bs last = do + bound <- isCurrentThreadBound + if rtsSupportsBoundThreads && not bound + then delegate + else doit p bs last + where + delegate = do + mIface <- readIORef workerIfaceRef + case mIface of + Just iface -> pipeTo iface + Nothing -> do + inV <- newEmptyMVar + outV <- newEmptyMVar + let iface = WorkerIface inV outV + justSetItGlobally <- atomicModifyIORef workerIfaceRef $ \mIface -> + case mIface of + Just _ -> (mIface, False) + Nothing -> (Just iface, True) + if justSetItGlobally + then do + _ <- forkOS $ worker iface + pipeTo iface + else + -- If it wasn't changed, then this is because we got a race + -- condition with another thread. We resolve this by trying + -- again. We'll succeed on the second attempt. The mvars + -- we allocated here will be GC'd. + delegate + + pipeTo (WorkerIface inV outV) = + putMVar inV (p, bs, last) >> takeMVar outV + + worker (WorkerIface inV outV) = forever $ + putMVar outV =<< uncurry3 doit =<< takeMVar inV + where + uncurry3 f (a, b, c) = f a b c + -- | Parse error, consisting of message text and error location data XMLParseError = XMLParseError String XMLParseLocation deriving (Eq, Show) @@ -622,7 +676,7 @@ -> Ptr CChar -- publicID -> IO () -foreign import ccall safe "wrapper" +foreign import ccall unsafe "wrapper" mkCExternalEntityRefHandler :: CExternalEntityRefHandler -> IO (FunPtr CExternalEntityRefHandler) diff --git a/hexpat.cabal b/hexpat.cabal --- a/hexpat.cabal +++ b/hexpat.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.6 Name: hexpat -Version: 0.19 +Version: 0.19.1 Synopsis: XML parser/formatter based on expat Description: This package provides a general purpose Haskell XML library using Expat to @@ -42,11 +42,21 @@ . Ensure @libexpat.dll@ can be found in your system PATH (or copy it into your executable's directory). . + BOUND VS. UNBOUND THREADS: GHC (at least versions 6.12.X) will spawn threads + if you call a safe FFI callback from an unbound thread. This can get out of + control in a busy application. To avoid this, from version 0.19.1 we now delegate + processing to a single worker thread if the calling thread is not bound. + This essentially means that hexpat currently won't exploit multicores very well. + It also means that hexpat may be more efficient on threads spawned with forkOS + (to give you a bound thread) rather than forkIO. + . ChangeLog: 0.15 changes intended to fix a (rare) \"error: a C finalizer called back into Haskell.\" that seemed only to happen only on ghc6.12.X; 0.15.1 Fix broken Annotated parse; 0.16 switch from mtl to transformers; 0.17 fix mapNodeContainer & rename some things.; 0.18 rename defaultEncoding to overrideEncoding. 0.18.3 formatG and indent were demanding list - items more than once (inefficient in chunked processing); 0.19 add Extended.hs. + items more than once (inefficient in chunked processing); 0.19 add Extended.hs; + 0.19.1 fix a memory leak introduced in 0.19, delegate parsing to bound thread + if unbound (see note above) Category: XML License: BSD3 License-File: LICENSE @@ -75,7 +85,16 @@ test/suite/Text/XML/Expat/UnitTests.hs, test/suite/Text/XML/Expat/Tests.hs, test/suite/Text/XML/Expat/Cursor/Tests.hs, - test/suite/Text/XML/Expat/ParseFormat.hs + test/suite/Text/XML/Expat/ParseFormat.hs, + test/thread-leak/build.sh, + test/thread-leak/callme.c, + test/thread-leak/cleak.c, + test/thread-leak/clean.sh, + test/thread-leak/thread-leak.hs, + test/hexpat-leak/instant-message.llsd, + test/hexpat-leak/Parse.hs, + test/hexpat-leak/run.sh, + test/hexpat-leak/build.sh Build-Type: Simple Stability: beta source-repository head @@ -87,7 +106,7 @@ base >= 3 && < 5, bytestring, transformers, - text >= 0.5 && < 0.8, + text >= 0.5 && < 0.9, utf8-string == 0.3.*, deepseq == 1.1.*, containers, diff --git a/test/hexpat-leak/Parse.hs b/test/hexpat-leak/Parse.hs new file mode 100644 --- /dev/null +++ b/test/hexpat-leak/Parse.hs @@ -0,0 +1,24 @@ +-- Thanks to Bryan O'Sullivan for this test case. +-- hexpat will spawn zillions of threads (which is seen as huge virtual memory +-- usage in top). This is now fixed in 0.19.1. + +import Control.Concurrent +import Control.Monad +import qualified Data.ByteString as B +import Text.XML.Expat.Tree +import System.Environment + +main = do + [path, threads, reads] <- getArgs + let nthreads = read threads + qs <- newQSem 0 + replicateM_ nthreads $ do + forkIO $ do + replicateM_ (read reads) $ do + bs <- B.readFile path + case parse' defaultParseOptions bs of + Left err -> print err + Right p -> print (p :: UNode B.ByteString) + signalQSem qs + replicateM_ nthreads $ waitQSem qs + putStrLn "done" diff --git a/test/hexpat-leak/build.sh b/test/hexpat-leak/build.sh new file mode 100644 --- /dev/null +++ b/test/hexpat-leak/build.sh @@ -0,0 +1,2 @@ +rm -f Parse.o +ghc -O Parse.hs --make -threaded diff --git a/test/hexpat-leak/instant-message.llsd b/test/hexpat-leak/instant-message.llsd new file mode 100644 --- /dev/null +++ b/test/hexpat-leak/instant-message.llsd @@ -0,0 +1,3 @@ +actioninstant_message_sessionparamsagent_paramsagent_idb6cc3bbb-fd33-4776-9326-3e9c8667b0f8check_estate1god_level0limited_to_estate1message_paramsdatabinary_bucketAA==from_group0from_idb6cc3bbb-fd33-4776-9326-3e9c8667b0f8from_nameLolita Cheriid61e7b1ae-36c2-bb2c-feca-12a96c88ff22message/*/*/*/*JEUX*/*/*/*/*GAMES*/*/*/*/ +*/*NANCY*/*ARTISY*/*DIEGO*/*WACKY*/*ALICE*/*NOUVEAU! Le multi NANCY .. jouer entre amis!*/*ALLEZ! VENEZ VOUS AMUSER ET GAGNER DES L$! +http://slurl.com/secondlife/Alia/170/161/25offline0parent_estate_id1position41.1074981689453125224.39700317382812535.55573272705078125region_idc54746d1-99bd-4715-a4ca-5a1d1064b8b1source0timestamp0to_id61e7b1ae-36c2-bb2c-feca-12a96c88ff22ttl1type17 diff --git a/test/hexpat-leak/run.sh b/test/hexpat-leak/run.sh new file mode 100644 --- /dev/null +++ b/test/hexpat-leak/run.sh @@ -0,0 +1,1 @@ +./Parse instant-message.llsd 10 10000 >/dev/null diff --git a/test/hexpat-tests.cabal b/test/hexpat-tests.cabal --- a/test/hexpat-tests.cabal +++ b/test/hexpat-tests.cabal @@ -11,7 +11,7 @@ build-depends: HUnit < 1.3, - QuickCheck == 1.2.0.0, + QuickCheck >= 2.1.0.3 && < 2.2, base >= 3 && < 5, bytestring, containers, @@ -19,15 +19,16 @@ haskell98, transformers, deepseq >= 1.1.0.0, - parallel < 2.2.0.0, - QuickCheck == 1.2.0.0, - test-framework < 0.3, - test-framework-hunit < 0.3, - test-framework-quickcheck < 0.3, + parallel == 3.1.*, + test-framework == 0.3.*, + test-framework-hunit == 0.2.*, + test-framework-quickcheck2 == 0.2.*, text >= 0.5, utf8-string >= 0.3.3, - List >= 0.4 + List >= 0.4, + monads-fd, + random - ghc-options: -Wall -fhpc + ghc-options: -Wall -fhpc -threaded if impl(ghc >= 6.8) ghc-options: -fwarn-tabs diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -4,6 +4,7 @@ import qualified Text.XML.Expat.Cursor.Tests import qualified Text.XML.Expat.Proc.Tests import qualified Text.XML.Expat.ParseFormat +import qualified Text.XML.Expat.ParallelTest import Test.Framework (defaultMain, testGroup) @@ -17,5 +18,7 @@ Text.XML.Expat.Cursor.Tests.tests , testGroup "Text.XML.Expat.ParseFormat" Text.XML.Expat.ParseFormat.tests + , testGroup "Text.XML.Expat.ParallelTest" + Text.XML.Expat.ParallelTest.tests ] diff --git a/test/suite/Text/XML/Expat/Cursor/Tests.hs b/test/suite/Text/XML/Expat/Cursor/Tests.hs --- a/test/suite/Text/XML/Expat/Cursor/Tests.hs +++ b/test/suite/Text/XML/Expat/Cursor/Tests.hs @@ -6,7 +6,7 @@ import Control.Monad (replicateM) import Data.Maybe import Test.Framework (Test) -import Test.Framework.Providers.QuickCheck +import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import Text.XML.Expat.Tests import Text.XML.Expat.Cursor diff --git a/test/suite/Text/XML/Expat/Proc/Tests.hs b/test/suite/Text/XML/Expat/Proc/Tests.hs --- a/test/suite/Text/XML/Expat/Proc/Tests.hs +++ b/test/suite/Text/XML/Expat/Proc/Tests.hs @@ -6,7 +6,7 @@ import Data.Maybe import Test.Framework (Test) -import Test.Framework.Providers.QuickCheck +import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import Text.XML.Expat.Tests import Text.XML.Expat.Proc diff --git a/test/suite/Text/XML/Expat/Tests.hs b/test/suite/Text/XML/Expat/Tests.hs --- a/test/suite/Text/XML/Expat/Tests.hs +++ b/test/suite/Text/XML/Expat/Tests.hs @@ -9,8 +9,10 @@ , testAttrSet ) where +import Control.Applicative import Control.Monad (liftM) import Data.ByteString.Char8 (ByteString) +import qualified Data.Map as M import Test.QuickCheck import Text.XML.Expat.Cursor (Cursor) import Text.XML.Expat.Tree @@ -49,14 +51,12 @@ instance Arbitrary TNode where - coarbitrary = undefined - - arbitrary = depth 0 + arbitrary = mkElem 0 where depth :: Int -> Gen TNode depth n = do - which <- (arbitrary :: Gen Bool) - if which then mkElem n else mkText + prob <- (choose (0, 1) :: Gen Float) + if prob < 0.75 then mkElem n else mkText mkAttr = do @@ -70,8 +70,9 @@ nchildren <- if n > 3 then return 0 else choose ((0,6) :: (Int,Int)) - nattrs <- choose ((0,3) :: (Int,Int)) - attrs <- sequence $ replicate nattrs mkAttr + nattrs <- choose ((0,4) :: (Int,Int)) + attrs <- M.toList . M.fromList -- remove duplicate attributes + <$> sequence (replicate nattrs mkAttr) children <- sequence $ replicate nchildren (depth (n+1)) tagname <- elements testTagSet diff --git a/test/thread-leak/build.sh b/test/thread-leak/build.sh new file mode 100644 --- /dev/null +++ b/test/thread-leak/build.sh @@ -0,0 +1,1 @@ +ghc thread-leak.hs callme.c --make -threaded diff --git a/test/thread-leak/callme.c b/test/thread-leak/callme.c new file mode 100644 --- /dev/null +++ b/test/thread-leak/callme.c @@ -0,0 +1,9 @@ + +void callme(void (*cb)()) +{ + int i; + + for (i = 0; i < 10; i++) + cb(); +} + diff --git a/test/thread-leak/cleak.c b/test/thread-leak/cleak.c new file mode 100644 --- /dev/null +++ b/test/thread-leak/cleak.c @@ -0,0 +1,1 @@ + diff --git a/test/thread-leak/clean.sh b/test/thread-leak/clean.sh new file mode 100644 --- /dev/null +++ b/test/thread-leak/clean.sh @@ -0,0 +1,1 @@ +rm -f *.hi *.o thread-leak thread-leak_stub.* diff --git a/test/thread-leak/thread-leak.hs b/test/thread-leak/thread-leak.hs new file mode 100644 --- /dev/null +++ b/test/thread-leak/thread-leak.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ForeignFunctionInterface, CPP #-} + +-- | In ghc 6.12.3, this program spawns lots of thread when os = False. +-- If you set os = True, then it doesn't. +-- +-- You can observe this either by seeing the virtual memory go crazy in top, +-- or by running in gdb and pressing ctrl-C. +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.ByteString as B +import Text.XML.Expat.Tree +import System.Environment +import Data.IORef +import Foreign + +os = False + +foreign import ccall safe "callme" callme :: FunPtr (IO ()) -> IO () +foreign import ccall safe "wrapper" mkPlain :: IO () -> IO (FunPtr (IO ())) + +main = do + args <- getArgs + let (nthreads, nloops) = case args of + threads : loops : _ -> (read threads, read loops) + _ -> (10, 10000) + putStrLn $ show nthreads++" threads with "++show nloops++" loops each"++ + ", using '"++(if os then "forkOS" else "forkIO")++"'" + qs <- newQSem 0 + replicateM_ nthreads $ do + (if os then forkOS else forkIO) $ do + cRef <- newIORef 0 + cb <- mkPlain $ modifyIORef cRef $ \x -> x `seq` (x+1) + replicateM_ nloops $ callme cb + freeHaskellFunPtr cb + c <- readIORef cRef + -- 'callme' calls us back 10 times + when (c /= nloops*10) $ fail $ "went really wrong: "++show (c, nloops*10) + signalQSem qs + replicateM_ nthreads $ waitQSem qs + putStrLn "done" +