ghc/compiler/main/MkIface.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[MkIface]{Print an interface for a module}
   5
   6 \begin{code}
   7 module MkIface (
   8         mkModDetails, mkModDetailsFromIface, completeIface
   9   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn
  14 import HsCore           ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr )
  15 import HsTypes          ( toHsTyVars )
  16 import BasicTypes       ( Fixity(..), NewOrData(..),
  17                           Version, bumpVersion, isLoopBreaker
  18                         )
  19 import RnMonad
  20 import RnHsSyn          ( RenamedInstDecl, RenamedTyClDecl )
  21 import TcHsSyn          ( TypecheckedRuleDecl )
  22 import HscTypes         ( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
  23                           TyThing(..), DFunId, TypeEnv, isTyClThing
  24                         )
  25
  26 import CmdLineOpts
  27 import Id               ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding,
  28                           idSpecialisation, idName, setIdInfo
  29                         )
  30 import Var              ( isId )
  31 import VarSet
  32 import DataCon          ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStrictMarks )
  33 import IdInfo           -- Lots
  34 import CoreSyn          ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule,
  35                           isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules,
  36                           bindersOfBinds
  37                         )
  38 import CoreFVs          ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
  39 import CoreUnfold       ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding )
  40 import Name             ( isLocallyDefined, getName,
  41                           Name, NamedThing(..),
  42                           plusNameEnv, lookupNameEnv, emptyNameEnv, mkNameEnv,
  43                           extendNameEnv, lookupNameEnv_NF, nameEnvElts
  44                         )
  45 import TyCon            ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon,
  46                           tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize
  47                         )
  48 import Class            ( classExtraBigSig, DefMeth(..) )
  49 import FieldLabel       ( fieldLabelType )
  50 import Type             ( splitSigmaTy, tidyTopType, deNoteType )
  51 import SrcLoc           ( noSrcLoc )
  52 import Outputable
  53
  54 import List             ( partition )
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Write a new interface file}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 \begin{code}
  65 mkModDetails :: TypeEnv -> [DFunId]     -- From typechecker
  66              -> [CoreBind] -> [Id]      -- Final bindings, plus the top-level Ids from the
  67                                         -- code generator; they have authoritative arity info
  68              -> [IdCoreRule]            -- Tidy orphan rules
  69              -> ModDetails
  70 mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules
  71   = ModDetails { md_types = new_type_env,
  72                  md_rules = rule_dcls,
  73                  md_insts = dfun_ids }
  74   where
  75         -- The competed type environment is gotten from
  76         --      a) keeping the types and classes
  77         --      b) removing all Ids, and Ids with correct IdInfo
  78         --              gotten from the bindings
  79     new_type_env = mkNameEnv [(getName tycl, tycl) | tycl <- orig_type_env, isTyClThing tycl]
  80                         `plusNameEnv`
  81                    mkNameEnv [(idName id, AnId id) | id <- final_ids]
  82
  83     orig_type_env = nameEnvElts type_env
  84
  85     final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
  86                            (mkVarSet stg_ids)
  87                            tidy_binds
  88
  89         -- The complete rules are gotten by combining
  90         --      a) the orphan rules
  91         --      b) rules embedded in the top-level Ids
  92     rule_dcls | opt_OmitInterfacePragmas = []
  93               | otherwise                 = getRules orphan_rules tidy_binds (mkVarSet final_ids)
  94
  95     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
  96                                    | (_, rule) <- orphan_rules]
  97
  98
  99 -- This version is used when we are re-linking a module
 100 -- so we've only run the type checker on its previous interface
 101 mkModDetailsFromIface :: TypeEnv -> [DFunId]    -- From typechecker
 102                       -> [TypecheckedRuleDecl]
 103                       -> ModDetails
 104 mkModDetailsFromIface type_env dfun_ids rules
 105   = ModDetails { md_types = type_env,
 106                  md_rules = rule_dcls,
 107                  md_insts = dfun_ids }
 108   where
 109     rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
 110         -- All the rules from an interface are of the IfaceRuleOut form
 111
 112 completeIface :: Maybe ModIface         -- The old interface, if we have it
 113               -> ModIface               -- The new one, minus the decls and versions
 114               -> ModDetails             -- The ModDetails for this module
 115               -> Maybe (ModIface, SDoc) -- The new one, complete with decls and versions
 116                                         -- The SDoc is a debug document giving differences
 117                                         -- Nothing => no change
 118
 119         -- NB: 'Nothing' means that even the usages havn't changed, so there's no
 120         --     need to write a new interface file.  But even if the usages have
 121         --     changed, the module version may not have.
 122         --
 123         -- The IO in the type is solely for debug output
 124         -- In particular, dumping a record of what has changed
 125 completeIface maybe_old_iface new_iface mod_details
 126   = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
 127   where
 128      new_decls = IfaceDecls { dcl_tycl  = ty_cls_dcls,
 129                               dcl_insts = inst_dcls,
 130                               dcl_rules = rule_dcls }
 131
 132      inst_dcls   = map ifaceInstance (md_insts mod_details)
 133      ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types mod_details))
 134      rule_dcls   = map ifaceRule (md_rules mod_details)
 135 \end{code}
 136
 137
 138 %************************************************************************
 139 %*                                                                      *
 140 \subsection{Types and classes}
 141 %*                                                                      *
 142 %************************************************************************
 143
 144 \begin{code}
 145 ifaceTyCls :: TyThing -> RenamedTyClDecl
 146 ifaceTyCls (AClass clas)
 147   = ClassDecl (toHsContext sc_theta)
 148               (getName clas)
 149               (toHsTyVars clas_tyvars)
 150               (toHsFDs clas_fds)
 151               (map toClassOpSig op_stuff)
 152               EmptyMonoBinds
 153               [] noSrcLoc
 154   where
 155      (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
 156
 157      toClassOpSig (sel_id, def_meth)
 158         = ASSERT(sel_tyvars == clas_tyvars)
 159           ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
 160         where
 161           (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
 162           def_meth' = case def_meth of
 163                          NoDefMeth  -> NoDefMeth
 164                          GenDefMeth -> GenDefMeth
 165                          DefMeth id -> DefMeth (getName id)
 166
 167 ifaceTyCls (ATyCon tycon)
 168   | isSynTyCon tycon
 169   = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
 170   where
 171     (tyvars, ty) = getSynTyConDefn tycon
 172
 173 ifaceTyCls (ATyCon tycon)
 174   | isAlgTyCon tycon
 175   = TyData new_or_data (toHsContext (tyConTheta tycon))
 176            (getName tycon)
 177            (toHsTyVars tyvars)
 178            (map ifaceConDecl (tyConDataCons tycon))
 179            (tyConFamilySize tycon)
 180            Nothing noSrcLoc (panic "gen1") (panic "gen2")
 181   where
 182     tyvars = tyConTyVars tycon
 183     new_or_data | isNewTyCon tycon = NewType
 184                 | otherwise        = DataType
 185
 186     ifaceConDecl data_con
 187         = ConDecl (getName data_con) (error "ifaceConDecl")
 188                   (toHsTyVars ex_tyvars)
 189                   (toHsContext ex_theta)
 190                   details noSrcLoc
 191         where
 192           (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
 193           field_labels   = dataConFieldLabels data_con
 194           strict_marks   = dataConStrictMarks data_con
 195           details | null field_labels
 196                   = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
 197                     VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
 198
 199                   | otherwise
 200                   = RecCon (zipWith mk_field strict_marks field_labels)
 201
 202     mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
 203     mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
 204     mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
 205
 206     mk_field strict_mark field_label
 207         = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
 208
 209 ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
 210
 211 ifaceTyCls (AnId id)
 212   = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
 213   where
 214     id_type = idType id
 215     id_info = idInfo id
 216
 217     hs_idinfo | opt_OmitInterfacePragmas = []
 218               | otherwise                = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++
 219                                            strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
 220
 221     ------------  Arity  --------------
 222     arity_hsinfo = case arityInfo id_info of
 223                         a@(ArityExactly n) -> [HsArity a]
 224                         other              -> []
 225
 226     ------------ Caf Info --------------
 227     caf_hsinfo = case cafInfo id_info of
 228                    NoCafRefs -> [HsNoCafRefs]
 229                    otherwise -> []
 230
 231     ------------ CPR Info --------------
 232     cpr_hsinfo = case cprInfo id_info of
 233                    ReturnsCPR -> [HsCprInfo]
 234                    NoCPRInfo  -> []
 235
 236     ------------  Strictness  --------------
 237     strict_hsinfo = case strictnessInfo id_info of
 238                         NoStrictnessInfo -> []
 239                         info             -> [HsStrictness info]
 240
 241
 242     ------------  Worker  --------------
 243     wrkr_hsinfo = case workerInfo id_info of
 244                     HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
 245                     NoWorker                     -> []
 246
 247     ------------  Unfolding  --------------
 248     unfold_info = unfoldingInfo id_info
 249     inline_prag = inlinePragInfo id_info
 250     rhs         = unfoldingTemplate unfold_info
 251     unfold_hsinfo | neverUnfold unfold_info = []
 252                   | otherwise               = [HsUnfold inline_prag (toUfExpr rhs)]
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsection{Instances and rules}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 ifaceInstance :: DFunId -> RenamedInstDecl
 264 ifaceInstance dfun_id
 265   = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc
 266   where
 267     tidy_ty = tidyTopType (deNoteType (idType dfun_id))
 268                 -- The deNoteType is very important.   It removes all type
 269                 -- synonyms from the instance type in interface files.
 270                 -- That in turn makes sure that when reading in instance decls
 271                 -- from interface files that the 'gating' mechanism works properly.
 272                 -- Otherwise you could have
 273                 --      type Tibble = T Int
 274                 --      instance Foo Tibble where ...
 275                 -- and this instance decl wouldn't get imported into a module
 276                 -- that mentioned T but not Tibble.
 277
 278 ifaceRule (id, BuiltinRule _)
 279   = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
 280
 281 ifaceRule (id, Rule name bndrs args rhs)
 282   = IfaceRule name (map toUfBndr bndrs) (getName id)
 283               (map toUfExpr args) (toUfExpr rhs) noSrcLoc
 284
 285 bogusIfaceRule id
 286   = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Compute final Ids}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 A "final Id" has exactly the IdInfo for going into an interface file, or
 297 exporting to another module.
 298
 299 \begin{code}
 300 bindsToIds :: IdSet             -- These Ids are needed already
 301            -> IdSet             -- Ids used at code-gen time; they have better pragma info!
 302            -> [CoreBind]        -- In dependency order, later depend on earlier
 303            -> [Id]              -- Set of Ids actually spat out, complete with exactly the IdInfo
 304                                 -- they need for exporting to another module
 305
 306 bindsToIds needed_ids codegen_ids binds
 307   = go needed_ids (reverse binds) []
 308                 -- Reverse so that later things will
 309                 -- provoke earlier ones to be emitted
 310   where
 311         -- The 'needed' set contains the Ids that are needed by earlier
 312         -- interface file emissions.  If the Id isn't in this set, and isn't
 313         -- exported, there's no need to emit anything
 314     need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id
 315
 316     go needed [] emitted
 317         | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
 318                                           (sep (map ppr (varSetElems needed)))
 319                                        emitted
 320         | otherwise                  = emitted
 321
 322     go needed (NonRec id rhs : binds) emitted
 323         | need_id needed id
 324         = if omitIfaceSigForId id then
 325             go (needed `delVarSet` id) binds (id:emitted)
 326           else
 327             go ((needed `unionVarSet` extras) `delVarSet` id)
 328                binds
 329                (new_id:emitted)
 330         | otherwise
 331         = go needed binds emitted
 332         where
 333           (new_id, extras) = mkFinalId codegen_ids False id rhs
 334
 335         -- Recursive groups are a bit more of a pain.  We may only need one to
 336         -- start with, but it may call out the next one, and so on.  So we
 337         -- have to look for a fixed point.  We don't want necessarily them all,
 338         -- because without -O we may only need the first one (if we don't emit
 339         -- its unfolding)
 340     go needed (Rec pairs : binds) emitted
 341         = go needed' binds emitted'
 342         where
 343           (new_emitted, extras) = go_rec needed pairs
 344           needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
 345           emitted' = new_emitted ++ emitted
 346
 347     go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
 348     go_rec needed pairs
 349         | null needed_prs = ([], emptyVarSet)
 350         | otherwise       = (emitted ++           more_emitted,
 351                              extras `unionVarSet` more_extras)
 352         where
 353           (needed_prs,leftover_prs)   = partition is_needed pairs
 354           (emitted, extras_s)         = unzip [ mkFinalId codegen_ids True id rhs
 355                                               | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
 356           extras                      = unionVarSets extras_s
 357           (more_emitted, more_extras) = go_rec extras leftover_prs
 358
 359           is_needed (id,_) = need_id needed id
 360 \end{code}
 361
 362
 363
 364 \begin{code}
 365 mkFinalId :: IdSet              -- The Ids with arity info from the code generator
 366           -> Bool                       -- True <=> recursive, so don't include unfolding
 367           -> Id
 368           -> CoreExpr           -- The Id's right hand side
 369           -> (Id, IdSet)                -- The emitted id, plus any *extra* needed Ids
 370
 371 mkFinalId codegen_ids is_rec id rhs
 372   = (id `setIdInfo` new_idinfo, new_needed_ids)
 373   where
 374     core_idinfo = idInfo id
 375     stg_idinfo  = case lookupVarSet codegen_ids id of
 376                         Just id' -> idInfo id'
 377                         Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
 378                                     idInfo id
 379
 380     new_idinfo | opt_OmitInterfacePragmas
 381                = vanillaIdInfo
 382                | otherwise
 383                = core_idinfo `setArityInfo`      arity_info
 384                              `setCafInfo`        cafInfo stg_idinfo
 385                              `setUnfoldingInfo`  unfold_info
 386                              `setWorkerInfo`     worker_info
 387                              `setSpecInfo`       emptyCoreRules
 388         -- We zap the specialisations because they are
 389         -- passed on separately through the modules IdCoreRules
 390
 391     ------------  Arity  --------------
 392     arity_info = arityInfo stg_idinfo
 393     stg_arity  = arityLowerBound arity_info
 394
 395     ------------  Worker  --------------
 396         -- We only treat a function as having a worker if
 397         -- the exported arity (which is now the number of visible lambdas)
 398         -- is the same as the arity at the moment of the w/w split
 399         -- If so, we can safely omit the unfolding inside the wrapper, and
 400         -- instead re-generate it from the type/arity/strictness info
 401         -- But if the arity has changed, we just take the simple path and
 402         -- put the unfolding into the interface file, forgetting the fact
 403         -- that it's a wrapper.
 404         --
 405         -- How can this happen?  Sometimes we get
 406         --      f = coerce t (\x y -> $wf x y)
 407         -- at the moment of w/w split; but the eta reducer turns it into
 408         --      f = coerce t $wf
 409         -- which is perfectly fine except that the exposed arity so far as
 410         -- the code generator is concerned (zero) differs from the arity
 411         -- when we did the split (2).
 412         --
 413         -- All this arises because we use 'arity' to mean "exactly how many
 414         -- top level lambdas are there" in interface files; but during the
 415         -- compilation of this module it means "how many things can I apply
 416         -- this to".
 417     worker_info = case workerInfo core_idinfo of
 418                      info@(HasWorker work_id wrap_arity)
 419                         | wrap_arity == stg_arity -> info
 420                         | otherwise               -> pprTrace "ifaceId: arity change:" (ppr id)
 421                                                      NoWorker
 422                      NoWorker                     -> NoWorker
 423
 424     has_worker = case worker_info of
 425                    HasWorker _ _ -> True
 426                    other         -> False
 427
 428     HasWorker work_id _ = worker_info
 429
 430     ------------  Unfolding  --------------
 431     inline_pragma  = inlinePragInfo core_idinfo
 432     dont_inline    = isNeverInlinePrag inline_pragma
 433     loop_breaker   = isLoopBreaker (occInfo core_idinfo)
 434     bottoming_fn   = isBottomingStrictness (strictnessInfo core_idinfo)
 435
 436     unfolding    = mkTopUnfolding rhs
 437     rhs_is_small = neverUnfold unfolding
 438
 439     unfold_info | show_unfold = unfolding
 440                 | otherwise   = noUnfolding
 441
 442     show_unfold = not has_worker         &&     -- Not unnecessary
 443                   not bottoming_fn       &&     -- Not necessary
 444                   not dont_inline        &&
 445                   not loop_breaker       &&
 446                   rhs_is_small           &&     -- Small enough
 447                   okToUnfoldInHiFile rhs        -- No casms etc
 448
 449
 450     ------------  Extra free Ids  --------------
 451     new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
 452                    | otherwise                = worker_ids      `unionVarSet`
 453                                                 unfold_ids      `unionVarSet`
 454                                                 spec_ids
 455
 456     spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))
 457
 458     worker_ids | has_worker && interestingId work_id = unitVarSet work_id
 459                         -- Conceivably, the worker might come from
 460                         -- another module
 461                | otherwise = emptyVarSet
 462
 463     unfold_ids | show_unfold = find_fvs rhs
 464                | otherwise   = emptyVarSet
 465
 466     find_fvs expr = exprSomeFreeVars interestingId expr
 467
 468 interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
 469 \end{code}
 470
 471
 472 \begin{code}
 473 getRules :: [IdCoreRule]        -- Orphan rules
 474          -> [CoreBind]          -- Bindings, with rules in the top-level Ids
 475          -> IdSet               -- Ids that are exported, so we need their rules
 476          -> [IdCoreRule]
 477 getRules orphan_rules binds emitted
 478   = orphan_rules ++ local_rules
 479   where
 480     local_rules  = [ (fn, rule)
 481                    | fn <- bindersOfBinds binds,
 482                      fn `elemVarSet` emitted,
 483                      rule <- rulesRules (idSpecialisation fn),
 484                      not (isBuiltinRule rule),
 485                                 -- We can't print builtin rules in interface files
 486                                 -- Since they are built in, an importing module
 487                                 -- will have access to them anyway
 488
 489                         -- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
 490                         -- from coming out, and to make it work properly we need to add ????
 491                         --      (put it back in for now)
 492                      all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
 493                                 -- Spit out a rule only if all its lhs free vars are emitted
 494                                 -- This is a good reason not to do it when we emit the Id itself
 495                    ]
 496 \end{code}
 497
 498
 499 %************************************************************************
 500 %*                                                                      *
 501 \subsection{Checking if the new interface is up to date
 502 %*                                                                      *
 503 %************************************************************************
 504
 505 \begin{code}
 506 addVersionInfo :: Maybe ModIface                -- The old interface, read from M.hi
 507                -> ModIface                      -- The new interface decls
 508                -> Maybe (ModIface, SDoc)        -- Nothing => no change; no need to write new Iface
 509                                                 -- Just mi => Here is the new interface to write
 510                                                 --            with correct version numbers
 511
 512 -- NB: the fixities, declarations, rules are all assumed
 513 -- to be sorted by increasing order of hsDeclName, so that
 514 -- we can compare for equality
 515
 516 addVersionInfo Nothing new_iface
 517 -- No old interface, so definitely write a new one!
 518   = Just (new_iface, text "No old interface available")
 519
 520 addVersionInfo (Just old_iface@(ModIface { mi_version = old_version,
 521                                            mi_decls   = old_decls,
 522                                            mi_fixities = old_fixities }))
 523                new_iface@(ModIface { mi_decls = new_decls,
 524                                      mi_fixities = new_fixities })
 525
 526   | no_output_change && no_usage_change
 527   = Nothing
 528
 529   | otherwise           -- Add updated version numbers
 530   = Just (final_iface, pp_tc_diffs)
 531
 532   where
 533     final_iface = new_iface { mi_version = new_version }
 534     new_version = VersionInfo { vers_module  = bumpVersion no_output_change (vers_module  old_version),
 535                                 vers_exports = bumpVersion no_export_change (vers_exports old_version),
 536                                 vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
 537                                 vers_decls   = tc_vers }
 538
 539     no_output_change = no_tc_change && no_rule_change && no_export_change
 540     no_usage_change  = mi_usages old_iface == mi_usages new_iface
 541
 542     no_export_change = mi_exports old_iface == mi_exports new_iface             -- Kept sorted
 543     no_rule_change   = dcl_rules old_decls  == dcl_rules  new_decls             -- Ditto
 544
 545         -- Fill in the version number on the new declarations by looking at the old declarations.
 546         -- Set the flag if anything changes.
 547         -- Assumes that the decls are sorted by hsDeclName.
 548     old_vers_decls = vers_decls old_version
 549     (no_tc_change,  pp_tc_diffs,  tc_vers) = diffDecls old_vers_decls old_fixities new_fixities
 550                                                        (dcl_tycl old_decls) (dcl_tycl new_decls)
 551
 552
 553
 554 diffDecls :: NameEnv Version                            -- Old version map
 555           -> NameEnv Fixity -> NameEnv Fixity           -- Old and new fixities
 556           -> [RenamedTyClDecl] -> [RenamedTyClDecl]     -- Old and new decls
 557           -> (Bool,             -- True <=> no change
 558               SDoc,             -- Record of differences
 559               NameEnv Version)  -- New version
 560
 561 diffDecls old_vers old_fixities new_fixities old new
 562   = diff True empty emptyNameEnv old new
 563   where
 564         -- When seeing if two decls are the same,
 565         -- remember to check whether any relevant fixity has changed
 566     eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
 567     same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n
 568
 569     diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
 570     diff ok_so_far pp new_vers old []      = (False,     pp, new_vers)
 571     diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
 572     diff ok_so_far pp new_vers (od:ods) (nd:nds)
 573         = case od_name `compare` nd_name of
 574                 LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
 575                 GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
 576                 EQ | od `eq_tc` nd -> diff ok_so_far pp                    new_vers  ods nds
 577                    | otherwise     -> diff False     (pp $$ changed od nd) new_vers' ods nds
 578         where
 579           od_name = tyClDeclName od
 580           nd_name = tyClDeclName nd
 581           new_vers' = extendNameEnv new_vers nd_name
 582                                     (bumpVersion True (lookupNameEnv_NF old_vers od_name))
 583
 584     only_old d   = ptext SLIT("Only in old iface:") <+> ppr d
 585     only_new d   = ptext SLIT("Only in new iface:") <+> ppr d
 586     changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$
 587                                                          (ptext SLIT("New:") <+> ppr nd))
 588 \end{code}