tidyNameOcc,
hashName, localiseName,
- nameSrcLoc, nameSrcSpan,
+ nameSrcLoc, nameSrcSpan, pprNameLoc,
isSystemName, isInternalName, isExternalName,
isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax,
-- 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}
%************************************************************************
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
SrcSpan, -- Abstract
noSrcSpan,
wiredInSrcSpan, -- Something wired into the compiler
- importedSrcSpan, -- Unknown place in an interface
mkGeneralSrcSpan,
isGoodSrcSpan, isOneLineSpan,
mkSrcSpan, srcLocSpan,
-- 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}
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc
-importedSrcLoc :: FastString -> SrcLoc
-importedSrcLoc mod_name = ImportedLoc mod_name
-
isGoodSrcLoc (SrcLoc _ _ _) = True
isGoodSrcLoc other = False
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
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}
srcSpanCol :: !Int
}
- | ImportedSpan FastString -- Module name
-
| UnhelpfulSpan FastString -- Just a general indication
-- also used to indicate an empty span
noSrcSpan = UnhelpfulSpan FSLIT("<no location info>")
wiredInSrcSpan = UnhelpfulSpan FSLIT("<wired into compiler>")
-importedSrcSpan = ImportedSpan
mkGeneralSrcSpan :: FastString -> SrcSpan
mkGeneralSrcSpan = UnhelpfulSpan
--------------------------------------------------------
-- 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
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)
(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
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
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
char ':', int col
]
-pprUserSpan (ImportedSpan mod) = ptext SLIT("Defined in") <+> ftext mod
pprUserSpan (UnhelpfulSpan s) = ftext s
\end{code}
| otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src
-\end{code}
\ No newline at end of file
+\end{code}
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
-- 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
import ByteCodeInstr
import BreakArray
import NameSet
-import TcRnDriver
import InteractiveEval
+import TcRnDriver
#endif
+import TcIface
+import TcRnMonad ( initIfaceCheck )
import Packages
import NameSet
import RdrName
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)
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
, 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
import Type ( pprTypeApp )
import GHC ( TyThing(..), SrcSpan )
import Var
+import Name
import Outputable
-- -----------------------------------------------------------------------------
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
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
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("--")
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})
-- 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
projects / ghc-hetmet.git / commitdiff