Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/bcf7123a319afe4ca0ed280e6a4bd03cfde89193 >--------------------------------------------------------------- commit bcf7123a319afe4ca0ed280e6a4bd03cfde89193 Author: Ian Lynagh <i...@well-typed.com> Date: Thu Dec 13 22:40:12 2012 +0000 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. >--------------------------------------------------------------- compiler/main/DriverPipeline.hs | 25 +++++++++++++++++++++++-- compiler/main/DynFlags.hs | 22 ++++++++++++++++++---- 2 files changed, 41 insertions(+), 6 deletions(-) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 59c7df7..a216370 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 81d32fe..e314955 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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 _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
