MkIface.lhs 83.1 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}
7 8
{-# LANGUAGE CPP, NondecreasingIndentation #-}

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

Simon Marlow's avatar
Simon Marlow committed
18 19
        mkIfaceTc,

20
        writeIfaceFile, -- Write the interface file
21

22 23
        checkOldIface,  -- See if recompilation is required, by
                        -- comparing version information
24
        RecompileRequired(..), recompileRequired,
25 26

        tyThingToIfaceDecl -- Converting things to their Iface equivalents
27 28 29
 ) where
\end{code}

30 31 32
  -----------------------------------------------
          Recompilation checking
  -----------------------------------------------
33

34 35
A complete description of how recompilation checking works can be
found in the wiki commentary:
36

37
 http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
38

39 40
Please read the above page for a top-down description of how this all
works.  Notes below cover specific issues related to the implementation.
41

42
Basic idea:
43

44
  * In the mi_usages information in an interface, we record the
45
    fingerprint of each free variable of the module
46

47 48 49 50 51
  * 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.
52 53 54 55
    Also record any dependent files added with
      * addDependentFile
      * #include
      * -optP-include
56 57

  * In checkOldIface we compare the mi_usages for the module with
58
    the actual fingerprint for all each thing recorded in mi_usages
59 60 61 62

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

Simon Marlow's avatar
Simon Marlow committed
63 64
import IfaceSyn
import LoadIface
65 66
import FlagChecker

Simon Marlow's avatar
Simon Marlow committed
67 68
import Id
import IdInfo
69
import Demand
Simon Peyton Jones's avatar
Simon Peyton Jones committed
70
import Coercion( tidyCo )
71
import Annotations
72
import CoreSyn
73
import CoreFVs
Simon Marlow's avatar
Simon Marlow committed
74
import Class
75
import Kind
Simon Marlow's avatar
Simon Marlow committed
76
import TyCon
77
import CoAxiom
Gergő Érdi's avatar
Gergő Érdi committed
78
import ConLike
Simon Marlow's avatar
Simon Marlow committed
79
import DataCon
Gergő Érdi's avatar
Gergő Érdi committed
80
import PatSyn
Simon Marlow's avatar
Simon Marlow committed
81 82
import Type
import TcType
83
import TysPrim ( alphaTyVars )
Simon Marlow's avatar
Simon Marlow committed
84 85
import InstEnv
import FamInstEnv
86
import TcRnMonad
87
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
88
import HscTypes
89
import Finder
Simon Marlow's avatar
Simon Marlow committed
90
import DynFlags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
91
import VarEnv
92
import VarSet
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
93
import Var
Simon Marlow's avatar
Simon Marlow committed
94
import Name
95
import Avail
Ian Lynagh's avatar
Ian Lynagh committed
96
import RdrName
97 98
import NameEnv
import NameSet
Simon Marlow's avatar
Simon Marlow committed
99
import Module
Simon Marlow's avatar
Simon Marlow committed
100 101 102 103
import BinIface
import ErrUtils
import Digraph
import SrcLoc
104 105
import Outputable
import BasicTypes       hiding ( SuccessFlag(..) )
106
import UniqFM
107
import Unique
108
import Util             hiding ( eqListBy )
109
import FastString
Simon Marlow's avatar
Simon Marlow committed
110
import Maybes
Simon Marlow's avatar
Simon Marlow committed
111
import ListSetOps
112 113
import Binary
import Fingerprint
114
import Bag
115
import Exception
116

Simon Marlow's avatar
Simon Marlow committed
117
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
118
import Data.Function
Simon Marlow's avatar
Simon Marlow committed
119
import Data.List
120 121
import Data.Map (Map)
import qualified Data.Map as Map
Ian Lynagh's avatar
Ian Lynagh committed
122
import Data.Ord
Simon Marlow's avatar
Simon Marlow committed
123
import Data.IORef
124
import System.Directory
Ian Lynagh's avatar
Ian Lynagh committed
125
import System.FilePath
126 127 128 129 130
\end{code}



