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