[commit: ghc] ghc-parmake-gsoc: Binary: Make lazyGet more thread-safe (25f8cc8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-parmake-gsoc
Link       : http://ghc.haskell.org/trac/ghc/changeset/25f8cc8375068f8277eeaacc530248a7b33edaa1/ghc

>---------------------------------------------------------------

commit 25f8cc8375068f8277eeaacc530248a7b33edaa1
Author: Patrick Palka <patrick at parcs.ath.cx>
Date:   Fri Apr 26 11:20:02 2013 -0400

    Binary: Make lazyGet more thread-safe
    
    All values read lazily from the same BinHandle share the same mutable
    offset variable (_off_r). If two such lazy values are simultaneously
    evaluated, the two threads will step over each other when writing to
    _off_r.
    
    Fortunately, for BinMem handles, making lazyGet thread-safe is simple:
    just use a fresh off_r variable when deferring the call to getAt.
    
    For BinIO handles, a race condition still exists because IO handles
    contain their own mutable file pointer variable that gets clobbered in a
    similar way that _off_r would. But GHC doesn't use BinIO handles anywhere
    so this particular issue could be ignored for now.


>---------------------------------------------------------------

25f8cc8375068f8277eeaacc530248a7b33edaa1
 compiler/utils/Binary.hs |    7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index d14c326..1997d43 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -635,11 +635,16 @@ lazyPut bh a = do
     putAt bh pre_a q    -- fill in slot before a with ptr to q
     seekBin bh q        -- finally carry on writing at q
 
+-- XXX: This function is not thread-safe on BinIO handles.
 lazyGet :: Binary a => BinHandle -> IO a
 lazyGet bh = do
     p <- get bh -- a BinPtr
     p_a <- tellBin bh
-    a <- unsafeInterleaveIO (getAt bh p_a)
+    a <- unsafeInterleaveIO $ do
+        -- NB: Use a fresh off_r variable in the child thread, for thread
+        -- safety.
+        off_r <- newFastMutInt
+        getAt bh { _off_r = off_r } p_a
     seekBin bh p -- skip over the object for now
     return a