MkIface.lhs 19.9 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4
5
6
%
\section[MkIface]{Print an interface for a module}

\begin{code}
7
module MkIface ( completeIface ) where
8

9
10
#include "HsVersions.h"

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
19
20
import RnHsSyn		( RenamedInstDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedIfaceSig )
import HscTypes		( VersionInfo(..), IfaceDecls(..), ModIface(..), ModDetails(..),
			  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
31
32
33
			  CprInfo(..), CafInfo(..),
			  inlinePragInfo, arityInfo, arityLowerBound,
			  strictnessInfo, isBottomingStrictness,
			  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, couldBeSmallEnoughToInline )
40
41
42
import Name		( isLocallyDefined, getName, nameModule,
			  Name, NamedThing(..),
			  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
61
62
\end{code}


63
64
65
66
67
%************************************************************************
%*				 					*
\subsection{Write a new interface file}
%*				 					*
%************************************************************************
68

69
\begin{code}
70
71
completeIface :: Maybe ModIface		-- The old interface, if we have it
	      -> ModIface		-- The new one, minus the decls and versions
72

73
74
75
76
	      -> ModDetails		-- The ModDetails for this module
	      -> [CoreBind] -> [Id]	-- Final bindings, plus the top-level Ids from the
					-- code generator; they have authoritative arity info
	      -> [ProtoCoreRule]	-- Tidy orphan rules
77

78
79
80
	      -> Maybe (ModIface, SDoc)	-- The new one, complete with decls and versions
					-- The SDoc is a debug document giving differences
					-- Nothing => no change
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
	-- NB: 'Nothing' means that even the usages havn't changed, so there's no
	--     need to write a new interface file.  But even if the usages have
	--     changed, the module version may not have.
	--
	-- The IO in the type is solely for debug output
	-- In particular, dumping a record of what has changed
completeIface maybe_old_iface new_iface mod_details 
	      tidy_binds final_ids tidy_orphan_rules
  = let
	new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules
    in
    addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })

declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
declsFromDetails details tidy_binds final_ids tidy_orphan_rules
   = IfaceDecls { dcl_tycl  = ty_cls_dcls,
		  dcl_insts = inst_dcls,
		  dcl_sigs  = bagToList val_dcls,
		  dcl_rules = rule_dcls }
   where
     dfun_ids	 = md_insts details
     inst_dcls   = map ifaceInstance dfun_ids
     ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details)))
  
     (val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
					  final_ids tidy_binds
108

109
110
     rule_dcls | opt_OmitInterfacePragmas = []
	       | otherwise		  = ifaceRules tidy_orphan_rules emitted_ids
111

112
113
     orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule 
				    | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
114

115
116
117
118
\end{code}

%************************************************************************
%*				 					*
119
\subsection{Types and classes}
120
121
%*				 					*
%************************************************************************
122

123
\begin{code}
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
emitTyCls :: TyThing -> Bool
emitTyCls (ATyCon tc) = True	-- Could filter out wired in ones, but it's not
				-- strictly necessary, and it costs extra time
emitTyCls (AClass cl) = True
emitTyCls (AnId   _)  = False


ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas)
  = ClassDecl (toHsContext sc_theta)
	      (getName clas)
	      (toHsTyVars clas_tyvars)
	      (toHsFDs clas_fds)
	      (map toClassOpSig op_stuff)
	      EmptyMonoBinds
	      [] noSrcLoc
140
  where
