FIX #903: mkWWcpr: not a product
authorSimon Marlow <simonmar@microsoft.com>
Mon, 10 Sep 2007 10:38:30 +0000 (10:38 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Mon, 10 Sep 2007 10:38:30 +0000 (10:38 +0000)
This fixes the long-standing bug that prevents some code with
mutally-recursive modules from being compiled with --make and -O,
including GHC itself.  See the comments for details.

There are some additional cleanups that were forced/enabled by this
patch: I removed importedSrcLoc/importedSrcSpan: it wasn't adding any
useful information, since a Name already contains its defining Module.
In fact when re-typechecking an interface file we were wrongly
replacing the interesting SrcSpans in the Names with boring
importedSrcSpans, which meant that location information could degrade
after reloading modules.  Also, recreating all these Names was a waste
of space/time.

compiler/basicTypes/Name.lhs
compiler/basicTypes/SrcLoc.lhs
compiler/iface/LoadIface.lhs
compiler/main/GHC.hs
compiler/main/PprTyThing.hs
compiler/types/FamInstEnv.lhs
compiler/types/InstEnv.lhs

index 488dbca..e2f2723 100644 (file)
@@ -30,7 +30,7 @@ module Name (
        tidyNameOcc, 
        hashName, localiseName,
 
-       nameSrcLoc, nameSrcSpan,
+       nameSrcLoc, nameSrcSpan, pprNameLoc,
 
        isSystemName, isInternalName, isExternalName,
        isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax,
@@ -401,6 +401,13 @@ ppr_occ_name occ = ftext (occNameFS occ)
 -- In code style, we Z-encode the strings.  The results of Z-encoding each FastString are
 -- cached behind the scenes in the FastString implementation.
 ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ))
+
+-- Prints "Defined at <loc>" or "Defined in <mod>" information for a Name.
+pprNameLoc :: Name -> SDoc
+pprNameLoc name
+  | isGoodSrcSpan loc = pprDefnLoc loc
+  | otherwise         = ptext SLIT("Defined in ") <> ppr (nameModule name)
+  where loc = nameSrcSpan name
 \end{code}
 
 %************************************************************************
index 5b8c6a6..8e91e3a 100644 (file)
@@ -17,7 +17,6 @@ module SrcLoc (
        noSrcLoc,               -- "I'm sorry, I haven't a clue"
        advanceSrcLoc,
 
-       importedSrcLoc,         -- Unknown place in an interface
        generatedSrcLoc,        -- Code generated within the compiler
        interactiveSrcLoc,      -- Code from an interactive session
 
@@ -29,7 +28,6 @@ module SrcLoc (
        SrcSpan,                -- Abstract
        noSrcSpan, 
        wiredInSrcSpan,         -- Something wired into the compiler
-       importedSrcSpan,        -- Unknown place in an interface
        mkGeneralSrcSpan, 
        isGoodSrcSpan, isOneLineSpan,
        mkSrcSpan, srcLocSpan,
@@ -70,16 +68,9 @@ data SrcLoc
                -- Don't ask me why lines start at 1 and columns start at
                -- zero.  That's just the way it is, so there.  --SDM
 
-  | ImportedLoc        FastString      -- Module name
-
   | UnhelpfulLoc FastString    -- Just a general indication
 \end{code}
 
-Note that an entity might be imported via more than one route, and
-there could be more than one ``definition point'' --- in two or more
-\tr{.hi} files.         We deemed it probably-unworthwhile to cater for this
-rare case.
-
 %************************************************************************
 %*                                                                     *
 \subsection[SrcLoc-access-fns]{Access functions for names}
@@ -96,9 +87,6 @@ interactiveSrcLoc = UnhelpfulLoc FSLIT("<interactive session>")
 mkGeneralSrcLoc :: FastString -> SrcLoc
 mkGeneralSrcLoc = UnhelpfulLoc 
 
-importedSrcLoc :: FastString -> SrcLoc
-importedSrcLoc mod_name = ImportedLoc mod_name
-
 isGoodSrcLoc (SrcLoc _ _ _) = True
 isGoodSrcLoc other          = False
 
@@ -139,10 +127,6 @@ instance Ord SrcLoc where
 cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
 cmpSrcLoc (UnhelpfulLoc _)  other                    = LT
 
-cmpSrcLoc (ImportedLoc _)  (UnhelpfulLoc _)  = GT
-cmpSrcLoc (ImportedLoc m1) (ImportedLoc m2)  = m1 `compare` m2
-cmpSrcLoc (ImportedLoc _)  other            = LT
-
 cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)      
   = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
 cmpSrcLoc (SrcLoc _ _ _) other = GT
@@ -159,7 +143,6 @@ instance Outputable SrcLoc where
           hcat [text "{-# LINE ", int src_line, space,
                 char '\"', ftext src_path, text " #-}"]
 
-    ppr (ImportedLoc mod) = ptext SLIT("Defined in") <+> ftext mod
     ppr (UnhelpfulLoc s)  = ftext s
 \end{code}
 
@@ -202,8 +185,6 @@ data SrcSpan
          srcSpanCol      :: !Int
        }
 
