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