Commit bcf7123a authored by ian@well-typed.com's avatar ian@well-typed.com

Implement the slow mode of -dynamic-too

I'm not sure if making an entirely new HscEnv is too large a hammer,
but it works for now.
parent 6409ba52
......@@ -501,9 +501,30 @@ runPipeline
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
mb_basename output maybe_loc maybe_stub_o
= do r <- runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
let dflags = extractDynFlags hsc_env0
whenCannotGenerateDynamicToo dflags $ do
let dflags' = doDynamicToo dflags
hsc_env1 <- newHscEnv dflags'
_ <- runPipeline' stop_phase hsc_env1 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
return ()
return r
runPipeline'
:: Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment
-> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix)
-> Maybe FilePath -- ^ original basename (if different from ^^^)
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline' stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
= do
let dflags0 = hsc_dflags hsc_env0
(input_basename, suffix) = splitExtension input_fn
......
......@@ -27,7 +27,9 @@ module DynFlags (
wopt, wopt_set, wopt_unset,
xopt, xopt_set, xopt_unset,
lang_set,
whenGeneratingDynamicToo, ifGeneratingDynamicToo, doDynamicToo,
whenGeneratingDynamicToo, ifGeneratingDynamicToo,
whenCannotGenerateDynamicToo,
doDynamicToo,
DynFlags(..),
HasDynFlags(..), ContainsDynFlags(..),
RtsOptsEnabled(..),
......@@ -1116,12 +1118,24 @@ whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()
whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ())
ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a
ifGeneratingDynamicToo dflags f g
ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g
whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m ()
whenCannotGenerateDynamicToo dflags f
= ifCannotGenerateDynamicToo dflags f (return ())
ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a
ifCannotGenerateDynamicToo dflags f g
= generateDynamicTooConditional dflags g f g
generateDynamicTooConditional :: MonadIO m
=> DynFlags -> m a -> m a -> m a -> m a
generateDynamicTooConditional dflags canGen cannotGen notTryingToGen
= if gopt Opt_BuildDynamicToo dflags
then do let ref = canGenerateDynamicToo dflags
b <- liftIO $ readIORef ref
if b then f else g
else g
if b then canGen else cannotGen
else notTryingToGen
doDynamicToo :: DynFlags -> DynFlags
doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
......
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