[commit: ghc] master: Implement the slow mode of -dynamic-too (bcf7123)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/bcf7123a319afe4ca0ed280e6a4bd03cfde89193

>---------------------------------------------------------------

commit bcf7123a319afe4ca0ed280e6a4bd03cfde89193
Author: Ian Lynagh <[email protected]>
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