-  | ImportedSpan FastString    -- Module name
-
   | UnhelpfulSpan FastString   -- Just a general indication
                                -- also used to indicate an empty span
 
@@ -217,7 +198,6 @@ instance Ord SrcSpan where
 
 noSrcSpan      = UnhelpfulSpan FSLIT("<no location info>")
 wiredInSrcSpan = UnhelpfulSpan FSLIT("<wired into compiler>")
-importedSrcSpan = ImportedSpan
 
 mkGeneralSrcSpan :: FastString -> SrcSpan
 mkGeneralSrcSpan = UnhelpfulSpan
@@ -242,7 +222,7 @@ isOneLineSpan s
 
 --------------------------------------------------------
 -- Don't export these four;
--- they panic on Imported, Unhelpful.
+-- they panic on Unhelpful.
 -- They are for internal use only
 -- Urk!  Some are needed for Lexer.x; see comment in export list
 
@@ -267,13 +247,11 @@ srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
 srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
 --------------------------------------------------------
 
-srcSpanStart (ImportedSpan str) = ImportedLoc str
 srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
 srcSpanStart s = mkSrcLoc (srcSpanFile s) 
                          (srcSpanStartLine s)
                          (srcSpanStartCol s)
 
-srcSpanEnd (ImportedSpan str) = ImportedLoc str
 srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
 srcSpanEnd s = 
   mkSrcLoc (srcSpanFile s) 
@@ -281,14 +259,11 @@ srcSpanEnd s =
           (srcSpanEndCol s)
 
 srcLocSpan :: SrcLoc -> SrcSpan
-srcLocSpan (ImportedLoc str)  = ImportedSpan str
 srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
 srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
 
 mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
-mkSrcSpan (ImportedLoc str) _  = ImportedSpan str
 mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
-mkSrcSpan _ (ImportedLoc str)  = ImportedSpan str
 mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
 mkSrcSpan loc1 loc2
   | line1 == line2 = if col1 == col2
@@ -304,9 +279,7 @@ mkSrcSpan loc1 loc2
 
 combineSrcSpans        :: SrcSpan -> SrcSpan -> SrcSpan
 -- Assumes the 'file' part is the same in both
-combineSrcSpans        (ImportedSpan str) _  = ImportedSpan str
 combineSrcSpans        (UnhelpfulSpan str) r = r -- this seems more useful
-combineSrcSpans        _ (ImportedSpan str)  = ImportedSpan str
 combineSrcSpans        l (UnhelpfulSpan str) = l
 combineSrcSpans        start end 
  = case line1 `compare` line2 of
@@ -324,7 +297,7 @@ combineSrcSpans     start end
        file  = srcSpanFile start
 
 pprDefnLoc :: SrcSpan -> SDoc
--- "defined at ..." or "imported from ..."
+-- "defined at ..."
 pprDefnLoc loc
   | isGoodSrcSpan loc = ptext SLIT("Defined at") <+> ppr loc
   | otherwise        = ppr loc
@@ -364,7 +337,6 @@ pprUserSpan (SrcSpanPoint src_path line col)
           char ':', int col
         ]
 
-pprUserSpan (ImportedSpan mod) = ptext SLIT("Defined in") <+> ftext mod
 pprUserSpan (UnhelpfulSpan s)  = ftext s
 \end{code}
 
@@ -435,4 +407,4 @@ isSubspanOf src parent
     | otherwise = srcSpanStart parent <= srcSpanStart src &&
                   srcSpanEnd parent   >= srcSpanEnd src
 
