hexpat 0.19 → 0.19.1

raw patch · 16 files changed

+187/−25 lines, 16 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• Text/XML/Expat/Internal/IO.hs +58/−4
• hexpat.cabal +23/−4
• test/hexpat-leak/Parse.hs +24/−0
• test/hexpat-leak/build.sh +2/−0
• test/hexpat-leak/instant-message.llsd +3/−0
• test/hexpat-leak/run.sh +1/−0
• test/hexpat-tests.cabal +9/−8
• test/suite/TestSuite.hs +3/−0
• test/suite/Text/XML/Expat/Cursor/Tests.hs +1/−1
• test/suite/Text/XML/Expat/Proc/Tests.hs +1/−1
• test/suite/Text/XML/Expat/Tests.hs +8/−7
• test/thread-leak/build.sh +1/−0
• test/thread-leak/callme.c +9/−0
• test/thread-leak/cleak.c +1/−0
• test/thread-leak/clean.sh +1/−0
• test/thread-leak/thread-leak.hs +42/−0

@@ -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) 

@@ -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,

@@ -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"

@@ -0,0 +1,2 @@+rm -f Parse.o+ghc -O Parse.hs --make -threaded

@@ -0,0 +1,3 @@+<llsd><map><key>action</key><string>instant_message_session</string><key>params</key><map><key>agent_params</key><map><key>agent_id</key><uuid>b6cc3bbb-fd33-4776-9326-3e9c8667b0f8</uuid><key>check_estate</key><integer>1</integer><key>god_level</key><integer>0</integer><key>limited_to_estate</key><integer>1</integer></map><key>message_params</key><map><key>data</key><map><key>binary_bucket</key><binary encoding="base64">AA==</binary></map><key>from_group</key><integer>0</integer><key>from_id</key><uuid>b6cc3bbb-fd33-4776-9326-3e9c8667b0f8</uuid><key>from_name</key><string>Lolita Cheri</string><key>id</key><uuid>61e7b1ae-36c2-bb2c-feca-12a96c88ff22</uuid><key>message</key><string>/*/*/*/*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/25</string><key>offline</key><integer>0</integer><key>parent_estate_id</key><integer>1</integer><key>position</key><array><real>41.1074981689453125</real><real>224.397003173828125</real><real>35.55573272705078125</real></array><key>region_id</key><uuid>c54746d1-99bd-4715-a4ca-5a1d1064b8b1</uuid><key>source</key><integer>0</integer><key>timestamp</key><integer>0</integer><key>to_id</key><uuid>61e7b1ae-36c2-bb2c-feca-12a96c88ff22</uuid><key>ttl</key><integer>1</integer><key>type</key><integer>17</integer></map></map></map></llsd>

@@ -0,0 +1,1 @@+./Parse instant-message.llsd 10 10000 >/dev/null

@@ -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

@@ -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                 ] 

@@ -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

@@ -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

@@ -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 

@@ -0,0 +1,1 @@+ghc thread-leak.hs callme.c --make -threaded

@@ -0,0 +1,9 @@++void callme(void (*cb)())+{+    int i;++    for (i = 0; i < 10; i++)+        cb();+}+

@@ -0,0 +1,1 @@+

@@ -0,0 +1,1 @@+rm -f *.hi *.o thread-leak thread-leak_stub.*

@@ -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"+