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