%************************************************************************
131
%*                                                                      *
132
\subsection{Completing an interface}
133
%*                                                                      *
134 135 136 137
%************************************************************************

\begin{code}
mkIface :: HscEnv
138 139 140 141
        -> 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
142
               Maybe (ModIface, -- The new one
143
                      Bool))    -- True <=> there was an old Iface, and the
144 145
                                --          new one is identical, so no need
                                --          to write it
146

147
mkIface hsc_env maybe_old_fingerprint mod_details
148 149 150 151 152 153 154 155 156 157 158 159
         ModGuts{     mg_module       = this_mod,
                      mg_boot         = is_boot,
                      mg_used_names   = used_names,
                      mg_used_th      = used_th,
                      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,
                      mg_safe_haskell = safe_mode,
                      mg_trust_pkg    = self_trust,
GregWeber's avatar
GregWeber committed
160 161
                      mg_dependent_files = dependent_files
                    }
162
        = mkIface_ hsc_env maybe_old_fingerprint
163
                   this_mod is_boot used_names used_th deps rdr_env fix_env
164 165
                   warns hpc_info dir_imp_mods self_trust dependent_files
                   safe_mode mod_details
Thomas Schilling's avatar
Thomas Schilling committed
166

Simon Marlow's avatar
Simon Marlow committed
167 168 169 170
-- | 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
171
          -> Maybe Fingerprint  -- The old fingerprint, if we have it
172
          -> SafeHaskellMode    -- The safe haskell mode
dterei's avatar
dterei committed
173 174 175
          -> ModDetails         -- gotten from mkBootModDetails, probably
          -> TcGblEnv           -- Usages, deprecations, etc
          -> IO (Messages, Maybe (ModIface, Bool))
176
mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
Simon Marlow's avatar
Simon Marlow committed
177 178 179 180 181
  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
182
                      tcg_warns = warns,
183
                      tcg_hpc = other_hpc_info,
GregWeber's avatar
GregWeber committed
184 185
                      tcg_th_splice_used = tc_splice_used,
                      tcg_dependent_files = dependent_files
Simon Marlow's avatar
Simon Marlow committed
186 187
                    }
  = do
188
          let used_names = mkUsedNames tc_result
Simon Marlow's avatar
Simon Marlow committed
189 190
          deps <- mkDependencies tc_result
          let hpc_info = emptyHpcInfo other_hpc_info
191
          used_th <- readIORef tc_splice_used
GregWeber's avatar
GregWeber committed
192
          dep_files <- (readIORef dependent_files)
193
          mkIface_ hsc_env maybe_old_fingerprint
194
                   this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env
195
                   fix_env warns hpc_info (imp_mods imports)
196
                   (imp_trust_own_pkg imports) dep_files safe_mode mod_details
197

Simon Marlow's avatar
Simon Marlow committed
198

199 200
mkUsedNames :: TcGblEnv -> NameSet
mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
201

202 203
-- | 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
204 205 206 207 208 209
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
          TcGblEnv{ tcg_mod = mod,
                    tcg_imports = imports,
                    tcg_th_used = th_var
                  }
210
 = do
dterei's avatar
dterei committed
211 212 213
      -- 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
214 215
                -- M.hi-boot can be in the imp_dep_mods, but we must remove
                -- it before recording the modules on which this one depends!
216 217 218
                -- (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
Simon Marlow's avatar
Simon Marlow committed
219 220
                --  check.)

221 222
          pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
               | otherwise = imp_dep_pkgs imports
Simon Marlow's avatar
Simon Marlow committed
223

224 225 226 227 228
          -- 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
229

