mirror of
https://github.com/jberthold/packman.git
synced 2024-09-11 13:45:24 +03:00
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.
This commit is contained in:
parent
1e01360aab
commit
464cb03fa2
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)))
|
||||
|
21
cbits/Pack.c
21
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)
|
||||
|
Loading…
Reference in New Issue
Block a user