141
     (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
142

143
144
145
146
147
148
149
150
151
     toClassOpSig (sel_id, def_meth)
	= ASSERT(sel_tyvars == clas_tyvars)
	  ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc
	where
	  (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id)
	  def_meth' = case def_meth of
			 NoDefMeth  -> NoDefMeth
			 GenDefMeth -> GenDefMeth
			 DefMeth id -> DefMeth (getName id)
152

153
154
155
ifaceTyCls (ATyCon tycon)
  | isSynTyCon tycon
  = TySynonym (getName tycon)(toHsTyVars tyvars) (toHsType ty) noSrcLoc
sof's avatar
sof committed
156
  where
157
    (tyvars, ty) = getSynTyConDefn tycon
158

159
160
161
162
163
164
165
166
ifaceTyCls (ATyCon tycon)
  | isAlgTyCon tycon
  = TyData new_or_data (toHsContext (tyConTheta tycon))
	   (getName tycon)
	   (toHsTyVars tyvars)
	   (map ifaceConDecl (tyConDataCons tycon))
	   (tyConFamilySize tycon)
	   Nothing noSrcLoc (panic "gen1") (panic "gen2")
167
  where
168
169
170
    tyvars = tyConTyVars tycon
    new_or_data | isNewTyCon tycon = NewType
	        | otherwise	   = DataType
171

172
173
174
175
176
177
178
179
180
181
182
183
    ifaceConDecl data_con 
	= ConDecl (getName data_con) (error "ifaceConDecl")
		  (toHsTyVars ex_tyvars)
		  (toHsContext ex_theta)
		  details noSrcLoc
	where
	  (tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
          field_labels   = dataConFieldLabels data_con
          strict_marks   = dataConStrictMarks data_con
	  details | null field_labels
	    	  = ASSERT( tycon == tycon1 && tyvars == tyvars1 )
	    	    VanillaCon (zipWith mk_bang_ty strict_marks arg_tys)
184

185
186
    	    	  | otherwise
	    	  = RecCon (zipWith mk_field strict_marks field_labels)
187

188
189
190
    mk_bang_ty NotMarkedStrict     ty = Unbanged (toHsType ty)
    mk_bang_ty (MarkedUnboxed _ _) ty = Unpacked (toHsType ty)
    mk_bang_ty MarkedStrict        ty = Banged   (toHsType ty)
191

192
193
194
195
    mk_field strict_mark field_label
	= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))

ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
196
197
198
199
200
\end{code}


%************************************************************************
%*				 					*
201
\subsection{Instances and rules}
202
203
204
%*				 					*
%************************************************************************

205
206
207
208
\begin{code}			 
ifaceInstance :: DFunId -> RenamedInstDecl
ifaceInstance dfun_id
  = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc			 
209
  where
210
211
212
213
214
215
216
217
218
219
    tidy_ty = tidyTopType (deNoteType (idType dfun_id))
		-- The deNoteType is very important.   It removes all type
		-- synonyms from the instance type in interface files.
		-- That in turn makes sure that when reading in instance decls
		-- from interface files that the 'gating' mechanism works properly.
		-- Otherwise you could have
		--	type Tibble = T Int
		--	instance Foo Tibble where ...
		-- and this instance decl wouldn't get imported into a module
		-- that mentioned T but not Tibble.
220
\end{code}
221

222
\begin{code}
223
ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl]
224
225
226
227
228
229
230
231
232
233
234
ifaceRules rules emitted
  = orphan_rules ++ local_rules
  where
    orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
    local_rules  = [ toHsRule fn rule
 		   | fn <- varSetElems emitted, 
		     rule <- rulesRules (idSpecialisation fn),
		     not (isBuiltinRule rule),
				-- We can't print builtin rules in interface files
				-- Since they are built in, an importing module
				-- will have access to them anyway
235
236

			-- Sept 00: I've disabled this test.  It doesn't stop many, if any, rules
237
238
239
			-- from coming out, and to make it work properly we need to add ????
			--	(put it back in for now)
		     all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
240
241
242
243
				-- Spit out a rule only if all its lhs free vars are emitted
				-- This is a good reason not to do it when we emit the Id itself
		   ]
\end{code}
244
245
246
247


%************************************************************************
%*				 					*
248
\subsection{Value bindings}
249
%*				 					* 
250
251
%************************************************************************

252
\begin{code}
253
254
255
ifaceBinds :: IdSet		-- These Ids are needed already
	   -> [Id]		-- Ids used at code-gen time; they have better pragma info!
	   -> [CoreBind]	-- In dependency order, later depend on earlier
256
	   -> (Bag RenamedIfaceSig, IdSet)		-- Set of Ids actually spat out