230
      return Deps { dep_mods   = sortBy (stableModuleNameCmp `on` fst) dep_mods,
231
                    dep_pkgs   = dep_pkgs',
232 233
                    dep_orphs  = sortBy stableModuleCmp (imp_orphs  imports),
                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
234 235
                    -- sort to get into canonical order
                    -- NB. remember to use lexicographic ordering
Simon Marlow's avatar
Simon Marlow committed
236

237
mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
238
         -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv
Ian Lynagh's avatar
Ian Lynagh committed
239
         -> NameEnv FixItem -> Warnings -> HpcInfo
240
         -> ImportedMods -> Bool
GregWeber's avatar
GregWeber committed
241
         -> [FilePath]
242
         -> SafeHaskellMode
Ian Lynagh's avatar
Ian Lynagh committed
243
         -> ModDetails
244
         -> IO (Messages, Maybe (ModIface, Bool))
245
mkIface_ hsc_env maybe_old_fingerprint
246
         this_mod is_boot used_names used_th deps rdr_env fix_env src_warns
247
         hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
248
         ModDetails{  md_insts     = insts,
dterei's avatar
dterei committed
249 250 251
                      md_fam_insts = fam_insts,
                      md_rules     = rules,
                      md_anns      = anns,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
252
                      md_vect_info = vect_info,
dterei's avatar
dterei committed
253 254 255 256 257 258 259
                      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

260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
  = do
    usages  <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files

    let entities = typeEnvElts type_env
        decls  = [ tyThingToIfaceDecl entity
                 | entity <- entities,
                   let name = getName entity,
                   not (isImplicitTyThing entity),
                      -- 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
        iface_vect_info = flattenVectInfo vect_info
        trust_info  = setSafeMode safe_mode
281
        annotations = map mkIfaceAnnotation anns
282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299

        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       = sortBy cmp_inst     iface_insts,
              mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,
              mi_rules       = sortBy cmp_rule     iface_rules,

              mi_vect_info   = iface_vect_info,

              mi_fixities    = fixities,
              mi_warns       = warns,
300
              mi_anns        = annotations,
301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320
              mi_globals     = maybeGlobalRdrEnv rdr_env,

              -- Left out deliberately: filled in by addFingerprints
              mi_iface_hash  = fingerprint0,
              mi_mod_hash    = fingerprint0,
              mi_flag_hash   = fingerprint0,
              mi_exp_hash    = fingerprint0,
              mi_used_th     = used_th,
              mi_orphan_hash = fingerprint0,
              mi_orphan      = False, -- Always set by addFingerprints, but
                                      -- it's a strict field, so we can't omit it.
              mi_finsts      = False, -- Ditto
              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,

              -- And build the cached values
              mi_warn_fn     = mkIfaceWarnCache warns,
321
              mi_fix_fn      = mkIfaceFixCache fixities }
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358

    (new_iface, no_change_at_all)
          <- {-# SCC "versioninfo" #-}
                   addFingerprints hsc_env maybe_old_fingerprint
                                   intermediate_iface decls

    -- Warn about orphans
    let warn_orphs      = wopt Opt_WarnOrphans dflags
        warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
        orph_warnings   --- Laziness means no work done unless -fwarn-orphans
          | 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 dflags unqual d
                               | (d,i) <- insts `zip` iface_insts
                               , isNothing (ifInstOrph i) ]
        rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
                               | r <- iface_rules
                               , isNothing (ifRuleOrph r)
                               , if ifRuleAuto r then warn_auto_orphs
                                                 else warn_orphs ]

    if errorsFound dflags errs_and_warns
      then return ( errs_and_warns, Nothing )
      else do
        -- Debug printing
        dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
                      (pprModIface new_iface)

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

        return (errs_and_warns, Just (final_iface, no_change_at_all))
359
  where
Ian Lynagh's avatar
Ian Lynagh committed
360 361 362 363 364
     cmp_rule     = comparing ifRuleName
     -- Compare these lexicographically by OccName, *not* by unique,
     -- because the latter is not stable across compilations:
     cmp_inst     = comparing (nameOccName . ifDFun)
     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
365

366
     dflags = hsc_dflags hsc_env
367

368 369 370 371 372
     -- 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
373
     -- scope available. (#5534)
374 375 376 377 378
     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
     maybeGlobalRdrEnv rdr_env
         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
         | otherwise                                   = Nothing

379
     deliberatelyOmitted :: String -> a
380
     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
381

382
     ifFamInstTcName = ifFamInstFam
383

384 385 386 387
     flattenVectInfo (VectInfo { vectInfoVar            = vVar
                               , vectInfoTyCon          = vTyCon
                               , vectInfoParallelVars     = vParallelVars
                               , vectInfoParallelTyCons = vParallelTyCons
388
                               }) =
389
       IfaceVectInfo
390 391 392 393 394
       { 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]
       , ifaceVectInfoParallelVars   = [Var.varName v | v <- varSetElems vParallelVars]
       , ifaceVectInfoParallelTyCons = nameSetToList vParallelTyCons
395
       }
396

397
-----------------------------
398 399
writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
writeIfaceFile dflags hi_file_path new_iface
400
    = do createDirectoryIfMissing True (takeDirectory hi_file_path)
401
         writeBinIface dflags hi_file_path new_iface
402 403


404 405
-- -----------------------------------------------------------------------------
-- Look up parents and versions of Names
406

407 408
-- 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
409
-- the parent and version info.
410

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

429 430 431 432 433 434
-- ---------------------------------------------------------------------------
-- Compute fingerprints for the interface

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

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

       edges :: [(IfaceDeclABI, Unique, [Unique])]
       edges = [ (abi, getUnique (ifName decl), out)
dterei's avatar
dterei committed
455
               | decl <- new_decls
456
               , let abi = declABI decl
dterei's avatar
dterei committed
457
               , let out = localOccs $ freeNamesDeclABI abi
458 459
               ]

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
460
       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
461
       localOccs = map (getUnique . getParent . getOccName)
462
                        . filter ((== this_mod) . name_module)
463 464 465 466 467 468 469 470
                        . 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
471
          where extend d env =
472
                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
473 474 475
                  where n = ifName d

        -- strongly-connected groups of declarations, in dependency order
476
       groups = stronglyConnCompFromEdgedVertices edges
477 478 479 480 481 482 483 484 485 486 487 488

       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
489
          | isWiredInName name  =  putNameLiterally bh name
490 491
           -- wired-in names don't have fingerprints
          | otherwise
492
          = ASSERT2( isExternalName name, ppr name )
dterei's avatar
dterei committed
493
            let hash | nameModule name /= this_mod =  global_hash_fn name
494
                     | otherwise = snd (lookupOccEnv local_env (getOccName name)
495
                           `orElse` pprPanic "urk! lookup local fingerprint"
496
                                       (ppr name)) -- (undefined,fingerprint0))
