From: Simon Marlow Date: Mon, 10 Sep 2007 10:38:30 +0000 (+0000) Subject: FIX #903: mkWWcpr: not a product X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3b1438a9757639d7f37f10e1237e2369ca0ebe4a FIX #903: mkWWcpr: not a product 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. --- diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 488dbca..e2f2723 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -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 " or "Defined in " 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} %************************************************************************ diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 5b8c6a6..8e91e3a 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -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("") 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("") wiredInSrcSpan = UnhelpfulSpan FSLIT("") -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} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 97ddbfd..a937b7f 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index f1c7b88..846bec1 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -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 diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index a0bad30..d58bd11 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -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("--") diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 215eaa2..4f83aba 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -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}) diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 15a0c30..e7b4f47 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -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