257
258
259
260
261
262
263
264
265
266
267

ifaceBinds needed_ids final_ids binds
  = go needed_ids (reverse binds) emptyBag emptyVarSet 
		-- Reverse so that later things will 
		-- provoke earlier ones to be emitted
  where
    final_id_map  = listToUFM [(id,id) | id <- final_ids]
    get_idinfo id = case lookupUFM final_id_map id of
			Just id' -> idInfo id'
			Nothing  -> pprTrace "ifaceBinds not found:" (ppr id) $
				    idInfo id
268

269
270
271
272
273
	-- The 'needed' set contains the Ids that are needed by earlier
	-- interface file emissions.  If the Id isn't in this set, and isn't
	-- exported, there's no need to emit anything
    need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id 

274
275
276
277
278
279
280
    go needed [] decls emitted
	| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" 
					  (sep (map ppr (varSetElems needed)))
				       (decls, emitted)
	| otherwise 		     = (decls, emitted)

    go needed (NonRec id rhs : binds) decls emitted
281
282
283
284
285
286
287
288
289
290
291
292
	| need_id needed id
	= if omitIfaceSigForId id then
	    go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
	  else
	    go ((needed `unionVarSet` extras) `delVarSet` id)
	       binds
	       (decl `consBag` decls)
	       (emitted `extendVarSet` id)
	| otherwise
	= go needed binds decls emitted
	where
	  (decl, extras) = ifaceId get_idinfo False id rhs
293
294
295

	-- Recursive groups are a bit more of a pain.  We may only need one to
	-- start with, but it may call out the next one, and so on.  So we
296
297
298
	-- have to look for a fixed point.  We don't want necessarily them all, 
	-- because without -O we may only need the first one (if we don't emit
	-- its unfolding)
299
300
301
302
303
304
305
306
    go needed (Rec pairs : binds) decls emitted
	= go needed' binds decls' emitted' 
	where
	  (new_decls, new_emitted, extras) = go_rec needed pairs
	  decls'   = new_decls `unionBags` decls
	  needed'  = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) 
	  emitted' = emitted `unionVarSet` new_emitted

307
    go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RenamedIfaceSig, IdSet, IdSet)
308
309
    go_rec needed pairs
	| null decls = (emptyBag, emptyVarSet, emptyVarSet)
310
311
312
	| otherwise  = (more_decls   `unionBags`   listToBag decls, 
			more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
			more_extras  `unionVarSet` extras)
313
	where
