Block/retry if a blackhole is met during packing

If packing hits a blackhole, the packing thread should block
and retry, to get consistent behaviour at the Haskell level.
To enable this from Haskell, the core routine now checks and
evaluates the blackhole before retrying (i.e. blocks on the
known-to-be-blackholed data).

As the blackhole is not necessarily (and most likely not) the
graphroot, the C code writes its address into the buffer at
position 0. This is OK since packing fails anyway, so the buffer
won't hold any useful data.

GHC/Packing/Core.hs

@@ -67,7 +67,16 @@ tryPack :: Any -> MutableByteArray# s
         -> State# s -> (# State# s , Int #)
 tryPack x# buf# s = case tryPack# x# buf# s of
                       (# s', 0#, size# #) -> (# s', I# size# #)
-                      (# s', e#,   0#  #) -> (# s', throw (decodeEx e#) #)
+                      (# s', e#,   0#  #) 
+                          | isBHExc e# -> repack s'
+                          | otherwise  -> (# s', throw (decodeEx e#) #)
+    where -- packing blocked, eval the blocking closure that we found
+          -- (i.e. block on it) and re-pack afterwards. The first
+          -- StgWord of the ByteArray contains the address (written by
+          -- the packing routine, see BLACKHOLE case in packClosure).
+      repack s = case readAddrArray# buf# 0# s of
+                   (# s', bh #) -> case (addrToAny# bh) of -- or seq it?
+                                     _ -> tryPack x# buf# s'
 
 -- | serialisation primitive, implemented in C. Returns: a
 -- status/error code and size used inside the array

GHC/Packing/PackException.hsc

@@ -32,6 +32,7 @@ serialised data.
 module GHC.Packing.PackException
     ( PackException(..)
     , decodeEx
+    , isBHExc
     ) where
 
 -- bring in error codes from cbits/Errors.h
@@ -89,3 +90,8 @@ instance Show PackException where
     show P_TypeMismatch   = "Packet data has unexpected type"
 
 instance Exception PackException
+
+-- | internally used: checks if the given code indicates 'P_BLACKHOLE'
+isBHExc :: Int## -> Bool
+isBHExc #{const P_BLACKHOLE}##   = True
+isBHExc e## = False

Test/TestExceptions.hs

@@ -63,7 +63,7 @@ runIt cfg f
 
 -- all configured tests, see below
 mytests :: [ MyTest ]
-mytests = [ evalArray,  packArray, packThreadId, packMVar, packBH,
+mytests = [ evalArray,  packArray, packThreadId, packMVar,
             unpackOther, unpackWrongType, unpackTruncated, unpackGarbled ]
 
 evalArray :: MyTest
@@ -97,21 +97,6 @@ packMVar _ = ("packing an MVar (should be cannotpack)",
                  expectException P_CANNOTPACK $ trySerialize m
              )
 
-packBH :: MyTest
-packBH _ = ("should hit a blackhole",
-            do let b = nfib 38 -- (-1) -- will loop, but so far unevaluated
-               m <- newEmptyMVar
-               putMVar m b
-               child <- forkIO $
-                       do n <- takeMVar m
-                          case n of -- poor child thread will evaluate bottom
-                            some -> error $"bottom is " ++ show some ++ "!"
-               yield -- let child thread pick up the trap
-               expectException P_BLACKHOLE
-                              (trySerialize b)
-                               -- `finally` (killThread child)
-         )
-
 unpackOther :: MyTest
 unpackOther _ = ("deserialise other binary's data (binary mismatch)",
                  expectException P_BinaryMismatch

Test/TestMThread.hs

@@ -28,9 +28,7 @@ fib x | x <= 1   = 1
 
 -- | duplicate data
 duplicate :: a -> IO a
-duplicate x = (deserialize =<< trySerialize x) `catch`
-              \e -> print (e::PackException) >> putStrLn "retry" >> duplicate x
-
+duplicate x = (deserialize =<< trySerialize x)
 
 testeval :: (Show b) => String -> a -> (a -> b) -> String -> IO ()
 testeval name dat f expected
@@ -61,8 +59,8 @@ main
         let doThread i = 
                 do v <- newEmptyMVar
                    -- note that all threads use fibL. Many calls to
-                   -- trySerialize will block on blackholes (duplicate
-                   -- function will retry in this program)
+                   -- trySerialize will block on blackholes (the core
+                   -- operation will block and retry)
                    forkIO (do testeval (show i)
                                        (cycle fibL) (!!i)
                                        (show (fibL!!(i `mod` length fibL)))

cbits/Pack.c

@@ -903,10 +903,10 @@ loop:
     case CONSTR_0_2:
         return PackGeneric(p, closure);
 
-    case CONSTR_STATIC:        // We ship indirections to CAFs: They are
-    case CONSTR_NOCAF_STATIC:  // evaluated on each PE if needed
-    case FUN_STATIC:
-    case THUNK_STATIC:
+    case CONSTR_STATIC:        // We pack indirections to CAFs:
+    case CONSTR_NOCAF_STATIC:  // Therefore, we need keepCAFs==rtsTrue
+    case FUN_STATIC:           // (otherwise GC leaves dangling pointers
+    case THUNK_STATIC:         // from original CAF site to the heap)
         // all these are packed with their tag (closure is still tagged)
         PACKETDEBUG(debugBelch("*>~~ Packing a %p (%s) as a PLC\n",
                                closure, info_type_by_ip(info)));
@@ -1029,10 +1029,21 @@ loop:
                         goto loop; // could not block (race condition), retry
                     }
                 }
+                // else (we don't know the packing TSO):
+                // In GUM, we would globalise and pack a FetchMe.
 #endif
-                // TSO not known/library code: just return the code (caller to handle it)
+                // Without global addresses and virtual shared heap, packing
+                // just fails, an error code is returned to Haskell. 
+                // Likewise in library code: would be good to just block on the
+                // blackhole, but there is no way to return to the scheduler.
                 PACKETDEBUG(debugBelch("packing hit a %s at %p (returning).\n",
                                        info_type_by_ip(info), closure));
+
+                // Packing will fail anyway, so write the blackhole address into
+                // the buffer (first word), to enable blocking from Haskell by a
+                // whnf evaluation. Caller to do the rest.
+                *p->buffer = (StgWord) closure;
+
                 return P_BLACKHOLE;
 
             default: // an indirection, pack the indirectee (jump back to start)