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