314
315
316
317
318
319
	  (needed_prs,leftover_prs) = partition is_needed pairs
	  (decls, extras_s)         = unzip [ifaceId get_idinfo True id rhs 
				            | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
	  extras	            = unionVarSets extras_s
	  (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
	  is_needed (id,_) = need_id needed id
320
321
322
323
324
325
326
327
328
\end{code}


\begin{code}
ifaceId :: (Id -> IdInfo)	-- This function "knows" the extra info added
				-- by the STG passes.  Sigh
	-> Bool			-- True <=> recursive, so don't print unfolding
	-> Id
	-> CoreExpr		-- The Id's right hand side
329
	-> (RenamedIfaceSig, IdSet)	-- The emitted stuff, plus any *extra* needed Ids
330

331
ifaceId get_idinfo is_rec id rhs
332
  = (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc,  new_needed_ids)
333
  where
334
    id_type     = idType id
335
336
    core_idinfo = idInfo id
    stg_idinfo  = get_idinfo id
337

338
339
340
    hs_idinfo | opt_OmitInterfacePragmas = []
 	      | otherwise		 = arity_hsinfo  ++ caf_hsinfo  ++ cpr_hsinfo ++ 
					   strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
341
342

    ------------  Arity  --------------
343
344
    arity_info   = arityInfo stg_idinfo
    stg_arity	 = arityLowerBound arity_info
345
346
347
    arity_hsinfo = case arityInfo stg_idinfo of
			a@(ArityExactly n) -> [HsArity a]
			other		   -> []
348

349
    ------------ Caf Info --------------
350
351
352
    caf_hsinfo = case cafInfo stg_idinfo of
		   NoCafRefs -> [HsNoCafRefs]
		   otherwise -> []
353

354
    ------------ CPR Info --------------
355
356
357
    cpr_hsinfo = case cprInfo core_idinfo of
		   ReturnsCPR -> [HsCprInfo]
		   NoCPRInfo  -> []
358

359
    ------------  Strictness  --------------
360
    strict_info   = strictnessInfo core_idinfo
361
    bottoming_fn  = isBottomingStrictness strict_info
362
363
364
365
    strict_hsinfo = case strict_info of
			NoStrictnessInfo -> []
			info		 -> [HsStrictness info]

sof's avatar
sof committed
366

367
    ------------  Worker  --------------
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
	-- We only treat a function as having a worker if
	-- the exported arity (which is now the number of visible lambdas)
	-- is the same as the arity at the moment of the w/w split
	-- If so, we can safely omit the unfolding inside the wrapper, and
	-- instead re-generate it from the type/arity/strictness info
	-- But if the arity has changed, we just take the simple path and
	-- put the unfolding into the interface file, forgetting the fact
	-- that it's a wrapper.  
	--
	-- How can this happen?  Sometimes we get
	--	f = coerce t (\x y -> $wf x y)
	-- at the moment of w/w split; but the eta reducer turns it into
	--	f = coerce t $wf
	-- which is perfectly fine except that the exposed arity so far as
	-- the code generator is concerned (zero) differs from the arity
	-- when we did the split (2).  
	--
	-- All this arises because we use 'arity' to mean "exactly how many
	-- top level lambdas are there" in interface files; but during the
	-- compilation of this module it means "how many things can I apply
	-- this to".
    work_info           = workerInfo core_idinfo
    HasWorker work_id _ = work_info

    has_worker = case work_info of
		  HasWorker work_id wrap_arity 
		   | wrap_arity == stg_arity -> True
		   | otherwise		     -> pprTrace "ifaceId: arity change:" (ppr id) 
						False
							  
		  other			     -> False

400
    wrkr_hsinfo | has_worker = [HsWorker (getName work_id)]
401
		| otherwise  = []
402

403
    ------------  Unfolding  --------------
404
    inline_pragma  = inlinePragInfo core_idinfo
405
    dont_inline	   = isNeverInlinePrag inline_pragma
406

407
408
    unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
		  | otherwise   = []
409

410
411
412
    show_unfold = not has_worker	 &&	-- Not unnecessary
		  not bottoming_fn	 &&	-- Not necessary
		  not dont_inline	 &&
413
		  not loop_breaker	 &&
414
415
		  rhs_is_small		 &&	-- Small enough
		  okToUnfoldInHiFile rhs 	-- No casms etc
416

417
    rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
418
419

    ------------  Specialisations --------------
420
    spec_info   = specInfo core_idinfo
421
    
422
423
424
    ------------  Occ info  --------------
    loop_breaker  = isLoopBreaker (occInfo core_idinfo)

425
    ------------  Extra free Ids  --------------
426
427
428
429
    new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
	           | otherwise		      = worker_ids	`unionVarSet`
						unfold_ids	`unionVarSet`
						spec_ids
430

431
    worker_ids | has_worker && interestingId work_id = unitVarSet work_id
432
433
			-- Conceivably, the worker might come from
			-- another module
434
	       | otherwise = emptyVarSet
435

436
    spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
437
438

    unfold_ids | show_unfold = find_fvs rhs
439
	       | otherwise   = emptyVarSet
440

441
    find_fvs expr = exprSomeFreeVars interestingId expr
442

443
interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id)
444
445
\end{code}

446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540

%************************************************************************
%*				 					*
\subsection{Checking if the new interface is up to date
%*				 					*
%************************************************************************

\begin{code}
addVersionInfo :: Maybe ModIface		-- The old interface, read from M.hi
	       -> ModIface			-- The new interface decls
	       -> Maybe (ModIface, SDoc)	-- Nothing => no change; no need to write new Iface
						-- Just mi => Here is the new interface to write
						-- 	      with correct version numbers

-- NB: the fixities, declarations, rules are all assumed
-- to be sorted by increasing order of hsDeclName, so that 
-- we can compare for equality

addVersionInfo Nothing new_iface
-- No old interface, so definitely write a new one!
  = Just (new_iface, text "No old interface available")

addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, 
				       	   mi_decls   = old_decls,
				       	   mi_fixities = old_fixities }))
	       new_iface@(ModIface { mi_decls = new_decls,
				     mi_fixities = new_fixities })

  | no_output_change && no_usage_change
  = Nothing

  | otherwise		-- Add updated version numbers
  = Just (final_iface, pp_tc_diffs $$ pp_sig_diffs)
	
  where
    final_iface = new_iface { mi_version = new_version }
    new_version = VersionInfo { vers_module  = bumpVersion no_output_change (vers_module  old_version),
				vers_exports = bumpVersion no_export_change (vers_exports old_version),
				vers_rules   = bumpVersion no_rule_change   (vers_rules   old_version),
				vers_decls   = sig_vers `plusNameEnv` tc_vers }

    no_output_change = no_sig_change && no_tc_change && no_rule_change && no_export_change
    no_usage_change  = mi_usages old_iface == mi_usages new_iface

    no_export_change = mi_exports old_iface == mi_exports new_iface		-- Kept sorted
    no_rule_change   = dcl_rules old_decls  == dcl_rules  new_decls		-- Ditto

	-- Fill in the version number on the new declarations by looking at the old declarations.
	-- Set the flag if anything changes. 
	-- Assumes that the decls are sorted by hsDeclName.
    old_vers_decls = vers_decls old_version
    (no_sig_change, pp_sig_diffs, sig_vers) = diffDecls ifaceSigName eq_sig old_vers_decls
							(dcl_sigs old_decls) (dcl_sigs new_decls)
    (no_tc_change,  pp_tc_diffs,  tc_vers)  = diffDecls tyClDeclName eq_tc old_vers_decls
							(dcl_tycl old_decls) (dcl_tycl new_decls)

	-- When seeing if two decls are the same, 
	-- remember to check whether any relevant fixity has changed
    eq_sig i1 i2 = i1 == i2 && same_fixity (ifaceSigName i1)
    eq_tc  d1 d2 = d1 == d2 && all (same_fixity . fst) (tyClDeclNames d1)
    same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n