497 498 499 500 501 502 503
                -- 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.
504
            in put_ bh hash
505 506 507 508

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

509
       fingerprint_group :: (OccEnv (OccName,Fingerprint),
510 511
                             [(Fingerprint,IfaceDecl)])
                         -> SCC IfaceDeclABI
512
                         -> IO (OccEnv (OccName,Fingerprint),
513 514 515 516 517 518
                                [(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
519
               hash <- computeFingerprint hash_fn abi
520 521
               env' <- extend_hash_env local_env (hash,decl)
               return (env', (hash,decl) : decls_w_hashes)
522 523 524

       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
          = do let decls = map abiDecl abis
525
               local_env1 <- foldM extend_hash_env local_env
526
                                   (zip (repeat fingerprint0) decls)
527
               let hash_fn = mk_put_name local_env1
528 529 530
               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
               let stable_abis = sortBy cmp_abiNames abis
                -- put the cycle in a canonical order
531
               hash <- computeFingerprint hash_fn stable_abis
532
               let pairs = zip (repeat hash) decls
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.
       --
       extend_hash_env :: OccEnv (OccName,Fingerprint)
                       -> (Fingerprint,IfaceDecl)
                       -> IO (OccEnv (OccName,Fingerprint))
       extend_hash_env env0 (hash,d) = do
544 545
          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
                 (ifaceDeclFingerprints hash d))
546

547
   --
548
   (local_env, decls_w_hashes) <-
549 550
       foldM fingerprint_group (emptyOccEnv, []) groups

551 552 553 554 555
   -- 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)

556
   -- the export hash of a module depends on the orphan hashes of the
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
557
   -- orphan modules below us in the dependency tree.  This is the way
558 559 560 561
   -- 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.
562 563
   let orph_mods = filter ((== this_pkg) . modulePackageId)
                   $ dep_orphs sorted_deps
564 565
   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods

566
   orphan_hash <- computeFingerprint (mk_put_name local_env)
567
                      (map ifDFun orph_insts, orph_rules, orph_fis)
568 569 570

   -- the export list hash doesn't depend on the fingerprints of
   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
571
   export_hash <- computeFingerprint putNameLiterally
572 573 574
                      (mi_exports iface0,
                       orphan_hash,
                       dep_orphan_hashes,
575
                       dep_pkgs (mi_deps iface0),
576 577
                        -- dep_pkgs: see "Package Version Changes" on
                        -- wiki/Commentary/Compiler/RecompilationAvoidance
578
                       mi_trust iface0)
579
                        -- Make sure change of Safe Haskell mode causes recomp.
580 581

   -- put the declarations in a canonical order, sorted by OccName
582
   let sorted_decls = Map.elems $ Map.fromList $
583
                          [(ifName d, e) | e@(_, d) <- decls_w_hashes]
584

585 586 587 588
   -- the flag hash depends on:
   --   - (some of) dflags
   -- it returns two hashes, one that shouldn't change
   -- the abi hash and one that should
589
   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
590 591 592 593 594 595

   -- the ABI hash depends on:
   --   - decls
   --   - export list
   --   - orphans
   --   - deprecations
596
   --   - vect info
597
   --   - flag abi hash
598
   mod_hash <- computeFingerprint putNameLiterally
599
                      (map fst sorted_decls,
600
                       export_hash,  -- includes orphan_hash
601 602
                       mi_warns iface0,
                       mi_vect_info iface0)
603 604

   -- The interface hash depends on:
605
   --   - the ABI hash, plus
606
   --   - the module level annotations,
607
   --   - usages
608
   --   - deps (home and external packages, dependent files)
609
   --   - hpc
610
   iface_hash <- computeFingerprint putNameLiterally
611
                      (mod_hash,
612
                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache
613
                       mi_usages iface0,
614
                       sorted_deps,
615 616 617 618 619 620 621 622 623 624
                       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,
625
                mi_flag_hash   = flag_hash,
626 627 628
                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
629
                                      && isNoIfaceVectInfo (mi_vect_info iface0)),
630 631 632 633
                mi_finsts      = not . null $ mi_fam_insts iface0,
                mi_decls       = sorted_decls,
                mi_hash_fn     = lookupOccEnv local_env }
   --
634
   return (final_iface, no_change_at_all)
635

636 637 638 639
  where
    this_mod = mi_module iface0
    dflags = hsc_dflags hsc_env
    this_pkg = thisPackage dflags
640 641 642
    (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)
643
    fix_fn = mi_fix_fn iface0
644
    ann_fn = mkIfaceAnnCache (mi_anns iface0)
645 646 647 648

getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
getOrphanHashes hsc_env mods = do
  eps <- hscEPS hsc_env
649
  let
650 651 652
    hpt        = hsc_HPT hsc_env
    pit        = eps_PIT eps
    dflags     = hsc_dflags hsc_env
653
    get_orph_hash mod =
654 655 656 657 658 659 660
          case lookupIfaceByModule dflags hpt pit mod of
            Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
            Just iface -> mi_orphan_hash iface
  --
  return (map get_orph_hash mods)


661 662 663
sortDependencies :: Dependencies -> Dependencies
sortDependencies d
 = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
664
          dep_pkgs   = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d),
665 666
          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
          dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
667 668 669
\end{code}


670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685
\begin{code}
-- | Creates cached lookup for the 'mi_anns' field of ModIface
-- Hackily, we use "module" as the OccName for any module-level annotations
mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
mkIfaceAnnCache anns
  = \n -> lookupOccEnv env n `orElse` []
  where
    pair (IfaceAnnotation target value) =
      (case target of
          NamedTarget occn -> occn
          ModuleTarget _   -> mkVarOcc "module"
      , [value])
    -- flipping (++), so the first argument is always short
    env = mkOccEnv_C (flip (++)) (map pair anns)
\end{code}

686
%************************************************************************
dterei's avatar
dterei committed
687
%*                                                                      *
688
          The ABI of an IfaceDecl
dterei's avatar
dterei committed
689
%*                                                                      *
690 691 692 693 694 695 696 697 698
%************************************************************************

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).
699

700 701
   (b) the declaration itself, as exposed to clients.  That is, the
       definition of an Id is included in the fingerprint only if
702
       it is made available as an unfolding in the interface.
703 704 705 706 707 708 709 710

   (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
711 712
the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
and fingerprinting that as part of the declaration.
713 714

\begin{code}
715 716
type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)

717
data IfaceDeclExtras
718
  = IfaceIdExtras IfaceIdExtras
