Fix Trac #2412: type synonyms and hs-boot recursion
[ghc.git] / compiler / iface / MkIface.lhs
1 %
2 % (c) The University of Glasgow 2006-2008
3 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 %
5
6 \begin{code}
7 module MkIface ( 
8         mkUsedNames,
9         mkDependencies,
10         mkIface,        -- Build a ModIface from a ModGuts, 
11                         -- including computing version information
12
13         mkIfaceTc,
14
15         writeIfaceFile, -- Write the interface file
16
17         checkOldIface,  -- See if recompilation is required, by
18                         -- comparing version information
19
20         tyThingToIfaceDecl -- Converting things to their Iface equivalents
21  ) where
22 \end{code}
23
24         -----------------------------------------------
25                 Recompilation checking
26         -----------------------------------------------
27
28 A complete description of how recompilation checking works can be
29 found in the wiki commentary:
30
31  http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
32
33 Please read the above page for a top-down description of how this all
34 works.  Notes below cover specific issues related to the implementation.
35
36 Basic idea: 
37
38   * In the mi_usages information in an interface, we record the 
39     fingerprint of each free variable of the module
40
41   * In mkIface, we compute the fingerprint of each exported thing A.f.
42     For each external thing that A.f refers to, we include the fingerprint
43     of the external reference when computing the fingerprint of A.f.  So
44     if anything that A.f depends on changes, then A.f's fingerprint will
45     change.
46
47   * In checkOldIface we compare the mi_usages for the module with
48     the actual fingerprint for all each thing recorded in mi_usages
49
50 \begin{code}
51 #include "HsVersions.h"
52
53 import IfaceSyn
54 import IfaceType
55 import LoadIface
56 import Id
57 import IdInfo
58 import NewDemand
59 import CoreSyn
60 import CoreFVs
61 import Class
62 import TyCon
63 import DataCon
64 import Type
65 import TcType
66 import InstEnv
67 import FamInstEnv
68 import TcRnMonad
69 import HscTypes
70 import Finder
71 import DynFlags
72 import VarEnv
73 import Var
74 import Name
75 import RdrName
76 import NameEnv
77 import NameSet
78 import OccName
79 import Module
80 import BinIface
81 import ErrUtils
82 import Digraph
83 import SrcLoc
84 import Outputable
85 import BasicTypes       hiding ( SuccessFlag(..) )
86 import LazyUniqFM
87 import Unique
88 import Util             hiding ( eqListBy )
89 import FiniteMap
90 import FastString
91 import Maybes
92 import ListSetOps
93 import Binary
94 import Fingerprint
95 import Bag
96 import Panic
97
98 import Control.Monad
99 import Data.List
100 import Data.IORef
101 import System.FilePath
102 import System.Exit      ( exitWith, ExitCode(..) )
103 \end{code}
104
105
106
107 %************************************************************************
108 %*                                                                      *
109 \subsection{Completing an interface}
110 %*                                                                      *
111 %************************************************************************
112
113 \begin{code}
114 mkIface :: HscEnv
115         -> Maybe Fingerprint    -- The old fingerprint, if we have it
116         -> ModDetails           -- The trimmed, tidied interface
117         -> ModGuts              -- Usages, deprecations, etc
118         -> IO (ModIface,        -- The new one
119                Bool)            -- True <=> there was an old Iface, and the 
120                                 --          new one is identical, so no need
121                                 --          to write it
122
123 mkIface hsc_env maybe_old_fingerprint mod_details
124          ModGuts{     mg_module    = this_mod,
125                       mg_boot      = is_boot,
126                       mg_used_names = used_names,
127                       mg_deps      = deps,
128                       mg_dir_imps  = dir_imp_mods,
129                       mg_rdr_env   = rdr_env,
130                       mg_fix_env   = fix_env,
131                       mg_warns   = warns,
132                       mg_hpc_info  = hpc_info }
133         = mkIface_ hsc_env maybe_old_fingerprint
134                    this_mod is_boot used_names deps rdr_env 
135                    fix_env warns hpc_info dir_imp_mods mod_details
136         
137 -- | make an interface from the results of typechecking only.  Useful
138 -- for non-optimising compilation, or where we aren't generating any
139 -- object code at all ('HscNothing').
140 mkIfaceTc :: HscEnv
141           -> Maybe Fingerprint  -- The old fingerprint, if we have it
142           -> ModDetails         -- gotten from mkBootModDetails, probably
143           -> TcGblEnv           -- Usages, deprecations, etc
144           -> IO (ModIface,
145                  Bool)
146 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
147   tc_result@TcGblEnv{ tcg_mod = this_mod,
148                       tcg_src = hsc_src,
149                       tcg_imports = imports,
150                       tcg_rdr_env = rdr_env,
151                       tcg_fix_env = fix_env,
152                       tcg_warns = warns,
153                       tcg_hpc = other_hpc_info
154                     }
155   = do
156           used_names <- mkUsedNames tc_result
157           deps <- mkDependencies tc_result
158           let hpc_info = emptyHpcInfo other_hpc_info
159           mkIface_ hsc_env maybe_old_fingerprint
160                    this_mod (isHsBoot hsc_src) used_names deps rdr_env 
161                    fix_env warns hpc_info (imp_mods imports) mod_details
162         
163
164 mkUsedNames :: TcGblEnv -> IO NameSet
165 mkUsedNames 
166           TcGblEnv{ tcg_inst_uses = dfun_uses_var,
167                     tcg_dus = dus
168                   }
169  = do
170         dfun_uses <- readIORef dfun_uses_var            -- What dfuns are used
171         return (allUses dus `unionNameSets` dfun_uses)
172         
173 mkDependencies :: TcGblEnv -> IO Dependencies
174 mkDependencies
175           TcGblEnv{ tcg_mod = mod,
176                     tcg_imports = imports,
177                     tcg_th_used = th_var
178                   }
179  = do 
180       th_used   <- readIORef th_var                     -- Whether TH is used
181       let
182         dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
183                 -- M.hi-boot can be in the imp_dep_mods, but we must remove
184                 -- it before recording the modules on which this one depends!
185                 -- (We want to retain M.hi-boot in imp_dep_mods so that 
186                 --  loadHiBootInterface can see if M's direct imports depend 
187                 --  on M.hi-boot, and hence that we should do the hi-boot consistency 
188                 --  check.)
189
190                 -- Modules don't compare lexicographically usually, 
191                 -- but we want them to do so here.
192         le_mod :: Module -> Module -> Bool         
193         le_mod m1 m2 = moduleNameFS (moduleName m1) 
194                            <= moduleNameFS (moduleName m2)
195
196         le_dep_mod :: (ModuleName, IsBootInterface)
197                     -> (ModuleName, IsBootInterface) -> Bool         
198         le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
199
200         
201         pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
202              | otherwise = imp_dep_pkgs imports
203
204       return Deps { dep_mods   = sortLe le_dep_mod dep_mods,
205                     dep_pkgs   = sortLe (<=)   pkgs,        
206                     dep_orphs  = sortLe le_mod (imp_orphs  imports),
207                     dep_finsts = sortLe le_mod (imp_finsts imports) }
208                 -- sort to get into canonical order
209
210
211 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
212          -> NameSet -> Dependencies -> GlobalRdrEnv
213          -> NameEnv FixItem -> Warnings -> HpcInfo
214          -> ImportedMods
215          -> ModDetails
216          -> IO (ModIface, Bool)
217 mkIface_ hsc_env maybe_old_fingerprint 
218          this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
219          dir_imp_mods
220          ModDetails{  md_insts     = insts, 
221                       md_fam_insts = fam_insts,
222                       md_rules     = rules,
223                       md_vect_info = vect_info,
224                       md_types     = type_env,
225                       md_exports   = exports }
226 -- NB:  notice that mkIface does not look at the bindings
227 --      only at the TypeEnv.  The previous Tidy phase has
228 --      put exactly the info into the TypeEnv that we want
229 --      to expose in the interface
230
231   = do  { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
232
233         ; let   { entities = typeEnvElts type_env ;
234                   decls  = [ tyThingToIfaceDecl entity
235                            | entity <- entities,
236                              let name = getName entity,
237                              not (isImplicitTyThing entity),
238                                 -- No implicit Ids and class tycons in the interface file
239                              not (isWiredInName name),
240                                 -- Nor wired-in things; the compiler knows about them anyhow
241                              nameIsLocalOrFrom this_mod name  ]
242                                 -- Sigh: see Note [Root-main Id] in TcRnDriver
243
244                 ; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
245                 ; warns     = src_warns
246                 ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
247                 ; iface_insts = map instanceToIfaceInst insts
248                 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
249                 ; iface_vect_info = flattenVectInfo vect_info
250
251                 ; intermediate_iface = ModIface { 
252                         mi_module   = this_mod,
253                         mi_boot     = is_boot,
254                         mi_deps     = deps,
255                         mi_usages   = usages,
256                         mi_exports  = mkIfaceExports exports,
257         
258                         -- Sort these lexicographically, so that
259                         -- the result is stable across compilations
260                         mi_insts    = sortLe le_inst iface_insts,
261                         mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
262                         mi_rules    = sortLe le_rule iface_rules,
263
264                         mi_vect_info = iface_vect_info,
265
266                         mi_fixities = fixities,
267                         mi_warns  = warns,
268                         mi_globals  = Just rdr_env,
269
270                         -- Left out deliberately: filled in by addVersionInfo
271                         mi_iface_hash = fingerprint0,
272                         mi_mod_hash  = fingerprint0,
273                         mi_exp_hash  = fingerprint0,
274                         mi_orphan_hash = fingerprint0,
275                         mi_orphan    = False,   -- Always set by addVersionInfo, but
276                                                 -- it's a strict field, so we can't omit it.
277                         mi_finsts    = False,   -- Ditto
278                         mi_decls     = deliberatelyOmitted "decls",
279                         mi_hash_fn   = deliberatelyOmitted "hash_fn",
280                         mi_hpc       = isHpcUsed hpc_info,
281
282                         -- And build the cached values
283                         mi_warn_fn = mkIfaceWarnCache warns,
284                         mi_fix_fn = mkIfaceFixCache fixities }
285                 }
286
287         ; (new_iface, no_change_at_all) 
288                 <- {-# SCC "versioninfo" #-}
289                          addFingerprints hsc_env maybe_old_fingerprint
290                                          intermediate_iface decls
291
292                 -- Warn about orphans
293         ; let orph_warnings   --- Laziness means no work done unless -fwarn-orphans
294                 | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
295                 | otherwise                   = emptyBag
296               errs_and_warns = (orph_warnings, emptyBag)
297               unqual = mkPrintUnqualified dflags rdr_env
298               inst_warns = listToBag [ instOrphWarn unqual d 
299                                      | (d,i) <- insts `zip` iface_insts
300                                      , isNothing (ifInstOrph i) ]
301               rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
302                                      | r <- iface_rules
303                                      , isNothing (ifRuleOrph r) ]
304
305         ; when (not (isEmptyBag orph_warnings))
306                (do { printErrorsAndWarnings dflags errs_and_warns
307                    ; when (errorsFound dflags errs_and_warns) 
308                           (exitWith (ExitFailure 1)) })
309
310 -- XXX  ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
311    
312                 -- Debug printing
313         ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
314                         (pprModIface new_iface)
315
316                 -- bug #1617: on reload we weren't updating the PrintUnqualified
317                 -- correctly.  This stems from the fact that the interface had
318                 -- not changed, so addVersionInfo returns the old ModIface
319                 -- with the old GlobalRdrEnv (mi_globals).
320         ; let final_iface = new_iface{ mi_globals = Just rdr_env }
321
322         ; return (final_iface, no_change_at_all) }
323   where
324      r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
325      i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2  
326      i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
327
328      le_occ :: Name -> Name -> Bool
329         -- Compare lexicographically by OccName, *not* by unique, because 
330         -- the latter is not stable across compilations
331      le_occ n1 n2 = nameOccName n1 <= nameOccName n2
332
333      dflags = hsc_dflags hsc_env
334      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
335      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
336
337      flattenVectInfo (VectInfo { vectInfoVar   = vVar
338                                , vectInfoTyCon = vTyCon
339                                }) = 
340        IfaceVectInfo { 
341          ifaceVectInfoVar        = [ Var.varName v 
342                                    | (v, _) <- varEnvElts vVar],
343          ifaceVectInfoTyCon      = [ tyConName t 
344                                    | (t, t_v) <- nameEnvElts vTyCon
345                                    , t /= t_v],
346          ifaceVectInfoTyConReuse = [ tyConName t
347                                    | (t, t_v) <- nameEnvElts vTyCon
348                                    , t == t_v]
349        } 
350
351 -----------------------------
352 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
353 writeIfaceFile dflags location new_iface
354     = do createDirectoryHierarchy (takeDirectory hi_file_path)
355          writeBinIface dflags hi_file_path new_iface
356     where hi_file_path = ml_hi_file location
357
358
359 -- -----------------------------------------------------------------------------
360 -- Look up parents and versions of Names
361
362 -- This is like a global version of the mi_hash_fn field in each ModIface.
363 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
364 -- the parent and version info.
365
366 mkHashFun
367         :: HscEnv                       -- needed to look up versions
368         -> ExternalPackageState         -- ditto
369         -> (Name -> Fingerprint)
370 mkHashFun hsc_env eps
371   = \name -> 
372       let 
373         mod = nameModule name
374         occ = nameOccName name
375         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
376                    pprPanic "lookupVers2" (ppr mod <+> ppr occ)
377       in  
378         snd (mi_hash_fn iface occ `orElse` 
379                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))
380   where
381       hpt = hsc_HPT hsc_env
382       pit = eps_PIT eps
383
384 -- ---------------------------------------------------------------------------
385 -- Compute fingerprints for the interface
386
387 addFingerprints
388         :: HscEnv
389         -> Maybe Fingerprint -- the old fingerprint, if any
390         -> ModIface          -- The new interface (lacking decls)
391         -> [IfaceDecl]       -- The new decls
392         -> IO (ModIface,     -- Updated interface
393                Bool)         -- True <=> no changes at all; 
394                              -- no need to write Iface
395
396 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
397  = do
398    eps <- hscEPS hsc_env
399    let
400         -- the ABI of a declaration represents everything that is made
401         -- visible about the declaration that a client can depend on.
402         -- see IfaceDeclABI below.
403        declABI :: IfaceDecl -> IfaceDeclABI 
404        declABI decl = (this_mod, decl, extras)
405         where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
406
407        edges :: [(IfaceDeclABI, Unique, [Unique])]
408        edges = [ (abi, getUnique (ifName decl), out)
409                | decl <- new_decls
410                , let abi = declABI decl
411                , let out = localOccs $ freeNamesDeclABI abi
412                ]
413
414        localOccs = map (getUnique . getParent . getOccName) 
415                         . filter ((== this_mod) . nameModule)
416                         . nameSetToList
417           where getParent occ = lookupOccEnv parent_map occ `orElse` occ
418
419         -- maps OccNames to their parents in the current module.
420         -- e.g. a reference to a constructor must be turned into a reference
421         -- to the TyCon for the purposes of calculating dependencies.
422        parent_map :: OccEnv OccName
423        parent_map = foldr extend emptyOccEnv new_decls
424           where extend d env = 
425                   extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
426                   where n = ifName d
427
428         -- strongly-connected groups of declarations, in dependency order
429        groups = stronglyConnCompFromEdgedVertices edges
430
431        global_hash_fn = mkHashFun hsc_env eps
432
433         -- how to output Names when generating the data to fingerprint.
434         -- Here we want to output the fingerprint for each top-level
435         -- Name, whether it comes from the current module or another
436         -- module.  In this way, the fingerprint for a declaration will
437         -- change if the fingerprint for anything it refers to (transitively)
438         -- changes.
439        mk_put_name :: (OccEnv (OccName,Fingerprint))
440                    -> BinHandle -> Name -> IO  ()
441        mk_put_name local_env bh name
442           | isWiredInName name  =  putNameLiterally bh name 
443            -- wired-in names don't have fingerprints
444           | otherwise
445           = let hash | nameModule name /= this_mod =  global_hash_fn name
446                      | otherwise = 
447                         snd (lookupOccEnv local_env (getOccName name)
448                            `orElse` pprPanic "urk! lookup local fingerprint" 
449                                        (ppr name)) -- (undefined,fingerprint0))
450                 -- This panic indicates that we got the dependency
451                 -- analysis wrong, because we needed a fingerprint for
452                 -- an entity that wasn't in the environment.  To debug
453                 -- it, turn the panic into a trace, uncomment the
454                 -- pprTraces below, run the compile again, and inspect
455                 -- the output and the generated .hi file with
456                 -- --show-iface.
457             in 
458             put_ bh hash
459
460         -- take a strongly-connected group of declarations and compute
461         -- its fingerprint.
462
463        fingerprint_group :: (OccEnv (OccName,Fingerprint), 
464                              [(Fingerprint,IfaceDecl)])
465                          -> SCC IfaceDeclABI
466                          -> IO (OccEnv (OccName,Fingerprint), 
467                                 [(Fingerprint,IfaceDecl)])
468
469        fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
470           = do let hash_fn = mk_put_name local_env
471                    decl = abiDecl abi
472                -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
473                hash <- computeFingerprint dflags hash_fn abi
474                return (extend_hash_env (hash,decl) local_env,
475                        (hash,decl) : decls_w_hashes)
476
477        fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
478           = do let decls = map abiDecl abis
479                    local_env' = foldr extend_hash_env local_env 
480                                    (zip (repeat fingerprint0) decls)
481                    hash_fn = mk_put_name local_env'
482                -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
483                let stable_abis = sortBy cmp_abiNames abis
484                 -- put the cycle in a canonical order
485                hash <- computeFingerprint dflags hash_fn stable_abis
486                let pairs = zip (repeat hash) decls
487                return (foldr extend_hash_env local_env pairs,
488                        pairs ++ decls_w_hashes)
489
490        extend_hash_env :: (Fingerprint,IfaceDecl)
491                        -> OccEnv (OccName,Fingerprint)
492                        -> OccEnv (OccName,Fingerprint)
493        extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
494         where
495           decl_name = ifName d
496           item = (decl_name, hash)
497           env1 = extendOccEnv env0 decl_name item
498           add_imp bndr env = extendOccEnv env bndr item
499             
500    --
501    (local_env, decls_w_hashes) <- 
502        foldM fingerprint_group (emptyOccEnv, []) groups
503
504    -- when calculating fingerprints, we always need to use canonical
505    -- ordering for lists of things.  In particular, the mi_deps has various
506    -- lists of modules and suchlike, so put these all in canonical order:
507    let sorted_deps = sortDependencies (mi_deps iface0)
508
509    -- the export hash of a module depends on the orphan hashes of the
510    -- orphan modules below us in the dependeny tree.  This is the way
511    -- that changes in orphans get propagated all the way up the
512    -- dependency tree.  We only care about orphan modules in the current
513    -- package, because changes to orphans outside this package will be
514    -- tracked by the usage on the ABI hash of package modules that we import.
515    let orph_mods = filter ((== this_pkg) . modulePackageId)
516                    $ dep_orphs sorted_deps
517    dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
518
519    orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
520                       (map IfaceInstABI orph_insts, orph_rules, fam_insts)
521
522    -- the export list hash doesn't depend on the fingerprints of
523    -- the Names it mentions, only the Names themselves, hence putNameLiterally.
524    export_hash <- computeFingerprint dflags putNameLiterally 
525                       (mi_exports iface0, orphan_hash, dep_orphan_hashes)
526
527    -- put the declarations in a canonical order, sorted by OccName
528    let sorted_decls = eltsFM $ listToFM $
529                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
530
531    -- the ABI hash depends on:
532    --   - decls
533    --   - export list
534    --   - orphans
535    --   - deprecations
536    --   - XXX vect info?
537    mod_hash <- computeFingerprint dflags putNameLiterally
538                       (map fst sorted_decls,
539                        export_hash,
540                        orphan_hash,
541                        mi_warns iface0)
542
543    -- The interface hash depends on:
544    --    - the ABI hash, plus
545    --    - usages
546    --    - deps
547    --    - hpc
548    iface_hash <- computeFingerprint dflags putNameLiterally
549                       (mod_hash, 
550                        mi_usages iface0,
551                        sorted_deps,
552                        mi_hpc iface0)
553
554    let
555     no_change_at_all = Just iface_hash == mb_old_fingerprint
556
557     final_iface = iface0 {
558                 mi_mod_hash    = mod_hash,
559                 mi_iface_hash  = iface_hash,
560                 mi_exp_hash    = export_hash,
561                 mi_orphan_hash = orphan_hash,
562                 mi_orphan      = not (null orph_rules && null orph_insts),
563                 mi_finsts      = not . null $ mi_fam_insts iface0,
564                 mi_decls       = sorted_decls,
565                 mi_hash_fn     = lookupOccEnv local_env }
566    --
567    return (final_iface, no_change_at_all)
568
569   where
570     this_mod = mi_module iface0
571     dflags = hsc_dflags hsc_env
572     this_pkg = thisPackage dflags
573     (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
574     (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
575         -- ToDo: shouldn't we be splitting fam_insts into orphans and
576         -- non-orphans?
577     fam_insts = mi_fam_insts iface0
578     fix_fn = mi_fix_fn iface0
579
580
581 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
582 getOrphanHashes hsc_env mods = do
583   eps <- hscEPS hsc_env
584   let 
585     hpt        = hsc_HPT hsc_env
586     pit        = eps_PIT eps
587     dflags     = hsc_dflags hsc_env
588     get_orph_hash mod = 
589           case lookupIfaceByModule dflags hpt pit mod of
590             Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
591             Just iface -> mi_orphan_hash iface
592   --
593   return (map get_orph_hash mods)
594
595
596 sortDependencies :: Dependencies -> Dependencies
597 sortDependencies d
598  = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
599           dep_pkgs   = sortBy (compare `on` packageIdFS)  (dep_pkgs d),
600           dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
601           dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
602
603 -- The ABI of a declaration consists of:
604      -- the full name of the identifier (inc. module and package, because
605      --   these are used to construct the symbol name by which the 
606      --   identifier is known externally).
607      -- the fixity of the identifier
608      -- the declaration itself, as exposed to clients.  That is, the
609      --   definition of an Id is included in the fingerprint only if
610      --   it is made available as as unfolding in the interface.
611      -- for Ids: rules
612      -- for classes: instances, fixity & rules for methods
613      -- for datatypes: instances, fixity & rules for constrs
614 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
615
616 abiDecl :: IfaceDeclABI -> IfaceDecl
617 abiDecl (_, decl, _) = decl
618
619 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
620 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` 
621                          ifName (abiDecl abi2)
622
623 freeNamesDeclABI :: IfaceDeclABI -> NameSet
624 freeNamesDeclABI (_mod, decl, extras) =
625   freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
626
627 data IfaceDeclExtras 
628   = IfaceIdExtras    Fixity [IfaceRule]
629   | IfaceDataExtras  Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
630   | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])]
631   | IfaceOtherDeclExtras
632
633 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
634 freeNamesDeclExtras (IfaceIdExtras    _ rules)
635   = unionManyNameSets (map freeNamesIfRule rules)
636 freeNamesDeclExtras (IfaceDataExtras  _ _insts subs)
637   = unionManyNameSets (map freeNamesSub subs)
638 freeNamesDeclExtras (IfaceClassExtras _insts subs)
639   = unionManyNameSets (map freeNamesSub subs)
640 freeNamesDeclExtras IfaceOtherDeclExtras
641   = emptyNameSet
642
643 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
644 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
645
646 instance Binary IfaceDeclExtras where
647   get _bh = panic "no get for IfaceDeclExtras"
648   put_ bh (IfaceIdExtras fix rules) = do
649    putByte bh 1; put_ bh fix; put_ bh rules
650   put_ bh (IfaceDataExtras fix insts cons) = do
651    putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
652   put_ bh (IfaceClassExtras insts methods) = do
653    putByte bh 3; put_ bh insts; put_ bh methods
654   put_ bh IfaceOtherDeclExtras = do
655    putByte bh 4
656
657 declExtras :: (OccName -> Fixity)
658            -> OccEnv [IfaceRule]
659            -> OccEnv [IfaceInst]
660            -> IfaceDecl
661            -> IfaceDeclExtras
662
663 declExtras fix_fn rule_env inst_env decl
664   = case decl of
665       IfaceId{} -> IfaceIdExtras (fix_fn n) 
666                         (lookupOccEnvL rule_env n)
667       IfaceData{ifCons=cons} -> 
668                      IfaceDataExtras (fix_fn n)
669                         (map IfaceInstABI $ lookupOccEnvL inst_env n)
670                         (map (id_extras . ifConOcc) (visibleIfConDecls cons))
671       IfaceClass{ifSigs=sigs} -> 
672                      IfaceClassExtras 
673                         (map IfaceInstABI $ lookupOccEnvL inst_env n)
674                         [id_extras op | IfaceClassOp op _ _ <- sigs]
675       _other -> IfaceOtherDeclExtras
676   where
677         n = ifName decl
678         id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
679
680 --
681 -- When hashing an instance, we hash only its structure, not the
682 -- fingerprints of the things it mentions.  See the section on instances
683 -- in the commentary,
684 --    http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
685 --
686 newtype IfaceInstABI = IfaceInstABI IfaceInst
687
688 instance Binary IfaceInstABI where
689   get = panic "no get for IfaceInstABI"
690   put_ bh (IfaceInstABI inst) = do
691     let ud  = getUserData bh
692         bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
693     put_ bh' inst
694
695 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
696 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
697
698 -- used when we want to fingerprint a structure without depending on the
699 -- fingerprints of external Names that it refers to.
700 putNameLiterally :: BinHandle -> Name -> IO ()
701 putNameLiterally bh name = do
702   put_ bh $! nameModule name
703   put_ bh $! nameOccName name
704
705 computeFingerprint :: Binary a
706                    => DynFlags 
707                    -> (BinHandle -> Name -> IO ())
708                    -> a
709                    -> IO Fingerprint
710
711 computeFingerprint _dflags put_name a = do
712   bh <- openBinMem (3*1024) -- just less than a block
713   ud <- newWriteState put_name putFS
714   bh <- return $ setUserData bh ud
715   put_ bh a
716   fingerprintBinMem bh
717
718 {-
719 -- for testing: use the md5sum command to generate fingerprints and
720 -- compare the results against our built-in version.
721   fp' <- oldMD5 dflags bh
722   if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
723                else return fp
724
725 oldMD5 dflags bh = do
726   tmp <- newTempName dflags "bin"
727   writeBinMem bh tmp
728   tmp2 <- newTempName dflags "md5"
729   let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
730   r <- system cmd
731   case r of
732     ExitFailure _ -> ghcError (PhaseFailed cmd r)
733     ExitSuccess -> do
734         hash_str <- readFile tmp2
735         return $! readHexFingerprint hash_str
736 -}
737
738 instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
739 instOrphWarn unqual inst
740   = mkWarnMsg (getSrcSpan inst) unqual $
741     hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
742
743 ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
744 ruleOrphWarn unqual mod rule
745   = mkWarnMsg silly_loc unqual $
746     ptext (sLit "Orphan rule:") <+> ppr rule
747   where
748     silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0)
749     -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
750     -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
751
752 ----------------------
753 -- mkOrphMap partitions instance decls or rules into
754 --      (a) an OccEnv for ones that are not orphans, 
755 --          mapping the local OccName to a list of its decls
756 --      (b) a list of orphan decls
757 mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
758                                         -- Nothing for an orphan decl
759           -> [decl]                     -- Sorted into canonical order
760           -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
761                                         --      each sublist in canonical order
762               [decl])                   -- Orphan decls; in canonical order
763 mkOrphMap get_key decls
764   = foldl go (emptyOccEnv, []) decls
765   where
766     go (non_orphs, orphs) d
767         | Just occ <- get_key d
768         = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
769         | otherwise = (non_orphs, d:orphs)
770 \end{code}
771
772
773 %*********************************************************
774 %*                                                      *
775 \subsection{Keeping track of what we've slurped, and fingerprints}
776 %*                                                      *
777 %*********************************************************
778
779
780 \begin{code}
781 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
782 mkUsageInfo hsc_env this_mod dir_imp_mods used_names
783   = do  { eps <- hscEPS hsc_env
784         ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
785                                      dir_imp_mods used_names
786         ; usages `seqList`  return usages }
787          -- seq the list of Usages returned: occasionally these
788          -- don't get evaluated for a while and we can end up hanging on to
789          -- the entire collection of Ifaces.
790
791 mk_usage_info :: PackageIfaceTable
792               -> HscEnv
793               -> Module
794               -> ImportedMods
795               -> NameSet
796               -> [Usage]
797 mk_usage_info pit hsc_env this_mod direct_imports used_names
798   = mapCatMaybes mkUsage usage_mods
799   where
800     hpt = hsc_HPT hsc_env
801     dflags = hsc_dflags hsc_env
802     this_pkg = thisPackage dflags
803
804     used_mods    = moduleEnvKeys ent_map
805     dir_imp_mods = (moduleEnvKeys direct_imports)
806     all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
807     usage_mods   = sortBy stableModuleCmp all_mods
808                         -- canonical order is imported, to avoid interface-file
809                         -- wobblage.
810
811     -- ent_map groups together all the things imported and used
812     -- from a particular module
813     ent_map :: ModuleEnv [OccName]
814     ent_map  = foldNameSet add_mv emptyModuleEnv used_names
815      where
816       add_mv name mv_map
817         | isWiredInName name = mv_map  -- ignore wired-in names
818         | otherwise
819         = case nameModule_maybe name of
820              Nothing  -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
821              Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
822                    where occ = nameOccName name
823     
824     -- We want to create a Usage for a home module if 
825     --  a) we used something from it; has something in used_names
826     --  b) we imported it, even if we used nothing from it
827     --     (need to recompile if its export list changes: export_fprint)
828     mkUsage :: Module -> Maybe Usage
829     mkUsage mod
830       | isNothing maybe_iface           -- We can't depend on it if we didn't
831                                         -- load its interface.
832       || mod == this_mod                -- We don't care about usages of
833                                         -- things in *this* module
834       = Nothing
835
836       | modulePackageId mod /= this_pkg
837       = Just UsagePackageModule{ usg_mod      = mod,
838                                  usg_mod_hash = mod_hash }
839         -- for package modules, we record the module hash only
840
841       | (null used_occs
842           && isNothing export_hash
843           && not is_direct_import
844           && not finsts_mod)
845       = Nothing                 -- Record no usage info
846         -- for directly-imported modules, we always want to record a usage
847         -- on the orphan hash.  This is what triggers a recompilation if
848         -- an orphan is added or removed somewhere below us in the future.
849     
850       | otherwise       
851       = Just UsageHomeModule { 
852                       usg_mod_name = moduleName mod,
853                       usg_mod_hash = mod_hash,
854                       usg_exports  = export_hash,
855                       usg_entities = fmToList ent_hashs }
856       where
857         maybe_iface  = lookupIfaceByModule dflags hpt pit mod
858                 -- In one-shot mode, the interfaces for home-package 
859                 -- modules accumulate in the PIT not HPT.  Sigh.
860
861         is_direct_import = mod `elemModuleEnv` direct_imports
862
863         Just iface   = maybe_iface
864         finsts_mod   = mi_finsts    iface
865         hash_env     = mi_hash_fn   iface
866         mod_hash     = mi_mod_hash  iface
867         export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
868                     | otherwise             = Nothing
869     
870         used_occs = lookupModuleEnv ent_map mod `orElse` []
871
872         -- Making a FiniteMap here ensures that (a) we remove duplicates
873         -- when we have usages on several subordinates of a single parent,
874         -- and (b) that the usages emerge in a canonical order, which
875         -- is why we use FiniteMap rather than OccEnv: FiniteMap works
876         -- using Ord on the OccNames, which is a lexicographic ordering.
877         ent_hashs :: FiniteMap OccName Fingerprint
878         ent_hashs = listToFM (map lookup_occ used_occs)
879         
880         lookup_occ occ = 
881             case hash_env occ of
882                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
883                 Just r  -> r
884
885         depend_on_exports mod = 
886            case lookupModuleEnv direct_imports mod of
887                 Just _ -> True
888                   -- Even if we used 'import M ()', we have to register a
889                   -- usage on the export list because we are sensitive to
890                   -- changes in orphan instances/rules.
891                 Nothing -> False
892                   -- In GHC 6.8.x the above line read "True", and in
893                   -- fact it recorded a dependency on *all* the
894                   -- modules underneath in the dependency tree.  This
895                   -- happens to make orphans work right, but is too
896                   -- expensive: it'll read too many interface files.
897                   -- The 'isNothing maybe_iface' check above saved us
898                   -- from generating many of these usages (at least in
899                   -- one-shot mode), but that's even more bogus!
900 \end{code}
901
902 \begin{code}
903 mkIfaceExports :: [AvailInfo]
904                -> [(Module, [GenAvailInfo OccName])]
905   -- Group by module and sort by occurrence
906   -- This keeps the list in canonical order
907 mkIfaceExports exports
908   = [ (mod, eltsFM avails)
909     | (mod, avails) <- fmToList groupFM
910     ]
911   where
912         -- Group by the module where the exported entities are defined
913         -- (which may not be the same for all Names in an Avail)
914         -- Deliberately use FiniteMap rather than UniqFM so we
915         -- get a canonical ordering
916     groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
917     groupFM = foldl add emptyModuleEnv exports
918
919     add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
920             -> Module -> GenAvailInfo OccName
921             -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
922     add_one env mod avail 
923       =  extendModuleEnv_C plusFM env mod 
924                 (unitFM (occNameFS (availName avail)) avail)
925
926         -- NB: we should not get T(X) and T(Y) in the export list
927         --     else the plusFM will simply discard one!  They
928         --     should have been combined by now.
929     add env (Avail n)
930       = add_one env (nameModule n) (Avail (nameOccName n))
931
932     add env (AvailTC tc ns)
933       = foldl add_for_mod env mods
934       where
935         tc_occ = nameOccName tc
936         mods   = nub (map nameModule ns)
937                 -- Usually just one, but see Note [Original module]
938
939         add_for_mod env mod
940             = add_one env mod (AvailTC tc_occ (sort names_from_mod))
941               -- NB. sort the children, we need a canonical order
942             where
943               names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
944 \end{code}
945
946 Note [Orignal module]
947 ~~~~~~~~~~~~~~~~~~~~~
948 Consider this:
949         module X where { data family T }
950         module Y( T(..) ) where { import X; data instance T Int = MkT Int }
951 The exported Avail from Y will look like
952         X.T{X.T, Y.MkT}
953 That is, in Y, 
954   - only MkT is brought into scope by the data instance;
955   - but the parent (used for grouping and naming in T(..) exports) is X.T
956   - and in this case we export X.T too
957
958 In the result of MkIfaceExports, the names are grouped by defining module,
959 so we may need to split up a single Avail into multiple ones.
960
961
962 %************************************************************************
963 %*                                                                      *
964         Load the old interface file for this module (unless
965         we have it aleady), and check whether it is up to date
966         
967 %*                                                                      *
968 %************************************************************************
969
970 \begin{code}
971 checkOldIface :: HscEnv
972               -> ModSummary
973               -> Bool                   -- Source unchanged
974               -> Maybe ModIface         -- Old interface from compilation manager, if any
975               -> IO (RecompileRequired, Maybe ModIface)
976
977 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
978   = do  { showPass (hsc_dflags hsc_env) 
979                    ("Checking old interface for " ++ 
980                         showSDoc (ppr (ms_mod mod_summary))) ;
981
982         ; initIfaceCheck hsc_env $
983           check_old_iface hsc_env mod_summary source_unchanged maybe_iface
984      }
985
986 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
987                 -> IfG (Bool, Maybe ModIface)
988 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
989  =  do  -- CHECK WHETHER THE SOURCE HAS CHANGED
990     { when (not source_unchanged)
991            (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
992
993      -- If the source has changed and we're in interactive mode, avoid reading
994      -- an interface; just return the one we might have been supplied with.
995     ; let dflags = hsc_dflags hsc_env
996     ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
997          return (outOfDate, maybe_iface)
998       else
999       case maybe_iface of {
1000         Just old_iface -> do -- Use the one we already have
1001           { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1002           ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1003           ; return (recomp, Just old_iface) }
1004
1005       ; Nothing -> do
1006
1007         -- Try and read the old interface for the current module
1008         -- from the .hi file left from the last time we compiled it
1009     { let iface_path = msHiFilePath mod_summary
1010     ; read_result <- readIface (ms_mod mod_summary) iface_path False
1011     ; case read_result of {
1012          Failed err -> do       -- Old interface file not found, or garbled; give up
1013                 { traceIf (text "FYI: cannot read old interface file:"
1014                                  $$ nest 4 err)
1015                 ; return (outOfDate, Nothing) }
1016
1017       ;  Succeeded iface -> do
1018
1019         -- We have got the old iface; check its versions
1020     { traceIf (text "Read the interface file" <+> text iface_path)
1021     ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1022     ; return (recomp, Just iface)
1023     }}}}}
1024
1025 \end{code}
1026
1027 @recompileRequired@ is called from the HscMain.   It checks whether
1028 a recompilation is required.  It needs access to the persistent state,
1029 finder, etc, because it may have to load lots of interface files to
1030 check their versions.
1031
1032 \begin{code}
1033 type RecompileRequired = Bool
1034 upToDate, outOfDate :: Bool
1035 upToDate  = False       -- Recompile not required
1036 outOfDate = True        -- Recompile required
1037
1038 checkVersions :: HscEnv
1039               -> Bool           -- True <=> source unchanged
1040               -> ModSummary
1041               -> ModIface       -- Old interface
1042               -> IfG RecompileRequired
1043 checkVersions hsc_env source_unchanged mod_summary iface
1044   | not source_unchanged
1045   = return outOfDate
1046   | otherwise
1047   = do  { traceHiDiffs (text "Considering whether compilation is required for" <+> 
1048                         ppr (mi_module iface) <> colon)
1049
1050         ; recomp <- checkDependencies hsc_env mod_summary iface
1051         ; if recomp then return outOfDate else do {
1052
1053         -- Source code unchanged and no errors yet... carry on 
1054         --
1055         -- First put the dependent-module info, read from the old
1056         -- interface, into the envt, so that when we look for
1057         -- interfaces we look for the right one (.hi or .hi-boot)
1058         -- 
1059         -- It's just temporary because either the usage check will succeed 
1060         -- (in which case we are done with this module) or it'll fail (in which
1061         -- case we'll compile the module from scratch anyhow).
1062         --      
1063         -- We do this regardless of compilation mode, although in --make mode
1064         -- all the dependent modules should be in the HPT already, so it's
1065         -- quite redundant
1066           updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
1067
1068         ; let this_pkg = thisPackage (hsc_dflags hsc_env)
1069         ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1070     }}
1071   where
1072         -- This is a bit of a hack really
1073     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1074     mod_deps = mkModDeps (dep_mods (mi_deps iface))
1075
1076
1077 -- If the direct imports of this module are resolved to targets that
1078 -- are not among the dependencies of the previous interface file,
1079 -- then we definitely need to recompile.  This catches cases like
1080 --   - an exposed package has been upgraded
1081 --   - we are compiling with different package flags
1082 --   - a home module that was shadowing a package module has been removed
1083 --   - a new home module has been added that shadows a package module
1084 -- See bug #1372.
1085 --
1086 -- Returns True if recompilation is required.
1087 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1088 checkDependencies hsc_env summary iface
1089  = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1090   where
1091    prev_dep_mods = dep_mods (mi_deps iface)
1092    prev_dep_pkgs = dep_pkgs (mi_deps iface)
1093
1094    this_pkg = thisPackage (hsc_dflags hsc_env)
1095
1096    orM = foldr f (return False)
1097     where f m rest = do b <- m; if b then return True else rest
1098
1099    dep_missing (L _ mod) = do
1100      find_res <- liftIO $ findImportedModule hsc_env mod Nothing
1101      case find_res of
1102         Found _ mod
1103           | pkg == this_pkg
1104            -> if moduleName mod `notElem` map fst prev_dep_mods
1105                  then do traceHiDiffs $
1106                            text "imported module " <> quotes (ppr mod) <>
1107                            text " not among previous dependencies"
1108                          return outOfDate
1109                  else
1110                          return upToDate
1111           | otherwise
1112            -> if pkg `notElem` prev_dep_pkgs
1113                  then do traceHiDiffs $
1114                            text "imported module " <> quotes (ppr mod) <>
1115                            text " is from package " <> quotes (ppr pkg) <>
1116                            text ", which is not among previous dependencies"
1117                          return outOfDate
1118                  else
1119                          return upToDate
1120            where pkg = modulePackageId mod
1121         _otherwise  -> return outOfDate
1122
1123 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1124               -> IfG RecompileRequired
1125 needInterface mod continue
1126   = do  -- Load the imported interface if possible
1127     let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1128     traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1129
1130     mb_iface <- loadInterface doc_str mod ImportBySystem
1131         -- Load the interface, but don't complain on failure;
1132         -- Instead, get an Either back which we can test
1133
1134     case mb_iface of
1135       Failed _ ->  (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
1136                                       ppr mod]))
1137                   -- Couldn't find or parse a module mentioned in the
1138                   -- old interface file.  Don't complain: it might
1139                   -- just be that the current module doesn't need that
1140                   -- import and it's been deleted
1141       Succeeded iface -> continue iface
1142
1143
1144 checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1145 -- Given the usage information extracted from the old
1146 -- M.hi file for the module being compiled, figure out
1147 -- whether M needs to be recompiled.
1148
1149 checkModUsage _this_pkg UsagePackageModule{
1150                                 usg_mod = mod,
1151                                 usg_mod_hash = old_mod_hash }
1152   = needInterface mod $ \iface -> do
1153     checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
1154         -- We only track the ABI hash of package modules, rather than
1155         -- individual entity usages, so if the ABI hash changes we must
1156         -- recompile.  This is safe but may entail more recompilation when
1157         -- a dependent package has changed.
1158
1159 checkModUsage this_pkg UsageHomeModule{ 
1160                                 usg_mod_name = mod_name, 
1161                                 usg_mod_hash = old_mod_hash,
1162                                 usg_exports = maybe_old_export_hash,
1163                                 usg_entities = old_decl_hash }
1164   = do
1165     let mod = mkModule this_pkg mod_name
1166     needInterface mod $ \iface -> do
1167
1168     let
1169         new_mod_hash    = mi_mod_hash    iface
1170         new_decl_hash   = mi_hash_fn     iface
1171         new_export_hash = mi_exp_hash    iface
1172
1173         -- CHECK MODULE
1174     recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
1175     if not recompile then return upToDate else do
1176                                  
1177         -- CHECK EXPORT LIST
1178     checkMaybeHash maybe_old_export_hash new_export_hash
1179         (ptext (sLit "  Export list changed")) $ do
1180
1181         -- CHECK ITEMS ONE BY ONE
1182     recompile <- checkList [ checkEntityUsage new_decl_hash u 
1183                            | u <- old_decl_hash]
1184     if recompile 
1185       then return outOfDate     -- This one failed, so just bail out now
1186       else up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
1187
1188 ------------------------
1189 checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
1190 checkModuleFingerprint old_mod_hash new_mod_hash
1191   | new_mod_hash == old_mod_hash
1192   = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1193
1194   | otherwise
1195   = out_of_date_hash (ptext (sLit "  Module fingerprint has changed"))
1196                      old_mod_hash new_mod_hash
1197
1198 ------------------------
1199 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
1200                -> IfG RecompileRequired -> IfG RecompileRequired
1201 checkMaybeHash maybe_old_hash new_hash doc continue
1202   | Just hash <- maybe_old_hash, hash /= new_hash
1203   = out_of_date_hash doc hash new_hash
1204   | otherwise
1205   = continue
1206
1207 ------------------------
1208 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
1209                  -> (OccName, Fingerprint)
1210                  -> IfG Bool
1211 checkEntityUsage new_hash (name,old_hash)
1212   = case new_hash name of
1213
1214         Nothing       ->        -- We used it before, but it ain't there now
1215                           out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
1216
1217         Just (_, new_hash)      -- It's there, but is it up to date?
1218           | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
1219                                        return upToDate
1220           | otherwise            -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
1221                                                      old_hash new_hash
1222
1223 up_to_date, out_of_date :: SDoc -> IfG Bool
1224 up_to_date  msg = traceHiDiffs msg >> return upToDate
1225 out_of_date msg = traceHiDiffs msg >> return outOfDate
1226
1227 out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
1228 out_of_date_hash msg old_hash new_hash 
1229   = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1230
1231 ----------------------
1232 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1233 -- This helper is used in two places
1234 checkList []             = return upToDate
1235 checkList (check:checks) = do recompile <- check
1236                               if recompile
1237                                 then return outOfDate
1238                                 else checkList checks
1239 \end{code}
1240
1241 %************************************************************************
1242 %*                                                                      *
1243                 Converting things to their Iface equivalents
1244 %*                                                                      *
1245 %************************************************************************
1246
1247 \begin{code}
1248 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1249 -- Assumption: the thing is already tidied, so that locally-bound names
1250 --             (lambdas, for-alls) already have non-clashing OccNames
1251 -- Reason: Iface stuff uses OccNames, and the conversion here does
1252 --         not do tidying on the way
1253 tyThingToIfaceDecl (AnId id)
1254   = IfaceId { ifName   = getOccName id,
1255               ifType   = toIfaceType (idType id),
1256               ifIdInfo = info }
1257   where
1258     info = case toIfaceIdInfo (idInfo id) of
1259                 []    -> NoInfo
1260                 items -> HasInfo items
1261
1262 tyThingToIfaceDecl (AClass clas)
1263   = IfaceClass { ifCtxt   = toIfaceContext sc_theta,
1264                  ifName   = getOccName clas,
1265                  ifTyVars = toIfaceTvBndrs clas_tyvars,
1266                  ifFDs    = map toIfaceFD clas_fds,
1267                  ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1268                  ifSigs   = map toIfaceClassOp op_stuff,
1269                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
1270   where
1271     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
1272       = classExtraBigSig clas
1273     tycon = classTyCon clas
1274
1275     toIfaceClassOp (sel_id, def_meth)
1276         = ASSERT(sel_tyvars == clas_tyvars)
1277           IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1278         where
1279                 -- Be careful when splitting the type, because of things
1280                 -- like         class Foo a where
1281                 --                op :: (?x :: String) => a -> a
1282                 -- and          class Baz a where
1283                 --                op :: (Ord a) => a -> a
1284           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1285           op_ty                = funResultTy rho_ty
1286
1287     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1288
1289 tyThingToIfaceDecl (ATyCon tycon)
1290   | isSynTyCon tycon
1291   = IfaceSyn {  ifName    = getOccName tycon,
1292                 ifTyVars  = toIfaceTvBndrs tyvars,
1293                 ifSynRhs  = syn_rhs,
1294                 ifSynKind = syn_ki,
1295                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
1296              }
1297
1298   | isAlgTyCon tycon
1299   = IfaceData { ifName    = getOccName tycon,
1300                 ifTyVars  = toIfaceTvBndrs tyvars,
1301                 ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
1302                 ifCons    = ifaceConDecls (algTyConRhs tycon),
1303                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
1304                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1305                 ifGeneric = tyConHasGenerics tycon,
1306                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1307
1308   | isForeignTyCon tycon
1309   = IfaceForeign { ifName    = getOccName tycon,
1310                    ifExtName = tyConExtName tycon }
1311
1312   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1313   where
1314     tyvars = tyConTyVars tycon
1315     (syn_rhs, syn_ki) 
1316        = case synTyConRhs tycon of
1317             OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
1318             SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
1319
1320     ifaceConDecls (NewTyCon { data_con = con })     = 
1321       IfNewTyCon  (ifaceConDecl con)
1322     ifaceConDecls (DataTyCon { data_cons = cons })  = 
1323       IfDataTyCon (map ifaceConDecl cons)
1324     ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
1325     ifaceConDecls AbstractTyCon                     = IfAbstractTyCon
1326         -- The last case happens when a TyCon has been trimmed during tidying
1327         -- Furthermore, tyThingToIfaceDecl is also used
1328         -- in TcRnDriver for GHCi, when browsing a module, in which case the
1329         -- AbstractTyCon case is perfectly sensible.
1330
1331     ifaceConDecl data_con 
1332         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
1333                     ifConInfix   = dataConIsInfix data_con,
1334                     ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
1335                     ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
1336                     ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
1337                     ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1338                     ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
1339                     ifConFields  = map getOccName 
1340                                        (dataConFieldLabels data_con),
1341                     ifConStricts = dataConStrictMarks data_con }
1342
1343     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1344
1345     famInstToIface Nothing                    = Nothing
1346     famInstToIface (Just (famTyCon, instTys)) = 
1347       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1348
1349 tyThingToIfaceDecl (ADataCon dc)
1350  = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
1351
1352
1353 getFS :: NamedThing a => a -> FastString
1354 getFS x = occNameFS (getOccName x)
1355
1356 --------------------------
1357 instanceToIfaceInst :: Instance -> IfaceInst
1358 instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
1359                                 is_cls = cls_name, is_tcs = mb_tcs })
1360   = ASSERT( cls_name == className cls )
1361     IfaceInst { ifDFun    = dfun_name,
1362                 ifOFlag   = oflag,
1363                 ifInstCls = cls_name,
1364                 ifInstTys = map do_rough mb_tcs,
1365                 ifInstOrph = orph }
1366   where
1367     do_rough Nothing  = Nothing
1368     do_rough (Just n) = Just (toIfaceTyCon_name n)
1369
1370     dfun_name = idName dfun_id
1371     mod       = nameModule dfun_name
1372     is_local name = nameIsLocalOrFrom mod name
1373
1374         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1375     (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
1376                 -- Slightly awkward: we need the Class to get the fundeps
1377     (tvs, fds) = classTvsFds cls
1378     arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
1379     orph | is_local cls_name = Just (nameOccName cls_name)
1380          | all isJust mb_ns  = head mb_ns
1381          | otherwise         = Nothing
1382     
1383     mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
1384                                 -- that is not in the "determined" arguments
1385     mb_ns | null fds   = [choose_one arg_names]
1386           | otherwise  = map do_one fds
1387     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1388                                           , not (tv `elem` rtvs)]
1389
1390     choose_one :: [NameSet] -> Maybe OccName
1391     choose_one nss = case nameSetToList (unionManyNameSets nss) of
1392                         []      -> Nothing
1393                         (n : _) -> Just (nameOccName n)
1394
1395 --------------------------
1396 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1397 famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
1398                                  fi_fam = fam,
1399                                  fi_tcs = mb_tcs })
1400   = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
1401                  , ifFamInstFam    = fam
1402                  , ifFamInstTys    = map do_rough mb_tcs }
1403   where
1404     do_rough Nothing  = Nothing
1405     do_rough (Just n) = Just (toIfaceTyCon_name n)
1406
1407 --------------------------
1408 toIfaceLetBndr :: Id -> IfaceLetBndr
1409 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
1410                                (toIfaceType (idType id)) 
1411                                prag_info
1412   where
1413         -- Stripped-down version of tcIfaceIdInfo
1414         -- Change this if you want to export more IdInfo for
1415         -- non-top-level Ids.  Don't forget to change
1416         -- CoreTidy.tidyLetBndr too!
1417         --
1418         -- See Note [IdInfo on nested let-bindings] in IfaceSyn
1419     id_info = idInfo id
1420     inline_prag = inlinePragInfo id_info
1421     prag_info | isAlwaysActive inline_prag = NoInfo
1422               | otherwise                  = HasInfo [HsInline inline_prag]
1423
1424 --------------------------
1425 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
1426 toIfaceIdInfo id_info
1427   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
1428                inline_hsinfo, wrkr_hsinfo,  unfold_hsinfo] 
1429   where
1430     ------------  Arity  --------------
1431     arity_info = arityInfo id_info
1432     arity_hsinfo | arity_info == 0 = Nothing
1433                  | otherwise       = Just (HsArity arity_info)
1434
1435     ------------ Caf Info --------------
1436     caf_info   = cafInfo id_info
1437     caf_hsinfo = case caf_info of
1438                    NoCafRefs -> Just HsNoCafRefs
1439                    _other    -> Nothing
1440
1441     ------------  Strictness  --------------
1442         -- No point in explicitly exporting TopSig
1443     strict_hsinfo = case newStrictnessInfo id_info of
1444                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1445                         _other                        -> Nothing
1446
1447     ------------  Worker  --------------
1448     work_info   = workerInfo id_info
1449     has_worker  = workerExists work_info
1450     wrkr_hsinfo = case work_info of
1451                     HasWorker work_id wrap_arity -> 
1452                         Just (HsWorker ((idName work_id)) wrap_arity)
1453                     NoWorker -> Nothing
1454
1455     ------------  Unfolding  --------------
1456     -- The unfolding is redundant if there is a worker
1457     unfold_info  = unfoldingInfo id_info
1458     rhs          = unfoldingTemplate unfold_info
1459     no_unfolding = neverUnfold unfold_info
1460                         -- The CoreTidy phase retains unfolding info iff
1461                         -- we want to expose the unfolding, taking into account
1462                         -- unconditional NOINLINE, etc.  See TidyPgm.addExternal
1463     unfold_hsinfo | no_unfolding = Nothing                      
1464                   | has_worker   = Nothing      -- Unfolding is implicit
1465                   | otherwise    = Just (HsUnfold (toIfaceExpr rhs))
1466                                         
1467     ------------  Inline prag  --------------
1468     inline_prag = inlinePragInfo id_info
1469     inline_hsinfo | isAlwaysActive inline_prag     = Nothing
1470                   | no_unfolding && not has_worker = Nothing
1471                         -- If the iface file give no unfolding info, we 
1472                         -- don't need to say when inlining is OK!
1473                   | otherwise                      = Just (HsInline inline_prag)
1474
1475 --------------------------
1476 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1477 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1478   = pprTrace "toHsRule: builtin" (ppr fn) $
1479     bogusIfaceRule fn
1480
1481 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, 
1482                                 ru_act = act, ru_bndrs = bndrs,
1483                                 ru_args = args, ru_rhs = rhs })
1484   = IfaceRule { ifRuleName  = name, ifActivation = act, 
1485                 ifRuleBndrs = map toIfaceBndr bndrs,
1486                 ifRuleHead  = fn, 
1487                 ifRuleArgs  = map do_arg args,
1488                 ifRuleRhs   = toIfaceExpr rhs,
1489                 ifRuleOrph  = orph }
1490   where
1491         -- For type args we must remove synonyms from the outermost
1492         -- level.  Reason: so that when we read it back in we'll
1493         -- construct the same ru_rough field as we have right now;
1494         -- see tcIfaceRule
1495     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1496     do_arg arg       = toIfaceExpr arg
1497
1498         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1499         -- A rule is an orphan only if none of the variables
1500         -- mentioned on its left-hand side are locally defined
1501     lhs_names = fn : nameSetToList (exprsFreeNames args)
1502                 -- No need to delete bndrs, because
1503                 -- exprsFreeNames finds only External names
1504
1505     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1506                         (n : _) -> Just (nameOccName n)
1507                         []      -> Nothing
1508
1509 bogusIfaceRule :: Name -> IfaceRule
1510 bogusIfaceRule id_name
1511   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,  
1512         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
1513         ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
1514
1515 ---------------------
1516 toIfaceExpr :: CoreExpr -> IfaceExpr
1517 toIfaceExpr (Var v)       = toIfaceVar v
1518 toIfaceExpr (Lit l)       = IfaceLit l
1519 toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
1520 toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1521 toIfaceExpr (App f a)     = toIfaceApp f [a]
1522 toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
1523 toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1524 toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
1525 toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
1526
1527 ---------------------
1528 toIfaceNote :: Note -> IfaceNote
1529 toIfaceNote (SCC cc)      = IfaceSCC cc
1530 toIfaceNote InlineMe      = IfaceInlineMe
1531 toIfaceNote (CoreNote s)  = IfaceCoreNote s
1532
1533 ---------------------
1534 toIfaceBind :: Bind Id -> IfaceBinding
1535 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1536 toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1537
1538 ---------------------
1539 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1540            -> (IfaceConAlt, [FastString], IfaceExpr)
1541 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1542
1543 ---------------------
1544 toIfaceCon :: AltCon -> IfaceConAlt
1545 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
1546                         | otherwise       = IfaceDataAlt (getName dc)
1547                         where
1548                           tc = dataConTyCon dc
1549            
1550 toIfaceCon (LitAlt l) = IfaceLitAlt l
1551 toIfaceCon DEFAULT    = IfaceDefault
1552
1553 ---------------------
1554 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1555 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1556 toIfaceApp (Var v) as
1557   = case isDataConWorkId_maybe v of
1558         -- We convert the *worker* for tuples into IfaceTuples
1559         Just dc |  isTupleTyCon tc && saturated 
1560                 -> IfaceTuple (tupleTyConBoxity tc) tup_args
1561           where
1562             val_args  = dropWhile isTypeArg as
1563             saturated = val_args `lengthIs` idArity v
1564             tup_args  = map toIfaceExpr val_args
1565             tc        = dataConTyCon dc
1566
1567         _ -> mkIfaceApps (toIfaceVar v) as
1568
1569 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1570
1571 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1572 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1573
1574 ---------------------
1575 toIfaceVar :: Id -> IfaceExpr
1576 toIfaceVar v 
1577   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
1578           -- Foreign calls have special syntax
1579   | isExternalName name             = IfaceExt name
1580   | Just (TickBox m ix) <- isTickBoxOp_maybe v
1581                                     = IfaceTick m ix
1582   | otherwise                       = IfaceLcl (getFS name)
1583   where
1584     name = idName v
1585 \end{code}