c94b19a2551819c75339cffe1dec70c88c1379ec
[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 for constructing @ModIface@ values (interface files),
8 -- writing them to disk and comparing two versions to see if
9 -- recompilation is required.
10 module MkIface ( 
11         mkUsedNames,
12         mkDependencies,
13         mkIface,        -- Build a ModIface from a ModGuts, 
14                         -- including computing version information
15
16         mkIfaceTc,
17
18         writeIfaceFile, -- Write the interface file
19
20         checkOldIface,  -- See if recompilation is required, by
21                         -- comparing version information
22         RecompileRequired(..), recompileRequired,
23
24         tyThingToIfaceDecl -- Converting things to their Iface equivalents
25  ) where
26 \end{code}
27
28   -----------------------------------------------
29           Recompilation checking
30   -----------------------------------------------
31
32 A complete description of how recompilation checking works can be
33 found in the wiki commentary:
34
35  http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
36
37 Please read the above page for a top-down description of how this all
38 works.  Notes below cover specific issues related to the implementation.
39
40 Basic idea: 
41
42   * In the mi_usages information in an interface, we record the 
43     fingerprint of each free variable of the module
44
45   * In mkIface, we compute the fingerprint of each exported thing A.f.
46     For each external thing that A.f refers to, we include the fingerprint
47     of the external reference when computing the fingerprint of A.f.  So
48     if anything that A.f depends on changes, then A.f's fingerprint will
49     change.
50     Also record any dependent files added with addDependentFile.
51     In the future record any #include usages.
52
53   * In checkOldIface we compare the mi_usages for the module with
54     the actual fingerprint for all each thing recorded in mi_usages
55
56 \begin{code}
57 #include "HsVersions.h"
58
59 import IfaceSyn
60 import LoadIface
61 import FlagChecker
62
63 import Id
64 import IdInfo
65 import Demand
66 import Annotations
67 import CoreSyn
68 import CoreFVs
69 import Class
70 import Kind
71 import TyCon
72 import Coercion         ( coAxiomSplitLHS )
73 import DataCon
74 import Type
75 import TcType
76 import InstEnv
77 import FamInstEnv
78 import TcRnMonad
79 import HsSyn
80 import HscTypes
81 import Finder
82 import DynFlags
83 import VarEnv
84 import VarSet
85 import Var
86 import Name
87 import Avail
88 import RdrName
89 import NameEnv
90 import NameSet
91 import Module
92 import BinIface
93 import ErrUtils
94 import Digraph
95 import SrcLoc
96 import Outputable
97 import BasicTypes       hiding ( SuccessFlag(..) )
98 import UniqFM
99 import Unique
100 import Util             hiding ( eqListBy )
101 import FastString
102 import Maybes
103 import ListSetOps
104 import Binary
105 import Fingerprint
106 import Bag
107 import Exception
108
109 import Control.Monad
110 import Data.Function
111 import Data.List
112 import Data.Map (Map)
113 import qualified Data.Map as Map
114 import Data.Ord
115 import Data.IORef
116 import System.Directory
117 import System.FilePath
118 \end{code}
119
120
121
122 %************************************************************************
123 %*                                                                      *
124 \subsection{Completing an interface}
125 %*                                                                      *
126 %************************************************************************
127
128 \begin{code}
129 mkIface :: HscEnv
130         -> Maybe Fingerprint    -- The old fingerprint, if we have it
131         -> ModDetails           -- The trimmed, tidied interface
132         -> ModGuts              -- Usages, deprecations, etc
133         -> IO (Messages,
134                Maybe (ModIface, -- The new one
135                       Bool))    -- True <=> there was an old Iface, and the
136                                 --          new one is identical, so no need
137                                 --          to write it
138
139 mkIface hsc_env maybe_old_fingerprint mod_details
140          ModGuts{     mg_module       = this_mod,
141                       mg_boot         = is_boot,
142                       mg_used_names   = used_names,
143                       mg_used_th      = used_th,
144                       mg_deps         = deps,
145                       mg_dir_imps     = dir_imp_mods,
146                       mg_rdr_env      = rdr_env,
147                       mg_fix_env      = fix_env,
148                       mg_warns        = warns,
149                       mg_hpc_info     = hpc_info,
150                       mg_safe_haskell = safe_mode,
151                       mg_trust_pkg    = self_trust,
152                       mg_dependent_files = dependent_files
153                     }
154         = mkIface_ hsc_env maybe_old_fingerprint
155                    this_mod is_boot used_names used_th deps rdr_env fix_env
156                    warns hpc_info dir_imp_mods self_trust dependent_files
157                    safe_mode mod_details
158
159 -- | make an interface from the results of typechecking only.  Useful
160 -- for non-optimising compilation, or where we aren't generating any
161 -- object code at all ('HscNothing').
162 mkIfaceTc :: HscEnv
163           -> Maybe Fingerprint  -- The old fingerprint, if we have it
164           -> SafeHaskellMode    -- The safe haskell mode
165           -> ModDetails         -- gotten from mkBootModDetails, probably
166           -> TcGblEnv           -- Usages, deprecations, etc
167           -> IO (Messages, Maybe (ModIface, Bool))
168 mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
169   tc_result@TcGblEnv{ tcg_mod = this_mod,
170                       tcg_src = hsc_src,
171                       tcg_imports = imports,
172                       tcg_rdr_env = rdr_env,
173                       tcg_fix_env = fix_env,
174                       tcg_warns = warns,
175                       tcg_hpc = other_hpc_info,
176                       tcg_th_splice_used = tc_splice_used,
177                       tcg_dependent_files = dependent_files
178                     }
179   = do
180           let used_names = mkUsedNames tc_result
181           deps <- mkDependencies tc_result
182           let hpc_info = emptyHpcInfo other_hpc_info
183           used_th <- readIORef tc_splice_used
184           dep_files <- (readIORef dependent_files)
185           mkIface_ hsc_env maybe_old_fingerprint
186                    this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
187                    fix_env warns hpc_info (imp_mods imports)
188                    (imp_trust_own_pkg imports) dep_files safe_mode mod_details
189         
190
191 mkUsedNames :: TcGblEnv -> NameSet
192 mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
193         
194 -- | Extract information from the rename and typecheck phases to produce
195 -- a dependencies information for the module being compiled.
196 mkDependencies :: TcGblEnv -> IO Dependencies
197 mkDependencies
198           TcGblEnv{ tcg_mod = mod,
199                     tcg_imports = imports,
200                     tcg_th_used = th_var
201                   }
202  = do 
203       -- Template Haskell used?
204       th_used <- readIORef th_var
205       let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
206                 -- M.hi-boot can be in the imp_dep_mods, but we must remove
207                 -- it before recording the modules on which this one depends!
208                 -- (We want to retain M.hi-boot in imp_dep_mods so that 
209                 --  loadHiBootInterface can see if M's direct imports depend 
210                 --  on M.hi-boot, and hence that we should do the hi-boot consistency 
211                 --  check.)
212
213           pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
214                | otherwise = imp_dep_pkgs imports
215
216           -- Set the packages required to be Safe according to Safe Haskell.
217           -- See Note [RnNames . Tracking Trust Transitively]
218           sorted_pkgs = sortBy stablePackageIdCmp pkgs
219           trust_pkgs  = imp_trust_pkgs imports
220           dep_pkgs'   = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
221
222       return Deps { dep_mods   = sortBy (stableModuleNameCmp `on` fst) dep_mods,
223                     dep_pkgs   = dep_pkgs',
224                     dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
225                     dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
226                     -- sort to get into canonical order
227                     -- NB. remember to use lexicographic ordering
228
229 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
230          -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
231          -> NameEnv FixItem -> Warnings -> HpcInfo
232          -> ImportedMods -> Bool
233          -> [FilePath]
234          -> SafeHaskellMode
235          -> ModDetails
236          -> IO (Messages, Maybe (ModIface, Bool))
237 mkIface_ hsc_env maybe_old_fingerprint 
238          this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
239          hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
240          ModDetails{  md_insts     = insts, 
241                       md_fam_insts = fam_insts,
242                       md_rules     = rules,
243                       md_anns      = anns,
244                       md_vect_info = vect_info,
245                       md_types     = type_env,
246                       md_exports   = exports }
247 -- NB:  notice that mkIface does not look at the bindings
248 --      only at the TypeEnv.  The previous Tidy phase has
249 --      put exactly the info into the TypeEnv that we want
250 --      to expose in the interface
251
252   = do  { usages  <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
253
254         ; let   { entities = typeEnvElts type_env ;
255                   decls  = [ tyThingToIfaceDecl entity
256                            | entity <- entities,
257                              let name = getName entity,
258                              not (isImplicitTyThing entity),
259                                 -- No implicit Ids and class tycons in the interface file
260                              not (isWiredInName name),
261                                 -- Nor wired-in things; the compiler knows about them anyhow
262                              nameIsLocalOrFrom this_mod name  ]
263                                 -- Sigh: see Note [Root-main Id] in TcRnDriver
264
265                 ; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
266                 ; warns       = src_warns
267                 ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
268                 ; iface_insts = map instanceToIfaceInst insts
269                 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
270                 ; iface_vect_info = flattenVectInfo vect_info
271                 ; trust_info  = setSafeMode safe_mode
272
273                 ; intermediate_iface = ModIface { 
274                         mi_module      = this_mod,
275                         mi_boot        = is_boot,
276                         mi_deps        = deps,
277                         mi_usages      = usages,
278                         mi_exports     = mkIfaceExports exports,
279         
280                         -- Sort these lexicographically, so that
281                         -- the result is stable across compilations
282                         mi_insts       = sortBy cmp_inst     iface_insts,
283                         mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,
284                         mi_rules       = sortBy cmp_rule     iface_rules,
285
286                         mi_vect_info   = iface_vect_info,
287
288                         mi_fixities    = fixities,
289                         mi_warns       = warns,
290                         mi_anns        = mkIfaceAnnotations anns,
291                         mi_globals     = maybeGlobalRdrEnv rdr_env,
292
293                         -- Left out deliberately: filled in by addFingerprints
294                         mi_iface_hash  = fingerprint0,
295                         mi_mod_hash    = fingerprint0,
296                         mi_flag_hash   = fingerprint0,
297                         mi_exp_hash    = fingerprint0,
298                         mi_used_th     = used_th,
299                         mi_orphan_hash = fingerprint0,
300                         mi_orphan      = False, -- Always set by addFingerprints, but
301                                                 -- it's a strict field, so we can't omit it.
302                         mi_finsts      = False, -- Ditto
303                         mi_decls       = deliberatelyOmitted "decls",
304                         mi_hash_fn     = deliberatelyOmitted "hash_fn",
305                         mi_hpc         = isHpcUsed hpc_info,
306                         mi_trust       = trust_info,
307                         mi_trust_pkg   = pkg_trust_req,
308
309                         -- And build the cached values
310                         mi_warn_fn     = mkIfaceWarnCache warns,
311                         mi_fix_fn      = mkIfaceFixCache fixities }
312                 }
313
314         ; (new_iface, no_change_at_all) 
315                 <- {-# SCC "versioninfo" #-}
316                          addFingerprints hsc_env maybe_old_fingerprint
317                                          intermediate_iface decls
318
319                 -- Warn about orphans
320         ; let warn_orphs      = wopt Opt_WarnOrphans dflags
321               warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
322               orph_warnings   --- Laziness means no work done unless -fwarn-orphans
323                 | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
324                 | otherwise                     = emptyBag
325               errs_and_warns = (orph_warnings, emptyBag)
326               unqual = mkPrintUnqualified dflags rdr_env
327               inst_warns = listToBag [ instOrphWarn dflags unqual d 
328                                      | (d,i) <- insts `zip` iface_insts
329                                      , isNothing (ifInstOrph i) ]
330               rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r 
331                                      | r <- iface_rules
332                                      , isNothing (ifRuleOrph r)
333                                      , if ifRuleAuto r then warn_auto_orphs
334                                                        else warn_orphs ]
335
336         ; if errorsFound dflags errs_and_warns
337             then return ( errs_and_warns, Nothing )
338             else do {
339
340                 -- Debug printing
341         ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
342                         (pprModIface new_iface)
343
344                 -- bug #1617: on reload we weren't updating the PrintUnqualified
345                 -- correctly.  This stems from the fact that the interface had
346                 -- not changed, so addFingerprints returns the old ModIface
347                 -- with the old GlobalRdrEnv (mi_globals).
348         ; let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
349
350         ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
351   where
352      cmp_rule     = comparing ifRuleName
353      -- Compare these lexicographically by OccName, *not* by unique,
354      -- because the latter is not stable across compilations:
355      cmp_inst     = comparing (nameOccName . ifDFun)
356      cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
357
358      dflags = hsc_dflags hsc_env
359
360      -- We only fill in mi_globals if the module was compiled to byte
361      -- code.  Otherwise, the compiler may not have retained all the
362      -- top-level bindings and they won't be in the TypeEnv (see
363      -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
364      -- by GHCi to decide whether the module has its full top-level
365      -- scope available. (#5534)
366      maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
367      maybeGlobalRdrEnv rdr_env
368          | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
369          | otherwise                                   = Nothing
370
371      deliberatelyOmitted :: String -> a
372      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
373
374      ifFamInstTcName = ifFamInstFam
375
376      flattenVectInfo (VectInfo { vectInfoVar          = vVar
377                                , vectInfoTyCon        = vTyCon
378                                , vectInfoScalarVars   = vScalarVars
379                                , vectInfoScalarTyCons = vScalarTyCons
380                                }) = 
381        IfaceVectInfo
382        { ifaceVectInfoVar          = [Var.varName v | (v, _  ) <- varEnvElts  vVar]
383        , ifaceVectInfoTyCon        = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
384        , ifaceVectInfoTyConReuse   = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
385        , ifaceVectInfoScalarVars   = [Var.varName v | v <- varSetElems vScalarVars]
386        , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons
387        } 
388
389 -----------------------------
390 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
391 writeIfaceFile dflags location new_iface
392     = do createDirectoryIfMissing True (takeDirectory hi_file_path)
393          writeBinIface dflags hi_file_path new_iface
394     where hi_file_path = ml_hi_file location
395
396
397 -- -----------------------------------------------------------------------------
398 -- Look up parents and versions of Names
399
400 -- This is like a global version of the mi_hash_fn field in each ModIface.
401 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
402 -- the parent and version info.
403
404 mkHashFun
405         :: HscEnv                       -- needed to look up versions
406         -> ExternalPackageState         -- ditto
407         -> (Name -> Fingerprint)
408 mkHashFun hsc_env eps
409   = \name -> 
410       let 
411         mod = ASSERT2( isExternalName name, ppr name ) nameModule name
412         occ = nameOccName name
413         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
414                    pprPanic "lookupVers2" (ppr mod <+> ppr occ)
415       in  
416         snd (mi_hash_fn iface occ `orElse` 
417                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))
418   where
419       hpt = hsc_HPT hsc_env
420       pit = eps_PIT eps
421
422 -- ---------------------------------------------------------------------------
423 -- Compute fingerprints for the interface
424
425 addFingerprints
426         :: HscEnv
427         -> Maybe Fingerprint -- the old fingerprint, if any
428         -> ModIface          -- The new interface (lacking decls)
429         -> [IfaceDecl]       -- The new decls
430         -> IO (ModIface,     -- Updated interface
431                Bool)         -- True <=> no changes at all; 
432                              -- no need to write Iface
433
434 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
435  = do
436    eps <- hscEPS hsc_env
437    let
438         -- The ABI of a declaration represents everything that is made
439         -- visible about the declaration that a client can depend on.
440         -- see IfaceDeclABI below.
441        declABI :: IfaceDecl -> IfaceDeclABI 
442        declABI decl = (this_mod, decl, extras)
443         where extras = declExtras fix_fn non_orph_rules non_orph_insts
444                                   non_orph_fis decl
445
446        edges :: [(IfaceDeclABI, Unique, [Unique])]
447        edges = [ (abi, getUnique (ifName decl), out)
448                | decl <- new_decls
449                , let abi = declABI decl
450                , let out = localOccs $ freeNamesDeclABI abi
451                ]
452
453        name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
454        localOccs = map (getUnique . getParent . getOccName) 
455                         . filter ((== this_mod) . name_module)
456                         . nameSetToList
457           where getParent occ = lookupOccEnv parent_map occ `orElse` occ
458
459         -- maps OccNames to their parents in the current module.
460         -- e.g. a reference to a constructor must be turned into a reference
461         -- to the TyCon for the purposes of calculating dependencies.
462        parent_map :: OccEnv OccName
463        parent_map = foldr extend emptyOccEnv new_decls
464           where extend d env = 
465                   extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
466                   where n = ifName d
467
468         -- strongly-connected groups of declarations, in dependency order
469        groups = stronglyConnCompFromEdgedVertices edges
470
471        global_hash_fn = mkHashFun hsc_env eps
472
473         -- how to output Names when generating the data to fingerprint.
474         -- Here we want to output the fingerprint for each top-level
475         -- Name, whether it comes from the current module or another
476         -- module.  In this way, the fingerprint for a declaration will
477         -- change if the fingerprint for anything it refers to (transitively)
478         -- changes.
479        mk_put_name :: (OccEnv (OccName,Fingerprint))
480                    -> BinHandle -> Name -> IO  ()
481        mk_put_name local_env bh name
482           | isWiredInName name  =  putNameLiterally bh name 
483            -- wired-in names don't have fingerprints
484           | otherwise
485           = ASSERT2( isExternalName name, ppr name )
486             let hash | nameModule name /= this_mod =  global_hash_fn name
487                      | otherwise = snd (lookupOccEnv local_env (getOccName name)
488                            `orElse` pprPanic "urk! lookup local fingerprint" 
489                                        (ppr name)) -- (undefined,fingerprint0))
490                 -- This panic indicates that we got the dependency
491                 -- analysis wrong, because we needed a fingerprint for
492                 -- an entity that wasn't in the environment.  To debug
493                 -- it, turn the panic into a trace, uncomment the
494                 -- pprTraces below, run the compile again, and inspect
495                 -- the output and the generated .hi file with
496                 -- --show-iface.
497             in put_ bh hash
498
499         -- take a strongly-connected group of declarations and compute
500         -- its fingerprint.
501
502        fingerprint_group :: (OccEnv (OccName,Fingerprint), 
503                              [(Fingerprint,IfaceDecl)])
504                          -> SCC IfaceDeclABI
505                          -> IO (OccEnv (OccName,Fingerprint), 
506                                 [(Fingerprint,IfaceDecl)])
507
508        fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
509           = do let hash_fn = mk_put_name local_env
510                    decl = abiDecl abi
511                -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
512                hash <- computeFingerprint hash_fn abi
513                env' <- extend_hash_env local_env (hash,decl)
514                return (env', (hash,decl) : decls_w_hashes)
515
516        fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
517           = do let decls = map abiDecl abis
518                local_env1 <- foldM extend_hash_env local_env
519                                    (zip (repeat fingerprint0) decls)
520                let hash_fn = mk_put_name local_env1
521                -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
522                let stable_abis = sortBy cmp_abiNames abis
523                 -- put the cycle in a canonical order
524                hash <- computeFingerprint hash_fn stable_abis
525                let pairs = zip (repeat hash) decls
526                local_env2 <- foldM extend_hash_env local_env pairs
527                return (local_env2, pairs ++ decls_w_hashes)
528
529        -- we have fingerprinted the whole declaration, but we now need
530        -- to assign fingerprints to all the OccNames that it binds, to
531        -- use when referencing those OccNames in later declarations.
532        --
533        -- We better give each name bound by the declaration a
534        -- different fingerprint!  So we calculate the fingerprint of
535        -- each binder by combining the fingerprint of the whole
536        -- declaration with the name of the binder. (#5614)
537        extend_hash_env :: OccEnv (OccName,Fingerprint)
538                        -> (Fingerprint,IfaceDecl)
539                        -> IO (OccEnv (OccName,Fingerprint))
540        extend_hash_env env0 (hash,d) = do
541           let
542             sub_bndrs = ifaceDeclImplicitBndrs d
543             fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
544           --
545           sub_fps <- mapM fp_sub_bndr sub_bndrs
546           return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
547                         (zip sub_bndrs sub_fps))
548         where
549           decl_name = ifName d
550           item = (decl_name, hash)
551           env1 = extendOccEnv env0 decl_name item
552
553    --
554    (local_env, decls_w_hashes) <- 
555        foldM fingerprint_group (emptyOccEnv, []) groups
556
557    -- when calculating fingerprints, we always need to use canonical
558    -- ordering for lists of things.  In particular, the mi_deps has various
559    -- lists of modules and suchlike, so put these all in canonical order:
560    let sorted_deps = sortDependencies (mi_deps iface0)
561
562    -- the export hash of a module depends on the orphan hashes of the
563    -- orphan modules below us in the dependency tree.  This is the way
564    -- that changes in orphans get propagated all the way up the
565    -- dependency tree.  We only care about orphan modules in the current
566    -- package, because changes to orphans outside this package will be
567    -- tracked by the usage on the ABI hash of package modules that we import.
568    let orph_mods = filter ((== this_pkg) . modulePackageId)
569                    $ dep_orphs sorted_deps
570    dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
571
572    orphan_hash <- computeFingerprint (mk_put_name local_env)
573                       (map ifDFun orph_insts, orph_rules, orph_fis)
574
575    -- the export list hash doesn't depend on the fingerprints of
576    -- the Names it mentions, only the Names themselves, hence putNameLiterally.
577    export_hash <- computeFingerprint putNameLiterally
578                       (mi_exports iface0,
579                        orphan_hash,
580                        dep_orphan_hashes,
581                        dep_pkgs (mi_deps iface0),
582                         -- dep_pkgs: see "Package Version Changes" on
583                         -- wiki/Commentary/Compiler/RecompilationAvoidance
584                        mi_trust iface0)
585                         -- Make sure change of Safe Haskell mode causes recomp.
586
587    -- put the declarations in a canonical order, sorted by OccName
588    let sorted_decls = Map.elems $ Map.fromList $
589                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
590    
591    -- the flag hash depends on:
592    --   - (some of) dflags
593    -- it returns two hashes, one that shouldn't change
594    -- the abi hash and one that should
595    flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
596
597    -- the ABI hash depends on:
598    --   - decls
599    --   - export list
600    --   - orphans
601    --   - deprecations
602    --   - vect info
603    --   - flag abi hash
604    mod_hash <- computeFingerprint putNameLiterally
605                       (map fst sorted_decls,
606                        export_hash,  -- includes orphan_hash
607                        mi_warns iface0,
608                        mi_vect_info iface0)
609
610    -- The interface hash depends on:
611    --   - the ABI hash, plus
612    --   - usages
613    --   - deps
614    --   - hpc
615    iface_hash <- computeFingerprint putNameLiterally
616                       (mod_hash, 
617                        mi_usages iface0,
618                        sorted_deps,
619                        mi_hpc iface0)
620
621    let
622     no_change_at_all = Just iface_hash == mb_old_fingerprint
623
624     final_iface = iface0 {
625                 mi_mod_hash    = mod_hash,
626                 mi_iface_hash  = iface_hash,
627                 mi_exp_hash    = export_hash,
628                 mi_orphan_hash = orphan_hash,
629                 mi_flag_hash   = flag_hash,
630                 mi_orphan      = not (   null orph_rules
631                                       && null orph_insts
632                                       && null orph_fis
633                                       && isNoIfaceVectInfo (mi_vect_info iface0)),
634                 mi_finsts      = not . null $ mi_fam_insts iface0,
635                 mi_decls       = sorted_decls,
636                 mi_hash_fn     = lookupOccEnv local_env }
637    --
638    return (final_iface, no_change_at_all)
639
640   where
641     this_mod = mi_module iface0
642     dflags = hsc_dflags hsc_env
643     this_pkg = thisPackage dflags
644     (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
645     (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)
646     (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
647     fix_fn = mi_fix_fn iface0
648
649
650 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
651 getOrphanHashes hsc_env mods = do
652   eps <- hscEPS hsc_env
653   let 
654     hpt        = hsc_HPT hsc_env
655     pit        = eps_PIT eps
656     dflags     = hsc_dflags hsc_env
657     get_orph_hash mod = 
658           case lookupIfaceByModule dflags hpt pit mod of
659             Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
660             Just iface -> mi_orphan_hash iface
661   --
662   return (map get_orph_hash mods)
663
664
665 sortDependencies :: Dependencies -> Dependencies
666 sortDependencies d
667  = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
668           dep_pkgs   = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d),
669           dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
670           dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
671 \end{code}
672
673
674 %************************************************************************
675 %*                                                                      *
676           The ABI of an IfaceDecl                                                                               
677 %*                                                                      *
678 %************************************************************************
679
680 Note [The ABI of an IfaceDecl]
681 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
682 The ABI of a declaration consists of:
683
684    (a) the full name of the identifier (inc. module and package,
685        because these are used to construct the symbol name by which
686        the identifier is known externally).
687
688    (b) the declaration itself, as exposed to clients.  That is, the
689        definition of an Id is included in the fingerprint only if
690        it is made available as as unfolding in the interface.
691
692    (c) the fixity of the identifier
693    (d) for Ids: rules
694    (e) for classes: instances, fixity & rules for methods
695    (f) for datatypes: instances, fixity & rules for constrs
696
697 Items (c)-(f) are not stored in the IfaceDecl, but instead appear
698 elsewhere in the interface file.  But they are *fingerprinted* with
699 the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
700 and fingerprinting that as part of the declaration.
701
702 \begin{code}
703 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
704
705 data IfaceDeclExtras 
706   = IfaceIdExtras    Fixity [IfaceRule]
707
708   | IfaceDataExtras  
709        Fixity                   -- Fixity of the tycon itself
710        [IfaceInstABI]           -- Local class and family instances of this tycon
711                                 -- See Note [Orphans] in IfaceSyn
712        [(Fixity,[IfaceRule])]   -- For each construcotr, fixity and RULES
713
714   | IfaceClassExtras 
715        Fixity                   -- Fixity of the class itself
716        [IfaceInstABI]           -- Local instances of this class *or*
717                                 --   of its associated data types
718                                 -- See Note [Orphans] in IfaceSyn
719        [(Fixity,[IfaceRule])]   -- For each class method, fixity and RULES
720
721   | IfaceSynExtras   Fixity [IfaceInstABI]
722
723   | IfaceOtherDeclExtras
724
725 -- When hashing a class or family instance, we hash only the 
726 -- DFunId or CoAxiom, because that depends on all the 
727 -- information about the instance.
728 --
729 type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance
730
731 abiDecl :: IfaceDeclABI -> IfaceDecl
732 abiDecl (_, decl, _) = decl
733
734 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
735 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` 
736                          ifName (abiDecl abi2)
737
738 freeNamesDeclABI :: IfaceDeclABI -> NameSet
739 freeNamesDeclABI (_mod, decl, extras) =
740   freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
741
742 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
743 freeNamesDeclExtras (IfaceIdExtras    _ rules)
744   = unionManyNameSets (map freeNamesIfRule rules)
745 freeNamesDeclExtras (IfaceDataExtras  _ insts subs)
746   = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
747 freeNamesDeclExtras (IfaceClassExtras _ insts subs)
748   = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
749 freeNamesDeclExtras (IfaceSynExtras _ insts)
750   = mkNameSet insts
751 freeNamesDeclExtras IfaceOtherDeclExtras
752   = emptyNameSet
753
754 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
755 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
756
757 instance Outputable IfaceDeclExtras where
758   ppr IfaceOtherDeclExtras       = empty
759   ppr (IfaceIdExtras  fix rules) = ppr_id_extras fix rules
760   ppr (IfaceSynExtras fix finsts) = vcat [ppr fix, ppr finsts]
761   ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
762                                                 ppr_id_extras_s stuff]
763   ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
764                                                  ppr_id_extras_s stuff]
765
766 ppr_insts :: [IfaceInstABI] -> SDoc
767 ppr_insts _ = ptext (sLit "<insts>")
768
769 ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc
770 ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff]
771
772 ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc
773 ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules)
774
775 -- This instance is used only to compute fingerprints
776 instance Binary IfaceDeclExtras where
777   get _bh = panic "no get for IfaceDeclExtras"
778   put_ bh (IfaceIdExtras fix rules) = do
779    putByte bh 1; put_ bh fix; put_ bh rules
780   put_ bh (IfaceDataExtras fix insts cons) = do
781    putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
782   put_ bh (IfaceClassExtras fix insts methods) = do
783    putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
784   put_ bh (IfaceSynExtras fix finsts) = do
785    putByte bh 4; put_ bh fix; put_ bh finsts
786   put_ bh IfaceOtherDeclExtras = do
787    putByte bh 5
788
789 declExtras :: (OccName -> Fixity)
790            -> OccEnv [IfaceRule]
791            -> OccEnv [IfaceClsInst]
792            -> OccEnv [IfaceFamInst]
793            -> IfaceDecl
794            -> IfaceDeclExtras
795
796 declExtras fix_fn rule_env inst_env fi_env decl
797   = case decl of
798       IfaceId{} -> IfaceIdExtras (fix_fn n) 
799                         (lookupOccEnvL rule_env n)
800       IfaceData{ifCons=cons} -> 
801                      IfaceDataExtras (fix_fn n)
802                         (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
803                          map ifDFun         (lookupOccEnvL inst_env n))
804                         (map (id_extras . ifConOcc) (visibleIfConDecls cons))
805       IfaceClass{ifSigs=sigs, ifATs=ats} -> 
806                      IfaceClassExtras (fix_fn n)
807                         (map ifDFun $ (concatMap at_extras ats)
808                                     ++ lookupOccEnvL inst_env n)
809                            -- Include instances of the associated types
810                            -- as well as instances of the class (Trac #5147)
811                         [id_extras op | IfaceClassOp op _ _ <- sigs]
812       IfaceSyn{} -> IfaceSynExtras (fix_fn n) 
813                         (map ifFamInstAxiom (lookupOccEnvL fi_env n))
814       _other -> IfaceOtherDeclExtras
815   where
816         n = ifName decl
817         id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
818         at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
819
820
821 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
822 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
823
824 -- used when we want to fingerprint a structure without depending on the
825 -- fingerprints of external Names that it refers to.
826 putNameLiterally :: BinHandle -> Name -> IO ()
827 putNameLiterally bh name = ASSERT( isExternalName name ) 
828   do { put_ bh $! nameModule name
829      ; put_ bh $! nameOccName name }
830
831 {-
832 -- for testing: use the md5sum command to generate fingerprints and
833 -- compare the results against our built-in version.
834   fp' <- oldMD5 dflags bh
835   if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
836                else return fp
837
838 oldMD5 dflags bh = do
839   tmp <- newTempName dflags "bin"
840   writeBinMem bh tmp
841   tmp2 <- newTempName dflags "md5"
842   let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
843   r <- system cmd
844   case r of
845     ExitFailure _ -> ghcError (PhaseFailed cmd r)
846     ExitSuccess -> do
847         hash_str <- readFile tmp2
848         return $! readHexFingerprint hash_str
849 -}
850
851 instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
852 instOrphWarn dflags unqual inst
853   = mkWarnMsg dflags (getSrcSpan inst) unqual $
854     hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
855
856 ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
857 ruleOrphWarn dflags unqual mod rule
858   = mkWarnMsg dflags silly_loc unqual $
859     ptext (sLit "Orphan rule:") <+> ppr rule
860   where
861     silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
862     -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
863     -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
864
865 ----------------------
866 -- mkOrphMap partitions instance decls or rules into
867 --      (a) an OccEnv for ones that are not orphans, 
868 --          mapping the local OccName to a list of its decls
869 --      (b) a list of orphan decls
870 mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
871                                         -- Nothing for an orphan decl
872           -> [decl]                     -- Sorted into canonical order
873           -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
874                                         --      each sublist in canonical order
875               [decl])                   -- Orphan decls; in canonical order
876 mkOrphMap get_key decls
877   = foldl go (emptyOccEnv, []) decls
878   where
879     go (non_orphs, orphs) d
880         | Just occ <- get_key d
881         = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
882         | otherwise = (non_orphs, d:orphs)
883 \end{code}
884
885
886 %************************************************************************
887 %*                                                                      *
888        Keeping track of what we've slurped, and fingerprints
889 %*                                                                      *
890 %************************************************************************
891
892 \begin{code}
893 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
894 mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
895   = do  { eps <- hscEPS hsc_env
896     ; mtimes <- mapM getModificationUTCTime dependent_files
897         ; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
898                                      dir_imp_mods used_names
899         ; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes)
900         ; usages `seqList`  return usages }
901          -- seq the list of Usages returned: occasionally these
902          -- don't get evaluated for a while and we can end up hanging on to
903          -- the entire collection of Ifaces.
904    where
905      to_file_usage (f, mtime) = UsageFile { usg_file_path = f, usg_mtime = mtime }
906
907 mk_mod_usage_info :: PackageIfaceTable
908               -> HscEnv
909               -> Module
910               -> ImportedMods
911               -> NameSet
912               -> [Usage]
913 mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
914   = mapCatMaybes mkUsage usage_mods
915   where
916     hpt = hsc_HPT hsc_env
917     dflags = hsc_dflags hsc_env
918     this_pkg = thisPackage dflags
919
920     used_mods    = moduleEnvKeys ent_map
921     dir_imp_mods = moduleEnvKeys direct_imports
922     all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
923     usage_mods   = sortBy stableModuleCmp all_mods
924                         -- canonical order is imported, to avoid interface-file
925                         -- wobblage.
926
927     -- ent_map groups together all the things imported and used
928     -- from a particular module
929     ent_map :: ModuleEnv [OccName]
930     ent_map  = foldNameSet add_mv emptyModuleEnv used_names
931      where
932       add_mv name mv_map
933         | isWiredInName name = mv_map  -- ignore wired-in names
934         | otherwise
935         = case nameModule_maybe name of
936              Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
937                 -- See Note [Internal used_names]
938
939              Just mod -> -- This lambda function is really just a
940                          -- specialised (++); originally came about to
941                          -- avoid quadratic behaviour (trac #2680)
942                          extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
943                 where occ = nameOccName name
944     
945     -- We want to create a Usage for a home module if 
946     --  a) we used something from it; has something in used_names
947     --  b) we imported it, even if we used nothing from it
948     --     (need to recompile if its export list changes: export_fprint)
949     mkUsage :: Module -> Maybe Usage
950     mkUsage mod
951       | isNothing maybe_iface           -- We can't depend on it if we didn't
952                                         -- load its interface.
953       || mod == this_mod                -- We don't care about usages of
954                                         -- things in *this* module
955       = Nothing
956
957       | modulePackageId mod /= this_pkg
958       = Just UsagePackageModule{ usg_mod      = mod,
959                                  usg_mod_hash = mod_hash,
960                                  usg_safe     = imp_safe }
961         -- for package modules, we record the module hash only
962
963       | (null used_occs
964           && isNothing export_hash
965           && not is_direct_import
966           && not finsts_mod)
967       = Nothing                 -- Record no usage info
968         -- for directly-imported modules, we always want to record a usage
969         -- on the orphan hash.  This is what triggers a recompilation if
970         -- an orphan is added or removed somewhere below us in the future.
971     
972       | otherwise       
973       = Just UsageHomeModule { 
974                       usg_mod_name = moduleName mod,
975                       usg_mod_hash = mod_hash,
976                       usg_exports  = export_hash,
977                       usg_entities = Map.toList ent_hashs,
978                       usg_safe     = imp_safe }
979       where
980         maybe_iface  = lookupIfaceByModule dflags hpt pit mod
981                 -- In one-shot mode, the interfaces for home-package
982                 -- modules accumulate in the PIT not HPT.  Sigh.
983
984         Just iface   = maybe_iface
985         finsts_mod   = mi_finsts    iface
986         hash_env     = mi_hash_fn   iface
987         mod_hash     = mi_mod_hash  iface
988         export_hash | depend_on_exports = Just (mi_exp_hash iface)
989                     | otherwise         = Nothing
990
991         (is_direct_import, imp_safe)
992             = case lookupModuleEnv direct_imports mod of
993                 Just ((_,_,_,safe):_xs) -> (True, safe)
994                 Just _                  -> pprPanic "mkUsage: empty direct import" empty
995                 Nothing                 -> (False, safeImplicitImpsReq dflags)
996                 -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
997                 -- is used in the source code. We require them to be safe in Safe Haskell
998     
999         used_occs = lookupModuleEnv ent_map mod `orElse` []
1000
1001         -- Making a Map here ensures that (a) we remove duplicates
1002         -- when we have usages on several subordinates of a single parent,
1003         -- and (b) that the usages emerge in a canonical order, which
1004         -- is why we use Map rather than OccEnv: Map works
1005         -- using Ord on the OccNames, which is a lexicographic ordering.
1006         ent_hashs :: Map OccName Fingerprint
1007         ent_hashs = Map.fromList (map lookup_occ used_occs)
1008         
1009         lookup_occ occ = 
1010             case hash_env occ of
1011                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
1012                 Just r  -> r
1013
1014         depend_on_exports = is_direct_import
1015         {- True
1016               Even if we used 'import M ()', we have to register a
1017               usage on the export list because we are sensitive to
1018               changes in orphan instances/rules.
1019            False
1020               In GHC 6.8.x we always returned true, and in
1021               fact it recorded a dependency on *all* the
1022               modules underneath in the dependency tree.  This
1023               happens to make orphans work right, but is too
1024               expensive: it'll read too many interface files.
1025               The 'isNothing maybe_iface' check above saved us
1026               from generating many of these usages (at least in
1027               one-shot mode), but that's even more bogus!
1028         -}
1029 \end{code}
1030
1031 \begin{code}
1032 mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
1033 mkIfaceAnnotations = map mkIfaceAnnotation
1034
1035 mkIfaceAnnotation :: Annotation -> IfaceAnnotation
1036 mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation { 
1037         ifAnnotatedTarget = fmap nameOccName target,
1038         ifAnnotatedValue = serialized
1039     }
1040 \end{code}
1041
1042 \begin{code}
1043 mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical
1044 mkIfaceExports exports
1045   = sortBy stableAvailCmp (map sort_subs exports)
1046   where
1047     sort_subs :: AvailInfo -> AvailInfo
1048     sort_subs (Avail n) = Avail n
1049     sort_subs (AvailTC n []) = AvailTC n []
1050     sort_subs (AvailTC n (m:ms)) 
1051        | n==m      = AvailTC n (m:sortBy stableNameCmp ms)
1052        | otherwise = AvailTC n (sortBy stableNameCmp (m:ms))
1053        -- Maintain the AvailTC Invariant
1054 \end{code}
1055
1056 Note [Orignal module]
1057 ~~~~~~~~~~~~~~~~~~~~~
1058 Consider this:
1059         module X where { data family T }
1060         module Y( T(..) ) where { import X; data instance T Int = MkT Int }
1061 The exported Avail from Y will look like
1062         X.T{X.T, Y.MkT}
1063 That is, in Y, 
1064   - only MkT is brought into scope by the data instance;
1065   - but the parent (used for grouping and naming in T(..) exports) is X.T
1066   - and in this case we export X.T too
1067
1068 In the result of MkIfaceExports, the names are grouped by defining module,
1069 so we may need to split up a single Avail into multiple ones.
1070
1071 Note [Internal used_names]
1072 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1073 Most of the used_names are External Names, but we can have Internal
1074 Names too: see Note [Binders in Template Haskell] in Convert, and
1075 Trac #5362 for an example.  Such Names are always
1076   - Such Names are always for locally-defined things, for which we
1077     don't gather usage info, so we can just ignore them in ent_map
1078   - They are always System Names, hence the assert, just as a double check.
1079
1080
1081 %************************************************************************
1082 %*                                                                      *
1083         Load the old interface file for this module (unless
1084         we have it already), and check whether it is up to date
1085 %*                                                                      *
1086 %************************************************************************
1087
1088 \begin{code}
1089 data RecompileRequired
1090   = UpToDate
1091        -- ^ everything is up to date, recompilation is not required
1092   | MustCompile
1093        -- ^ The .hs file has been touched, or the .o/.hi file does not exist
1094   | RecompBecause String
1095        -- ^ The .o/.hi files are up to date, but something else has changed
1096        -- to force recompilation; the String says what (one-line summary)
1097    deriving Eq
1098
1099 recompileRequired :: RecompileRequired -> Bool
1100 recompileRequired UpToDate = False
1101 recompileRequired _ = True
1102
1103
1104
1105 -- | Top level function to check if the version of an old interface file
1106 -- is equivalent to the current source file the user asked us to compile.
1107 -- If the same, we can avoid recompilation. We return a tuple where the
1108 -- first element is a bool saying if we should recompile the object file
1109 -- and the second is maybe the interface file, where Nothng means to
1110 -- rebuild the interface file not use the exisitng one.
1111 checkOldIface :: HscEnv
1112               -> ModSummary
1113               -> SourceModified
1114               -> Maybe ModIface         -- Old interface from compilation manager, if any
1115               -> IO (RecompileRequired, Maybe ModIface)
1116
1117 checkOldIface hsc_env mod_summary source_modified maybe_iface
1118   = do  let dflags = hsc_dflags hsc_env
1119         showPass dflags $
1120             "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary)
1121         initIfaceCheck hsc_env $
1122             check_old_iface hsc_env mod_summary source_modified maybe_iface
1123
1124 check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface
1125                 -> IfG (RecompileRequired, Maybe ModIface)
1126 check_old_iface hsc_env mod_summary src_modified maybe_iface
1127   = let dflags = hsc_dflags hsc_env
1128         getIface =
1129             case maybe_iface of
1130                 Just _  -> do
1131                     traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1132                     return maybe_iface
1133                 Nothing -> loadIface
1134
1135         loadIface = do
1136              let iface_path = msHiFilePath mod_summary
1137              read_result <- readIface (ms_mod mod_summary) iface_path False
1138              case read_result of
1139                  Failed err -> do
1140                      traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err)
1141                      return Nothing
1142                  Succeeded iface -> do
1143                      traceIf (text "Read the interface file" <+> text iface_path)
1144                      return $ Just iface
1145
1146         src_changed
1147             | dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
1148             | SourceModified <- src_modified = True
1149             | otherwise = False
1150     in do
1151         when src_changed $
1152             traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
1153
1154         case src_changed of
1155             -- If the source has changed and we're in interactive mode,
1156             -- avoid reading an interface; just return the one we might
1157             -- have been supplied with.
1158             True | not (isObjectTarget $ hscTarget dflags) ->
1159                 return (MustCompile, maybe_iface)
1160
1161             -- Try and read the old interface for the current module
1162             -- from the .hi file left from the last time we compiled it
1163             True -> do
1164                 maybe_iface' <- getIface
1165                 return (MustCompile, maybe_iface')
1166
1167             False -> do
1168                 maybe_iface' <- getIface
1169                 case maybe_iface' of
1170                     -- We can't retrieve the iface
1171                     Nothing    -> return (MustCompile, Nothing)
1172
1173                     -- We have got the old iface; check its versions
1174                     -- even in the SourceUnmodifiedAndStable case we
1175                     -- should check versions because some packages
1176                     -- might have changed or gone away.
1177                     Just iface -> checkVersions hsc_env mod_summary iface
1178
1179 -- | Check if a module is still the same 'version'.
1180 --
1181 -- This function is called in the recompilation checker after we have
1182 -- determined that the module M being checked hasn't had any changes
1183 -- to its source file since we last compiled M. So at this point in general
1184 -- two things may have changed that mean we should recompile M:
1185 --   * The interface export by a dependency of M has changed.
1186 --   * The compiler flags specified this time for M have changed
1187 --     in a manner that is significant for recompilaiton.
1188 -- We return not just if we should recompile the object file but also
1189 -- if we should rebuild the interface file.
1190 checkVersions :: HscEnv
1191               -> ModSummary
1192               -> ModIface       -- Old interface
1193               -> IfG (RecompileRequired, Maybe ModIface)
1194 checkVersions hsc_env mod_summary iface
1195   = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
1196                         ppr (mi_module iface) <> colon)
1197
1198        ; recomp <- checkFlagHash hsc_env iface
1199        ; if recompileRequired recomp then return (recomp, Nothing) else do {
1200        ; recomp <- checkDependencies hsc_env mod_summary iface
1201        ; if recompileRequired recomp then return (recomp, Just iface) else do {
1202
1203        -- Source code unchanged and no errors yet... carry on
1204        --
1205        -- First put the dependent-module info, read from the old
1206        -- interface, into the envt, so that when we look for
1207        -- interfaces we look for the right one (.hi or .hi-boot)
1208        --
1209        -- It's just temporary because either the usage check will succeed
1210        -- (in which case we are done with this module) or it'll fail (in which
1211        -- case we'll compile the module from scratch anyhow).
1212        --
1213        -- We do this regardless of compilation mode, although in --make mode
1214        -- all the dependent modules should be in the HPT already, so it's
1215        -- quite redundant
1216        ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
1217        ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1218        ; return (recomp, Just iface)
1219     }}}
1220   where
1221     this_pkg = thisPackage (hsc_dflags hsc_env)
1222     -- This is a bit of a hack really
1223     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1224     mod_deps = mkModDeps (dep_mods (mi_deps iface))
1225
1226 -- | Check the flags haven't changed
1227 checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
1228 checkFlagHash hsc_env iface = do
1229     let old_hash = mi_flag_hash iface
1230     new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
1231                                              (mi_module iface)
1232                                              putNameLiterally
1233     case old_hash == new_hash of
1234         True  -> up_to_date (ptext $ sLit "Module flags unchanged")
1235         False -> out_of_date_hash "flags changed"
1236                      (ptext $ sLit "  Module flags have changed")
1237                      old_hash new_hash
1238
1239 -- If the direct imports of this module are resolved to targets that
1240 -- are not among the dependencies of the previous interface file,
1241 -- then we definitely need to recompile.  This catches cases like
1242 --   - an exposed package has been upgraded
1243 --   - we are compiling with different package flags
1244 --   - a home module that was shadowing a package module has been removed
1245 --   - a new home module has been added that shadows a package module
1246 -- See bug #1372.
1247 --
1248 -- Returns True if recompilation is required.
1249 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1250 checkDependencies hsc_env summary iface
1251  = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1252   where
1253    prev_dep_mods = dep_mods (mi_deps iface)
1254    prev_dep_pkgs = dep_pkgs (mi_deps iface)
1255
1256    this_pkg = thisPackage (hsc_dflags hsc_env)
1257
1258    dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do
1259      find_res <- liftIO $ findImportedModule hsc_env mod pkg
1260      let reason = moduleNameString mod ++ " changed"
1261      case find_res of
1262         Found _ mod
1263           | pkg == this_pkg
1264            -> if moduleName mod `notElem` map fst prev_dep_mods
1265                  then do traceHiDiffs $
1266                            text "imported module " <> quotes (ppr mod) <>
1267                            text " not among previous dependencies"
1268                          return (RecompBecause reason)
1269                  else
1270                          return UpToDate
1271           | otherwise
1272            -> if pkg `notElem` (map fst prev_dep_pkgs)
1273                  then do traceHiDiffs $
1274                            text "imported module " <> quotes (ppr mod) <>
1275                            text " is from package " <> quotes (ppr pkg) <>
1276                            text ", which is not among previous dependencies"
1277                          return (RecompBecause reason)
1278                  else
1279                          return UpToDate
1280            where pkg = modulePackageId mod
1281         _otherwise  -> return (RecompBecause reason)
1282
1283 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1284               -> IfG RecompileRequired
1285 needInterface mod continue
1286   = do  -- Load the imported interface if possible
1287     let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1288     traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1289
1290     mb_iface <- loadInterface doc_str mod ImportBySystem
1291         -- Load the interface, but don't complain on failure;
1292         -- Instead, get an Either back which we can test
1293
1294     case mb_iface of
1295       Failed _ -> do
1296         traceHiDiffs (sep [ptext (sLit "Couldn't load interface for module"),
1297                            ppr mod])
1298         return MustCompile
1299                   -- Couldn't find or parse a module mentioned in the
1300                   -- old interface file.  Don't complain: it might
1301                   -- just be that the current module doesn't need that
1302                   -- import and it's been deleted
1303       Succeeded iface -> continue iface
1304
1305
1306 -- | Given the usage information extracted from the old
1307 -- M.hi file for the module being compiled, figure out
1308 -- whether M needs to be recompiled.
1309 checkModUsage :: PackageId -> Usage -> IfG RecompileRequired
1310 checkModUsage _this_pkg UsagePackageModule{
1311                                 usg_mod = mod,
1312                                 usg_mod_hash = old_mod_hash }
1313   = needInterface mod $ \iface -> do
1314     let reason = moduleNameString (moduleName mod) ++ " changed"
1315     checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
1316         -- We only track the ABI hash of package modules, rather than
1317         -- individual entity usages, so if the ABI hash changes we must
1318         -- recompile.  This is safe but may entail more recompilation when
1319         -- a dependent package has changed.
1320
1321 checkModUsage this_pkg UsageHomeModule{ 
1322                                 usg_mod_name = mod_name, 
1323                                 usg_mod_hash = old_mod_hash,
1324                                 usg_exports = maybe_old_export_hash,
1325                                 usg_entities = old_decl_hash }
1326   = do
1327     let mod = mkModule this_pkg mod_name
1328     needInterface mod $ \iface -> do
1329
1330     let
1331         new_mod_hash    = mi_mod_hash    iface
1332         new_decl_hash   = mi_hash_fn     iface
1333         new_export_hash = mi_exp_hash    iface
1334
1335         reason = moduleNameString mod_name ++ " changed"
1336
1337         -- CHECK MODULE
1338     recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
1339     if not (recompileRequired recompile) then return UpToDate else do
1340
1341         -- CHECK EXPORT LIST
1342     checkMaybeHash reason maybe_old_export_hash new_export_hash
1343         (ptext (sLit "  Export list changed")) $ do
1344
1345         -- CHECK ITEMS ONE BY ONE
1346     recompile <- checkList [ checkEntityUsage reason new_decl_hash u
1347                            | u <- old_decl_hash]
1348     if recompileRequired recompile
1349       then return recompile     -- This one failed, so just bail out now
1350       else up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
1351  
1352
1353 checkModUsage _this_pkg UsageFile{ usg_file_path = file,
1354                                    usg_mtime = old_mtime } =
1355   liftIO $
1356     handleIO handle $ do
1357       new_mtime <- getModificationUTCTime file
1358       if (old_mtime /= new_mtime)
1359          then return recomp
1360          else return UpToDate
1361  where
1362    recomp = RecompBecause (file ++ " changed")
1363    handle =
1364 #ifdef DEBUG
1365        \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
1366 #else
1367        \_ -> return recomp -- if we can't find the file, just recompile, don't fail
1368 #endif
1369
1370 ------------------------
1371 checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
1372                        -> IfG RecompileRequired
1373 checkModuleFingerprint reason old_mod_hash new_mod_hash
1374   | new_mod_hash == old_mod_hash
1375   = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1376
1377   | otherwise
1378   = out_of_date_hash reason (ptext (sLit "  Module fingerprint has changed"))
1379                      old_mod_hash new_mod_hash
1380
1381 ------------------------
1382 checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
1383                -> IfG RecompileRequired -> IfG RecompileRequired
1384 checkMaybeHash reason maybe_old_hash new_hash doc continue
1385   | Just hash <- maybe_old_hash, hash /= new_hash
1386   = out_of_date_hash reason doc hash new_hash
1387   | otherwise
1388   = continue
1389
1390 ------------------------
1391 checkEntityUsage :: String
1392                  -> (OccName -> Maybe (OccName, Fingerprint))
1393                  -> (OccName, Fingerprint)
1394                  -> IfG RecompileRequired
1395 checkEntityUsage reason new_hash (name,old_hash)
1396   = case new_hash name of
1397
1398         Nothing       ->        -- We used it before, but it ain't there now
1399                           out_of_date reason (sep [ptext (sLit "No longer exported:"), ppr name])
1400
1401         Just (_, new_hash)      -- It's there, but is it up to date?
1402           | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
1403                                        return UpToDate
1404           | otherwise            -> out_of_date_hash reason (ptext (sLit "  Out of date:") <+> ppr name)
1405                                                      old_hash new_hash
1406
1407 up_to_date :: SDoc -> IfG RecompileRequired
1408 up_to_date  msg = traceHiDiffs msg >> return UpToDate
1409
1410 out_of_date :: String -> SDoc -> IfG RecompileRequired
1411 out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
1412
1413 out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
1414 out_of_date_hash reason msg old_hash new_hash
1415   = out_of_date reason (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1416
1417 ----------------------
1418 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1419 -- This helper is used in two places
1420 checkList []             = return UpToDate
1421 checkList (check:checks) = do recompile <- check
1422                               if recompileRequired recompile
1423                                 then return recompile
1424                                 else checkList checks
1425 \end{code}
1426
1427 %************************************************************************
1428 %*                                                                      *
1429                 Converting things to their Iface equivalents
1430 %*                                                                      *
1431 %************************************************************************
1432
1433 \begin{code}
1434 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1435 tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id
1436 tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon
1437 tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax
1438 tyThingToIfaceDecl (ADataCon dc)  = pprPanic "toIfaceDecl" (ppr dc)
1439                                     -- Should be trimmed out earlier
1440
1441 --------------------------
1442 idToIfaceDecl :: Id -> IfaceDecl
1443 -- The Id is already tidied, so that locally-bound names
1444 -- (lambdas, for-alls) already have non-clashing OccNames
1445 -- We can't tidy it here, locally, because it may have
1446 -- free variables in its type or IdInfo
1447 idToIfaceDecl id
1448   = IfaceId { ifName      = getOccName id,
1449               ifType      = toIfaceType (idType id),
1450               ifIdDetails = toIfaceIdDetails (idDetails id),
1451               ifIdInfo    = toIfaceIdInfo (idInfo id) }
1452
1453
1454 --------------------------
1455 coAxiomToIfaceDecl :: CoAxiom -> IfaceDecl
1456 -- We *do* tidy Axioms, because they are not (and cannot 
1457 -- conveniently be) built in tidy form
1458 coAxiomToIfaceDecl ax
1459  = IfaceAxiom { ifName = name
1460               , ifTyVars = toIfaceTvBndrs tv_bndrs
1461               , ifLHS    = tidyToIfaceType env (coAxiomLHS ax)
1462               , ifRHS    = tidyToIfaceType env (coAxiomRHS ax) }
1463  where
1464    name = getOccName ax
1465    (env, tv_bndrs) = tidyTyVarBndrs emptyTidyEnv (coAxiomTyVars ax)
1466
1467 -----------------
1468 tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl
1469 -- We *do* tidy TyCons, because they are not (and cannot 
1470 -- conveniently be) built in tidy form
1471 tyConToIfaceDecl env tycon
1472   | Just clas <- tyConClass_maybe tycon
1473   = classToIfaceDecl env clas
1474
1475   | isSynTyCon tycon
1476   = IfaceSyn {  ifName    = getOccName tycon,
1477                 ifTyVars  = toIfaceTvBndrs tyvars,
1478                 ifSynRhs  = syn_rhs,
1479                 ifSynKind = syn_ki }
1480
1481   | isAlgTyCon tycon
1482   = IfaceData { ifName    = getOccName tycon,
1483                 ifCType   = tyConCType tycon,
1484                 ifTyVars  = toIfaceTvBndrs tyvars,
1485                 ifCtxt    = tidyToIfaceContext env1 (tyConStupidTheta tycon),
1486                 ifCons    = ifaceConDecls (algTyConRhs tycon),
1487                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
1488                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1489                 ifAxiom   = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
1490
1491   | isForeignTyCon tycon
1492   = IfaceForeign { ifName    = getOccName tycon,
1493                    ifExtName = tyConExtName tycon }
1494
1495   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1496   where
1497     (env1, tyvars) = tidyTyVarBndrs env (tyConTyVars tycon)
1498
1499     (syn_rhs, syn_ki) 
1500        = case synTyConRhs tycon of
1501             SynFamilyTyCon  ->
1502                ( Nothing
1503                , tidyToIfaceType env1 (synTyConResKind tycon) )
1504             SynonymTyCon ty ->
1505                ( Just (tidyToIfaceType env1 ty)
1506                , tidyToIfaceType env1 (typeKind ty) )
1507
1508     ifaceConDecls (NewTyCon { data_con = con })     = IfNewTyCon  (ifaceConDecl con)
1509     ifaceConDecls (DataTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
1510     ifaceConDecls DataFamilyTyCon {}                = IfDataFamTyCon
1511     ifaceConDecls (AbstractTyCon distinct)          = IfAbstractTyCon distinct
1512         -- The last case happens when a TyCon has been trimmed during tidying
1513         -- Furthermore, tyThingToIfaceDecl is also used
1514         -- in TcRnDriver for GHCi, when browsing a module, in which case the
1515         -- AbstractTyCon case is perfectly sensible.
1516
1517     ifaceConDecl data_con 
1518         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
1519                     ifConInfix   = dataConIsInfix data_con,
1520                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
1521                     ifConUnivTvs = toIfaceTvBndrs univ_tvs',
1522                     ifConExTvs   = toIfaceTvBndrs ex_tvs',
1523                     ifConEqSpec  = to_eq_spec eq_spec,
1524                     ifConCtxt    = tidyToIfaceContext env3 theta,
1525                     ifConArgTys  = map (tidyToIfaceType env3) arg_tys,
1526                     ifConFields  = map getOccName 
1527                                        (dataConFieldLabels data_con),
1528                     ifConStricts = dataConStrictMarks data_con }
1529         where
1530           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
1531           (env2, univ_tvs') = tidyTyClTyVarBndrs env1 univ_tvs
1532           (env3, ex_tvs')   = tidyTyVarBndrs env2 ex_tvs
1533           to_eq_spec spec = [ (getOccName (tidyTyVar env3 tv), tidyToIfaceType env3 ty) 
1534                             | (tv,ty) <- spec]
1535
1536
1537 classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
1538 classToIfaceDecl env clas
1539   = IfaceClass { ifCtxt   = tidyToIfaceContext env1 sc_theta,
1540                  ifName   = getOccName (classTyCon clas),
1541                  ifTyVars = toIfaceTvBndrs clas_tyvars',
1542                  ifFDs    = map toIfaceFD clas_fds,
1543                  ifATs    = map toIfaceAT clas_ats,
1544                  ifSigs   = map toIfaceClassOp op_stuff,
1545                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
1546   where
1547     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
1548       = classExtraBigSig clas
1549     tycon = classTyCon clas
1550
1551     (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars
1552     
1553     toIfaceAT :: ClassATItem -> IfaceAT
1554     toIfaceAT (tc, defs)
1555       = IfaceAT (tyConToIfaceDecl env1 tc) (map to_if_at_def defs)
1556       where
1557         to_if_at_def (ATD tvs pat_tys ty _loc)
1558           = IfaceATD (toIfaceTvBndrs tvs') 
1559                      (map (tidyToIfaceType env2) pat_tys) 
1560                      (tidyToIfaceType env2 ty)
1561           where
1562             (env2, tvs') = tidyTyClTyVarBndrs env1 tvs
1563
1564     toIfaceClassOp (sel_id, def_meth)
1565         = ASSERT(sel_tyvars == clas_tyvars)
1566           IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) 
1567                        (tidyToIfaceType env1 op_ty)
1568         where
1569                 -- Be careful when splitting the type, because of things
1570                 -- like         class Foo a where
1571                 --                op :: (?x :: String) => a -> a
1572                 -- and          class Baz a where
1573                 --                op :: (Ord a) => a -> a
1574           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1575           op_ty                = funResultTy rho_ty
1576
1577     toDmSpec NoDefMeth      = NoDM
1578     toDmSpec (GenDefMeth _) = GenericDM
1579     toDmSpec (DefMeth _)    = VanillaDM
1580
1581     toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1, 
1582                               map (getFS . tidyTyVar env1) tvs2)
1583
1584 --------------------------
1585 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
1586 tidyToIfaceType env ty = toIfaceType (tidyType env ty)
1587
1588 tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
1589 tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
1590
1591 tidyTyClTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
1592 tidyTyClTyVarBndrs env tvs = mapAccumL tidyTyClTyVarBndr env tvs
1593
1594 tidyTyClTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
1595 -- If the type variable "binder" is in scope, don't re-bind it
1596 -- In a class decl, for example, the ATD binders mention 
1597 -- (amd must mention) the class tyvars
1598 tidyTyClTyVarBndr env@(_, subst) tv
1599  | Just tv' <- lookupVarEnv subst tv = (env, tv')
1600  | otherwise                         = tidyTyVarBndr env tv
1601
1602 tidyTyVar :: TidyEnv -> TyVar -> TyVar
1603 tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv
1604    -- TcType.tidyTyVarOcc messes around with FlatSkols
1605
1606 getFS :: NamedThing a => a -> FastString
1607 getFS x = occNameFS (getOccName x)
1608
1609 --------------------------
1610 instanceToIfaceInst :: ClsInst -> IfaceClsInst
1611 instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag,
1612                                 is_cls = cls_name, is_tcs = mb_tcs })
1613   = ASSERT( cls_name == className cls )
1614     IfaceClsInst { ifDFun    = dfun_name,
1615                 ifOFlag   = oflag,
1616                 ifInstCls = cls_name,
1617                 ifInstTys = map do_rough mb_tcs,
1618                 ifInstOrph = orph }
1619   where
1620     do_rough Nothing  = Nothing
1621     do_rough (Just n) = Just (toIfaceTyCon_name n)
1622
1623     dfun_name = idName dfun_id
1624     mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
1625     is_local name = nameIsLocalOrFrom mod name
1626
1627         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1628     (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
1629                 -- Slightly awkward: we need the Class to get the fundeps
1630     (tvs, fds) = classTvsFds cls
1631     arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
1632
1633     -- See Note [When exactly is an instance decl an orphan?] in IfaceSyn
1634     orph | is_local cls_name = Just (nameOccName cls_name)
1635          | all isJust mb_ns  = ASSERT( not (null mb_ns) ) head mb_ns
1636          | otherwise         = Nothing
1637     
1638     mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
1639                                 -- that is not in the "determined" arguments
1640     mb_ns | null fds   = [choose_one arg_names]
1641           | otherwise  = map do_one fds
1642     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1643                                           , not (tv `elem` rtvs)]
1644
1645     choose_one :: [NameSet] -> Maybe OccName
1646     choose_one nss = case nameSetToList (unionManyNameSets nss) of
1647                         []      -> Nothing
1648                         (n : _) -> Just (nameOccName n)
1649
1650 --------------------------
1651 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1652 famInstToIfaceFamInst (FamInst { fi_axiom  = axiom,
1653                                  fi_fam    = fam,
1654                                  fi_tcs    = mb_tcs })
1655   = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom
1656                  , ifFamInstFam   = fam
1657                  , ifFamInstTys   = map do_rough mb_tcs
1658                  , ifFamInstOrph  = orph }
1659   where
1660     do_rough Nothing  = Nothing
1661     do_rough (Just n) = Just (toIfaceTyCon_name n)
1662
1663     fam_decl = tyConName . fst $ coAxiomSplitLHS axiom
1664     mod = ASSERT( isExternalName (coAxiomName axiom) )
1665           nameModule (coAxiomName axiom)
1666     is_local name = nameIsLocalOrFrom mod name
1667
1668     lhs_names = filterNameSet is_local (orphNamesOfType (coAxiomLHS axiom))
1669
1670     orph | is_local fam_decl
1671          = Just (nameOccName fam_decl)
1672
1673          | not (isEmptyNameSet lhs_names)
1674          = Just (nameOccName (head (nameSetToList lhs_names)))
1675
1676
1677          | otherwise
1678          = Nothing
1679
1680 --------------------------
1681 toIfaceLetBndr :: Id -> IfaceLetBndr
1682 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
1683                                (toIfaceType (idType id)) 
1684                                (toIfaceIdInfo (idInfo id))
1685   -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr 
1686   -- has left on the Id.  See Note [IdInfo on nested let-bindings] in IfaceSyn
1687
1688 --------------------------
1689 toIfaceIdDetails :: IdDetails -> IfaceIdDetails
1690 toIfaceIdDetails VanillaId                      = IfVanillaId
1691 toIfaceIdDetails (DFunId ns _)                  = IfDFunId ns
1692 toIfaceIdDetails (RecSelId { sel_naughty = n
1693                            , sel_tycon = tc })  = IfRecSelId (toIfaceTyCon tc) n
1694 toIfaceIdDetails other                          = pprTrace "toIfaceIdDetails" (ppr other) 
1695                                                   IfVanillaId   -- Unexpected
1696
1697 toIfaceIdInfo :: IdInfo -> IfaceIdInfo
1698 toIfaceIdInfo id_info
1699   = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
1700                     inline_hsinfo,  unfold_hsinfo] of
1701        []    -> NoInfo
1702        infos -> HasInfo infos
1703                -- NB: strictness must appear in the list before unfolding
1704                -- See TcIface.tcUnfolding
1705   where
1706     ------------  Arity  --------------
1707     arity_info = arityInfo id_info
1708     arity_hsinfo | arity_info == 0 = Nothing
1709                  | otherwise       = Just (HsArity arity_info)
1710
1711     ------------ Caf Info --------------
1712     caf_info   = cafInfo id_info
1713     caf_hsinfo = case caf_info of
1714                    NoCafRefs -> Just HsNoCafRefs
1715                    _other    -> Nothing
1716
1717     ------------  Strictness  --------------
1718         -- No point in explicitly exporting TopSig
1719     strict_hsinfo = case strictnessInfo id_info of
1720                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1721                         _other                        -> Nothing
1722
1723     ------------  Unfolding  --------------
1724     unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) 
1725     loop_breaker  = isStrongLoopBreaker (occInfo id_info)
1726                                         
1727     ------------  Inline prag  --------------
1728     inline_prag = inlinePragInfo id_info
1729     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
1730                   | otherwise = Just (HsInline inline_prag)
1731
1732 --------------------------
1733 toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
1734 toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
1735                                 , uf_src = src, uf_guidance = guidance })
1736   = Just $ HsUnfold lb $
1737     case src of
1738         InlineStable
1739           -> case guidance of
1740                UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
1741                _other                     -> IfCoreUnfold True if_rhs
1742         InlineWrapper w | isExternalName n -> IfExtWrapper arity n
1743                         | otherwise        -> IfLclWrapper arity (getFS n)
1744                         where
1745                           n = idName w
1746         InlineCompulsory -> IfCompulsory if_rhs
1747         InlineRhs        -> IfCoreUnfold False if_rhs
1748         -- Yes, even if guidance is UnfNever, expose the unfolding
1749         -- If we didn't want to expose the unfolding, TidyPgm would
1750         -- have stuck in NoUnfolding.  For supercompilation we want 
1751         -- to see that unfolding!
1752   where
1753     if_rhs = toIfaceExpr rhs
1754
1755 toIfUnfolding lb (DFunUnfolding _ar _con ops)
1756   = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops)))
1757       -- No need to serialise the data constructor; 
1758       -- we can recover it from the type of the dfun
1759
1760 toIfUnfolding _ _
1761   = Nothing
1762
1763 --------------------------
1764 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1765 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1766   = pprTrace "toHsRule: builtin" (ppr fn) $
1767     bogusIfaceRule fn
1768
1769 coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, 
1770                                      ru_act = act, ru_bndrs = bndrs,
1771                                      ru_args = args, ru_rhs = rhs, 
1772                                      ru_auto = auto })
1773   = IfaceRule { ifRuleName  = name, ifActivation = act, 
1774                 ifRuleBndrs = map toIfaceBndr bndrs,
1775                 ifRuleHead  = fn, 
1776                 ifRuleArgs  = map do_arg args,
1777                 ifRuleRhs   = toIfaceExpr rhs,
1778                 ifRuleAuto  = auto,
1779                 ifRuleOrph  = orph }
1780   where
1781         -- For type args we must remove synonyms from the outermost
1782         -- level.  Reason: so that when we read it back in we'll
1783         -- construct the same ru_rough field as we have right now;
1784         -- see tcIfaceRule
1785     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1786     do_arg (Coercion co) = IfaceType (coToIfaceType co)
1787                            
1788     do_arg arg       = toIfaceExpr arg
1789
1790         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1791         -- A rule is an orphan only if none of the variables
1792         -- mentioned on its left-hand side are locally defined
1793     lhs_names = nameSetToList (ruleLhsOrphNames rule)
1794
1795     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1796                         (n : _) -> Just (nameOccName n)
1797                         []      -> Nothing
1798
1799 bogusIfaceRule :: Name -> IfaceRule
1800 bogusIfaceRule id_name
1801   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,  
1802         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], 
1803         ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
1804
1805 ---------------------
1806 toIfaceExpr :: CoreExpr -> IfaceExpr
1807 toIfaceExpr (Var v)         = toIfaceVar v
1808 toIfaceExpr (Lit l)         = IfaceLit l
1809 toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
1810 toIfaceExpr (Coercion co)   = IfaceCo   (coToIfaceType co)
1811 toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1812 toIfaceExpr (App f a)       = toIfaceApp f [a]
1813 toIfaceExpr (Case s x ty as) 
1814   | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)
1815   | otherwise               = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
1816 toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1817 toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (coToIfaceType co)
1818 toIfaceExpr (Tick t e)    = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
1819
1820 ---------------------
1821 toIfaceTickish :: Tickish Id -> IfaceTickish
1822 toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push
1823 toIfaceTickish (HpcTick modl ix)       = IfaceHpcTick modl ix
1824 toIfaceTickish _ = panic "toIfaceTickish"
1825
1826 ---------------------
1827 toIfaceBind :: Bind Id -> IfaceBinding
1828 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1829 toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1830
1831 ---------------------
1832 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1833            -> (IfaceConAlt, [FastString], IfaceExpr)
1834 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1835
1836 ---------------------
1837 toIfaceCon :: AltCon -> IfaceConAlt
1838 toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
1839 toIfaceCon (LitAlt l)   = IfaceLitAlt l
1840 toIfaceCon DEFAULT      = IfaceDefault
1841
1842 ---------------------
1843 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1844 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1845 toIfaceApp (Var v) as
1846   = case isDataConWorkId_maybe v of
1847         -- We convert the *worker* for tuples into IfaceTuples
1848         Just dc |  isTupleTyCon tc && saturated 
1849                 -> IfaceTuple (tupleTyConSort tc) tup_args
1850           where
1851             val_args  = dropWhile isTypeArg as
1852             saturated = val_args `lengthIs` idArity v
1853             tup_args  = map toIfaceExpr val_args
1854             tc        = dataConTyCon dc
1855
1856         _ -> mkIfaceApps (toIfaceVar v) as
1857
1858 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1859
1860 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1861 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1862
1863 ---------------------
1864 toIfaceVar :: Id -> IfaceExpr
1865 toIfaceVar v
1866     | Just fcall <- isFCallId_maybe v            = IfaceFCall fcall (toIfaceType (idType v))
1867        -- Foreign calls have special syntax
1868     | isExternalName name                        = IfaceExt name
1869     | otherwise                                  = IfaceLcl (getFS name)
1870   where name = idName v
1871 \end{code}