Commit 3b1438a9 authored by Simon Marlow's avatar Simon Marlow

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.
parent 37df27c6
......@@ -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}
%************************************************************************
......
......@@ -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}
......@@ -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
......
......@@ -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
......@@ -1272,6 +1278,83 @@ retainInTopLevelEnvs keep_these hpt
, let mb_mod_info = lookupUFM hpt mod
, 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
......
......@@ -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("--")
......
......@@ -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})
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment