MkIface.lhs 76 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006-2008
3 4 5 6
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%

\begin{code}
dterei's avatar
dterei committed
7 8 9
-- | Module for constructing @ModIface@ values (interface files),
-- writing them to disk and comparing two versions to see if
-- recompilation is required.
10
module MkIface ( 
Simon Marlow's avatar
Simon Marlow committed
11 12
        mkUsedNames,
        mkDependencies,
13 14
        mkIface,        -- Build a ModIface from a ModGuts, 
                        -- including computing version information
15

Simon Marlow's avatar
Simon Marlow committed
16 17
        mkIfaceTc,

18
        writeIfaceFile, -- Write the interface file
19

20 21
        checkOldIface,  -- See if recompilation is required, by
                        -- comparing version information
22 23

        tyThingToIfaceDecl -- Converting things to their Iface equivalents
24 25 26
 ) where
\end{code}

27 28 29
  -----------------------------------------------
          Recompilation checking
  -----------------------------------------------
30

31 32
A complete description of how recompilation checking works can be
found in the wiki commentary:
33

34
 http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
35

36 37
Please read the above page for a top-down description of how this all
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 45 46 47 48
  * In mkIface, we compute the fingerprint of each exported thing A.f.
    For each external thing that A.f refers to, we include the fingerprint
    of the external reference when computing the fingerprint of A.f.  So
    if anything that A.f depends on changes, then A.f's fingerprint will
    change.
GregWeber's avatar
GregWeber committed
49 50
    Also record any dependent files added with addDependentFile.
    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 56 57

\begin{code}
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
58 59
import IfaceSyn
import LoadIface
60 61
import FlagChecker

Simon Marlow's avatar
Simon Marlow committed
62 63
import Id
import IdInfo
64
import Demand
65
import Annotations
66
import CoreSyn
67
import CoreFVs
Simon Marlow's avatar
Simon Marlow committed
68
import Class
69
import Kind
Simon Marlow's avatar
Simon Marlow committed
70
import TyCon
71
import Coercion         ( coAxiomSplitLHS )
Simon Marlow's avatar
Simon Marlow committed
72 73 74 75 76
import DataCon
import Type
import TcType
import InstEnv
import FamInstEnv
77
import TcRnMonad
78
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
79
import HscTypes
80
import Finder
Simon Marlow's avatar
Simon Marlow committed
81
import DynFlags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
82
import VarEnv
83
import VarSet
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
84
import Var
Simon Marlow's avatar
Simon Marlow committed
85
import Name
86
import Avail
Ian Lynagh's avatar
Ian Lynagh committed
87
import RdrName
88 89
import NameEnv
import NameSet
Simon Marlow's avatar
Simon Marlow committed
90
import Module
Simon Marlow's avatar
Simon Marlow committed
91 92 93 94
import BinIface
import ErrUtils
import Digraph
import SrcLoc
95 96
import Outputable
import BasicTypes       hiding ( SuccessFlag(..) )
97
import UniqFM
98
import Unique
99
import Util             hiding ( eqListBy )
100
import FastString
Simon Marlow's avatar
Simon Marlow committed
101
import Maybes
Simon Marlow's avatar
Simon Marlow committed
102
import ListSetOps
103 104
import Binary
import Fingerprint
105
import Bag
106
import Exception
107

Simon Marlow's avatar
Simon Marlow committed
108 109
import Control.Monad
import Data.List
110 111
import Data.Map (Map)
import qualified Data.Map as Map
Simon Marlow's avatar
Simon Marlow committed
112
import Data.IORef
Ian Lynagh's avatar
Ian Lynagh committed
113
import System.FilePath
114 115 116 117 118
\end{code}



%************************************************************************
119
%*                                                                      *
120
\subsection{Completing an interface}
121
%*                                                                      *
122 123 124 125
%************************************************************************

\begin{code}
mkIface :: HscEnv
126 127 128 129
        -> Maybe Fingerprint    -- The old fingerprint, if we have it
        -> ModDetails           -- The trimmed, tidied interface
        -> ModGuts              -- Usages, deprecations, etc
        -> IO (Messages,
Thomas Schilling's avatar
Thomas Schilling committed
130
               Maybe (ModIface, -- The new one
131
                      Bool))    -- True <=> there was an old Iface, and the
132 133
                                --          new one is identical, so no need
                                --          to write it
134

135
mkIface hsc_env maybe_old_fingerprint mod_details
136 137 138
         ModGuts{     mg_module     = this_mod,
                      mg_boot       = is_boot,
                      mg_used_names = used_names,
139
                      mg_used_th    = used_th,
140 141 142 143 144 145
                      mg_deps       = deps,
                      mg_dir_imps   = dir_imp_mods,
                      mg_rdr_env    = rdr_env,
                      mg_fix_env    = fix_env,
                      mg_warns      = warns,
                      mg_hpc_info   = hpc_info,
GregWeber's avatar
GregWeber committed
146 147 148
                      mg_trust_pkg  = self_trust,
                      mg_dependent_files = dependent_files
                    }
