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 MkIface (
   8         mkUsedNames,
   9         mkDependencies,
  10         mkIface,        -- Build a ModIface from a ModGuts,
  11                         -- including computing version information
  12
  13         mkIfaceTc,
  14
  15         writeIfaceFile, -- Write the interface file
  16
  17         checkOldIface,  -- See if recompilation is required, by
  18                         -- comparing version information
  19
  20         tyThingToIfaceDecl -- Converting things to their Iface equivalents
  21  ) where
  22 \end{code}
  23
  24         -----------------------------------------------
  25                 Recompilation checking
  26         -----------------------------------------------
  27
  28 A complete description of how recompilation checking works can be
  29 found in the wiki commentary:
  30
  31  http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
  32
  33 Please read the above page for a top-down description of how this all
  34 works.  Notes below cover specific issues related to the implementation.
  35
  36 Basic idea:
  37
  38   * In the mi_usages information in an interface, we record the
  39     fingerprint of each free variable of the module
  40
  41   * In mkIface, we compute the fingerprint of each exported thing A.f.
  42     For each external thing that A.f refers to, we include the fingerprint
  43     of the external reference when computing the fingerprint of A.f.  So
  44     if anything that A.f depends on changes, then A.f's fingerprint will
  45     change.
  46
  47   * In checkOldIface we compare the mi_usages for the module with
  48     the actual fingerprint for all each thing recorded in mi_usages
  49
  50 \begin{code}
  51 #include "HsVersions.h"
  52
  53 import IfaceSyn
  54 import IfaceType
  55 import LoadIface
  56 import Id
  57 import IdInfo
  58 import NewDemand
  59 import CoreSyn
  60 import CoreFVs
  61 import Class
  62 import TyCon
  63 import DataCon
  64 import Type
  65 import TcType
  66 import InstEnv
  67 import FamInstEnv
  68 import TcRnMonad
  69 import HscTypes
  70 import Finder
  71 import DynFlags
  72 import VarEnv
  73 import Var
  74 import Name
  75 import RdrName
  76 import NameEnv
  77 import NameSet
  78 import OccName
  79 import Module
  80 import BinIface
  81 import ErrUtils
  82 import Digraph
  83 import SrcLoc
  84 import Outputable
  85 import BasicTypes       hiding ( SuccessFlag(..) )
  86 import LazyUniqFM
  87 import Unique
  88 import Util             hiding ( eqListBy )
  89 import FiniteMap
  90 import FastString
  91 import Maybes
  92 import ListSetOps
  93 import Binary
  94 import Fingerprint
  95 import Bag
  96 import Panic
  97
  98 import Control.Monad
  99 import Data.List
 100 import Data.IORef
 101 import System.FilePath
 102 import System.Exit      ( exitWith, ExitCode(..) )
 103 \end{code}
 104
 105
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection{Completing an interface}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 \begin{code}
 114 mkIface :: HscEnv
 115         -> Maybe Fingerprint    -- The old fingerprint, if we have it
 116         -> ModDetails           -- The trimmed, tidied interface
 117         -> ModGuts              -- Usages, deprecations, etc
 118         -> IO (ModIface,        -- The new one
 119                Bool)            -- True <=> there was an old Iface, and the
 120                                 --          new one is identical, so no need
 121                                 --          to write it
 122
 123 mkIface hsc_env maybe_old_fingerprint mod_details
 124          ModGuts{     mg_module    = this_mod,
 125                       mg_boot      = is_boot,
 126                       mg_used_names = used_names,
 127                       mg_deps      = deps,
 128                       mg_dir_imps  = dir_imp_mods,
 129                       mg_rdr_env   = rdr_env,
 130                       mg_fix_env   = fix_env,
 131                       mg_warns   = warns,
 132                       mg_hpc_info  = hpc_info }
 133         = mkIface_ hsc_env maybe_old_fingerprint
 134                    this_mod is_boot used_names deps rdr_env
 135                    fix_env warns hpc_info dir_imp_mods mod_details
 136
 137 -- | make an interface from the results of typechecking only.  Useful
 138 -- for non-optimising compilation, or where we aren't generating any
 139 -- object code at all ('HscNothing').
 140 mkIfaceTc :: HscEnv
 141           -> Maybe Fingerprint  -- The old fingerprint, if we have it
 142           -> ModDetails         -- gotten from mkBootModDetails, probably
 143           -> TcGblEnv           -- Usages, deprecations, etc
 144           -> IO (ModIface,
 145                  Bool)
 146 mkIfaceTc hsc_env maybe_old_fingerprint mod_details
 147   tc_result@TcGblEnv{ tcg_mod = this_mod,
 148                       tcg_src = hsc_src,
 149                       tcg_imports = imports,
 150                       tcg_rdr_env = rdr_env,
 151                       tcg_fix_env = fix_env,
 152                       tcg_warns = warns,
 153                       tcg_hpc = other_hpc_info
 154                     }
 155   = do
 156           used_names <- mkUsedNames tc_result
 157           deps <- mkDependencies tc_result
 158           let hpc_info = emptyHpcInfo other_hpc_info
 159           mkIface_ hsc_env maybe_old_fingerprint
 160                    this_mod (isHsBoot hsc_src) used_names deps rdr_env
 161                    fix_env warns hpc_info (imp_mods imports) mod_details
 162
 163
 164 mkUsedNames :: TcGblEnv -> IO NameSet
 165 mkUsedNames
 166           TcGblEnv{ tcg_inst_uses = dfun_uses_var,
 167                     tcg_dus = dus
 168                   }
 169  = do
 170         dfun_uses <- readIORef dfun_uses_var            -- What dfuns are used
 171         return (allUses dus `unionNameSets` dfun_uses)
 172
 173 mkDependencies :: TcGblEnv -> IO Dependencies
 174 mkDependencies
 175           TcGblEnv{ tcg_mod = mod,
 176                     tcg_imports = imports,
 177                     tcg_th_used = th_var
 178                   }
 179  = do
 180       th_used   <- readIORef th_var                     -- Whether TH is used
 181       let
 182         dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
 183                 -- M.hi-boot can be in the imp_dep_mods, but we must remove
 184                 -- it before recording the modules on which this one depends!
 185                 -- (We want to retain M.hi-boot in imp_dep_mods so that
 186                 --  loadHiBootInterface can see if M's direct imports depend
 187                 --  on M.hi-boot, and hence that we should do the hi-boot consistency
 188                 --  check.)
 189
 190                 -- Modules don't compare lexicographically usually,
 191                 -- but we want them to do so here.
 192         le_mod :: Module -> Module -> Bool
 193         le_mod m1 m2 = moduleNameFS (moduleName m1)
 194                            <= moduleNameFS (moduleName m2)
 195
 196         le_dep_mod :: (ModuleName, IsBootInterface)
 197                     -> (ModuleName, IsBootInterface) -> Bool
 198         le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2
 199
 200
 201         pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
 202              | otherwise = imp_dep_pkgs imports
 203
 204       return Deps { dep_mods   = sortLe le_dep_mod dep_mods,
 205                     dep_pkgs   = sortLe (<=)   pkgs,
 206                     dep_orphs  = sortLe le_mod (imp_orphs  imports),
 207                     dep_finsts = sortLe le_mod (imp_finsts imports) }
 208                 -- sort to get into canonical order
 209
 210
 211 mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
 212          -> NameSet -> Dependencies -> GlobalRdrEnv
 213          -> NameEnv FixItem -> Warnings -> HpcInfo
 214          -> ImportedMods
 215          -> ModDetails
 216          -> IO (ModIface, Bool)
 217 mkIface_ hsc_env maybe_old_fingerprint
 218          this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
 219          dir_imp_mods
 220          ModDetails{  md_insts     = insts,
 221                       md_fam_insts = fam_insts,
 222                       md_rules     = rules,
 223                       md_vect_info = vect_info,
 224                       md_types     = type_env,
 225                       md_exports   = exports }
 226 -- NB:  notice that mkIface does not look at the bindings
 227 --      only at the TypeEnv.  The previous Tidy phase has
 228 --      put exactly the info into the TypeEnv that we want
 229 --      to expose in the interface
 230
 231   = do  { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
 232
 233         ; let   { entities = typeEnvElts type_env ;
 234                   decls  = [ tyThingToIfaceDecl entity
 235                            | entity <- entities,
 236                              let name = getName entity,
 237                              not (isImplicitTyThing entity),
 238                                 -- No implicit Ids and class tycons in the interface file
 239                              not (isWiredInName name),
 240                                 -- Nor wired-in things; the compiler knows about them anyhow
 241                              nameIsLocalOrFrom this_mod name  ]
 242                                 -- Sigh: see Note [Root-main Id] in TcRnDriver
 243
 244                 ; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
 245                 ; warns     = src_warns
 246                 ; iface_rules = map (coreRuleToIfaceRule this_mod) rules
 247                 ; iface_insts = map instanceToIfaceInst insts
 248                 ; iface_fam_insts = map famInstToIfaceFamInst fam_insts
 249                 ; iface_vect_info = flattenVectInfo vect_info
 250
 251                 ; intermediate_iface = ModIface {
 252                         mi_module   = this_mod,
 253                         mi_boot     = is_boot,
 254                         mi_deps     = deps,
 255                         mi_usages   = usages,
 256                         mi_exports  = mkIfaceExports exports,
 257
 258                         -- Sort these lexicographically, so that
 259                         -- the result is stable across compilations
 260                         mi_insts    = sortLe le_inst iface_insts,
 261                         mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
 262                         mi_rules    = sortLe le_rule iface_rules,
 263
 264                         mi_vect_info = iface_vect_info,
 265
 266                         mi_fixities = fixities,
 267                         mi_warns  = warns,
 268                         mi_globals  = Just rdr_env,
 269
 270                         -- Left out deliberately: filled in by addVersionInfo
 271                         mi_iface_hash = fingerprint0,
 272                         mi_mod_hash  = fingerprint0,
 273                         mi_exp_hash  = fingerprint0,
 274                         mi_orphan_hash = fingerprint0,
 275                         mi_orphan    = False,   -- Always set by addVersionInfo, but
 276                                                 -- it's a strict field, so we can't omit it.
 277                         mi_finsts    = False,   -- Ditto
 278                         mi_decls     = deliberatelyOmitted "decls",
 279                         mi_hash_fn   = deliberatelyOmitted "hash_fn",
 280                         mi_hpc       = isHpcUsed hpc_info,
 281
 282                         -- And build the cached values
 283                         mi_warn_fn = mkIfaceWarnCache warns,
 284                         mi_fix_fn = mkIfaceFixCache fixities }
 285                 }
 286
 287         ; (new_iface, no_change_at_all)
 288                 <- {-# SCC "versioninfo" #-}
 289                          addFingerprints hsc_env maybe_old_fingerprint
 290                                          intermediate_iface decls
 291
 292                 -- Warn about orphans
 293         ; let orph_warnings   --- Laziness means no work done unless -fwarn-orphans
 294                 | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
 295                 | otherwise                   = emptyBag
 296               errs_and_warns = (orph_warnings, emptyBag)
 297               unqual = mkPrintUnqualified dflags rdr_env
 298               inst_warns = listToBag [ instOrphWarn unqual d
 299                                      | (d,i) <- insts `zip` iface_insts
 300                                      , isNothing (ifInstOrph i) ]
 301               rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
 302                                      | r <- iface_rules
 303                                      , isNothing (ifRuleOrph r) ]
 304
 305         ; when (not (isEmptyBag orph_warnings))
 306                (do { printErrorsAndWarnings dflags errs_and_warns -- XXX
 307                    ; when (errorsFound dflags errs_and_warns)
 308                           (exitWith (ExitFailure 1)) })
 309
 310 -- XXX  ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
 311
 312                 -- Debug printing
 313         ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
 314                         (pprModIface new_iface)
 315
 316                 -- bug #1617: on reload we weren't updating the PrintUnqualified
 317                 -- correctly.  This stems from the fact that the interface had
 318                 -- not changed, so addVersionInfo returns the old ModIface
 319                 -- with the old GlobalRdrEnv (mi_globals).
 320         ; let final_iface = new_iface{ mi_globals = Just rdr_env }
 321
 322         ; return (final_iface, no_change_at_all) }
 323   where
 324      r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
 325      i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2
 326      i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2
 327
 328      le_occ :: Name -> Name -> Bool
 329         -- Compare lexicographically by OccName, *not* by unique, because
 330         -- the latter is not stable across compilations
 331      le_occ n1 n2 = nameOccName n1 <= nameOccName n2
 332
 333      dflags = hsc_dflags hsc_env
 334      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
 335      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
 336
 337      flattenVectInfo (VectInfo { vectInfoVar   = vVar
 338                                , vectInfoTyCon = vTyCon
 339                                }) =
 340        IfaceVectInfo {
 341          ifaceVectInfoVar        = [ Var.varName v
 342                                    | (v, _) <- varEnvElts vVar],
 343          ifaceVectInfoTyCon      = [ tyConName t
 344                                    | (t, t_v) <- nameEnvElts vTyCon
 345                                    , t /= t_v],
 346          ifaceVectInfoTyConReuse = [ tyConName t
 347                                    | (t, t_v) <- nameEnvElts vTyCon
 348                                    , t == t_v]
 349        }
 350
 351 -----------------------------
 352 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
 353 writeIfaceFile dflags location new_iface
 354     = do createDirectoryHierarchy (takeDirectory hi_file_path)
 355          writeBinIface dflags hi_file_path new_iface
 356     where hi_file_path = ml_hi_file location
 357
 358
 359 -- -----------------------------------------------------------------------------
 360 -- Look up parents and versions of Names
 361
 362 -- This is like a global version of the mi_hash_fn field in each ModIface.
 363 -- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
 364 -- the parent and version info.
 365
 366 mkHashFun
 367         :: HscEnv                       -- needed to look up versions
 368         -> ExternalPackageState         -- ditto
 369         -> (Name -> Fingerprint)
 370 mkHashFun hsc_env eps
 371   = \name ->
 372       let
 373         mod = ASSERT2( isExternalName name, ppr name ) nameModule name
 374         occ = nameOccName name
 375         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
 376                    pprPanic "lookupVers2" (ppr mod <+> ppr occ)
 377       in
 378         snd (mi_hash_fn iface occ `orElse`
 379                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))
 380   where
 381       hpt = hsc_HPT hsc_env
 382       pit = eps_PIT eps
 383
 384 -- ---------------------------------------------------------------------------
 385 -- Compute fingerprints for the interface
 386
 387 addFingerprints
 388         :: HscEnv
 389         -> Maybe Fingerprint -- the old fingerprint, if any
 390         -> ModIface          -- The new interface (lacking decls)
 391         -> [IfaceDecl]       -- The new decls
 392         -> IO (ModIface,     -- Updated interface
 393                Bool)         -- True <=> no changes at all;
 394                              -- no need to write Iface
 395
 396 addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
 397  = do
 398    eps <- hscEPS hsc_env
 399    let
 400         -- the ABI of a declaration represents everything that is made
 401         -- visible about the declaration that a client can depend on.
 402         -- see IfaceDeclABI below.
 403        declABI :: IfaceDecl -> IfaceDeclABI
 404        declABI decl = (this_mod, decl, extras)
 405         where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
 406
 407        edges :: [(IfaceDeclABI, Unique, [Unique])]
 408        edges = [ (abi, getUnique (ifName decl), out)
 409                | decl <- new_decls
 410                , let abi = declABI decl
 411                , let out = localOccs $ freeNamesDeclABI abi
 412                ]
 413
 414        name_module n = ASSERT( isExternalName n ) nameModule n
 415        localOccs = map (getUnique . getParent . getOccName)
 416                         . filter ((== this_mod) . name_module)
 417                         . nameSetToList
 418           where getParent occ = lookupOccEnv parent_map occ `orElse` occ
 419
 420         -- maps OccNames to their parents in the current module.
 421         -- e.g. a reference to a constructor must be turned into a reference
 422         -- to the TyCon for the purposes of calculating dependencies.
 423        parent_map :: OccEnv OccName
 424        parent_map = foldr extend emptyOccEnv new_decls
 425           where extend d env =
 426                   extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
 427                   where n = ifName d
 428
 429         -- strongly-connected groups of declarations, in dependency order
 430        groups = stronglyConnCompFromEdgedVertices edges
 431
 432        global_hash_fn = mkHashFun hsc_env eps
 433
 434         -- how to output Names when generating the data to fingerprint.
 435         -- Here we want to output the fingerprint for each top-level
 436         -- Name, whether it comes from the current module or another
 437         -- module.  In this way, the fingerprint for a declaration will
 438         -- change if the fingerprint for anything it refers to (transitively)
 439         -- changes.
 440        mk_put_name :: (OccEnv (OccName,Fingerprint))
 441                    -> BinHandle -> Name -> IO  ()
 442        mk_put_name local_env bh name
 443           | isWiredInName name  =  putNameLiterally bh name
 444            -- wired-in names don't have fingerprints
 445           | otherwise
 446           = ASSERT( isExternalName name )
 447             let hash | nameModule name /= this_mod =  global_hash_fn name
 448                      | otherwise =
 449                         snd (lookupOccEnv local_env (getOccName name)
 450                            `orElse` pprPanic "urk! lookup local fingerprint"
 451                                        (ppr name)) -- (undefined,fingerprint0))
 452                 -- This panic indicates that we got the dependency
 453                 -- analysis wrong, because we needed a fingerprint for
 454                 -- an entity that wasn't in the environment.  To debug
 455                 -- it, turn the panic into a trace, uncomment the
 456                 -- pprTraces below, run the compile again, and inspect
 457                 -- the output and the generated .hi file with
 458                 -- --show-iface.
 459             in
 460             put_ bh hash
 461
 462         -- take a strongly-connected group of declarations and compute
 463         -- its fingerprint.
 464
 465        fingerprint_group :: (OccEnv (OccName,Fingerprint),
 466                              [(Fingerprint,IfaceDecl)])
 467                          -> SCC IfaceDeclABI
 468                          -> IO (OccEnv (OccName,Fingerprint),
 469                                 [(Fingerprint,IfaceDecl)])
 470
 471        fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
 472           = do let hash_fn = mk_put_name local_env
 473                    decl = abiDecl abi
 474                -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
 475                hash <- computeFingerprint dflags hash_fn abi
 476                return (extend_hash_env (hash,decl) local_env,
 477                        (hash,decl) : decls_w_hashes)
 478
 479        fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
 480           = do let decls = map abiDecl abis
 481                    local_env' = foldr extend_hash_env local_env
 482                                    (zip (repeat fingerprint0) decls)
 483                    hash_fn = mk_put_name local_env'
 484                -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
 485                let stable_abis = sortBy cmp_abiNames abis
 486                 -- put the cycle in a canonical order
 487                hash <- computeFingerprint dflags hash_fn stable_abis
 488                let pairs = zip (repeat hash) decls
 489                return (foldr extend_hash_env local_env pairs,
 490                        pairs ++ decls_w_hashes)
 491
 492        extend_hash_env :: (Fingerprint,IfaceDecl)
 493                        -> OccEnv (OccName,Fingerprint)
 494                        -> OccEnv (OccName,Fingerprint)
 495        extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
 496         where
 497           decl_name = ifName d
 498           item = (decl_name, hash)
 499           env1 = extendOccEnv env0 decl_name item
 500           add_imp bndr env = extendOccEnv env bndr item
 501
 502    --
 503    (local_env, decls_w_hashes) <-
 504        foldM fingerprint_group (emptyOccEnv, []) groups
 505
 506    -- when calculating fingerprints, we always need to use canonical
 507    -- ordering for lists of things.  In particular, the mi_deps has various
 508    -- lists of modules and suchlike, so put these all in canonical order:
 509    let sorted_deps = sortDependencies (mi_deps iface0)
 510
 511    -- the export hash of a module depends on the orphan hashes of the
 512    -- orphan modules below us in the dependeny tree.  This is the way
 513    -- that changes in orphans get propagated all the way up the
 514    -- dependency tree.  We only care about orphan modules in the current
 515    -- package, because changes to orphans outside this package will be
 516    -- tracked by the usage on the ABI hash of package modules that we import.
 517    let orph_mods = filter ((== this_pkg) . modulePackageId)
 518                    $ dep_orphs sorted_deps
 519    dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
 520
 521    orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
 522                       (map IfaceInstABI orph_insts, orph_rules, fam_insts)
 523
 524    -- the export list hash doesn't depend on the fingerprints of
 525    -- the Names it mentions, only the Names themselves, hence putNameLiterally.
 526    export_hash <- computeFingerprint dflags putNameLiterally
 527                       (mi_exports iface0, orphan_hash, dep_orphan_hashes)
 528
 529    -- put the declarations in a canonical order, sorted by OccName
 530    let sorted_decls = eltsFM $ listToFM $
 531                           [(ifName d, e) | e@(_, d) <- decls_w_hashes]
 532
 533    -- the ABI hash depends on:
 534    --   - decls
 535    --   - export list
 536    --   - orphans
 537    --   - deprecations
 538    --   - XXX vect info?
 539    mod_hash <- computeFingerprint dflags putNameLiterally
 540                       (map fst sorted_decls,
 541                        export_hash,
 542                        orphan_hash,
 543                        mi_warns iface0)
 544
 545    -- The interface hash depends on:
 546    --    - the ABI hash, plus
 547    --    - usages
 548    --    - deps
 549    --    - hpc
 550    iface_hash <- computeFingerprint dflags putNameLiterally
 551                       (mod_hash,
 552                        mi_usages iface0,
 553                        sorted_deps,
 554                        mi_hpc iface0)
 555
 556    let
 557     no_change_at_all = Just iface_hash == mb_old_fingerprint
 558
 559     final_iface = iface0 {
 560                 mi_mod_hash    = mod_hash,
 561                 mi_iface_hash  = iface_hash,
 562                 mi_exp_hash    = export_hash,
 563                 mi_orphan_hash = orphan_hash,
 564                 mi_orphan      = not (null orph_rules && null orph_insts),
 565                 mi_finsts      = not . null $ mi_fam_insts iface0,
 566                 mi_decls       = sorted_decls,
 567                 mi_hash_fn     = lookupOccEnv local_env }
 568    --
 569    return (final_iface, no_change_at_all)
 570
 571   where
 572     this_mod = mi_module iface0
 573     dflags = hsc_dflags hsc_env
 574     this_pkg = thisPackage dflags
 575     (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
 576     (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
 577         -- ToDo: shouldn't we be splitting fam_insts into orphans and
 578         -- non-orphans?
 579     fam_insts = mi_fam_insts iface0
 580     fix_fn = mi_fix_fn iface0
 581
 582
 583 getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
 584 getOrphanHashes hsc_env mods = do
 585   eps <- hscEPS hsc_env
 586   let
 587     hpt        = hsc_HPT hsc_env
 588     pit        = eps_PIT eps
 589     dflags     = hsc_dflags hsc_env
 590     get_orph_hash mod =
 591           case lookupIfaceByModule dflags hpt pit mod of
 592             Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
 593             Just iface -> mi_orphan_hash iface
 594   --
 595   return (map get_orph_hash mods)
 596
 597
 598 sortDependencies :: Dependencies -> Dependencies
 599 sortDependencies d
 600  = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
 601           dep_pkgs   = sortBy (compare `on` packageIdFS)  (dep_pkgs d),
 602           dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
 603           dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
 604
 605 -- The ABI of a declaration consists of:
 606      -- the full name of the identifier (inc. module and package, because
 607      --   these are used to construct the symbol name by which the
 608      --   identifier is known externally).
 609      -- the fixity of the identifier
 610      -- the declaration itself, as exposed to clients.  That is, the
 611      --   definition of an Id is included in the fingerprint only if
 612      --   it is made available as as unfolding in the interface.
 613      -- for Ids: rules
 614      -- for classes: instances, fixity & rules for methods
 615      -- for datatypes: instances, fixity & rules for constrs
 616 type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
 617
 618 abiDecl :: IfaceDeclABI -> IfaceDecl
 619 abiDecl (_, decl, _) = decl
 620
 621 cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
 622 cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare`
 623                          ifName (abiDecl abi2)
 624
 625 freeNamesDeclABI :: IfaceDeclABI -> NameSet
 626 freeNamesDeclABI (_mod, decl, extras) =
 627   freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
 628
 629 data IfaceDeclExtras
 630   = IfaceIdExtras    Fixity [IfaceRule]
 631   | IfaceDataExtras  Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
 632   | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])]
 633   | IfaceOtherDeclExtras
 634
 635 freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
 636 freeNamesDeclExtras (IfaceIdExtras    _ rules)
 637   = unionManyNameSets (map freeNamesIfRule rules)
 638 freeNamesDeclExtras (IfaceDataExtras  _ _insts subs)
 639   = unionManyNameSets (map freeNamesSub subs)
 640 freeNamesDeclExtras (IfaceClassExtras _insts subs)
 641   = unionManyNameSets (map freeNamesSub subs)
 642 freeNamesDeclExtras IfaceOtherDeclExtras
 643   = emptyNameSet
 644
 645 freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
 646 freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
 647
 648 instance Binary IfaceDeclExtras where
 649   get _bh = panic "no get for IfaceDeclExtras"
 650   put_ bh (IfaceIdExtras fix rules) = do
 651    putByte bh 1; put_ bh fix; put_ bh rules
 652   put_ bh (IfaceDataExtras fix insts cons) = do
 653    putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
 654   put_ bh (IfaceClassExtras insts methods) = do
 655    putByte bh 3; put_ bh insts; put_ bh methods
 656   put_ bh IfaceOtherDeclExtras = do
 657    putByte bh 4
 658
 659 declExtras :: (OccName -> Fixity)
 660            -> OccEnv [IfaceRule]
 661            -> OccEnv [IfaceInst]
 662            -> IfaceDecl
 663            -> IfaceDeclExtras
 664
 665 declExtras fix_fn rule_env inst_env decl
 666   = case decl of
 667       IfaceId{} -> IfaceIdExtras (fix_fn n)
 668                         (lookupOccEnvL rule_env n)
 669       IfaceData{ifCons=cons} ->
 670                      IfaceDataExtras (fix_fn n)
 671                         (map IfaceInstABI $ lookupOccEnvL inst_env n)
 672                         (map (id_extras . ifConOcc) (visibleIfConDecls cons))
 673       IfaceClass{ifSigs=sigs} ->
 674                      IfaceClassExtras
 675                         (map IfaceInstABI $ lookupOccEnvL inst_env n)
 676                         [id_extras op | IfaceClassOp op _ _ <- sigs]
 677       _other -> IfaceOtherDeclExtras
 678   where
 679         n = ifName decl
 680         id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
 681
 682 --
 683 -- When hashing an instance, we hash only its structure, not the
 684 -- fingerprints of the things it mentions.  See the section on instances
 685 -- in the commentary,
 686 --    http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
 687 --
 688 newtype IfaceInstABI = IfaceInstABI IfaceInst
 689
 690 instance Binary IfaceInstABI where
 691   get = panic "no get for IfaceInstABI"
 692   put_ bh (IfaceInstABI inst) = do
 693     let ud  = getUserData bh
 694         bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
 695     put_ bh' inst
 696
 697 lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
 698 lookupOccEnvL env k = lookupOccEnv env k `orElse` []
 699
 700 -- used when we want to fingerprint a structure without depending on the
 701 -- fingerprints of external Names that it refers to.
 702 putNameLiterally :: BinHandle -> Name -> IO ()
 703 putNameLiterally bh name = ASSERT( isExternalName name )
 704   do { put_ bh $! nameModule name
 705      ; put_ bh $! nameOccName name }
 706
 707 computeFingerprint :: Binary a
 708                    => DynFlags
 709                    -> (BinHandle -> Name -> IO ())
 710                    -> a
 711                    -> IO Fingerprint
 712
 713 computeFingerprint _dflags put_name a = do
 714   bh <- openBinMem (3*1024) -- just less than a block
 715   ud <- newWriteState put_name putFS
 716   bh <- return $ setUserData bh ud
 717   put_ bh a
 718   fingerprintBinMem bh
 719
 720 {-
 721 -- for testing: use the md5sum command to generate fingerprints and
 722 -- compare the results against our built-in version.
 723   fp' <- oldMD5 dflags bh
 724   if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
 725                else return fp
 726
 727 oldMD5 dflags bh = do
 728   tmp <- newTempName dflags "bin"
 729   writeBinMem bh tmp
 730   tmp2 <- newTempName dflags "md5"
 731   let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
 732   r <- system cmd
 733   case r of
 734     ExitFailure _ -> ghcError (PhaseFailed cmd r)
 735     ExitSuccess -> do
 736         hash_str <- readFile tmp2
 737         return $! readHexFingerprint hash_str
 738 -}
 739
 740 instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
 741 instOrphWarn unqual inst
 742   = mkWarnMsg (getSrcSpan inst) unqual $
 743     hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
 744
 745 ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
 746 ruleOrphWarn unqual mod rule
 747   = mkWarnMsg silly_loc unqual $
 748     ptext (sLit "Orphan rule:") <+> ppr rule
 749   where
 750     silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0)
 751     -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
 752     -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
 753
 754 ----------------------
 755 -- mkOrphMap partitions instance decls or rules into
 756 --      (a) an OccEnv for ones that are not orphans,
 757 --          mapping the local OccName to a list of its decls
 758 --      (b) a list of orphan decls
 759 mkOrphMap :: (decl -> Maybe OccName)    -- (Just occ) for a non-orphan decl, keyed by occ
 760                                         -- Nothing for an orphan decl
 761           -> [decl]                     -- Sorted into canonical order
 762           -> (OccEnv [decl],            -- Non-orphan decls associated with their key;
 763                                         --      each sublist in canonical order
 764               [decl])                   -- Orphan decls; in canonical order
 765 mkOrphMap get_key decls
 766   = foldl go (emptyOccEnv, []) decls
 767   where
 768     go (non_orphs, orphs) d
 769         | Just occ <- get_key d
 770         = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
 771         | otherwise = (non_orphs, d:orphs)
 772 \end{code}
 773
 774
 775 %*********************************************************
 776 %*                                                      *
 777 \subsection{Keeping track of what we've slurped, and fingerprints}
 778 %*                                                      *
 779 %*********************************************************
 780
 781
 782 \begin{code}
 783 mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
 784 mkUsageInfo hsc_env this_mod dir_imp_mods used_names
 785   = do  { eps <- hscEPS hsc_env
 786         ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
 787                                      dir_imp_mods used_names
 788         ; usages `seqList`  return usages }
 789          -- seq the list of Usages returned: occasionally these
 790          -- don't get evaluated for a while and we can end up hanging on to
 791          -- the entire collection of Ifaces.
 792
 793 mk_usage_info :: PackageIfaceTable
 794               -> HscEnv
 795               -> Module
 796               -> ImportedMods
 797               -> NameSet
 798               -> [Usage]
 799 mk_usage_info pit hsc_env this_mod direct_imports used_names
 800   = mapCatMaybes mkUsage usage_mods
 801   where
 802     hpt = hsc_HPT hsc_env
 803     dflags = hsc_dflags hsc_env
 804     this_pkg = thisPackage dflags
 805
 806     used_mods    = moduleEnvKeys ent_map
 807     dir_imp_mods = (moduleEnvKeys direct_imports)
 808     all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
 809     usage_mods   = sortBy stableModuleCmp all_mods
 810                         -- canonical order is imported, to avoid interface-file
 811                         -- wobblage.
 812
 813     -- ent_map groups together all the things imported and used
 814     -- from a particular module
 815     ent_map :: ModuleEnv [OccName]
 816     ent_map  = foldNameSet add_mv emptyModuleEnv used_names
 817      where
 818       add_mv name mv_map
 819         | isWiredInName name = mv_map  -- ignore wired-in names
 820         | otherwise
 821         = case nameModule_maybe name of
 822              Nothing  -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
 823              Just mod -> -- We use this fiddly lambda function rather than
 824                          -- (++) as the argument to extendModuleEnv_C to
 825                          -- avoid quadratic behaviour (trac #2680)
 826                          extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
 827                    where occ = nameOccName name
 828
 829     -- We want to create a Usage for a home module if
 830     --  a) we used something from it; has something in used_names
 831     --  b) we imported it, even if we used nothing from it
 832     --     (need to recompile if its export list changes: export_fprint)
 833     mkUsage :: Module -> Maybe Usage
 834     mkUsage mod
 835       | isNothing maybe_iface           -- We can't depend on it if we didn't
 836                                         -- load its interface.
 837       || mod == this_mod                -- We don't care about usages of
 838                                         -- things in *this* module
 839       = Nothing
 840
 841       | modulePackageId mod /= this_pkg
 842       = Just UsagePackageModule{ usg_mod      = mod,
 843                                  usg_mod_hash = mod_hash }
 844         -- for package modules, we record the module hash only
 845
 846       | (null used_occs
 847           && isNothing export_hash
 848           && not is_direct_import
 849           && not finsts_mod)
 850       = Nothing                 -- Record no usage info
 851         -- for directly-imported modules, we always want to record a usage
 852         -- on the orphan hash.  This is what triggers a recompilation if
 853         -- an orphan is added or removed somewhere below us in the future.
 854
 855       | otherwise
 856       = Just UsageHomeModule {
 857                       usg_mod_name = moduleName mod,
 858                       usg_mod_hash = mod_hash,
 859                       usg_exports  = export_hash,
 860                       usg_entities = fmToList ent_hashs }
 861       where
 862         maybe_iface  = lookupIfaceByModule dflags hpt pit mod
 863                 -- In one-shot mode, the interfaces for home-package
 864                 -- modules accumulate in the PIT not HPT.  Sigh.
 865
 866         is_direct_import = mod `elemModuleEnv` direct_imports
 867
 868         Just iface   = maybe_iface
 869         finsts_mod   = mi_finsts    iface
 870         hash_env     = mi_hash_fn   iface
 871         mod_hash     = mi_mod_hash  iface
 872         export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
 873                     | otherwise             = Nothing
 874
 875         used_occs = lookupModuleEnv ent_map mod `orElse` []
 876
 877         -- Making a FiniteMap here ensures that (a) we remove duplicates
 878         -- when we have usages on several subordinates of a single parent,
 879         -- and (b) that the usages emerge in a canonical order, which
 880         -- is why we use FiniteMap rather than OccEnv: FiniteMap works
 881         -- using Ord on the OccNames, which is a lexicographic ordering.
 882         ent_hashs :: FiniteMap OccName Fingerprint
 883         ent_hashs = listToFM (map lookup_occ used_occs)
 884
 885         lookup_occ occ =
 886             case hash_env occ of
 887                 Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
 888                 Just r  -> r
 889
 890         depend_on_exports mod =
 891            case lookupModuleEnv direct_imports mod of
 892                 Just _ -> True
 893                   -- Even if we used 'import M ()', we have to register a
 894                   -- usage on the export list because we are sensitive to
 895                   -- changes in orphan instances/rules.
 896                 Nothing -> False
 897                   -- In GHC 6.8.x the above line read "True", and in
 898                   -- fact it recorded a dependency on *all* the
 899                   -- modules underneath in the dependency tree.  This
 900                   -- happens to make orphans work right, but is too
 901                   -- expensive: it'll read too many interface files.
 902                   -- The 'isNothing maybe_iface' check above saved us
 903                   -- from generating many of these usages (at least in
 904                   -- one-shot mode), but that's even more bogus!
 905 \end{code}
 906
 907 \begin{code}
 908 mkIfaceExports :: [AvailInfo]
 909                -> [(Module, [GenAvailInfo OccName])]
 910   -- Group by module and sort by occurrence
 911   -- This keeps the list in canonical order
 912 mkIfaceExports exports
 913   = [ (mod, eltsFM avails)
 914     | (mod, avails) <- fmToList groupFM
 915     ]
 916   where
 917         -- Group by the module where the exported entities are defined
 918         -- (which may not be the same for all Names in an Avail)
 919         -- Deliberately use FiniteMap rather than UniqFM so we
 920         -- get a canonical ordering
 921     groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
 922     groupFM = foldl add emptyModuleEnv exports
 923
 924     add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
 925             -> Module -> GenAvailInfo OccName
 926             -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
 927     add_one env mod avail
 928       =  extendModuleEnv_C plusFM env mod
 929                 (unitFM (occNameFS (availName avail)) avail)
 930
 931         -- NB: we should not get T(X) and T(Y) in the export list
 932         --     else the plusFM will simply discard one!  They
 933         --     should have been combined by now.
 934     add env (Avail n)
 935       = ASSERT( isExternalName n )
 936         add_one env (nameModule n) (Avail (nameOccName n))
 937
 938     add env (AvailTC tc ns)
 939       = ASSERT( all isExternalName ns )
 940         foldl add_for_mod env mods
 941       where
 942         tc_occ = nameOccName tc
 943         mods   = nub (map nameModule ns)
 944                 -- Usually just one, but see Note [Original module]
 945
 946         add_for_mod env mod
 947             = add_one env mod (AvailTC tc_occ (sort names_from_mod))
 948               -- NB. sort the children, we need a canonical order
 949             where
 950               names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
 951 \end{code}
 952
 953 Note [Orignal module]
 954 ~~~~~~~~~~~~~~~~~~~~~
 955 Consider this:
 956         module X where { data family T }
 957         module Y( T(..) ) where { import X; data instance T Int = MkT Int }
 958 The exported Avail from Y will look like
 959         X.T{X.T, Y.MkT}
 960 That is, in Y,
 961   - only MkT is brought into scope by the data instance;
 962   - but the parent (used for grouping and naming in T(..) exports) is X.T
 963   - and in this case we export X.T too
 964
 965 In the result of MkIfaceExports, the names are grouped by defining module,
 966 so we may need to split up a single Avail into multiple ones.
 967
 968
 969 %************************************************************************
 970 %*                                                                      *
 971         Load the old interface file for this module (unless
 972         we have it aleady), and check whether it is up to date
 973
 974 %*                                                                      *
 975 %************************************************************************
 976
 977 \begin{code}
 978 checkOldIface :: HscEnv
 979               -> ModSummary
 980               -> Bool                   -- Source unchanged
 981               -> Maybe ModIface         -- Old interface from compilation manager, if any
 982               -> IO (RecompileRequired, Maybe ModIface)
 983
 984 checkOldIface hsc_env mod_summary source_unchanged maybe_iface
 985   = do  { showPass (hsc_dflags hsc_env)
 986                    ("Checking old interface for " ++
 987                         showSDoc (ppr (ms_mod mod_summary))) ;
 988
 989         ; initIfaceCheck hsc_env $
 990           check_old_iface hsc_env mod_summary source_unchanged maybe_iface
 991      }
 992
 993 check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface
 994                 -> IfG (Bool, Maybe ModIface)
 995 check_old_iface hsc_env mod_summary source_unchanged maybe_iface
 996  =  do  -- CHECK WHETHER THE SOURCE HAS CHANGED
 997     { when (not source_unchanged)
 998            (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 999
1000      -- If the source has changed and we're in interactive mode, avoid reading
1001      -- an interface; just return the one we might have been supplied with.
1002     ; let dflags = hsc_dflags hsc_env
1003     ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
1004          return (outOfDate, maybe_iface)
1005       else
1006       case maybe_iface of {
1007         Just old_iface -> do -- Use the one we already have
1008           { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1009           ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1010           ; return (recomp, Just old_iface) }
1011
1012       ; Nothing -> do
1013
1014         -- Try and read the old interface for the current module
1015         -- from the .hi file left from the last time we compiled it
1016     { let iface_path = msHiFilePath mod_summary
1017     ; read_result <- readIface (ms_mod mod_summary) iface_path False
1018     ; case read_result of {
1019          Failed err -> do       -- Old interface file not found, or garbled; give up
1020                 { traceIf (text "FYI: cannot read old interface file:"
1021                                  $$ nest 4 err)
1022                 ; return (outOfDate, Nothing) }
1023
1024       ;  Succeeded iface -> do
1025
1026         -- We have got the old iface; check its versions
1027     { traceIf (text "Read the interface file" <+> text iface_path)
1028     ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1029     ; return (recomp, Just iface)
1030     }}}}}
1031
1032 \end{code}
1033
1034 @recompileRequired@ is called from the HscMain.   It checks whether
1035 a recompilation is required.  It needs access to the persistent state,
1036 finder, etc, because it may have to load lots of interface files to
1037 check their versions.
1038
1039 \begin{code}
1040 type RecompileRequired = Bool
1041 upToDate, outOfDate :: Bool
1042 upToDate  = False       -- Recompile not required
1043 outOfDate = True        -- Recompile required
1044
1045 checkVersions :: HscEnv
1046               -> Bool           -- True <=> source unchanged
1047               -> ModSummary
1048               -> ModIface       -- Old interface
1049               -> IfG RecompileRequired
1050 checkVersions hsc_env source_unchanged mod_summary iface
1051   | not source_unchanged
1052   = return outOfDate
1053   | otherwise
1054   = do  { traceHiDiffs (text "Considering whether compilation is required for" <+>
1055                         ppr (mi_module iface) <> colon)
1056
1057         ; recomp <- checkDependencies hsc_env mod_summary iface
1058         ; if recomp then return outOfDate else do {
1059
1060         -- Source code unchanged and no errors yet... carry on
1061         --
1062         -- First put the dependent-module info, read from the old
1063         -- interface, into the envt, so that when we look for
1064         -- interfaces we look for the right one (.hi or .hi-boot)
1065         --
1066         -- It's just temporary because either the usage check will succeed
1067         -- (in which case we are done with this module) or it'll fail (in which
1068         -- case we'll compile the module from scratch anyhow).
1069         --
1070         -- We do this regardless of compilation mode, although in --make mode
1071         -- all the dependent modules should be in the HPT already, so it's
1072         -- quite redundant
1073           updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
1074
1075         ; let this_pkg = thisPackage (hsc_dflags hsc_env)
1076         ; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1077     }}
1078   where
1079         -- This is a bit of a hack really
1080     mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1081     mod_deps = mkModDeps (dep_mods (mi_deps iface))
1082
1083
1084 -- If the direct imports of this module are resolved to targets that
1085 -- are not among the dependencies of the previous interface file,
1086 -- then we definitely need to recompile.  This catches cases like
1087 --   - an exposed package has been upgraded
1088 --   - we are compiling with different package flags
1089 --   - a home module that was shadowing a package module has been removed
1090 --   - a new home module has been added that shadows a package module
1091 -- See bug #1372.
1092 --
1093 -- Returns True if recompilation is required.
1094 checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
1095 checkDependencies hsc_env summary iface
1096  = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
1097   where
1098    prev_dep_mods = dep_mods (mi_deps iface)
1099    prev_dep_pkgs = dep_pkgs (mi_deps iface)
1100
1101    this_pkg = thisPackage (hsc_dflags hsc_env)
1102
1103    orM = foldr f (return False)
1104     where f m rest = do b <- m; if b then return True else rest
1105
1106    dep_missing (L _ mod) = do
1107      find_res <- liftIO $ findImportedModule hsc_env mod Nothing
1108      case find_res of
1109         Found _ mod
1110           | pkg == this_pkg
1111            -> if moduleName mod `notElem` map fst prev_dep_mods
1112                  then do traceHiDiffs $
1113                            text "imported module " <> quotes (ppr mod) <>
1114                            text " not among previous dependencies"
1115                          return outOfDate
1116                  else
1117                          return upToDate
1118           | otherwise
1119            -> if pkg `notElem` prev_dep_pkgs
1120                  then do traceHiDiffs $
1121                            text "imported module " <> quotes (ppr mod) <>
1122                            text " is from package " <> quotes (ppr pkg) <>
1123                            text ", which is not among previous dependencies"
1124                          return outOfDate
1125                  else
1126                          return upToDate
1127            where pkg = modulePackageId mod
1128         _otherwise  -> return outOfDate
1129
1130 needInterface :: Module -> (ModIface -> IfG RecompileRequired)
1131               -> IfG RecompileRequired
1132 needInterface mod continue
1133   = do  -- Load the imported interface if possible
1134     let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
1135     traceHiDiffs (text "Checking usages for module" <+> ppr mod)
1136
1137     mb_iface <- loadInterface doc_str mod ImportBySystem
1138         -- Load the interface, but don't complain on failure;
1139         -- Instead, get an Either back which we can test
1140
1141     case mb_iface of
1142       Failed _ ->  (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
1143                                       ppr mod]))
1144                   -- Couldn't find or parse a module mentioned in the
1145                   -- old interface file.  Don't complain: it might
1146                   -- just be that the current module doesn't need that
1147                   -- import and it's been deleted
1148       Succeeded iface -> continue iface
1149
1150
1151 checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1152 -- Given the usage information extracted from the old
1153 -- M.hi file for the module being compiled, figure out
1154 -- whether M needs to be recompiled.
1155
1156 checkModUsage _this_pkg UsagePackageModule{
1157                                 usg_mod = mod,
1158                                 usg_mod_hash = old_mod_hash }
1159   = needInterface mod $ \iface -> do
1160     checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
1161         -- We only track the ABI hash of package modules, rather than
1162         -- individual entity usages, so if the ABI hash changes we must
1163         -- recompile.  This is safe but may entail more recompilation when
1164         -- a dependent package has changed.
1165
1166 checkModUsage this_pkg UsageHomeModule{
1167                                 usg_mod_name = mod_name,
1168                                 usg_mod_hash = old_mod_hash,
1169                                 usg_exports = maybe_old_export_hash,
1170                                 usg_entities = old_decl_hash }
1171   = do
1172     let mod = mkModule this_pkg mod_name
1173     needInterface mod $ \iface -> do
1174
1175     let
1176         new_mod_hash    = mi_mod_hash    iface
1177         new_decl_hash   = mi_hash_fn     iface
1178         new_export_hash = mi_exp_hash    iface
1179
1180         -- CHECK MODULE
1181     recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
1182     if not recompile then return upToDate else do
1183
1184         -- CHECK EXPORT LIST
1185     checkMaybeHash maybe_old_export_hash new_export_hash
1186         (ptext (sLit "  Export list changed")) $ do
1187
1188         -- CHECK ITEMS ONE BY ONE
1189     recompile <- checkList [ checkEntityUsage new_decl_hash u
1190                            | u <- old_decl_hash]
1191     if recompile
1192       then return outOfDate     -- This one failed, so just bail out now
1193       else up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
1194
1195 ------------------------
1196 checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
1197 checkModuleFingerprint old_mod_hash new_mod_hash
1198   | new_mod_hash == old_mod_hash
1199   = up_to_date (ptext (sLit "Module fingerprint unchanged"))
1200
1201   | otherwise
1202   = out_of_date_hash (ptext (sLit "  Module fingerprint has changed"))
1203                      old_mod_hash new_mod_hash
1204
1205 ------------------------
1206 checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
1207                -> IfG RecompileRequired -> IfG RecompileRequired
1208 checkMaybeHash maybe_old_hash new_hash doc continue
1209   | Just hash <- maybe_old_hash, hash /= new_hash
1210   = out_of_date_hash doc hash new_hash
1211   | otherwise
1212   = continue
1213
1214 ------------------------
1215 checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
1216                  -> (OccName, Fingerprint)
1217                  -> IfG Bool
1218 checkEntityUsage new_hash (name,old_hash)
1219   = case new_hash name of
1220
1221         Nothing       ->        -- We used it before, but it ain't there now
1222                           out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
1223
1224         Just (_, new_hash)      -- It's there, but is it up to date?
1225           | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
1226                                        return upToDate
1227           | otherwise            -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
1228                                                      old_hash new_hash
1229
1230 up_to_date, out_of_date :: SDoc -> IfG Bool
1231 up_to_date  msg = traceHiDiffs msg >> return upToDate
1232 out_of_date msg = traceHiDiffs msg >> return outOfDate
1233
1234 out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
1235 out_of_date_hash msg old_hash new_hash
1236   = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
1237
1238 ----------------------
1239 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
1240 -- This helper is used in two places
1241 checkList []             = return upToDate
1242 checkList (check:checks) = do recompile <- check
1243                               if recompile
1244                                 then return outOfDate
1245                                 else checkList checks
1246 \end{code}
1247
1248 %************************************************************************
1249 %*                                                                      *
1250                 Converting things to their Iface equivalents
1251 %*                                                                      *
1252 %************************************************************************
1253
1254 \begin{code}
1255 tyThingToIfaceDecl :: TyThing -> IfaceDecl
1256 -- Assumption: the thing is already tidied, so that locally-bound names
1257 --             (lambdas, for-alls) already have non-clashing OccNames
1258 -- Reason: Iface stuff uses OccNames, and the conversion here does
1259 --         not do tidying on the way
1260 tyThingToIfaceDecl (AnId id)
1261   = IfaceId { ifName   = getOccName id,
1262               ifType   = toIfaceType (idType id),
1263               ifIdInfo = info }
1264   where
1265     info = case toIfaceIdInfo (idInfo id) of
1266                 []    -> NoInfo
1267                 items -> HasInfo items
1268
1269 tyThingToIfaceDecl (AClass clas)
1270   = IfaceClass { ifCtxt   = toIfaceContext sc_theta,
1271                  ifName   = getOccName clas,
1272                  ifTyVars = toIfaceTvBndrs clas_tyvars,
1273                  ifFDs    = map toIfaceFD clas_fds,
1274                  ifATs    = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1275                  ifSigs   = map toIfaceClassOp op_stuff,
1276                  ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
1277   where
1278     (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff)
1279       = classExtraBigSig clas
1280     tycon = classTyCon clas
1281
1282     toIfaceClassOp (sel_id, def_meth)
1283         = ASSERT(sel_tyvars == clas_tyvars)
1284           IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1285         where
1286                 -- Be careful when splitting the type, because of things
1287                 -- like         class Foo a where
1288                 --                op :: (?x :: String) => a -> a
1289                 -- and          class Baz a where
1290                 --                op :: (Ord a) => a -> a
1291           (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
1292           op_ty                = funResultTy rho_ty
1293
1294     toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1295
1296 tyThingToIfaceDecl (ATyCon tycon)
1297   | isSynTyCon tycon
1298   = IfaceSyn {  ifName    = getOccName tycon,
1299                 ifTyVars  = toIfaceTvBndrs tyvars,
1300                 ifSynRhs  = syn_rhs,
1301                 ifSynKind = syn_ki,
1302                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
1303              }
1304
1305   | isAlgTyCon tycon
1306   = IfaceData { ifName    = getOccName tycon,
1307                 ifTyVars  = toIfaceTvBndrs tyvars,
1308                 ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
1309                 ifCons    = ifaceConDecls (algTyConRhs tycon),
1310                 ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
1311                 ifGadtSyntax = isGadtSyntaxTyCon tycon,
1312                 ifGeneric = tyConHasGenerics tycon,
1313                 ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1314
1315   | isForeignTyCon tycon
1316   = IfaceForeign { ifName    = getOccName tycon,
1317                    ifExtName = tyConExtName tycon }
1318
1319   | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1320   where
1321     tyvars = tyConTyVars tycon
1322     (syn_rhs, syn_ki)
1323        = case synTyConRhs tycon of
1324             OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
1325             SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
1326
1327     ifaceConDecls (NewTyCon { data_con = con })     =
1328       IfNewTyCon  (ifaceConDecl con)
1329     ifaceConDecls (DataTyCon { data_cons = cons })  =
1330       IfDataTyCon (map ifaceConDecl cons)
1331     ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
1332     ifaceConDecls AbstractTyCon                     = IfAbstractTyCon
1333         -- The last case happens when a TyCon has been trimmed during tidying
1334         -- Furthermore, tyThingToIfaceDecl is also used
1335         -- in TcRnDriver for GHCi, when browsing a module, in which case the
1336         -- AbstractTyCon case is perfectly sensible.
1337
1338     ifaceConDecl data_con
1339         = IfCon   { ifConOcc     = getOccName (dataConName data_con),
1340                     ifConInfix   = dataConIsInfix data_con,
1341                     ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
1342                     ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
1343                     ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
1344                     ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1345                     ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
1346                     ifConFields  = map getOccName
1347                                        (dataConFieldLabels data_con),
1348                     ifConStricts = dataConStrictMarks data_con }
1349
1350     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1351
1352     famInstToIface Nothing                    = Nothing
1353     famInstToIface (Just (famTyCon, instTys)) =
1354       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1355
1356 tyThingToIfaceDecl (ADataCon dc)
1357  = pprPanic "toIfaceDecl" (ppr dc)      -- Should be trimmed out earlier
1358
1359
1360 getFS :: NamedThing a => a -> FastString
1361 getFS x = occNameFS (getOccName x)
1362
1363 --------------------------
1364 instanceToIfaceInst :: Instance -> IfaceInst
1365 instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
1366                                 is_cls = cls_name, is_tcs = mb_tcs })
1367   = ASSERT( cls_name == className cls )
1368     IfaceInst { ifDFun    = dfun_name,
1369                 ifOFlag   = oflag,
1370                 ifInstCls = cls_name,
1371                 ifInstTys = map do_rough mb_tcs,
1372                 ifInstOrph = orph }
1373   where
1374     do_rough Nothing  = Nothing
1375     do_rough (Just n) = Just (toIfaceTyCon_name n)
1376
1377     dfun_name = idName dfun_id
1378     mod       = ASSERT( isExternalName dfun_name ) nameModule dfun_name
1379     is_local name = nameIsLocalOrFrom mod name
1380
1381         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1382     (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
1383                 -- Slightly awkward: we need the Class to get the fundeps
1384     (tvs, fds) = classTvsFds cls
1385     arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
1386     orph | is_local cls_name = Just (nameOccName cls_name)
1387          | all isJust mb_ns  = head mb_ns
1388          | otherwise         = Nothing
1389
1390     mb_ns :: [Maybe OccName]    -- One for each fundep; a locally-defined name
1391                                 -- that is not in the "determined" arguments
1392     mb_ns | null fds   = [choose_one arg_names]
1393           | otherwise  = map do_one fds
1394     do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
1395                                           , not (tv `elem` rtvs)]
1396
1397     choose_one :: [NameSet] -> Maybe OccName
1398     choose_one nss = case nameSetToList (unionManyNameSets nss) of
1399                         []      -> Nothing
1400                         (n : _) -> Just (nameOccName n)
1401
1402 --------------------------
1403 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
1404 famInstToIfaceFamInst (FamInst { fi_tycon = tycon,
1405                                  fi_fam = fam,
1406                                  fi_tcs = mb_tcs })
1407   = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
1408                  , ifFamInstFam    = fam
1409                  , ifFamInstTys    = map do_rough mb_tcs }
1410   where
1411     do_rough Nothing  = Nothing
1412     do_rough (Just n) = Just (toIfaceTyCon_name n)
1413
1414 --------------------------
1415 toIfaceLetBndr :: Id -> IfaceLetBndr
1416 toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
1417                                (toIfaceType (idType id))
1418                                prag_info
1419   where
1420         -- Stripped-down version of tcIfaceIdInfo
1421         -- Change this if you want to export more IdInfo for
1422         -- non-top-level Ids.  Don't forget to change
1423         -- CoreTidy.tidyLetBndr too!
1424         --
1425         -- See Note [IdInfo on nested let-bindings] in IfaceSyn
1426     id_info = idInfo id
1427     inline_prag = inlinePragInfo id_info
1428     prag_info | isAlwaysActive inline_prag = NoInfo
1429               | otherwise                  = HasInfo [HsInline inline_prag]
1430
1431 --------------------------
1432 toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
1433 toIfaceIdInfo id_info
1434   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
1435                inline_hsinfo, wrkr_hsinfo,  unfold_hsinfo]
1436   where
1437     ------------  Arity  --------------
1438     arity_info = arityInfo id_info
1439     arity_hsinfo | arity_info == 0 = Nothing
1440                  | otherwise       = Just (HsArity arity_info)
1441
1442     ------------ Caf Info --------------
1443     caf_info   = cafInfo id_info
1444     caf_hsinfo = case caf_info of
1445                    NoCafRefs -> Just HsNoCafRefs
1446                    _other    -> Nothing
1447
1448     ------------  Strictness  --------------
1449         -- No point in explicitly exporting TopSig
1450     strict_hsinfo = case newStrictnessInfo id_info of
1451                         Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
1452                         _other                        -> Nothing
1453
1454     ------------  Worker  --------------
1455     work_info   = workerInfo id_info
1456     has_worker  = workerExists work_info
1457     wrkr_hsinfo = case work_info of
1458                     HasWorker work_id wrap_arity ->
1459                         Just (HsWorker ((idName work_id)) wrap_arity)
1460                     NoWorker -> Nothing
1461
1462     ------------  Unfolding  --------------
1463     -- The unfolding is redundant if there is a worker
1464     unfold_info  = unfoldingInfo id_info
1465     rhs          = unfoldingTemplate unfold_info
1466     no_unfolding = neverUnfold unfold_info
1467                         -- The CoreTidy phase retains unfolding info iff
1468                         -- we want to expose the unfolding, taking into account
1469                         -- unconditional NOINLINE, etc.  See TidyPgm.addExternal
1470     unfold_hsinfo | no_unfolding = Nothing
1471                   | has_worker   = Nothing      -- Unfolding is implicit
1472                   | otherwise    = Just (HsUnfold (toIfaceExpr rhs))
1473
1474     ------------  Inline prag  --------------
1475     inline_prag = inlinePragInfo id_info
1476     inline_hsinfo | isAlwaysActive inline_prag     = Nothing
1477                   | no_unfolding && not has_worker = Nothing
1478                         -- If the iface file give no unfolding info, we
1479                         -- don't need to say when inlining is OK!
1480                   | otherwise                      = Just (HsInline inline_prag)
1481
1482 --------------------------
1483 coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
1484 coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
1485   = pprTrace "toHsRule: builtin" (ppr fn) $
1486     bogusIfaceRule fn
1487
1488 coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
1489                                 ru_act = act, ru_bndrs = bndrs,
1490                                 ru_args = args, ru_rhs = rhs })
1491   = IfaceRule { ifRuleName  = name, ifActivation = act,
1492                 ifRuleBndrs = map toIfaceBndr bndrs,
1493                 ifRuleHead  = fn,
1494                 ifRuleArgs  = map do_arg args,
1495                 ifRuleRhs   = toIfaceExpr rhs,
1496                 ifRuleOrph  = orph }
1497   where
1498         -- For type args we must remove synonyms from the outermost
1499         -- level.  Reason: so that when we read it back in we'll
1500         -- construct the same ru_rough field as we have right now;
1501         -- see tcIfaceRule
1502     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
1503     do_arg arg       = toIfaceExpr arg
1504
1505         -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
1506         -- A rule is an orphan only if none of the variables
1507         -- mentioned on its left-hand side are locally defined
1508     lhs_names = fn : nameSetToList (exprsFreeNames args)
1509                 -- No need to delete bndrs, because
1510                 -- exprsFreeNames finds only External names
1511
1512     orph = case filter (nameIsLocalOrFrom mod) lhs_names of
1513                         (n : _) -> Just (nameOccName n)
1514                         []      -> Nothing
1515
1516 bogusIfaceRule :: Name -> IfaceRule
1517 bogusIfaceRule id_name
1518   = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
1519         ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
1520         ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
1521
1522 ---------------------
1523 toIfaceExpr :: CoreExpr -> IfaceExpr
1524 toIfaceExpr (Var v)       = toIfaceVar v
1525 toIfaceExpr (Lit l)       = IfaceLit l
1526 toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
1527 toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
1528 toIfaceExpr (App f a)     = toIfaceApp f [a]
1529 toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
1530 toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
1531 toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
1532 toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
1533
1534 ---------------------
1535 toIfaceNote :: Note -> IfaceNote
1536 toIfaceNote (SCC cc)      = IfaceSCC cc
1537 toIfaceNote InlineMe      = IfaceInlineMe
1538 toIfaceNote (CoreNote s)  = IfaceCoreNote s
1539
1540 ---------------------
1541 toIfaceBind :: Bind Id -> IfaceBinding
1542 toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)
1543 toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]
1544
1545 ---------------------
1546 toIfaceAlt :: (AltCon, [Var], CoreExpr)
1547            -> (IfaceConAlt, [FastString], IfaceExpr)
1548 toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
1549
1550 ---------------------
1551 toIfaceCon :: AltCon -> IfaceConAlt
1552 toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
1553                         | otherwise       = IfaceDataAlt (getName dc)
1554                         where
1555                           tc = dataConTyCon dc
1556
1557 toIfaceCon (LitAlt l) = IfaceLitAlt l
1558 toIfaceCon DEFAULT    = IfaceDefault
1559
1560 ---------------------
1561 toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
1562 toIfaceApp (App f a) as = toIfaceApp f (a:as)
1563 toIfaceApp (Var v) as
1564   = case isDataConWorkId_maybe v of
1565         -- We convert the *worker* for tuples into IfaceTuples
1566         Just dc |  isTupleTyCon tc && saturated
1567                 -> IfaceTuple (tupleTyConBoxity tc) tup_args
1568           where
1569             val_args  = dropWhile isTypeArg as
1570             saturated = val_args `lengthIs` idArity v
1571             tup_args  = map toIfaceExpr val_args
1572             tc        = dataConTyCon dc
1573
1574         _ -> mkIfaceApps (toIfaceVar v) as
1575
1576 toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as
1577
1578 mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr
1579 mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
1580
1581 ---------------------
1582 toIfaceVar :: Id -> IfaceExpr
1583 toIfaceVar v
1584   | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
1585           -- Foreign calls have special syntax
1586   | isExternalName name             = IfaceExt name
1587   | Just (TickBox m ix) <- isTickBoxOp_maybe v
1588                                     = IfaceTick m ix
1589   | otherwise                       = IfaceLcl (getFS name)
1590   where
1591     name = idName v
1592 \end{code}