2 % (c) The GRASP Project, Glasgow University, 1992-1998
4 \section[Rename]{Renaming and dependency analysis passes}
7 module Rename ( renameModule ) where
9 #include "HsVersions.h"
12 import RdrHsSyn ( RdrNameHsModule )
13 import RnHsSyn ( RenamedHsModule, RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames )
15 import CmdLineOpts ( opt_HiMap, opt_D_dump_rn_trace,
16 opt_D_dump_rn, opt_D_dump_rn_stats,
17 opt_WarnUnusedBinds, opt_WarnUnusedImports
20 import RnNames ( getGlobalNames )
21 import RnSource ( rnSourceDecls, rnDecl )
22 import RnIfaces ( getImportedInstDecls, importDecl, getImportVersions,
23 getImportedRules, loadHomeInterface, getSlurped
25 import RnEnv ( availName, availNames, availsToNameSet,
26 warnUnusedTopNames, mapFvRn,
27 FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
29 import Module ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule )
30 import Name ( Name, isLocallyDefined,
31 NamedThing(..), ImportReason(..), Provenance(..),
32 pprOccName, nameOccName,
33 getNameProvenance, occNameUserString,
34 maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
37 import DataCon ( dataConTyCon, dataConType )
38 import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
39 import RdrName ( RdrName )
41 import PrelMods ( mAIN_Name, pREL_MAIN_Name )
42 import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
43 import PrelInfo ( ioTyCon_NAME, thinAirIdNames )
44 import Type ( namesOfType, funTyCon )
45 import ErrUtils ( pprBagOfErrors, pprBagOfWarnings,
46 doIfSet, dumpIfSet, ghcExit
48 import BasicTypes ( NewOrData(..) )
49 import Bag ( isEmptyBag, bagToList )
50 import FiniteMap ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM )
51 import UniqSupply ( UniqSupply )
52 import Util ( equivClasses )
53 import Maybes ( maybeToBool )
60 renameModule :: UniqSupply
64 , RenamedHsModule -- Output, after renaming
65 , InterfaceDetails -- Interface; for interface file generation
66 , RnNameSupply -- Final env; for renaming derivings
67 , [ModuleName] -- Imported modules; for profiling
70 renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc)
71 = -- Initialise the renamer monad
72 initRn mod_name us (mkSearchPath opt_HiMap) loc
74 \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
77 doIfSet (not (isEmptyBag rn_warns_bag))
78 (printErrs (pprBagOfWarnings rn_warns_bag)) >>
80 -- Check for errors; exit if so
81 doIfSet (not (isEmptyBag rn_errs_bag))
82 (printErrs (pprBagOfErrors rn_errs_bag) >>
86 -- Dump output, if any
87 (case maybe_rn_stuff of
89 Just results@(_, rn_mod, _, _, _)
90 -> dumpIfSet opt_D_dump_rn "Renamer:"
100 rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
101 = -- FIND THE GLOBAL NAME ENVIRONMENT
102 getGlobalNames this_mod `thenRn` \ maybe_stuff ->
104 -- CHECK FOR EARLY EXIT
105 if not (maybeToBool maybe_stuff) then
106 -- Everything is up to date; no need to recompile further
111 Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
115 initRnMS gbl_env fixity_env SourceMode (
116 rnSourceDecls local_decls
117 ) `thenRn` \ (rn_local_decls, source_fvs) ->
119 -- SLURP IN ALL THE NEEDED DECLARATIONS
121 real_source_fvs = implicitFVs mod_name `plusFV` source_fvs
122 -- It's important to do the "plus" this way round, so that
123 -- when compiling the prelude, locally-defined (), Bool, etc
124 -- override the implicit ones.
126 slurpImpDecls real_source_fvs `thenRn` \ rn_imp_decls ->
128 -- EXIT IF ERRORS FOUND
129 checkErrsRn `thenRn` \ no_errs_so_far ->
130 if not no_errs_so_far then
131 -- Found errors already, so exit now
136 -- GENERATE THE VERSION/USAGE INFO
137 getImportVersions mod_name exports `thenRn` \ my_usages ->
138 getNameSupplyRn `thenRn` \ name_supply ->
140 -- REPORT UNUSED NAMES
141 reportUnusedNames gbl_env global_avail_env
145 -- RETURN THE RENAMED MODULE
147 has_orphans = any isOrphanDecl rn_local_decls
148 direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
149 rn_all_decls = rn_imp_decls ++ rn_local_decls
150 renamed_module = HsModule mod_name vers
151 trashed_exports trashed_imports
155 rnStats rn_imp_decls `thenRn_`
156 returnRn (Just (mkThisModule mod_name,
158 (has_orphans, my_usages, export_env),
162 trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
163 trashed_imports = {-trace "rnSource:trashed_imports"-} []
166 @implicitFVs@ forces the renamer to slurp in some things which aren't
167 mentioned explicitly, but which might be needed by the type checker.
171 = implicit_main `plusFV`
172 mkNameSet default_tys `plusFV`
173 mkNameSet thinAirIdNames
175 -- Add occurrences for Int, Double, and (), because they
176 -- are the types to which ambigious type variables may be defaulted by
177 -- the type checker; so they won't always appear explicitly.
178 -- [The () one is a GHC extension for defaulting CCall results.]
179 -- ALSO: funTyCon, since it occurs implicitly everywhere!
180 -- (we don't want to be bothered with making funTyCon a
181 -- free var at every function application!)
182 default_tys = [getName intTyCon, getName doubleTyCon,
183 getName unitTyCon, getName funTyCon, getName boolTyCon]
185 -- Add occurrences for IO or PrimIO
186 implicit_main | mod_name == mAIN_Name
187 || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME
188 | otherwise = emptyFVs
192 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
193 = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty))
194 isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))
197 check (HsVar v) = not (isLocallyDefined v)
198 check (HsApp f a) = check f && check a
200 isOrphanDecl other = False
204 %*********************************************************
206 \subsection{Slurping declarations}
208 %*********************************************************
211 -------------------------------------------------------
212 slurpImpDecls source_fvs
213 = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
214 -- The current slurped-set records all local things
215 getSlurped `thenRn` \ local_binders ->
217 slurpSourceRefs source_fvs `thenRn` \ (decls1, needed1, wired_in) ->
219 inst_gates1 = foldr (plusFV . getWiredInGates) source_fvs wired_in
220 inst_gates2 = foldr (plusFV . getGates source_fvs) inst_gates1 decls1
222 -- Do this first slurpDecls before the getImportedInstDecls,
223 -- so that the home modules of all the inst_gates will be sure to be loaded
224 slurpDecls decls1 needed1 `thenRn` \ (decls2, needed2) ->
225 mapRn_ (load_home local_binders) wired_in `thenRn_`
227 -- Now we can get the instance decls
228 getImportedInstDecls inst_gates2 `thenRn` \ inst_decls ->
229 rnIfaceDecls decls2 needed2 inst_decls `thenRn` \ (decls3, needed3) ->
230 closeDecls decls3 needed3
232 load_home local_binders name
233 | name `elemNameSet` local_binders = returnRn ()
234 -- When compiling the prelude, a wired-in thing may
235 -- be defined in this module, in which case we don't
236 -- want to load its home module!
237 -- Using 'isLocallyDefined' doesn't work because some of
238 -- the free variables returned are simply 'listTyCon_Name',
239 -- with a system provenance. We could look them up every time
240 -- but that seems a waste.
241 | otherwise = loadHomeInterface doc name `thenRn_`
244 doc = ptext SLIT("need home module for wired in thing") <+> ppr name
246 -------------------------------------------------------
247 slurpSourceRefs :: FreeVars -- Variables referenced in source
248 -> RnMG ([RenamedHsDecl],
249 FreeVars, -- Un-satisfied needs
250 [Name]) -- Those variables referenced in the source
251 -- that turned out to be wired in things
253 slurpSourceRefs source_fvs
254 = go [] emptyFVs [] (nameSetToList source_fvs)
256 go decls fvs wired []
257 = returnRn (decls, fvs, wired)
258 go decls fvs wired (wanted_name:refs)
259 | isWiredInName wanted_name
260 = go decls fvs (wanted_name:wired) refs
262 = importDecl wanted_name `thenRn` \ maybe_decl ->
264 -- No declaration... (already slurped, or local)
265 Nothing -> go decls fvs wired refs
266 Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
267 go (new_decl : decls) (fvs1 `plusFV` fvs) wired
268 (extraGates new_decl ++ refs)
270 -- Hack alert. If we suck in a class
271 -- class Ord a => Baz a where ...
272 -- then Eq is also a 'gate'. Why? Because Eq is a superclass of Ord,
273 -- and hence may be needed during context reduction even though
274 -- Eq is never mentioned explicitly. So we snaffle out the super-classes
275 -- right now, so that slurpSourceRefs will heave them in
277 -- Similarly the RHS of type synonyms
278 extraGates (TyClD (ClassDecl ctxt _ tvs _ _ _ _ _ _ _))
279 = nameSetToList (delListFromNameSet (extractHsCtxtTyNames ctxt) (map getTyVarName tvs))
280 extraGates (TyClD (TySynonym _ tvs ty _))
281 = nameSetToList (delListFromNameSet (extractHsTyNames ty) (map getTyVarName tvs))
282 extraGates other = []
284 -------------------------------------------------------
285 -- closeDecls keeps going until the free-var set is empty
286 closeDecls decls needed
287 | not (isEmptyFVs needed)
288 = slurpDecls decls needed `thenRn` \ (decls1, needed1) ->
289 closeDecls decls1 needed1
292 = getImportedRules `thenRn` \ rule_decls ->
294 [] -> returnRn decls -- No new rules, so we are done
295 other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) ->
296 closeDecls decls1 needed1
299 -------------------------------------------------------
300 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
301 -> [(Module, RdrNameHsDecl)]
302 -> RnM d ([RenamedHsDecl], FreeVars)
303 rnIfaceDecls decls fvs [] = returnRn (decls, fvs)
304 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
305 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
307 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
310 -------------------------------------------------------
311 -- Augment decls with any decls needed by needed.
312 -- Return also free vars of the new decls (only)
313 slurpDecls decls needed
314 = go decls emptyFVs (nameSetToList needed)
316 go decls fvs [] = returnRn (decls, fvs)
317 go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) ->
320 -------------------------------------------------------
321 slurpDecl decls fvs wanted_name
322 = importDecl wanted_name `thenRn` \ maybe_decl ->
324 -- No declaration... (wired in thing)
325 Nothing -> returnRn (decls, fvs)
327 -- Found a declaration... rename it
328 Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
329 returnRn (new_decl:decls, fvs1 `plusFV` fvs)
333 %*********************************************************
335 \subsection{Extracting the 'gates'}
337 %*********************************************************
339 When we import a declaration like
341 data T = T1 Wibble | T2 Wobble
343 we don't want to treat Wibble and Wobble as gates *unless* T1, T2
344 respectively are mentioned by the user program. If only T is mentioned
345 we want only T to be a gate; that way we don't suck in useless instance
346 decls for (say) Eq Wibble, when they can't possibly be useful.
348 @getGates@ takes a newly imported (and renamed) decl, and the free
349 vars of the source program, and extracts from the decl the gate names.
352 getGates source_fvs (SigD (IfaceSig _ ty _ _))
353 = extractHsTyNames ty
355 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _))
356 = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
357 (map getTyVarName tvs)
358 `addOneToNameSet` cls
360 get (ClassOpSig n _ ty _)
361 | n `elemNameSet` source_fvs = extractHsTyNames ty
362 | otherwise = emptyFVs
364 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
365 = delListFromNameSet (extractHsTyNames ty)
366 (map getTyVarName tvs)
367 `addOneToNameSet` tycon
369 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))
370 = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
371 (map getTyVarName tvs)
372 `addOneToNameSet` tycon
374 get (ConDecl n tvs ctxt details _)
375 | n `elemNameSet` source_fvs
376 -- If the constructor is method, get fvs from all its fields
377 = delListFromNameSet (get_details details `plusFV`
378 extractHsCtxtTyNames ctxt)
379 (map getTyVarName tvs)
380 get (ConDecl n tvs ctxt (RecCon fields) _)
381 -- Even if the constructor isn't mentioned, the fields
382 -- might be, as selectors. They can't mention existentially
383 -- bound tyvars (typechecker checks for that) so no need for
384 -- the deleteListFromNameSet part
385 = foldr (plusFV . get_field) emptyFVs fields
387 get other_con = emptyFVs
389 get_details (VanillaCon tys) = plusFVs (map get_bang tys)
390 get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
391 get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields]
392 get_details (NewCon t _) = extractHsTyNames t
394 get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
395 | otherwise = emptyFVs
397 get_bang (Banged t) = extractHsTyNames t
398 get_bang (Unbanged t) = extractHsTyNames t
399 get_bang (Unpacked t) = extractHsTyNames t
401 getGates source_fvs other_decl = emptyFVs
404 getWiredInGates is just like getGates, but it sees a wired-in Name
405 rather than a declaration.
408 getWiredInGates name | is_tycon = get_wired_tycon the_tycon
409 | otherwise = get_wired_id the_id
411 maybe_wired_in_tycon = maybeWiredInTyConName name
412 is_tycon = maybeToBool maybe_wired_in_tycon
413 maybe_wired_in_id = maybeWiredInIdName name
414 Just the_tycon = maybe_wired_in_tycon
415 Just the_id = maybe_wired_in_id
417 get_wired_id id = namesOfType (idType id)
419 get_wired_tycon tycon
421 = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
423 | otherwise -- data or newtype
424 = foldr (unionNameSets . namesOfType . dataConType) emptyNameSet data_cons
426 (tyvars,ty) = getSynTyConDefn tycon
427 data_cons = tyConDataCons tycon
431 %*********************************************************
433 \subsection{Unused names}
435 %*********************************************************
438 reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names
439 | not (opt_WarnUnusedBinds || opt_WarnUnusedImports)
444 used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
446 -- Now, a use of C implies a use of T,
447 -- if C was brought into scope by T(..) or T(C)
448 really_used_names = used_names `unionNameSets`
449 mkNameSet [ availName avail
450 | sub_name <- nameSetToList used_names,
451 let avail = case lookupNameEnv avail_env sub_name of
453 Nothing -> pprTrace "r.u.n" (ppr sub_name) $
457 defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
458 defined_but_not_used = nameSetToList (defined_names `minusNameSet` really_used_names)
460 -- Filter out the ones only defined implicitly
461 bad_guys = filter reportableUnusedName defined_but_not_used
463 warnUnusedTopNames bad_guys `thenRn_`
466 reportableUnusedName :: Name -> Bool
467 reportableUnusedName name
468 = explicitlyImported (getNameProvenance name) &&
469 not (startsWithUnderscore (occNameUserString (nameOccName name)))
471 explicitlyImported (LocalDef _ _) = True -- Report unused defns of local vars
472 explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl -- Report unused explicit imports
473 explicitlyImported other = False -- Don't report others
475 -- Haskell 98 encourages compilers to suppress warnings about
476 -- unused names in a pattern if they start with "_".
477 startsWithUnderscore ('_' : _) = True -- Suppress warnings for names starting
478 startsWithUnderscore other = False -- with an underscore
480 rnStats :: [RenamedHsDecl] -> RnMG ()
482 | opt_D_dump_rn_trace ||
483 opt_D_dump_rn_stats ||
485 = getRnStats imp_decls `thenRn` \ msg ->
486 ioToRnM (printErrs msg) `thenRn_`
489 | otherwise = returnRn ()
494 %*********************************************************
496 \subsection{Statistics}
498 %*********************************************************
501 getRnStats :: [RenamedHsDecl] -> RnMG SDoc
502 getRnStats imported_decls
503 = getIfacesRn `thenRn` \ ifaces ->
505 n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]
507 decls_read = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
508 -- Data, newtype, and class decls are in the decls_fm
509 -- under multiple names; the tycon/class, and each
510 -- constructor/class op too.
511 -- The 'True' selects just the 'main' decl
512 not (isLocallyDefined (availName avail))
515 (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd, _) = count_decls decls_read
516 (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
518 unslurped_insts = iInsts ifaces
519 inst_decls_unslurped = length (bagToList unslurped_insts)
520 inst_decls_read = id_sp + inst_decls_unslurped
523 [int n_mods <+> text "interfaces read",
524 hsep [ int cd_sp, text "class decls imported, out of",
525 int cd_rd, text "read"],
526 hsep [ int dd_sp, text "data decls imported, out of",
527 int dd_rd, text "read"],
528 hsep [ int nd_sp, text "newtype decls imported, out of",
529 int nd_rd, text "read"],
530 hsep [int sd_sp, text "type synonym decls imported, out of",
531 int sd_rd, text "read"],
532 hsep [int vd_sp, text "value signatures imported, out of",
533 int vd_rd, text "read"],
534 hsep [int id_sp, text "instance decls imported, out of",
535 int inst_decls_read, text "read"],
536 text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName)
537 [d | TyClD d <- imported_decls, isClassDecl d]),
538 text "cls dcls read" <+> fsep (map (ppr . tyClDeclName)
539 [d | TyClD d <- decls_read, isClassDecl d])]
541 returnRn (hcat [text "Renamer stats: ", stats])
551 tycl_decls = [d | TyClD d <- decls]
552 (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
554 val_decls = length [() | SigD _ <- decls]
555 inst_decls = length [() | InstD _ <- decls]