diffDecls :: (Outputable decl)
	  => (decl->Name)
	  -> (decl->decl->Bool)	-- True if no change
	  -> NameEnv Version	-- Old version map
	  -> [decl] -> [decl]	-- Old and new decls
	  -> (Bool,		-- True <=> no change
	      SDoc,		-- Record of differences
	      NameEnv Version)	-- New version

diffDecls get_name eq old_vers old new
  = diff True empty emptyNameEnv old new
  where
    diff ok_so_far pp new_vers []  []      = (ok_so_far, pp, new_vers)
    diff ok_so_far pp new_vers old []      = (False,     pp, new_vers)
    diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds
    diff ok_so_far pp new_vers (od:ods) (nd:nds)
	= case od_name `compare` nd_name of
		LT -> diff False (pp $$ only_old od) new_vers ods      (nd:nds)
		GT -> diff False (pp $$ only_new nd) new_vers (od:ods) nds
		EQ | od `eq` nd -> diff ok_so_far pp 		         new_vers  ods nds
		   | otherwise  -> diff False	   (pp $$ changed od nd) new_vers' ods nds
	where
 	  od_name = get_name od
 	  nd_name = get_name nd
	  new_vers' = extendNameEnv new_vers nd_name 
				    (bumpVersion True (lookupNameEnv_NF old_vers od_name))

    only_old d   = ptext SLIT("Only in old iface:") <+> ppr d
    only_new d   = ptext SLIT("Only in new iface:") <+> ppr d
    changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$ 
							 (ptext SLIT("New:") <+> ppr nd))
\end{code}