Commit 4fc6524a authored by Moritz Angermann's avatar Moritz Angermann Committed by Ben Gamari

Stop the linker panic

If we fail to initialize the liker properly, we still set the
`initLinkerDone`. In fact we even set that prior to actually
initializing the linker. However if the linker initialization fails, we
the `Done` state is still true. As such we run into the `Dynamic Linker
not initialised` error. Which while technically corret is confusing as
it pulls the attation away from the real issue.

This change puts the Done state into an MVar, and as such ensureing
that all parallel access needs to wait for the linker to be actually
initialized, or try to re-initilize if it fails.

Reviewers: bgamari, RyanGlScott, simonmar, hvr

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #9868, #10355, #13137, #13607, #13531

Differential Revision: https://phabricator.haskell.org/D5012
parent 36a4c194
......@@ -87,35 +87,45 @@ import Foreign (Ptr)
The persistent linker state *must* match the actual state of the
C dynamic linker at all times, so we keep it in a private global variable.
The global IORef used for PersistentLinkerState actually contains another MVar.
The reason for this is that we want to allow another loaded copy of the GHC
library to side-effect the PLS and for those changes to be reflected here.
The global IORef used for PersistentLinkerState actually contains another MVar,
which in turn contains a Maybe PersistentLinkerState. The MVar serves to ensure
mutual exclusion between multiple loaded copies of the GHC library. The Maybe
may be Nothing to indicate that the linker has not yet been initialised.
The PersistentLinkerState maps Names to actual closures (for
interpreted code only), for use during linking.
-}
#if STAGE < 2
GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState)
GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
GLOBAL_VAR_M( v_PersistentLinkerState
, newMVar Nothing
, MVar (Maybe PersistentLinkerState))
#else
SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
, getOrSetLibHSghcPersistentLinkerState
, "getOrSetLibHSghcPersistentLinkerState"
, newMVar (panic "Dynamic linker not initialised")
, MVar PersistentLinkerState)
-- Set True when dynamic linker is initialised
SHARED_GLOBAL_VAR( v_InitLinkerDone
, getOrSetLibHSghcInitLinkerDone
, "getOrSetLibHSghcInitLinkerDone"
, False
, Bool)
, newMVar Nothing
, MVar (Maybe PersistentLinkerState))
#endif
uninitialised :: a
uninitialised = panic "Dynamic linker not initialised"
modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
modifyPLS_ f = readIORef v_PersistentLinkerState
>>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)
modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f
modifyPLS f = readIORef v_PersistentLinkerState
>>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)
where fmapFst f = fmap (\(x, y) -> (f x, y))
readPLS :: IO PersistentLinkerState
readPLS = readIORef v_PersistentLinkerState
>>= fmap (fromMaybe uninitialised) . readMVar
modifyMbPLS_
:: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
data PersistentLinkerState
= PersistentLinkerState {
......@@ -255,7 +265,7 @@ withExtendedLinkEnv new_env action
-- | Display the persistent linker state.
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
= do pls <- readPLS
putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [text "----- Linker state -----",
......@@ -290,11 +300,10 @@ showLinkerState dflags
--
initDynLinker :: HscEnv -> IO ()
initDynLinker hsc_env =
modifyPLS_ $ \pls0 -> do
done <- readIORef v_InitLinkerDone
if done then return pls0
else do writeIORef v_InitLinkerDone True
reallyInitDynLinker hsc_env
modifyMbPLS_ $ \pls -> do
case pls of
Just _ -> return pls
Nothing -> Just <$> reallyInitDynLinker hsc_env
reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState
reallyInitDynLinker hsc_env = do
......@@ -1338,8 +1347,8 @@ load_dyn hsc_env dll = do
r <- loadDLL hsc_env dll
case r of
Nothing -> return ()
Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
Just err -> cmdLineErrorIO ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")")
loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
loadFrameworks hsc_env platform pkg
......@@ -1351,8 +1360,8 @@ loadFrameworks hsc_env platform pkg
load fw = do r <- loadFramework hsc_env fw_dirs fw
case r of
Nothing -> return ()
Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
Just err -> cmdLineErrorIO ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" )
-- Try to find an object file for a given library in the given paths.
-- If it isn't present, we assume that addDLL in the RTS can find it,
......
......@@ -20,6 +20,8 @@ module Panic (
panic, sorry, assertPanic, trace,
panicDoc, sorryDoc, pgmErrorDoc,
cmdLineError, cmdLineErrorIO,
Exception.Exception(..), showException, safeShowException,
try, tryMost, throwTo,
......@@ -195,6 +197,17 @@ panicDoc x doc = throwGhcException (PprPanic x doc)
sorryDoc x doc = throwGhcException (PprSorry x doc)
pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)
cmdLineError :: String -> a
cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO
cmdLineErrorIO :: String -> IO a
cmdLineErrorIO x = do
stack <- ccsToStrings =<< getCurrentCCS x
if null stack
then throwGhcException (CmdLineError x)
else throwGhcException (CmdLineError (x ++ '\n' : renderStack stack))
-- | Throw a failed assertion exception for a given filename and line number.
assertPanic :: String -> Int -> a
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment