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