149
        = mkIface_ hsc_env maybe_old_fingerprint
150
                   this_mod is_boot used_names used_th deps rdr_env fix_env
GregWeber's avatar
GregWeber committed
151
                   warns hpc_info dir_imp_mods self_trust dependent_files mod_details
Thomas Schilling's avatar
Thomas Schilling committed
152

Simon Marlow's avatar
Simon Marlow committed
153 154 155 156
-- | make an interface from the results of typechecking only.  Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing').
mkIfaceTc :: HscEnv
dterei's avatar
dterei committed
157 158 159 160
          -> Maybe Fingerprint  -- The old fingerprint, if we have it
          -> ModDetails         -- gotten from mkBootModDetails, probably
          -> TcGblEnv           -- Usages, deprecations, etc
          -> IO (Messages, Maybe (ModIface, Bool))
161
mkIfaceTc hsc_env maybe_old_fingerprint mod_details
Simon Marlow's avatar
Simon Marlow committed
162 163 164 165 166
  tc_result@TcGblEnv{ tcg_mod = this_mod,
                      tcg_src = hsc_src,
                      tcg_imports = imports,
                      tcg_rdr_env = rdr_env,
                      tcg_fix_env = fix_env,
Ian Lynagh's avatar
Ian Lynagh committed
167
                      tcg_warns = warns,
168
                      tcg_hpc = other_hpc_info,
GregWeber's avatar
GregWeber committed
169 170
                      tcg_th_splice_used = tc_splice_used,
                      tcg_dependent_files = dependent_files
Simon Marlow's avatar
Simon Marlow committed
171 172
                    }
  = do
173
          let used_names = mkUsedNames tc_result
Simon Marlow's avatar
Simon Marlow committed
174 175
          deps <- mkDependencies tc_result
          let hpc_info = emptyHpcInfo other_hpc_info
176
          used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
177
          dep_files <- (readIORef dependent_files)
178
          mkIface_ hsc_env maybe_old_fingerprint
179
                   this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
180
                   fix_env warns hpc_info (imp_mods imports)
GregWeber's avatar
GregWeber committed
181
                   (imp_trust_own_pkg imports) dep_files mod_details
Simon Marlow's avatar
Simon Marlow committed
182 183
        

184 185
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
Simon Marlow's avatar
Simon Marlow committed
186
        
187 188
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
Simon Marlow's avatar
Simon Marlow committed
189 190 191 192 193 194 195
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
          TcGblEnv{ tcg_mod = mod,
                    tcg_imports = imports,
                    tcg_th_used = th_var
                  }
 = do 
dterei's avatar
dterei committed
196 197 198
      -- Template Haskell used?
      th_used <- readIORef th_var
      let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
Simon Marlow's avatar
Simon Marlow committed
199 200 201 202 203 204 205
                -- M.hi-boot can be in the imp_dep_mods, but we must remove
                -- it before recording the modules on which this one depends!
                -- (We want to retain M.hi-boot in imp_dep_mods so that 
                --  loadHiBootInterface can see if M's direct imports depend 
                --  on M.hi-boot, and hence that we should do the hi-boot consistency 
                --  check.)

206 207
          pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
               | otherwise = imp_dep_pkgs imports
Simon Marlow's avatar
Simon Marlow committed
208

209 210 211 212 213
          -- Set the packages required to be Safe according to Safe Haskell.
          -- See Note [RnNames . Tracking Trust Transitively]
          sorted_pkgs = sortBy stablePackageIdCmp pkgs
          trust_pkgs  = imp_trust_pkgs imports
          dep_pkgs'   = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
214

