[project @ 1999-06-25 12:26:27 by keithw]
[ghc-hetmet.git] / ghc / compiler / rename / Rename.lhs
1 %
2 % (c) The GRASP Project, Glasgow University, 1992-1998
3 %
4 \section[Rename]{Renaming and dependency analysis passes}
5
6 \begin{code}
7 module Rename ( renameModule ) where
8
9 #include "HsVersions.h"
10
11 import HsSyn
12 import RdrHsSyn         ( RdrNameHsModule )
13 import RnHsSyn          ( RenamedHsModule, RenamedHsDecl, 
14                           extractHsTyNames, extractHsCtxtTyNames
15                         )
16
17 import CmdLineOpts      ( opt_HiMap, opt_D_dump_rn_trace,
18                           opt_D_dump_rn, opt_D_dump_rn_stats,
19                           opt_WarnUnusedBinds, opt_WarnUnusedImports
20                         )
21 import RnMonad
22 import RnNames          ( getGlobalNames )
23 import RnSource         ( rnSourceDecls, rnDecl )
24 import RnIfaces         ( getImportedInstDecls, importDecl, getImportVersions,
25                           getImportedRules, loadHomeInterface, getSlurped
26                         )
27 import RnEnv            ( availName, availNames, availsToNameSet, 
28                           warnUnusedTopNames, mapFvRn,
29                           FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs
30                         )
31 import Module           ( Module, ModuleName, pprModule, mkSearchPath, mkThisModule )
32 import Name             ( Name, isLocallyDefined,
33                           NamedThing(..), ImportReason(..), Provenance(..),
34                           pprOccName, getNameProvenance, 
35                           maybeWiredInTyConName, maybeWiredInIdName, isWiredInName
36                         )
37 import Id               ( idType )
38 import DataCon          ( dataConTyCon, dataConType )
39 import TyCon            ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
40 import RdrName          ( RdrName )
41 import NameSet
42 import PrelMods         ( mAIN_Name, pREL_MAIN_Name )
43 import TysWiredIn       ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
44 import PrelInfo         ( ioTyCon_NAME, thinAirIdNames )
45 import Type             ( namesOfType, funTyCon )
46 import ErrUtils         ( pprBagOfErrors, pprBagOfWarnings,
47                           doIfSet, dumpIfSet, ghcExit
48                         )
49 import BasicTypes       ( NewOrData(..) )
50 import Bag              ( isEmptyBag, bagToList )
51 import FiniteMap        ( fmToList, delListFromFM, addToFM, sizeFM, eltsFM )
52 import UniqSupply       ( UniqSupply )
53 import Util             ( equivClasses )
54 import Maybes           ( maybeToBool )
55 import Outputable
56 \end{code}
57
58
59
60 \begin{code}
61 renameModule :: UniqSupply
62              -> RdrNameHsModule
63              -> IO (Maybe 
64                       ( Module
65                       , RenamedHsModule   -- Output, after renaming
66                       , InterfaceDetails  -- Interface; for interface file generation
67                       , RnNameSupply      -- Final env; for renaming derivings
68                       , [ModuleName]      -- Imported modules; for profiling
69                       ))
70
71 renameModule us this_mod@(HsModule mod_name vers exports imports local_decls loc)
72   =     -- Initialise the renamer monad
73     initRn mod_name us (mkSearchPath opt_HiMap) loc
74            (rename this_mod)                            >>=
75         \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
76
77         -- Check for warnings
78     doIfSet (not (isEmptyBag rn_warns_bag))
79             (printErrs (pprBagOfWarnings rn_warns_bag)) >>
80
81         -- Check for errors; exit if so
82     doIfSet (not (isEmptyBag rn_errs_bag))
83             (printErrs (pprBagOfErrors rn_errs_bag)      >>
84              ghcExit 1
85             )                                            >>
86
87         -- Dump output, if any
88     (case maybe_rn_stuff of
89         Nothing  -> return ()
90         Just results@(_, rn_mod, _, _, _)
91                  -> dumpIfSet opt_D_dump_rn "Renamer:"
92                               (ppr rn_mod)
93     )                                                   >>
94
95         -- Return results
96     return maybe_rn_stuff
97 \end{code}
98
99
100 \begin{code}
101 rename this_mod@(HsModule mod_name vers exports imports local_decls loc)
102   =     -- FIND THE GLOBAL NAME ENVIRONMENT
103     getGlobalNames this_mod                     `thenRn` \ maybe_stuff ->
104
105         -- CHECK FOR EARLY EXIT
106     if not (maybeToBool maybe_stuff) then
107         -- Everything is up to date; no need to recompile further
108         rnStats []              `thenRn_`
109         returnRn Nothing
110     else
111     let
112         Just (export_env, gbl_env, fixity_env, global_avail_env) = maybe_stuff
113     in
114
115         -- RENAME THE SOURCE
116     initRnMS gbl_env fixity_env SourceMode (
117         rnSourceDecls local_decls
118     )                                   `thenRn` \ (rn_local_decls, source_fvs) ->
119
120         -- SLURP IN ALL THE NEEDED DECLARATIONS
121     let
122         real_source_fvs = implicitFVs mod_name `plusFV` source_fvs
123                 -- It's important to do the "plus" this way round, so that
124                 -- when compiling the prelude, locally-defined (), Bool, etc
125                 -- override the implicit ones. 
126     in
127     slurpImpDecls real_source_fvs       `thenRn` \ rn_imp_decls ->
128
129         -- EXIT IF ERRORS FOUND
130     checkErrsRn                         `thenRn` \ no_errs_so_far ->
131     if not no_errs_so_far then
132         -- Found errors already, so exit now
133         rnStats []              `thenRn_`
134         returnRn Nothing
135     else
136
137         -- GENERATE THE VERSION/USAGE INFO
138     getImportVersions mod_name exports                  `thenRn` \ my_usages ->
139     getNameSupplyRn                                     `thenRn` \ name_supply ->
140
141         -- REPORT UNUSED NAMES
142     reportUnusedNames gbl_env global_avail_env
143                       export_env
144                       source_fvs                        `thenRn_`
145
146         -- RETURN THE RENAMED MODULE
147     let
148         has_orphans        = any isOrphanDecl rn_local_decls
149         direct_import_mods = [mod | ImportDecl mod _ _ _ _ _ <- imports]
150         rn_all_decls       = rn_imp_decls ++ rn_local_decls 
151         renamed_module = HsModule mod_name vers 
152                                   trashed_exports trashed_imports
153                                   rn_all_decls
154                                   loc
155     in
156     rnStats rn_imp_decls        `thenRn_`
157     returnRn (Just (mkThisModule mod_name,
158                     renamed_module, 
159                     (has_orphans, my_usages, export_env),
160                     name_supply,
161                     direct_import_mods))
162   where
163     trashed_exports  = {-trace "rnSource:trashed_exports"-} Nothing
164     trashed_imports  = {-trace "rnSource:trashed_imports"-} []
165 \end{code}
166
167 @implicitFVs@ forces the renamer to slurp in some things which aren't
168 mentioned explicitly, but which might be needed by the type checker.
169
170 \begin{code}
171 implicitFVs mod_name
172   = implicit_main               `plusFV` 
173     mkNameSet default_tys       `plusFV`
174     mkNameSet thinAirIdNames
175   where
176         -- Add occurrences for Int, Double, and (), because they
177         -- are the types to which ambigious type variables may be defaulted by
178         -- the type checker; so they won't always appear explicitly.
179         -- [The () one is a GHC extension for defaulting CCall results.]
180         -- ALSO: funTyCon, since it occurs implicitly everywhere!
181         --       (we don't want to be bothered with making funTyCon a
182         --        free var at every function application!)
183     default_tys = [getName intTyCon, getName doubleTyCon,
184                    getName unitTyCon, getName funTyCon, getName boolTyCon]
185
186         -- Add occurrences for IO or PrimIO
187     implicit_main |  mod_name == mAIN_Name
188                   || mod_name == pREL_MAIN_Name = unitFV ioTyCon_NAME
189                   |  otherwise                  = emptyFVs
190 \end{code}
191
192 \begin{code}
193 isOrphanDecl (InstD (InstDecl inst_ty _ _ _ _))
194   = not (foldNameSet ((||) . isLocallyDefined) False (extractHsTyNames inst_ty))
195 isOrphanDecl (RuleD (RuleDecl _ _ _ lhs _ _))
196   = check lhs
197   where
198     check (HsVar v)   = not (isLocallyDefined v)
199     check (HsApp f a) = check f && check a
200     check other       = True
201 isOrphanDecl other = False
202 \end{code}
203
204
205 %*********************************************************
206 %*                                                       *
207 \subsection{Slurping declarations}
208 %*                                                       *
209 %*********************************************************
210
211 \begin{code}
212 -------------------------------------------------------
213 slurpImpDecls source_fvs
214   = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
215
216         -- The current slurped-set records all local things
217     getSlurped                                  `thenRn` \ source_binders ->
218     slurpSourceRefs source_binders source_fvs   `thenRn` \ (decls1, needed1, inst_gates) ->
219
220         -- Now we can get the instance decls
221     slurpInstDecls decls1 needed1 inst_gates    `thenRn` \ (decls2, needed2) ->
222
223         -- And finally get everything else
224     closeDecls   decls2 needed2
225
226 -------------------------------------------------------
227 slurpSourceRefs :: NameSet                      -- Variables defined in source
228                 -> FreeVars                     -- Variables referenced in source
229                 -> RnMG ([RenamedHsDecl],
230                          FreeVars,              -- Un-satisfied needs
231                          FreeVars)              -- "Gates"
232 -- The declaration (and hence home module) of each gate has
233 -- already been loaded
234
235 slurpSourceRefs source_binders source_fvs
236   = go []                               -- Accumulating decls
237        emptyFVs                         -- Unsatisfied needs
238        source_fvs                       -- Accumulating gates
239        (nameSetToList source_fvs)       -- Gates whose defn hasn't been loaded yet
240   where
241     go decls fvs gates []
242         = returnRn (decls, fvs, gates)
243
244     go decls fvs gates (wanted_name:refs) 
245         | isWiredInName wanted_name
246         = load_home wanted_name         `thenRn_`
247           go decls fvs (gates `plusFV` getWiredInGates wanted_name) refs
248
249         | otherwise
250         = importDecl wanted_name                `thenRn` \ maybe_decl ->
251           case maybe_decl of
252                 -- No declaration... (already slurped, or local)
253             Nothing   -> go decls fvs gates refs
254             Just decl -> rnIfaceDecl decl               `thenRn` \ (new_decl, fvs1) ->
255                          let
256                             new_gates = getGates source_fvs new_decl
257                          in
258                          go (new_decl : decls)
259                             (fvs1 `plusFV` fvs)
260                             (gates `plusFV` new_gates)
261                             (nameSetToList new_gates ++ refs)
262
263         -- When we find a wired-in name we must load its
264         -- home module so that we find any instance decls therein
265     load_home name 
266         | name `elemNameSet` source_binders = returnRn ()
267                 -- When compiling the prelude, a wired-in thing may
268                 -- be defined in this module, in which case we don't
269                 -- want to load its home module!
270                 -- Using 'isLocallyDefined' doesn't work because some of
271                 -- the free variables returned are simply 'listTyCon_Name',
272                 -- with a system provenance.  We could look them up every time
273                 -- but that seems a waste.
274         | otherwise                           = loadHomeInterface doc name      `thenRn_`
275                                                 returnRn ()
276         where
277           doc = ptext SLIT("need home module for wired in thing") <+> ppr name
278 \end{code}
279 %
280 @slurpInstDecls@ imports appropriate instance decls.
281 It has to incorporate a loop, because consider
282 \begin{verbatim}
283         instance Foo a => Baz (Maybe a) where ...
284 \end{verbatim}
285 It may be that @Baz@ and @Maybe@ are used in the source module,
286 but not @Foo@; so we need to chase @Foo@ too.
287
288 \begin{code}
289 slurpInstDecls decls needed gates
290   | isEmptyFVs gates
291   = returnRn (decls, needed)
292
293   | otherwise
294   = getImportedInstDecls gates                          `thenRn` \ inst_decls ->
295     rnInstDecls decls needed emptyFVs inst_decls        `thenRn` \ (decls1, needed1, gates1) ->
296     slurpInstDecls decls1 needed1 gates1
297   where
298     rnInstDecls decls fvs gates []
299         = returnRn (decls, fvs, gates)
300     rnInstDecls decls fvs gates (d:ds) 
301         = rnIfaceDecl d         `thenRn` \ (new_decl, fvs1) ->
302           rnInstDecls (new_decl:decls) 
303                       (fvs1 `plusFV` fvs)
304                       (gates `plusFV` getInstDeclGates new_decl)
305                       ds
306     
307
308 -------------------------------------------------------
309 -- closeDecls keeps going until the free-var set is empty
310 closeDecls decls needed
311   | not (isEmptyFVs needed)
312   = slurpDecls decls needed     `thenRn` \ (decls1, needed1) ->
313     closeDecls decls1 needed1
314
315   | otherwise
316   = getImportedRules                    `thenRn` \ rule_decls ->
317     case rule_decls of
318         []    -> returnRn decls -- No new rules, so we are done
319         other -> rnIfaceDecls decls emptyFVs rule_decls         `thenRn` \ (decls1, needed1) ->
320                  closeDecls decls1 needed1
321                  
322
323 -------------------------------------------------------
324 rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
325              -> [(Module, RdrNameHsDecl)]
326              -> RnM d ([RenamedHsDecl], FreeVars)
327 rnIfaceDecls decls fvs []     = returnRn (decls, fvs)
328 rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d           `thenRn` \ (new_decl, fvs1) ->
329                                 rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
330
331 rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)       
332                         
333
334 -------------------------------------------------------
335 -- Augment decls with any decls needed by needed.
336 -- Return also free vars of the new decls (only)
337 slurpDecls decls needed
338   = go decls emptyFVs (nameSetToList needed) 
339   where
340     go decls fvs []         = returnRn (decls, fvs)
341     go decls fvs (ref:refs) = slurpDecl decls fvs ref   `thenRn` \ (decls1, fvs1) ->
342                               go decls1 fvs1 refs
343
344 -------------------------------------------------------
345 slurpDecl decls fvs wanted_name
346   = importDecl wanted_name              `thenRn` \ maybe_decl ->
347     case maybe_decl of
348         -- No declaration... (wired in thing)
349         Nothing -> returnRn (decls, fvs)
350
351         -- Found a declaration... rename it
352         Just decl -> rnIfaceDecl decl           `thenRn` \ (new_decl, fvs1) ->
353                      returnRn (new_decl:decls, fvs1 `plusFV` fvs)
354 \end{code}
355
356
357 %*********************************************************
358 %*                                                       *
359 \subsection{Extracting the `gates'}
360 %*                                                       *
361 %*********************************************************
362
363 When we import a declaration like
364 \begin{verbatim}
365         data T = T1 Wibble | T2 Wobble
366 \end{verbatim}
367 we don't want to treat @Wibble@ and @Wobble@ as gates
368 {\em unless} @T1@, @T2@ respectively are mentioned by the user program.
369 If only @T@ is mentioned
370 we want only @T@ to be a gate;
371 that way we don't suck in useless instance
372 decls for (say) @Eq Wibble@, when they can't possibly be useful.
373
374 @getGates@ takes a newly imported (and renamed) decl, and the free
375 vars of the source program, and extracts from the decl the gate names.
376
377 \begin{code}
378 getGates source_fvs (SigD (IfaceSig _ ty _ _))
379   = extractHsTyNames ty
380
381 getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _))
382   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
383                        (map getTyVarName tvs)
384     `addOneToNameSet` cls
385   where
386     get (ClassOpSig n _ ty _) 
387         | n `elemNameSet` source_fvs = extractHsTyNames ty
388         | otherwise                  = emptyFVs
389
390 getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
391   = delListFromNameSet (extractHsTyNames ty)
392                        (map getTyVarName tvs)
393         -- A type synonym type constructor isn't a "gate" for instance decls
394
395 getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))
396   = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
397                        (map getTyVarName tvs)
398     `addOneToNameSet` tycon
399   where
400     get (ConDecl n tvs ctxt details _)
401         | n `elemNameSet` source_fvs
402                 -- If the constructor is method, get fvs from all its fields
403         = delListFromNameSet (get_details details `plusFV` 
404                               extractHsCtxtTyNames ctxt)
405                              (map getTyVarName tvs)
406     get (ConDecl n tvs ctxt (RecCon fields) _)
407                 -- Even if the constructor isn't mentioned, the fields
408                 -- might be, as selectors.  They can't mention existentially
409                 -- bound tyvars (typechecker checks for that) so no need for 
410                 -- the deleteListFromNameSet part
411         = foldr (plusFV . get_field) emptyFVs fields
412         
413     get other_con = emptyFVs
414
415     get_details (VanillaCon tys) = plusFVs (map get_bang tys)
416     get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2
417     get_details (RecCon fields)  = plusFVs [get_bang t | (_, t) <- fields]
418     get_details (NewCon t _)     = extractHsTyNames t
419
420     get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t
421                      | otherwise                         = emptyFVs
422
423     get_bang (Banged   t) = extractHsTyNames t
424     get_bang (Unbanged t) = extractHsTyNames t
425     get_bang (Unpacked t) = extractHsTyNames t
426
427 getGates source_fvs other_decl = emptyFVs
428 \end{code}
429
430 @getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@
431 rather than a declaration.
432
433 \begin{code}
434 getWiredInGates :: Name -> FreeVars
435 getWiredInGates name    -- No classes are wired in
436   | is_id                = getWiredInGates_s (namesOfType (idType the_id))
437   | isSynTyCon the_tycon = getWiredInGates_s
438          (delListFromNameSet (namesOfType ty) (map getName tyvars))
439   | otherwise            = unitFV name
440   where
441     maybe_wired_in_id    = maybeWiredInIdName name
442     is_id                = maybeToBool maybe_wired_in_id
443     maybe_wired_in_tycon = maybeWiredInTyConName name
444     Just the_id          = maybe_wired_in_id
445     Just the_tycon       = maybe_wired_in_tycon
446     (tyvars,ty)          = getSynTyConDefn the_tycon
447
448 getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
449 \end{code}
450
451 \begin{code}
452 getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
453 getInstDeclGates other                              = emptyFVs
454 \end{code}
455
456
457 %*********************************************************
458 %*                                                       *
459 \subsection{Unused names}
460 %*                                                       *
461 %*********************************************************
462
463 \begin{code}
464 reportUnusedNames gbl_env avail_env (ExportEnv export_avails _) mentioned_names
465   | not (opt_WarnUnusedBinds || opt_WarnUnusedImports)
466   = returnRn ()
467
468   | otherwise
469   = let
470         used_names = mentioned_names `unionNameSets` availsToNameSet export_avails
471
472         -- Now, a use of C implies a use of T,
473         -- if C was brought into scope by T(..) or T(C)
474         really_used_names = used_names `unionNameSets`
475           mkNameSet [ availName avail   
476                     | sub_name <- nameSetToList used_names,
477                       let avail = case lookupNameEnv avail_env sub_name of
478                             Just avail -> avail
479                             Nothing -> pprTrace "r.u.n" (ppr sub_name) $
480                                        Avail sub_name
481                     ]
482
483         defined_names = mkNameSet (concat (rdrEnvElts gbl_env))
484         defined_but_not_used =
485            nameSetToList (defined_names `minusNameSet` really_used_names)
486
487         -- Filter out the ones only defined implicitly
488         bad_guys = filter reportableUnusedName defined_but_not_used
489     in
490     warnUnusedTopNames bad_guys `thenRn_`
491     returnRn ()
492
493 reportableUnusedName :: Name -> Bool
494 reportableUnusedName name
495   = explicitlyImported (getNameProvenance name)
496   where
497     explicitlyImported (LocalDef _ _)                        = True
498         -- Report unused defns of local vars
499     explicitlyImported (NonLocalDef (UserImport _ _ expl) _) = expl
500         -- Report unused explicit imports
501     explicitlyImported other                                 = False
502         -- Don't report others
503    
504 rnStats :: [RenamedHsDecl] -> RnMG ()
505 rnStats imp_decls
506         | opt_D_dump_rn_trace || 
507           opt_D_dump_rn_stats ||
508           opt_D_dump_rn 
509         = getRnStats imp_decls          `thenRn` \ msg ->
510           ioToRnM (printErrs msg)       `thenRn_`
511           returnRn ()
512
513         | otherwise = returnRn ()
514 \end{code}
515
516
517
518 %*********************************************************
519 %*                                                      *
520 \subsection{Statistics}
521 %*                                                      *
522 %*********************************************************
523
524 \begin{code}
525 getRnStats :: [RenamedHsDecl] -> RnMG SDoc
526 getRnStats imported_decls
527   = getIfacesRn                 `thenRn` \ ifaces ->
528     let
529         n_mods = length [() | (_, _, Just _) <- eltsFM (iImpModInfo ifaces)]
530
531         decls_read     = [decl | (_, avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces),
532                                 -- Data, newtype, and class decls are in the decls_fm
533                                 -- under multiple names; the tycon/class, and each
534                                 -- constructor/class op too.
535                                 -- The 'True' selects just the 'main' decl
536                                  not (isLocallyDefined (availName avail))
537                              ]
538
539         (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd,     _) = count_decls decls_read
540         (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls
541
542         unslurped_insts       = iInsts ifaces
543         inst_decls_unslurped  = length (bagToList unslurped_insts)
544         inst_decls_read       = id_sp + inst_decls_unslurped
545
546         stats = vcat 
547                 [int n_mods <+> text "interfaces read",
548                  hsep [ int cd_sp, text "class decls imported, out of", 
549                         int cd_rd, text "read"],
550                  hsep [ int dd_sp, text "data decls imported, out of",  
551                         int dd_rd, text "read"],
552                  hsep [ int nd_sp, text "newtype decls imported, out of",  
553                         int nd_rd, text "read"],
554                  hsep [int sd_sp, text "type synonym decls imported, out of",  
555                         int sd_rd, text "read"],
556                  hsep [int vd_sp, text "value signatures imported, out of",  
557                         int vd_rd, text "read"],
558                  hsep [int id_sp, text "instance decls imported, out of",  
559                         int inst_decls_read, text "read"],
560                  text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) 
561                                            [d | TyClD d <- imported_decls, isClassDecl d]),
562                  text "cls dcls read"  <+> fsep (map (ppr . tyClDeclName) 
563                                            [d | TyClD d <- decls_read, isClassDecl d])]
564     in
565     returnRn (hcat [text "Renamer stats: ", stats])
566
567 count_decls decls
568   = (class_decls, 
569      data_decls, 
570      newtype_decls,
571      syn_decls, 
572      val_decls, 
573      inst_decls)
574   where
575     tycl_decls = [d | TyClD d <- decls]
576     (class_decls, data_decls, newtype_decls, syn_decls) = countTyClDecls tycl_decls
577
578     val_decls     = length [() | SigD _   <- decls]
579     inst_decls    = length [() | InstD _  <- decls]
580 \end{code}    
581