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