215
      return Deps { dep_mods   = sortBy (stableModuleNameCmp `on` fst) dep_mods,
216
                    dep_pkgs   = dep_pkgs',
217 218
                    dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
219 220
                    -- sort to get into canonical order
                    -- NB. remember to use lexicographic ordering
Simon Marlow's avatar
Simon Marlow committed
221

222
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
223
         -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
Ian Lynagh's avatar
Ian Lynagh committed
224
         -> NameEnv FixItem -> Warnings -> HpcInfo
225
         -> ImportedMods -> Bool
GregWeber's avatar
GregWeber committed
226
         -> [FilePath]
Ian Lynagh's avatar
Ian Lynagh committed
227
         -> ModDetails
228
         -> IO (Messages, Maybe (ModIface, Bool))
229
mkIface_ hsc_env maybe_old_fingerprint 
230
         this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
GregWeber's avatar
GregWeber committed
231
         hpc_info dir_imp_mods pkg_trust_req dependent_files
dterei's avatar
dterei committed
232 233 234 235
         ModDetails{  md_insts     = insts, 
                      md_fam_insts = fam_insts,
                      md_rules     = rules,
                      md_anns      = anns,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
236
                      md_vect_info = vect_info,
dterei's avatar
dterei committed
237 238 239 240 241 242 243 244
                      md_types     = type_env,
                      md_exports   = exports }
-- NB:  notice that mkIface does not look at the bindings
--      only at the TypeEnv.  The previous Tidy phase has
--      put exactly the info into the TypeEnv that we want
--      to expose in the interface

  = do  { usages  <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
245
        ; safeInf <- hscGetSafeInf hsc_env
Simon Marlow's avatar
Simon Marlow committed
246

dterei's avatar
dterei committed
247
        ; let   { entities = typeEnvElts type_env ;
248
                  decls  = [ tyThingToIfaceDecl entity
dterei's avatar
dterei committed
249 250
                           | entity <- entities,
                             let name = getName entity,
251
                             not (isImplicitTyThing entity),
dterei's avatar
dterei committed
252 253 254 255 256 257 258 259 260 261 262
                                -- No implicit Ids and class tycons in the interface file
                             not (isWiredInName name),
                                -- Nor wired-in things; the compiler knows about them anyhow
                             nameIsLocalOrFrom this_mod name  ]
                                -- Sigh: see Note [Root-main Id] in TcRnDriver

                ; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
                ; warns       = src_warns
                ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
                ; iface_insts = map instanceToIfaceInst insts
                ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
263
                ; iface_vect_info = flattenVectInfo vect_info
264 265 266

                -- Check if we are in Safe Inference mode 
                -- but we failed to pass the muster
267
                ; safeMode    = if safeInferOn dflags && not safeInf
268 269 270
                                    then Sf_None
                                    else safeHaskell dflags
                ; trust_info  = setSafeMode safeMode
271

dterei's avatar
dterei committed
272 273 274 275 276 277 278 279 280 281 282 283
                ; intermediate_iface = ModIface { 
                        mi_module      = this_mod,
                        mi_boot        = is_boot,
                        mi_deps        = deps,
                        mi_usages      = usages,
                        mi_exports     = mkIfaceExports exports,
        
                        -- Sort these lexicographically, so that
                        -- the result is stable across compilations
                        mi_insts       = sortLe le_inst iface_insts,
                        mi_fam_insts   = sortLe le_fam_inst iface_fam_insts,
                        mi_rules       = sortLe le_rule iface_rules,
284

dterei's avatar
dterei committed
285
                        mi_vect_info   = iface_vect_info,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
286

dterei's avatar
dterei committed
287 288 289
                        mi_fixities    = fixities,
                        mi_warns       = warns,
                        mi_anns        = mkIfaceAnnotations anns,
290
                        mi_globals     = maybeGlobalRdrEnv rdr_env,
291

292
                        -- Left out deliberately: filled in by addFingerprints
dterei's avatar
dterei committed
293 294
                        mi_iface_hash  = fingerprint0,
                        mi_mod_hash    = fingerprint0,
295
                        mi_flag_hash   = fingerprint0,
dterei's avatar
dterei committed
296
                        mi_exp_hash    = fingerprint0,
dterei's avatar
dterei committed
297
                        mi_used_th     = used_th,
298
                        mi_orphan_hash = fingerprint0,
299
                        mi_orphan      = False, -- Always set by addFingerprints, but
dterei's avatar
dterei committed
300
                                                -- it's a strict field, so we can't omit it.
dterei's avatar
dterei committed
301
                        mi_finsts      = False, -- Ditto
dterei's avatar
dterei committed
302 303 304 305 306
                        mi_decls       = deliberatelyOmitted "decls",
                        mi_hash_fn     = deliberatelyOmitted "hash_fn",
                        mi_hpc         = isHpcUsed hpc_info,
                        mi_trust       = trust_info,
                        mi_trust_pkg   = pkg_trust_req,
307

dterei's avatar
dterei committed
308 309 310 311
                        -- And build the cached values
                        mi_warn_fn     = mkIfaceWarnCache warns,
                        mi_fix_fn      = mkIfaceFixCache fixities }
                }
312

313
        ; (new_iface, no_change_at_all) 
dterei's avatar
dterei committed
314 315
                <- {-# SCC "versioninfo" #-}
                         addFingerprints hsc_env maybe_old_fingerprint
316
                                         intermediate_iface decls
317

dterei's avatar
dterei committed
318 319
                -- Warn about orphans
        ; let warn_orphs      = wopt Opt_WarnOrphans dflags
320
              warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
321
              orph_warnings   --- Laziness means no work done unless -fwarn-orphans
dterei's avatar
dterei committed
322 323 324 325 326 327 328 329 330 331
                | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
                | otherwise                     = emptyBag
              errs_and_warns = (orph_warnings, emptyBag)
              unqual = mkPrintUnqualified dflags rdr_env
              inst_warns = listToBag [ instOrphWarn unqual d 
                                     | (d,i) <- insts `zip` iface_insts
                                     , isNothing (ifInstOrph i) ]
              rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
                                     | r <- iface_rules
                                     , isNothing (ifRuleOrph r)
332 333
                                     , if ifRuleAuto r then warn_auto_orphs
                                                       else warn_orphs ]
334

dterei's avatar
dterei committed
335
        ; if errorsFound dflags errs_and_warns
Thomas Schilling's avatar
Thomas Schilling committed
336 337
            then return ( errs_and_warns, Nothing )
            else do {
338

dterei's avatar
dterei committed
339 340 341
                -- Debug printing
        ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
                        (pprModIface new_iface)
342

343 344
                -- bug #1617: on reload we weren't updating the PrintUnqualified
                -- correctly.  This stems from the fact that the interface had
345
                -- not changed, so addFingerprints returns the old ModIface
346
                -- with the old GlobalRdrEnv (mi_globals).
347
        ; let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
348

dterei's avatar
dterei committed
349
        ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
350
  where
351 352 353 354 355
     r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
     i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2  
     i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2

     le_occ :: Name -> Name -> Bool
dterei's avatar
dterei committed
356 357
        -- Compare lexicographically by OccName, *not* by unique, because 
        -- the latter is not stable across compilations
358
     le_occ n1 n2 = nameOccName n1 <= nameOccName n2
359

360
     dflags = hsc_dflags hsc_env
361

362 363 364 365 366
     -- We only fill in mi_globals if the module was compiled to byte
     -- code.  Otherwise, the compiler may not have retained all the
     -- top-level bindings and they won't be in the TypeEnv (see
     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
     -- by GHCi to decide whether the module has its full top-level
Simon Marlow's avatar
Simon Marlow committed
367
     -- scope available. (#5534)
368 369 370 371 372
     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
     maybeGlobalRdrEnv rdr_env
         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
         | otherwise                                   = Nothing

373
     deliberatelyOmitted :: String -> a
374
     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
375

376
     ifFamInstTcName = ifFamInstFam
377

378 379 380 381
     flattenVectInfo (VectInfo { vectInfoVar          = vVar
                               , vectInfoTyCon        = vTyCon
                               , vectInfoScalarVars   = vScalarVars
                               , vectInfoScalarTyCons = vScalarTyCons
382
                               }) = 
383 384 385 386 387 388
       IfaceVectInfo
       { ifaceVectInfoVar          = [Var.varName v | (v, _  ) <- varEnvElts  vVar]
       , ifaceVectInfoTyCon        = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
       , ifaceVectInfoTyConReuse   = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
       , ifaceVectInfoScalarVars   = [Var.varName v | v <- varSetElems vScalarVars]
       , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons
389
       } 
390

391
-----------------------------
392 393
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
Ian Lynagh's avatar
Ian Lynagh committed
394
    = do createDirectoryHierarchy (takeDirectory hi_file_path)
395
         writeBinIface dflags hi_file_path new_iface
396
    where hi_file_path = ml_hi_file location
397 398


399 400
-- -----------------------------------------------------------------------------
-- Look up parents and versions of Names
401

402 403
-- This is like a global version of the mi_hash_fn field in each ModIface.
-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
404
-- the parent and version info.
405

406
mkHashFun
407 408
        :: HscEnv                       -- needed to look up versions
        -> ExternalPackageState         -- ditto
409 410
        -> (Name -> Fingerprint)
mkHashFun hsc_env eps
411 412
  = \name -> 
      let 
413
        mod = ASSERT2( isExternalName name, ppr name ) nameModule name
414 415 416 417
        occ = nameOccName name
        iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
                   pprPanic "lookupVers2" (ppr mod <+> ppr occ)
      in  
418 419
        snd (mi_hash_fn iface occ `orElse` 
                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
420
  where
421 422
      hpt = hsc_HPT hsc_env
      pit = eps_PIT eps
423

424 425 426 427 428 429
-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface

addFingerprints
        :: HscEnv
        -> Maybe Fingerprint -- the old fingerprint, if any
dterei's avatar
dterei committed
430
        -> ModIface          -- The new interface (lacking decls)
431 432
        -> [IfaceDecl]       -- The new decls
        -> IO (ModIface,     -- Updated interface
dterei's avatar
dterei committed
433
               Bool)         -- True <=> no changes at all; 
434 435 436 437 438 439
                             -- no need to write Iface

addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 = do
   eps <- hscEPS hsc_env
   let
440
        -- The ABI of a declaration represents everything that is made
441 442 443 444
        -- visible about the declaration that a client can depend on.
        -- see IfaceDeclABI below.
       declABI :: IfaceDecl -> IfaceDeclABI 
       declABI decl = (this_mod, decl, extras)
445 446
        where extras = declExtras fix_fn non_orph_rules non_orph_insts
                                  non_orph_fis decl
447 448 449

       edges :: [(IfaceDeclABI, Unique, [Unique])]
       edges = [ (abi, getUnique (ifName decl), out)
dterei's avatar
dterei committed
450
               | decl <- new_decls
451
               , let abi = declABI decl
dterei's avatar
dterei committed
452
               , let out = localOccs $ freeNamesDeclABI abi
453 454
               ]

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
455
       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
456
       localOccs = map (getUnique . getParent . getOccName) 
457
                        . filter ((== this_mod) . name_module)
458 459 460 461 462 463 464 465 466
                        . nameSetToList
          where getParent occ = lookupOccEnv parent_map occ `orElse` occ

        -- maps OccNames to their parents in the current module.
        -- e.g. a reference to a constructor must be turned into a reference
        -- to the TyCon for the purposes of calculating dependencies.
       parent_map :: OccEnv OccName
       parent_map = foldr extend emptyOccEnv new_decls
          where extend d env = 
467
                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
468 469 470
                  where n = ifName d

        -- strongly-connected groups of declarations, in dependency order
471
       groups = stronglyConnCompFromEdgedVertices edges
472 473 474 475 476 477 478 479 480 481 482 483 484 485 486

       global_hash_fn = mkHashFun hsc_env eps

        -- how to output Names when generating the data to fingerprint.
        -- Here we want to output the fingerprint for each top-level
        -- Name, whether it comes from the current module or another
        -- module.  In this way, the fingerprint for a declaration will
        -- change if the fingerprint for anything it refers to (transitively)
        -- changes.
       mk_put_name :: (OccEnv (OccName,Fingerprint))
                   -> BinHandle -> Name -> IO  ()
       mk_put_name local_env bh name
          | isWiredInName name  =  putNameLiterally bh name 
           -- wired-in names don't have fingerprints
          | otherwise
487
          = ASSERT2( isExternalName name, ppr name )
dterei's avatar
dterei committed
488
            let hash | nameModule name /= this_mod =  global_hash_fn name
489
                     | otherwise = snd (lookupOccEnv local_env (getOccName name)
490 491
                           `orElse` pprPanic "urk! lookup local fingerprint" 
                                       (ppr name)) -- (undefined,fingerprint0))
492 493 494 495 496 497 498
                -- This panic indicates that we got the dependency
                -- analysis wrong, because we needed a fingerprint for
                -- an entity that wasn't in the environment.  To debug
                -- it, turn the panic into a trace, uncomment the
                -- pprTraces below, run the compile again, and inspect
                -- the output and the generated .hi file with
                -- --show-iface.
499
            in put_ bh hash
500 501 502 503 504 505 506 507 508 509 510 511 512 513

        -- take a strongly-connected group of declarations and compute
        -- its fingerprint.

       fingerprint_group :: (OccEnv (OccName,Fingerprint), 
                             [(Fingerprint,IfaceDecl)])
                         -> SCC IfaceDeclABI
                         -> IO (OccEnv (OccName,Fingerprint), 
                                [(Fingerprint,IfaceDecl)])

       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
          = do let hash_fn = mk_put_name local_env
                   decl = abiDecl abi
               -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
514
               hash <- computeFingerprint hash_fn abi
515 516
               env' <- extend_hash_env local_env (hash,decl)
               return (env', (hash,decl) : decls_w_hashes)
517 518 519

       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
          = do let decls = map abiDecl abis
520
               local_env1 <- foldM extend_hash_env local_env
521
                                   (zip (repeat fingerprint0) decls)
522
               let hash_fn = mk_put_name local_env1
523 524 525
               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
               let stable_abis = sortBy cmp_abiNames abis
                -- put the cycle in a canonical order
526
               hash <- computeFingerprint hash_fn stable_abis
527
               let pairs = zip (repeat hash) decls
528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543
               local_env2 <- foldM extend_hash_env local_env pairs
               return (local_env2, pairs ++ decls_w_hashes)

       -- we have fingerprinted the whole declaration, but we now need
       -- to assign fingerprints to all the OccNames that it binds, to
       -- use when referencing those OccNames in later declarations.
       --
       -- We better give each name bound by the declaration a
       -- different fingerprint!  So we calculate the fingerprint of
       -- each binder by combining the fingerprint of the whole
       -- declaration with the name of the binder. (#5614)
       extend_hash_env :: OccEnv (OccName,Fingerprint)
                       -> (Fingerprint,IfaceDecl)
                       -> IO (OccEnv (OccName,Fingerprint))
       extend_hash_env env0 (hash,d) = do
          let
544
            sub_bndrs = ifaceDeclImplicitBndrs d
545 546 547 548 549
            fp_sub_bndr occ = computeFingerprint putNameLiterally (hash,occ)
          --
          sub_fps <- mapM fp_sub_bndr sub_bndrs
          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env1
                        (zip sub_bndrs sub_fps))
550
        where
551 552 553
          decl_name = ifName d
          item = (decl_name, hash)
          env1 = extendOccEnv env0 decl_name item
554

555 556 557 558
   --
   (local_env, decls_w_hashes) <- 
       foldM fingerprint_group (emptyOccEnv, []) groups

559 560 561 562 563
   -- when calculating fingerprints, we always need to use canonical
   -- ordering for lists of things.  In particular, the mi_deps has various
   -- lists of modules and suchlike, so put these all in canonical order:
   let sorted_deps = sortDependencies (mi_deps iface0)

564
   -- the export hash of a module depends on the orphan hashes of the
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
565
   -- orphan modules below us in the dependency tree.  This is the way
566 567 568 569
   -- that changes in orphans get propagated all the way up the
   -- dependency tree.  We only care about orphan modules in the current
   -- package, because changes to orphans outside this package will be
   -- tracked by the usage on the ABI hash of package modules that we import.
570 571
   let orph_mods = filter ((== this_pkg) . modulePackageId)
                   $ dep_orphs sorted_deps
572 573
   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods

574
   orphan_hash <- computeFingerprint (mk_put_name local_env)
575
                      (map ifDFun orph_insts, orph_rules, orph_fis)
576 577 578

   -- the export list hash doesn't depend on the fingerprints of
   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
579
   export_hash <- computeFingerprint putNameLiterally
580 581 582
                      (mi_exports iface0,
                       orphan_hash,
                       dep_orphan_hashes,
583
                       dep_pkgs (mi_deps iface0),
584 585
                        -- dep_pkgs: see "Package Version Changes" on
                        -- wiki/Commentary/Compiler/RecompilationAvoidance
586
                       mi_trust iface0)
587
                        -- Make sure change of Safe Haskell mode causes recomp.
588 589

   -- put the declarations in a canonical order, sorted by OccName
590
   let sorted_decls = Map.elems $ Map.fromList $
591
                          [(ifName d, e) | e@(_, d) <- decls_w_hashes]
592 593 594 595 596
   
   -- the flag hash depends on:
   --   - (some of) dflags
   -- it returns two hashes, one that shouldn't change
   -- the abi hash and one that should
597
   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
598 599 600 601 602 603

   -- the ABI hash depends on:
   --   - decls
   --   - export list
   --   - orphans
   --   - deprecations
604
   --   - vect info
605
   --   - flag abi hash
606
   mod_hash <- computeFingerprint putNameLiterally
607
                      (map fst sorted_decls,
608
                       export_hash,  -- includes orphan_hash
609 610
                       mi_warns iface0,
                       mi_vect_info iface0)
611 612

   -- The interface hash depends on:
613 614 615 616
   --   - the ABI hash, plus
   --   - usages
   --   - deps
   --   - hpc
617
   iface_hash <- computeFingerprint putNameLiterally
618 619
                      (mod_hash, 
                       mi_usages iface0,
620
                       sorted_deps,
621 622 623 624 625 626 627 628 629 630
                       mi_hpc iface0)

   let
    no_change_at_all = Just iface_hash == mb_old_fingerprint

    final_iface = iface0 {
                mi_mod_hash    = mod_hash,
                mi_iface_hash  = iface_hash,
                mi_exp_hash    = export_hash,
                mi_orphan_hash = orphan_hash,
631
                mi_flag_hash   = flag_hash,
632 633 634
                mi_orphan      = not (   null orph_rules
                                      && null orph_insts
                                      && null orph_fis
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
635
                                      && isNoIfaceVectInfo (mi_vect_info iface0)),
636 637 638 639
                mi_finsts      = not . null $ mi_fam_insts iface0,
                mi_decls       = sorted_decls,
                mi_hash_fn     = lookupOccEnv local_env }
   --
640
   return (final_iface, no_change_at_all)
641

642 643 644 645
  where
    this_mod = mi_module iface0
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags
646 647 648
    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)
    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666
    fix_fn = mi_fix_fn iface0


getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
  eps <- hscEPS hsc_env
  let 
    hpt        = hsc_HPT hsc_env
    pit        = eps_PIT eps
    dflags     = hsc_dflags hsc_env
    get_orph_hash mod = 
          case lookupIfaceByModule dflags hpt pit mod of
            Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
            Just iface -> mi_orphan_hash iface
  --
  return (map get_orph_hash mods)


667 668 669
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
 = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
670
          dep_pkgs   = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d),
671 672
          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
          dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
673 674 675 676
\end{code}


%************************************************************************
dterei's avatar
dterei committed
677 678 679
%*                                                                      *
          The ABI of an IfaceDecl                                                                               
%*                                                                      *
680 681 682 683 684 685 686 687 688
%************************************************************************

Note [The ABI of an IfaceDecl]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The ABI of a declaration consists of:

   (a) the full name of the identifier (inc. module and package,
       because these are used to construct the symbol name by which
       the identifier is known externally).
689

690 691 692 693 694 695 696 697 698 699 700
   (b) the declaration itself, as exposed to clients.  That is, the
       definition of an Id is included in the fingerprint only if
       it is made available as as unfolding in the interface.

   (c) the fixity of the identifier
   (d) for Ids: rules
   (e) for classes: instances, fixity & rules for methods
   (f) for datatypes: instances, fixity & rules for constrs

Items (c)-(f) are not stored in the IfaceDecl, but instead appear
elsewhere in the interface file.  But they are *fingerprinted* with
701 702
the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
and fingerprinting that as part of the declaration.
703 704

\begin{code}
705 706
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)

707 708
data IfaceDeclExtras 
  = IfaceIdExtras    Fixity [IfaceRule]
709 710

  | IfaceDataExtras  
dterei's avatar
dterei committed
711
       Fixity                   -- Fixity of the tycon itself
712
       [IfaceInstABI]           -- Local class and family instances of this tycon
dterei's avatar
dterei committed
713 714
                                -- See Note [Orphans] in IfaceSyn
       [(Fixity,[IfaceRule])]   -- For each construcotr, fixity and RULES
715 716

  | IfaceClassExtras 
dterei's avatar
dterei committed
717 718 719 720 721
       Fixity                   -- Fixity of the class itself
       [IfaceInstABI]           -- Local instances of this class *or*
                                --   of its associated data types
                                -- See Note [Orphans] in IfaceSyn
       [(Fixity,[IfaceRule])]   -- For each class method, fixity and RULES
722

723
  | IfaceSynExtras   Fixity [IfaceInstABI]
724

725 726
  | IfaceOtherDeclExtras

727 728 729 730 731 732
-- When hashing a class or family instance, we hash only the 
-- DFunId or CoAxiom, because that depends on all the 
-- information about the instance.
--
type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance

733 734 735 736 737 738 739 740 741 742 743 744 745 746
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl, _) = decl

cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` 
                         ifName (abiDecl abi2)

freeNamesDeclABI :: IfaceDeclABI -> NameSet
freeNamesDeclABI (_mod, decl, extras) =
  freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras

freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras    _ rules)
  = unionManyNameSets (map freeNamesIfRule rules)
747 748 749 750
freeNamesDeclExtras (IfaceDataExtras  _ insts subs)
  = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
freeNamesDeclExtras (IfaceClassExtras _ insts subs)
  = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
751 752
freeNamesDeclExtras (IfaceSynExtras _ insts)
  = mkNameSet insts
753 754 755 756 757 758
freeNamesDeclExtras IfaceOtherDeclExtras
  = emptyNameSet

freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)

759 760 761
instance Outputable IfaceDeclExtras where
  ppr IfaceOtherDeclExtras       = empty
  ppr (IfaceIdExtras  fix rules) = ppr_id_extras fix rules
762 763 764
  ppr (IfaceSynExtras fix finsts) = vcat [ppr fix, ppr finsts]
  ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
                                                ppr_id_extras_s stuff]
765 766 767 768 769 770 771 772 773 774 775 776
  ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
                                                 ppr_id_extras_s stuff]

ppr_insts :: [IfaceInstABI] -> SDoc
ppr_insts _ = ptext (sLit "<insts>")

ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc
ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff]

ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc
ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules)

777
-- This instance is used only to compute fingerprints
778 779 780 781 782 783
instance Binary IfaceDeclExtras where
  get _bh = panic "no get for IfaceDeclExtras"
  put_ bh (IfaceIdExtras fix rules) = do
   putByte bh 1; put_ bh fix; put_ bh rules
  put_ bh (IfaceDataExtras fix insts cons) = do
   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
784 785
  put_ bh (IfaceClassExtras fix insts methods) = do
   putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
786 787
  put_ bh (IfaceSynExtras fix finsts) = do
   putByte bh 4; put_ bh fix; put_ bh finsts
788
  put_ bh IfaceOtherDeclExtras = do
789
   putByte bh 5
790 791 792

declExtras :: (OccName -> Fixity)
           -> OccEnv [IfaceRule]
793 794
           -> OccEnv [IfaceClsInst]
           -> OccEnv [IfaceFamInst]
795 796 797
           -> IfaceDecl
           -> IfaceDeclExtras

798
declExtras fix_fn rule_env inst_env fi_env decl
799 800 801 802 803
  = case decl of
      IfaceId{} -> IfaceIdExtras (fix_fn n) 
                        (lookupOccEnvL rule_env n)
      IfaceData{ifCons=cons} -> 
                     IfaceDataExtras (fix_fn n)
804 805
                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
                         map ifDFun         (lookupOccEnvL inst_env n))
806
                        (map (id_extras . ifConOcc) (visibleIfConDecls cons))
807
      IfaceClass{ifSigs=sigs, ifATs=ats} -> 
808
                     IfaceClassExtras (fix_fn n)
809
                        (map ifDFun $ (concatMap at_extras ats)
810
                                    ++ lookupOccEnvL inst_env n)
dterei's avatar
dterei committed
811 812
                           -- Include instances of the associated types
                           -- as well as instances of the class (Trac #5147)
813
                        [id_extras op | IfaceClassOp op _ _ <- sigs]
814 815
      IfaceSyn{} -> IfaceSynExtras (fix_fn n) 
                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
816 817 818 819
      _other -> IfaceOtherDeclExtras
  where
        n = ifName decl
        id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
820
        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
821 822 823 824 825 826 827 828


lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env k = lookupOccEnv env k `orElse` []

-- used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
829 830 831
putNameLiterally bh name = ASSERT( isExternalName name ) 
  do { put_ bh $! nameModule name
     ; put_ bh $! nameOccName name }
832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851

{-
-- for testing: use the md5sum command to generate fingerprints and
-- compare the results against our built-in version.
  fp' <- oldMD5 dflags bh
  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
               else return fp

oldMD5 dflags bh = do
  tmp <- newTempName dflags "bin"
  writeBinMem bh tmp
  tmp2 <- newTempName dflags "md5"
  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
  r <- system cmd
  case r of
    ExitFailure _ -> ghcError (PhaseFailed cmd r)
    ExitSuccess -> do
        hash_str <- readFile tmp2
        return $! readHexFingerprint hash_str
-}
852

853
instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg
854 855
instOrphWarn unqual inst
  = mkWarnMsg (getSrcSpan inst) unqual $
856
    hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
857 858 859 860 861 862

ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn unqual mod rule
  = mkWarnMsg silly_loc unqual $
    ptext (sLit "Orphan rule:") <+> ppr rule
  where
863
    silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
864 865
    -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
    -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
866 867

----------------------
868
-- mkOrphMap partitions instance decls or rules into
dterei's avatar
dterei committed
869 870 871 872 873 874 875 876 877
--      (a) an OccEnv for ones that are not orphans, 
--          mapping the local OccName to a list of its decls
--      (b) a list of orphan decls
mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
                                        -- Nothing for an orphan decl
          -> [decl]                     -- Sorted into canonical order
          -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
                                        --      each sublist in canonical order
              [decl])                   -- Orphan decls; in canonical order
878
mkOrphMap get_key decls
879 880 881
  = foldl go (emptyOccEnv, []) decls
  where
    go (non_orphs, orphs) d
dterei's avatar
dterei committed
882 883 884
        | Just occ <- get_key d
        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
        | otherwise = (non_orphs, d:orphs)
885 886 887
\end{code}


888
%************************************************************************
dterei's avatar
dterei committed
889
%*                                                                      *
890
       Keeping track of what we've slurped, and fingerprints
dterei's avatar
dterei committed
891
%*                                                                      *
892
%************************************************************************
893 894

\begin{code}
GregWeber's avatar
GregWeber committed
895 896
mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] -> IO [Usage]
mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files
dterei's avatar
dterei committed
897
  = do  { eps <- hscEPS hsc_env
898
    ; mtimes <- mapM getModificationUTCTime dependent_files
dterei's avatar
dterei committed
899 900 901 902 903 904 905
        ; let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
                                     dir_imp_mods used_names
        ; let usages = mod_usages ++ map to_file_usage (zip dependent_files mtimes)
        ; usages `seqList`  return usages }
         -- seq the list of Usages returned: occasionally these
         -- don't get evaluated for a while and we can end up hanging on to
         -- the entire collection of Ifaces.
GregWeber's avatar
GregWeber committed
906 907
   where
     to_file_usage (f, mtime) = UsageFile { usg_file_path = f, usg_mtime = mtime }
908

GregWeber's avatar
GregWeber committed
909
mk_mod_usage_info :: PackageIfaceTable
910
              -> HscEnv
911 912
              -> Module
              -> ImportedMods
913 914
              -> NameSet
              -> [Usage]
GregWeber's avatar
GregWeber committed
915
mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
916
  = mapCatMaybes mkUsage usage_mods
917
  where
918
    hpt = hsc_HPT hsc_env
Simon Marlow's avatar
Simon Marlow committed
919
    dflags = hsc_dflags hsc_env
920 921 922
    this_pkg = thisPackage dflags

    used_mods    = moduleEnvKeys ent_map
923
    dir_imp_mods = moduleEnvKeys direct_imports