[commit: ghc] master: Fix loading dynamic interfaces when using -dynamic-too (ecd9676)

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

On branch  : master

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

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

commit ecd967612877e1965ddebefe9b83acd837bb413a
Author: Ian Lynagh <[email protected]>
Date:   Sat Dec 8 19:52:24 2012 +0000

    Fix loading dynamic interfaces when using -dynamic-too
    
    We need to have WayDyn in the ways in the DynFlags, or the interface
    loader will fail.
    
    -dynamic-too now correctly evaluates whether or not it is possible to
    build for the dynamic way too, but doesn't actually do so yet.

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

 compiler/iface/LoadIface.lhs     |    2 +-
 compiler/main/DynFlags.hs        |   24 ++++++++++++++----------
 compiler/typecheck/TcRnMonad.lhs |    9 +++++++++
 3 files changed, 24 insertions(+), 11 deletions(-)

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 6d23419..2c36fa9 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -561,7 +561,7 @@ findAndReadIface doc_str mod hi_boot_file
               when (gopt Opt_BuildDynamicToo dflags) $ do
                   let ref = canGenerateDynamicToo dflags
                   b <- liftIO $ readIORef ref
-                  when b $ do
+                  when b $ withDoDynamicToo $ do
                       let dynFilePath = replaceExtension filePath (dynHiSuf dflags)
                       r <- read_file dynFilePath
                       case r of
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 186c566..5e2638c 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -970,7 +970,7 @@ data Way
   | WayGran
   | WayNDP
   | WayDyn
-  deriving (Eq,Ord)
+  deriving (Eq, Ord, Show)
 
 allowed_combination :: [Way] -> Bool
 allowed_combination way = and [ x `allowedWith` y
@@ -1119,7 +1119,8 @@ doDynamicToo dflags0 = let dflags1 = unSetGeneralFlag' Opt_Static dflags0
                                          hiSuf = dynHiSuf dflags2,
                                          objectSuf = dynObjectSuf dflags2
                                      }
-                       in dflags3
+                           dflags4 = updateWays dflags3
+                       in dflags4
 
 -----------------------------------------------------------------------------
 
@@ -1759,14 +1760,8 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
 
   -- check for disabled flags in safe haskell
   let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
-
-      theWays = sort $ nub $ ways dflags2
-      theBuildTag = mkBuildTag (filter (not . wayRTSOnly) theWays)
-      dflags3 = dflags2 {
-                    ways        = theWays,
-                    buildTag    = theBuildTag,
-                    rtsBuildTag = mkBuildTag theWays
-                }
+      dflags3 = updateWays dflags2
+      theWays = ways dflags3
 
   unless (allowed_combination theWays) $
       throwGhcException (CmdLineError ("combination not supported: "  ++
@@ -1778,6 +1773,15 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
 
   return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns)
 
+updateWays :: DynFlags -> DynFlags
+updateWays dflags
+    = let theWays = sort $ nub $ ways dflags
+          theBuildTag = mkBuildTag (filter (not . wayRTSOnly) theWays)
+      in dflags {
+             ways        = theWays,
+             buildTag    = theBuildTag,
+             rtsBuildTag = mkBuildTag theWays
+         }
 
 -- | Check (and potentially disable) any extensions that aren't allowed
 -- in safe mode.
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index d866893..1d27729 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -306,6 +306,15 @@ getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
 \end{code}
 
 \begin{code}
+withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+withDoDynamicToo m = do env <- getEnv
+                        let dflags = extractDynFlags env
+                            dflags' = doDynamicToo dflags
+                            env' = replaceDynFlags env dflags'
+                        setEnv env' m
+\end{code}
+
+\begin{code}
 getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
 getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }