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