-\end{code}
\ No newline at end of file
+\end{code}
index 97ddbfd..a937b7f 100644 (file)
@@ -343,9 +343,9 @@ loadDecl :: Bool                -- Don't load pragmas into the decl pool
 loadDecl ignore_prags mod (_version, decl)
   = do         {       -- Populate the name cache with final versions of all 
                -- the names associated with the decl
-         main_name      <- mk_new_bndr mod (ifName decl)
+         main_name      <- lookupOrig mod (ifName decl)
 --        ; traceIf (text "Loading decl for " <> ppr main_name)
-       ; implicit_names <- mapM (mk_new_bndr mod) (ifaceDeclSubBndrs decl)
+       ; implicit_names <- mapM (lookupOrig mod) (ifaceDeclSubBndrs decl)
 
        -- Typecheck the thing, lazily
        -- NB. Firstly, the laziness is there in case we never need the
@@ -390,15 +390,6 @@ loadDecl ignore_prags mod (_version, decl)
                -- as the TyThings.  That way we can extend the PTE without poking the
                -- thunks
   where
-       -- mk_new_bndr allocates in the name cache the final canonical
-       -- name for the thing, with the correct 
-       --      * parent
-       --      * location
-       -- imported name, to fix the module correctly in the cache
-    mk_new_bndr mod occ 
-       = newGlobalBinder mod occ (importedSrcSpan (moduleNameFS (moduleName mod)))
-                       -- ToDo: qualify with the package name if necessary
-
     doc = ptext SLIT("Declaration for") <+> ppr (ifName decl)
 
 bumpDeclStats :: Name -> IfL ()                -- Record that one more declaration has actually been used
index f1c7b88..846bec1 100644 (file)
@@ -206,10 +206,12 @@ import Linker           ( HValue )
 import ByteCodeInstr
 import BreakArray
 import NameSet
-import TcRnDriver
 import InteractiveEval
+import TcRnDriver
 #endif
 
+import TcIface
+import TcRnMonad        ( initIfaceCheck )
 import Packages
 import NameSet
 import RdrName
@@ -1065,20 +1067,21 @@ upsweep
            HscEnv,             -- With an updated HPT
            [ModSummary])       -- Mods which succeeded
 
-upsweep hsc_env old_hpt stable_mods cleanup mods
-   = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
+upsweep hsc_env old_hpt stable_mods cleanup sccs = do
+   (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
+   return (res, hsc_env, reverse done)
  where
 
-  upsweep' hsc_env _old_hpt _stable_mods _cleanup
+  upsweep' hsc_env _old_hpt done
      [] _ _
-   = return (Succeeded, hsc_env, [])
+   = return (Succeeded, hsc_env, done)
 
-  upsweep' hsc_env _old_hpt _stable_mods _cleanup
+  upsweep' hsc_env _old_hpt done
      (CyclicSCC ms:_) _ _
    = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
-        return (Failed, hsc_env, [])
+        return (Failed, hsc_env, done)
 
-  upsweep' hsc_env old_hpt stable_mods cleanup
+  upsweep' hsc_env old_hpt done
      (AcyclicSCC mod:mods) mod_index nmods
    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ 
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface) 
@@ -1092,26 +1095,29 @@ upsweep hsc_env old_hpt stable_mods cleanup mods
         case mb_mod_info of
            Nothing -> return (Failed, hsc_env, [])
            Just mod_info -> do 
-               let this_mod = ms_mod_name mod
+               let this_mod = ms_mod_name mod
 
                        -- Add new info to hsc_env
-                     hpt1     = addToUFM (hsc_HPT hsc_env) this_mod mod_info
-                     hsc_env1 = hsc_env { hsc_HPT = hpt1 }
+                   hpt1     = addToUFM (hsc_HPT hsc_env) this_mod mod_info
+                   hsc_env1 = hsc_env { hsc_HPT = hpt1 }
 
                        -- Space-saving: delete the old HPT entry
                        -- for mod BUT if mod is a hs-boot
                        -- node, don't delete it.  For the
                        -- interface, the HPT entry is probaby for the
                        -- main Haskell source file.  Deleting it
-                       -- would force .. (what?? --SDM)
-                     old_hpt1 | isBootSummary mod = old_hpt
-                              | otherwise = delFromUFM old_hpt this_mod
+                       -- would force the real module to be recompiled
+                        -- every time.
+                   old_hpt1 | isBootSummary mod = old_hpt
+                            | otherwise = delFromUFM old_hpt this_mod
+
+                    done' = mod:done
+
+                        -- fixup our HomePackageTable after we've finished compiling
+                        -- a mutually-recursive loop.  See reTypecheckLoop, below.
+                hsc_env2 <- reTypecheckLoop hsc_env1 mod done'
 
-               ; (restOK, hsc_env2, modOKs) 
-                       <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup 
-                               mods (mod_index+1) nmods
-               ; return (restOK, hsc_env2, mod:modOKs)
-               }
+               upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
 
 
 -- Compile a single module.  Always produce a Linkable for it if 
@@ -1273,6 +1279,83 @@ retainInTopLevelEnvs keep_these hpt
                 , isJust mb_mod_info ]
 
 -- ---------------------------------------------------------------------------
