Implement the slow mode of -dynamic-too
authorIan Lynagh <ian@well-typed.com>
Thu, 13 Dec 2012 22:40:12 +0000 (22:40 +0000)
committerIan Lynagh <ian@well-typed.com>
Fri, 14 Dec 2012 21:28:42 +0000 (21:28 +0000)
I'm not sure if making an entirely new HscEnv is too large a hammer,
but it works for now.

compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs

index 59c7df7..a216370 100644 (file)
@@ -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
index 81d32fe..e314955 100644 (file)
@@ -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