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