+-- Typecheck module loops
+
+{-
+See bug #930.  This code fixes a long-standing bug in --make.  The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky.  Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node.  This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+  | not (isBootSummary ms) && 
+    any (\m -> ms_mod m == this_mod && isBootSummary m) graph
+  = do
+        let mss = reachableBackwards (ms_mod_name ms) graph
+            non_boot = filter (not.isBootSummary) mss
+        debugTraceMsg (hsc_dflags hsc_env) 2 $
+           text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
+        typecheckLoop hsc_env (map ms_mod_name non_boot)
+  | otherwise
+  = return hsc_env
+ where
+  this_mod = ms_mod ms
+
+typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop hsc_env mods = do
+  new_hpt <-
+    fixIO $ \new_hpt -> do
+      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+      mds <- initIfaceCheck new_hsc_env $ 
+                mapM (typecheckIface . hm_iface) hmis
+      let new_hpt = addListToUFM old_hpt 
+                        (zip mods [ hmi{ hm_details = details }
+                                  | (hmi,details) <- zip hmis mds ])
+      return new_hpt
+  return hsc_env{ hsc_HPT = new_hpt }
+  where
+    old_hpt = hsc_HPT hsc_env
+    hmis    = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+  = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ]
+  where          
+        -- all the nodes reachable by traversing the edges backwards
+        -- from the root node:
+        nodes_we_want = reachable (transposeG graph) root
+
+        -- the rest just sets up the graph:
+       (nodes, lookup_key) = moduleGraphNodes False summaries
+       (graph, vertex_fn, key_fn) = graphFromEdges' nodes
+       root 
+         | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v
+         | otherwise = panic "reachableBackwards"
+
+-- ---------------------------------------------------------------------------
 -- Topological sort of the module graph
 
 topSortModuleGraph
index a0bad30..d58bd11 100644 (file)
@@ -30,6 +30,7 @@ import TyCon  ( tyConFamInst_maybe )
 import Type    ( pprTypeApp )
 import GHC     ( TyThing(..), SrcSpan )
 import Var
+import Name
 import Outputable
 
 -- -----------------------------------------------------------------------------
@@ -44,7 +45,7 @@ type PrintExplicitForalls = Bool
 pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
 pprTyThingLoc pefas tyThing 
   = showWithLoc loc (pprTyThing pefas tyThing)
-  where loc = GHC.nameSrcSpan (GHC.getName tyThing)
+  where loc = pprNameLoc (GHC.getName tyThing)
 
 -- | Pretty-prints a 'TyThing'.
 pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
@@ -57,7 +58,7 @@ pprTyThing pefas (AClass cls)       = pprClass      pefas cls
 pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
 pprTyThingInContextLoc pefas tyThing
   = showWithLoc loc (pprTyThingInContext pefas tyThing)
-  where loc = GHC.nameSrcSpan (GHC.getName tyThing)
+  where loc = pprNameLoc (GHC.getName tyThing)
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
 -- is a data constructor, record selector, or class method, then 
@@ -241,9 +242,9 @@ add_bars (c:cs)  = sep ((equals <+> c) : map (char '|' <+>) cs)
 ppr_bndr :: GHC.NamedThing a => a -> SDoc
 ppr_bndr a = GHC.pprParenSymName a
 
-showWithLoc :: SrcSpan -> SDoc -> SDoc
+showWithLoc :: SDoc -> SDoc -> SDoc
 showWithLoc loc doc 
-    = hang doc 2 (char '\t' <> comment <+> GHC.pprDefnLoc loc)
+    = hang doc 2 (char '\t' <> comment <+> loc)
                -- The tab tries to make them line up a bit
   where
     comment = ptext SLIT("--")
index 215eaa2..4f83aba 100644 (file)
@@ -96,7 +96,7 @@ instance Outputable FamInst where
 pprFamInst :: FamInst -> SDoc
 pprFamInst famInst
   = hang (pprFamInstHdr famInst)
-       2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan famInst)))
+       2 (ptext SLIT("--") <+> pprNameLoc (getName famInst))
 
 pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
index 15a0c30..e7b4f47 100644 (file)
@@ -141,7 +141,7 @@ pprInstance :: Instance -> SDoc
 -- Prints the Instance as an instance declaration
 pprInstance ispec@(Instance { is_flag = flag })
   = hang (pprInstanceHdr ispec)
-       2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan ispec)))
+       2 (ptext SLIT("--") <+> pprNameLoc (getName ispec))
 
 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
 pprInstanceHdr :: Instance -> SDoc