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