719

720
  | IfaceDataExtras
dterei's avatar
dterei committed
721
       Fixity                   -- Fixity of the tycon itself
722
       [IfaceInstABI]           -- Local class and family instances of this tycon
dterei's avatar
dterei committed
723
                                -- See Note [Orphans] in IfaceSyn
724 725
       [AnnPayload]             -- Annotations of the type itself
       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations
726

727
  | IfaceClassExtras
dterei's avatar
dterei committed
728 729 730 731
       Fixity                   -- Fixity of the class itself
       [IfaceInstABI]           -- Local instances of this class *or*
                                --   of its associated data types
                                -- See Note [Orphans] in IfaceSyn
732 733
       [AnnPayload]             -- Annotations of the type itself
       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
734

735
  | IfaceSynExtras   Fixity [IfaceInstABI] [AnnPayload]
736

737 738
  | IfaceOtherDeclExtras

739 740 741 742 743 744
data IfaceIdExtras
  = IdExtras
       Fixity                   -- Fixity of the Id
       [IfaceRule]              -- Rules for the Id
       [AnnPayload]             -- Annotations for the Id

745 746
-- When hashing a class or family instance, we hash only the
-- DFunId or CoAxiom, because that depends on all the
747 748 749 750
-- information about the instance.
--
type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance

751 752 753 754
abiDecl :: IfaceDeclABI -> IfaceDecl
abiDecl (_, decl, _) = decl

cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
755
cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
756 757 758 759 760 761 762
                         ifName (abiDecl abi2)

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

freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
763 764
freeNamesDeclExtras (IfaceIdExtras id_extras)
  = freeNamesIdExtras id_extras
765
freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)
766
  = unionManyNameSets (mkNameSet insts : map freeNamesIdExtras subs)
767
freeNamesDeclExtras (IfaceClassExtras _ insts _ subs)
768
  = unionManyNameSets (mkNameSet insts : map freeNamesIdExtras subs)
769
freeNamesDeclExtras (IfaceSynExtras _ insts _)
770
  = mkNameSet insts
771 772 773
freeNamesDeclExtras IfaceOtherDeclExtras
  = emptyNameSet

774 775
freeNamesIdExtras :: IfaceIdExtras -> NameSet
freeNamesIdExtras (IdExtras _ rules _) = unionManyNameSets (map freeNamesIfRule rules)
776

777 778
instance Outputable IfaceDeclExtras where
  ppr IfaceOtherDeclExtras       = empty
779
  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras
780 781
  ppr (IfaceSynExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
782
                                                ppr_id_extras_s stuff]
783
  ppr (IfaceClassExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
784 785 786 787 788
                                                 ppr_id_extras_s stuff]

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

789 790
ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
791

792 793
ppr_id_extras :: IfaceIdExtras -> SDoc
ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
794

795
-- This instance is used only to compute fingerprints
796 797
instance Binary IfaceDeclExtras where
  get _bh = panic "no get for IfaceDeclExtras"
798 799
  put_ bh (IfaceIdExtras extras) = do
   putByte bh 1; put_ bh extras
800 801 802 803 804 805
  put_ bh (IfaceDataExtras fix insts anns cons) = do
   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
  put_ bh (IfaceClassExtras fix insts anns methods) = do
   putByte bh 3; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh methods
  put_ bh (IfaceSynExtras fix finsts anns) = do
   putByte bh 4; put_ bh fix; put_ bh finsts; put_ bh anns
806 807 808 809 810
  put_ bh IfaceOtherDeclExtras = putByte bh 5

instance Binary IfaceIdExtras where
  get _bh = panic "no get for IfaceIdExtras"
  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
811 812

declExtras :: (OccName -> Fixity)
813
           -> (OccName -> [AnnPayload])
814
           -> OccEnv [IfaceRule]
815 816
           -> OccEnv [IfaceClsInst]
           -> OccEnv [IfaceFamInst]
817 818 819
           -> IfaceDecl
           -> IfaceDeclExtras

820
declExtras fix_fn ann_fn rule_env inst_env fi_env decl
821
  = case decl of
822
      IfaceId{} -> IfaceIdExtras (id_extras n)
823
      IfaceData{ifCons=cons} ->
824
                     IfaceDataExtras (fix_fn n)
825 826
                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
                         map ifDFun         (lookupOccEnvL inst_env n))
827
                        (ann_fn n)
828
                        (map (id_extras . ifConOcc) (visibleIfConDecls cons))
829
      IfaceClass{ifSigs=sigs, ifATs=ats} ->
830
                     IfaceClassExtras (fix_fn n)
831
                        (map ifDFun $ (concatMap at_extras ats)
832
                                    ++ lookupOccEnvL inst_env n)
dterei's avatar
dterei committed
833 834
                           -- Include instances of the associated types
                           -- as well as instances of the class (Trac #5147)
835
                        (ann_fn n)
836
                        [id_extras op | IfaceClassOp op _ _ <- sigs]
837
      IfaceSyn{} -> IfaceSynExtras (fix_fn n)
838
                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
839
                        (ann_fn n)
840 841 842
      _other -> IfaceOtherDeclExtras
  where
        n = ifName decl
843
        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
844
        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (ifName decl)
845 846 847 848 849 850 851 852


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 ()
853
putNameLiterally bh name = ASSERT( isExternalName name )
854 855 856
  do
    put_ bh $! nameModule name
    put_ bh $! nameOccName name
857 858 859 860 861 862 863 864 865 866 867 868 869 870 871

{-
-- 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
872
    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
873 874 875 876
    ExitSuccess -> do
        hash_str <- readFile tmp2
        return $! readHexFingerprint hash_str
-}
877

Ian Lynagh's avatar
Ian Lynagh committed
878 879 880
instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
instOrphWarn dflags unqual inst
  = mkWarnMsg dflags (getSrcSpan inst) unqual $
881
    hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
882

Ian Lynagh's avatar
Ian Lynagh committed
883 884 885
ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
ruleOrphWarn dflags unqual mod rule
  = mkWarnMsg dflags silly_loc unqual $
886 887
    ptext (sLit "Orphan rule:") <+> ppr rule
  where
888
    silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
889 890
    -- 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
891 892

----------------------
893
-- mkOrphMap partitions instance decls or rules into
894
--      (a) an OccEnv for ones that are not orphans,
dterei's avatar
dterei committed
895 896 897 898 899 900 901 902
--          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