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