MkIface.lhs 59.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
4
5
6
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%

\begin{code}
7
{-# OPTIONS -w #-}
8
9
10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12
13
-- for details

14
module MkIface ( 
Simon Marlow's avatar
Simon Marlow committed
15
16
        mkUsedNames,
        mkDependencies,
17
18
19
	mkIface, 	-- Build a ModIface from a ModGuts, 
			-- including computing version information

Simon Marlow's avatar
Simon Marlow committed
20
21
        mkIfaceTc,

22
23
	writeIfaceFile,	-- Write the interface file

24
	checkOldIface,	-- See if recompilation is required, by
25
			-- comparing version information
26
27

        tyThingToIfaceDecl -- Converting things to their Iface equivalents
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
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
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
 ) where
\end{code}

	-----------------------------------------------
		MkIface.lhs deals with versioning
	-----------------------------------------------

Here's the version-related info in an interface file

  module Foo 8		-- module-version 
	     3		-- export-list-version
	     2		-- rule-version
    Usages: 	-- Version info for what this compilation of Foo imported
	Baz 3		-- Module version
	    [4]		-- The export-list version if Foo depended on it
	    (g,2)	-- Function and its version
	    (T,1)	-- Type and its version

    <version> f :: Int -> Int {- Unfolding: \x -> Wib.t[2] x -}
		-- The [2] says that f's unfolding 
		-- mentions verison 2 of Wib.t
	
	-----------------------------------------------
			Basic idea
	-----------------------------------------------

Basic idea: 
  * In the mi_usages information in an interface, we record the 
    version number of each free variable of the module

  * In mkIface, we compute the version number of each exported thing A.f
    by comparing its A.f's info with its new info, and bumping its 
    version number if it differs.  If A.f mentions B.g, and B.g's version
    number has changed, then we count A.f as having changed too.

  * In checkOldIface we compare the mi_usages for the module with
    the actual version info for all each thing recorded in mi_usages


Fixities
~~~~~~~~
We count A.f as changing if its fixity changes

Rules
~~~~~
If a rule changes, we want to recompile any module that might be
affected by that rule.  For non-orphan rules, this is relatively easy.
If module M defines f, and a rule for f, just arrange that the version
number for M.f changes if any of the rules for M.f change.  Any module
that does not depend on M.f can't be affected by the rule-change
either.

Orphan rules (ones whose 'head function' is not defined in M) are
harder.  Here's what we do.

  * We have a per-module orphan-rule version number which changes if 
    any orphan rule changes. (It's unaffected by non-orphan rules.)

  * We record usage info for any orphan module 'below' this one,
    giving the orphan-rule version number.  We recompile if this 
    changes. 

The net effect is that if an orphan rule changes, we recompile every
module above it.  That's very conservative, but it's devilishly hard
to know what it might affect, so we just have to be conservative.

Instance decls
~~~~~~~~~~~~~~
In an iface file we have
     module A where
	instance Eq a => Eq [a]  =  dfun29
	dfun29 :: ... 

We have a version number for dfun29, covering its unfolding
etc. Suppose we are compiling a module M that imports A only
indirectly.  If typechecking M uses this instance decl, we record the
dependency on A.dfun29 as if it were a free variable of the module
(via the tcg_inst_usages accumulator).  That means that A will appear
in M's usage list.  If the shape of the instance declaration changes,
then so will dfun29's version, triggering a recompilation.

Adding an instance declaration, or changing an instance decl that is
not currently used, is more tricky.  (This really only makes a
difference when we have overlapping instance decls, because then the
new instance decl might kick in to override the old one.)  We handle
this in a very similar way that we handle rules above.

  * For non-orphan instance decls, identify one locally-defined tycon/class
    mentioned in the decl.  Treat the instance decl as part of the defn of that
    tycon/class, so that if the shape of the instance decl changes, so does the
    tycon/class; that in turn will force recompilation of anything that uses
    that tycon/class.

  * For orphan instance decls, act the same way as for orphan rules.
    Indeed, we use the same global orphan-rule version number.

mkUsageInfo
~~~~~~~~~~~
mkUsageInfo figures out what the ``usage information'' for this
moudule is; that is, what it must record in its interface file as the
things it uses.  

We produce a line for every module B below the module, A, currently being
compiled:
	import B <n> ;
to record the fact that A does import B indirectly.  This is used to decide
Simon Marlow's avatar
Simon Marlow committed
134
to look for B.hi rather than B.hi-boot when compiling a module that
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
imports A.  This line says that A imports B, but uses nothing in it.
So we'll get an early bale-out when compiling A if B's version changes.

The usage information records:

\begin{itemize}
\item	(a) anything reachable from its body code
\item	(b) any module exported with a @module Foo@
\item   (c) anything reachable from an exported item
\end{itemize}

Why (b)?  Because if @Foo@ changes then this module's export list
will change, so we must recompile this module at least as far as
making a new interface file --- but in practice that means complete
recompilation.

Why (c)?  Consider this:
\begin{verbatim}
	module A( f, g ) where	|	module B( f ) where
	  import B( f )		|	  f = h 3
	  g = ...		|	  h = ...
\end{verbatim}

Here, @B.f@ isn't used in A.  Should we nevertheless record @B.f@ in
@A@'s usages?  Our idea is that we aren't going to touch A.hi if it is
*identical* to what it was before.  If anything about @B.f@ changes
than anyone who imports @A@ should be recompiled in case they use
@B.f@ (they'll get an early exit if they don't).  So, if anything
about @B.f@ changes we'd better make sure that something in A.hi
changes, and the convenient way to do that is to record the version
number @B.f@ in A.hi in the usage list.  If B.f changes that'll force a
complete recompiation of A, which is overkill but it's the only way to 
write a new, slightly different, A.hi.

But the example is tricker.  Even if @B.f@ doesn't change at all,
@B.h@ may do so, and this change may not be reflected in @f@'s version
number.  But with -O, a module that imports A must be recompiled if
@B.h@ changes!  So A must record a dependency on @B.h@.  So we treat
the occurrence of @B.f@ in the export list *just as if* it were in the
code of A, and thereby haul in all the stuff reachable from it.

	*** Conclusion: if A mentions B.f in its export list,
	    behave just as if A mentioned B.f in its source code,
	    and slurp in B.f and all its transitive closure ***

[NB: If B was compiled with -O, but A isn't, we should really *still*
haul in all the unfoldings for B, in case the module that imports A *is*
compiled with -O.  I think this is the case.]

Simon Marlow's avatar
Simon Marlow committed
184
185
186
187
SimonM [30/11/2007]: I believe the above is all out of date; the
current implementation doesn't do it this way.  Instead, when any of
the dependencies of a declaration changes, the version of the
declaration itself changes.
188
189
190
191

\begin{code}
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
192
import IfaceSyn
193
import IfaceType
Simon Marlow's avatar
Simon Marlow committed
194
195
196
197
import LoadIface
import Id
import IdInfo
import NewDemand
198
import CoreSyn
199
import CoreFVs
Simon Marlow's avatar
Simon Marlow committed
200
201
202
203
204
205
206
import Class
import TyCon
import DataCon
import Type
import TcType
import InstEnv
import FamInstEnv
207
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
208
import HscTypes
209
import Finder
Simon Marlow's avatar
Simon Marlow committed
210
import DynFlags
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
211
212
import VarEnv
import Var
Simon Marlow's avatar
Simon Marlow committed
213
import Name
214
215
import NameEnv
import NameSet
Simon Marlow's avatar
Simon Marlow committed
216
import OccName
Simon Marlow's avatar
Simon Marlow committed
217
import Module
Simon Marlow's avatar
Simon Marlow committed
218
219
220
221
222
223
import BinIface
import Unique
import ErrUtils
import Digraph
import SrcLoc
import PackageConfig    hiding ( Version )
224
225
226
227
import Outputable
import BasicTypes       hiding ( SuccessFlag(..) )
import UniqFM
import Util             hiding ( eqListBy )
228
229
import FiniteMap
import FastString
Simon Marlow's avatar
Simon Marlow committed
230
import Maybes
Simon Marlow's avatar
Simon Marlow committed
231
import ListSetOps
232

Simon Marlow's avatar
Simon Marlow committed
233
234
import Control.Monad
import Data.List
Simon Marlow's avatar
Simon Marlow committed
235
import Data.IORef
236
237
238
239
240
241
242
243
244
245
246
247
248
\end{code}



%************************************************************************
%*				 					*
\subsection{Completing an interface}
%*				 					*
%************************************************************************

\begin{code}
mkIface :: HscEnv
	-> Maybe ModIface	-- The old interface, if we have it
249
	-> ModDetails		-- The trimmed, tidied interface
Simon Marlow's avatar
Simon Marlow committed
250
	-> ModGuts		-- Usages, deprecations, etc
251
252
253
254
	-> IO (ModIface, 	-- The new one, complete with decls and versions
	       Bool)		-- True <=> there was an old Iface, and the new one
				--	    is identical, so no need to write it

Simon Marlow's avatar
Simon Marlow committed
255
256
mkIface hsc_env maybe_old_iface mod_details
	 ModGuts{     mg_module    = this_mod,
257
		      mg_boot      = is_boot,
Simon Marlow's avatar
Simon Marlow committed
258
		      mg_used_names = used_names,
259
		      mg_deps      = deps,
Simon Marlow's avatar
Simon Marlow committed
260
                      mg_dir_imps  = dir_imp_mods,
261
262
		      mg_rdr_env   = rdr_env,
		      mg_fix_env   = fix_env,
Simon Marlow's avatar
Simon Marlow committed
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
		      mg_deprecs   = deprecs,
	              mg_hpc_info  = hpc_info }
        = mkIface_ hsc_env maybe_old_iface
                   this_mod is_boot used_names deps rdr_env 
                   fix_env deprecs hpc_info dir_imp_mods mod_details
	
-- | make an interface from the results of typechecking only.  Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing').
mkIfaceTc :: HscEnv
          -> Maybe ModIface	-- The old interface, if we have it
          -> ModDetails		-- gotten from mkBootModDetails, probably
          -> TcGblEnv		-- Usages, deprecations, etc
	  -> IO (ModIface,
	         Bool)
mkIfaceTc hsc_env maybe_old_iface mod_details
  tc_result@TcGblEnv{ tcg_mod = this_mod,
                      tcg_src = hsc_src,
                      tcg_imports = imports,
                      tcg_rdr_env = rdr_env,
                      tcg_fix_env = fix_env,
                      tcg_deprecs = deprecs,
                      tcg_hpc = other_hpc_info
                    }
  = do
          used_names <- mkUsedNames tc_result
          deps <- mkDependencies tc_result
          let hpc_info = emptyHpcInfo other_hpc_info
          mkIface_ hsc_env maybe_old_iface
                   this_mod (isHsBoot hsc_src) used_names deps rdr_env 
                   fix_env deprecs hpc_info (imp_mods imports) mod_details
        

mkUsedNames :: TcGblEnv -> IO NameSet
mkUsedNames 
          TcGblEnv{ tcg_inst_uses = dfun_uses_var,
                    tcg_dus = dus
                  }
 = do
        dfun_uses <- readIORef dfun_uses_var		-- What dfuns are used
        return (allUses dus `unionNameSets` dfun_uses)
        
mkDependencies :: TcGblEnv -> IO Dependencies
mkDependencies
          TcGblEnv{ tcg_mod = mod,
                    tcg_imports = imports,
                    tcg_th_used = th_var
                  }
 = do 
      th_used   <- readIORef th_var                        -- Whether TH is used
      let
        dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod))
                -- M.hi-boot can be in the imp_dep_mods, but we must remove
                -- it before recording the modules on which this one depends!
                -- (We want to retain M.hi-boot in imp_dep_mods so that 
                --  loadHiBootInterface can see if M's direct imports depend 
                --  on M.hi-boot, and hence that we should do the hi-boot consistency 
                --  check.)

        dir_imp_mods = imp_mods imports

                -- Modules don't compare lexicographically usually, 
                -- but we want them to do so here.
        le_mod :: Module -> Module -> Bool         
        le_mod m1 m2 = moduleNameFS (moduleName m1) 
                           <= moduleNameFS (moduleName m2)

        le_dep_mod :: (ModuleName, IsBootInterface)
                    -> (ModuleName, IsBootInterface) -> Bool         
        le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2

        
        pkgs | th_used   = insertList thPackageId (imp_dep_pkgs imports)
             | otherwise = imp_dep_pkgs imports

      return Deps { dep_mods   = sortLe le_dep_mod dep_mods,
                    dep_pkgs   = sortLe (<=)   pkgs,        
                    dep_orphs  = sortLe le_mod (imp_orphs  imports),
                    dep_finsts = sortLe le_mod (imp_finsts imports) }
                -- sort to get into canonical order


mkIface_ hsc_env maybe_old_iface 
         this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
         dir_imp_mods
	 ModDetails{  md_insts 	   = insts, 
349
350
		      md_fam_insts = fam_insts,
		      md_rules 	   = rules,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
351
                      md_vect_info = vect_info,
352
		      md_types 	   = type_env,
Simon Marlow's avatar
Simon Marlow committed
353
		      md_exports   = exports }
354
355
356
357
358
-- NB:	notice that mkIface does not look at the bindings
--	only at the TypeEnv.  The previous Tidy phase has
--	put exactly the info into the TypeEnv that we want
--	to expose in the interface

359
  = do	{eps <- hscEPS hsc_env
Simon Marlow's avatar
Simon Marlow committed
360
361
362

	; usages <- mkUsageInfo hsc_env dir_imp_mods (dep_mods deps) used_names

363
364
365
	; let	{ entities = typeEnvElts type_env ;
                  decls  = [ tyThingToIfaceDecl entity
			   | entity <- entities,
366
367
368
369
370
371
372
			     let name = getName entity,
                             not (isImplicitTyThing entity),
	                        -- No implicit Ids and class tycons in the interface file
			     not (isWiredInName name),
	                        -- Nor wired-in things; the compiler knows about them anyhow
			     nameIsLocalOrFrom this_mod name  ]
				-- Sigh: see Note [Root-main Id] in TcRnDriver
373

374
375
		; fixities    = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
		; deprecs     = src_deprecs
376
		; iface_rules = map (coreRuleToIfaceRule this_mod) rules
377
378
		; iface_insts = map instanceToIfaceInst insts
		; iface_fam_insts = map famInstToIfaceFamInst fam_insts
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
379
                ; iface_vect_info = flattenVectInfo vect_info
380
381
382

	        ; intermediate_iface = ModIface { 
			mi_module   = this_mod,
383
			mi_boot     = is_boot,
384
385
			mi_deps     = deps,
			mi_usages   = usages,
386
			mi_exports  = mkIfaceExports exports,
387
388
389
	
			-- Sort these lexicographically, so that
			-- the result is stable across compilations
390
			mi_insts    = sortLe le_inst iface_insts,
391
			mi_fam_insts= sortLe le_fam_inst iface_fam_insts,
392
			mi_rules    = sortLe le_rule iface_rules,
393

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
394
395
                        mi_vect_info = iface_vect_info,

396
397
			mi_fixities = fixities,
			mi_deprecs  = deprecs,
398
399
			mi_globals  = Just rdr_env,

400
401
402
403
404
405
			-- Left out deliberately: filled in by addVersionInfo
			mi_mod_vers  = initialVersion,
 			mi_exp_vers  = initialVersion,
 			mi_rule_vers = initialVersion,
			mi_orphan    = False,	-- Always set by addVersionInfo, but
						-- it's a strict field, so we can't omit it.
406
                        mi_finsts    = False,   -- Ditto
407
408
			mi_decls     = deliberatelyOmitted "decls",
			mi_ver_fn    = deliberatelyOmitted "ver_fn",
409
			mi_hpc       = isHpcUsed hpc_info,
410
411
412
413
414
415

			-- And build the cached values
			mi_dep_fn = mkIfaceDepCache deprecs,
			mi_fix_fn = mkIfaceFixCache fixities }

		-- Add version information
416
              ; ext_ver_fn = mkParentVerFun hsc_env eps
417
		; (new_iface, no_change_at_all, pp_diffs, pp_orphs) 
418
			= {-# SCC "versioninfo" #-}
419
420
			 addVersionInfo ext_ver_fn maybe_old_iface
                                         intermediate_iface decls
421
422
423
		}

		-- Debug printing
424
	; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) 
425
	       (printDump (expectJust "mkIface" pp_orphs))
426
	; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
427
428
429
	; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
			(pprModIface new_iface)

430
431
432
433
434
435
436
                -- bug #1617: on reload we weren't updating the PrintUnqualified
                -- correctly.  This stems from the fact that the interface had
                -- not changed, so addVersionInfo returns the old ModIface
                -- with the old GlobalRdrEnv (mi_globals).
        ; let final_iface = new_iface{ mi_globals = Just rdr_env }

	; return (final_iface, no_change_at_all) }
437
  where
438
439
440
441
442
443
444
445
     r1 `le_rule`     r2 = ifRuleName      r1    <=    ifRuleName      r2
     i1 `le_inst`     i2 = ifDFun          i1 `le_occ` ifDFun          i2  
     i1 `le_fam_inst` i2 = ifFamInstTcName i1 `le_occ` ifFamInstTcName i2

     le_occ :: Name -> Name -> Bool
	-- Compare lexicographically by OccName, *not* by unique, because 
	-- the latter is not stable across compilations
     le_occ n1 n2 = nameOccName n1 <= nameOccName n2
446

447
448
     dflags = hsc_dflags hsc_env
     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
449
     ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
450

451
452
     flattenVectInfo (VectInfo { vectInfoVar   = vVar
                               , vectInfoTyCon = vTyCon
453
454
                               }) = 
       IfaceVectInfo { 
455
456
457
458
459
460
461
462
         ifaceVectInfoVar        = [ Var.varName v 
                                   | (v, _) <- varEnvElts vVar],
         ifaceVectInfoTyCon      = [ tyConName t 
                                   | (t, t_v) <- nameEnvElts vTyCon
                                   , t /= t_v],
         ifaceVectInfoTyConReuse = [ tyConName t
                                   | (t, t_v) <- nameEnvElts vTyCon
                                   , t == t_v]
463
       } 
464

465
-----------------------------
466
467
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
468
    = do createDirectoryHierarchy (directoryOf hi_file_path)
469
         writeBinIface dflags hi_file_path new_iface
470
    where hi_file_path = ml_hi_file location
471
472


473
474
-- -----------------------------------------------------------------------------
-- Look up parents and versions of Names
475

476
477
478
-- This is like a global version of the mi_ver_fn field in each ModIface.
-- Given a Name, it finds the ModIface, and then uses mi_ver_fn to get
-- the parent and version info.
479

480
481
482
483
484
485
486
487
488
489
490
491
492
493
mkParentVerFun
        :: HscEnv                       -- needed to look up versions
        -> ExternalPackageState         -- ditto
        -> (Name -> (OccName,Version))
mkParentVerFun hsc_env eps
  = \name -> 
      let 
        mod = nameModule name
        occ = nameOccName name
        iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
                   pprPanic "lookupVers2" (ppr mod <+> ppr occ)
      in  
        mi_ver_fn iface occ `orElse` 
                 pprPanic "lookupVers1" (ppr mod <+> ppr occ)
494
  where
495
496
      hpt = hsc_HPT hsc_env
      pit = eps_PIT eps
497

498
-----------------------------------------------------------------------------
499
500
-- Compute version numbers for local decls

501
502
503
504
505
506
507
508
509
510
511
addVersionInfo
        :: (Name -> (OccName,Version))  -- lookup parents and versions of names
        -> Maybe ModIface  -- The old interface, read from M.hi
        -> ModIface	   -- The new interface (lacking decls)
        -> [IfaceDecl]	   -- The new decls
        -> (ModIface,   -- Updated interface
            Bool,	   -- True <=> no changes at all; no need to write Iface
            SDoc,	   -- Differences
            Maybe SDoc) -- Warnings about orphans

addVersionInfo ver_fn Nothing new_iface new_decls
512
-- No old interface, so definitely write a new one!
513
  = (new_iface { mi_orphan = not (null orph_insts && null orph_rules)
514
515
516
517
518
               , mi_finsts = not . null $ mi_fam_insts new_iface
               , mi_decls  = [(initialVersion, decl) | decl <- new_decls]
               , mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion) 
						  new_decls)
	       },
519
520
521
     False, 
     ptext SLIT("No old interface file"),
     pprOrphans orph_insts orph_rules)
522
  where
523
524
    orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
    orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface)
525

526
527
addVersionInfo ver_fn (Just old_iface@(ModIface { 
                                           mi_mod_vers  = old_mod_vers, 
528
529
530
531
532
533
534
					   mi_exp_vers  = old_exp_vers, 
					   mi_rule_vers = old_rule_vers, 
				       	   mi_decls     = old_decls,
					   mi_ver_fn    = old_decl_vers,
				       	   mi_fix_fn    = old_fixities }))
	       new_iface@(ModIface { mi_fix_fn = new_fixities })
	       new_decls
535
536
537
538
539
540
541
542
543
544
545
 | no_change_at_all
 = (old_iface,  True,   ptext SLIT("Interface file unchanged"), pp_orphs)
 | otherwise
 = (final_iface, False, vcat [ptext SLIT("Interface file has changed"),
			      nest 2 pp_diffs], pp_orphs)
 where
    final_iface = new_iface { 
                mi_mod_vers  = bump_unless no_output_change old_mod_vers,
                mi_exp_vers  = bump_unless no_export_change old_exp_vers,
                mi_rule_vers = bump_unless no_rule_change   old_rule_vers,
                mi_orphan    = not (null new_orph_rules && null new_orph_insts),
546
                mi_finsts    = not . null $ mi_fam_insts new_iface,
547
548
                mi_decls     = decls_w_vers,
                mi_ver_fn    = mkIfaceVerCache decls_w_vers }
549
550
551
552

    decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]

    -------------------
553
554
555
556
    (old_non_orph_insts, old_orph_insts) = 
        mkOrphMap ifInstOrph (mi_insts old_iface)
    (new_non_orph_insts, new_orph_insts) = 
        mkOrphMap ifInstOrph (mi_insts new_iface)
557
558
    old_fam_insts = mi_fam_insts old_iface
    new_fam_insts = mi_fam_insts new_iface
559
560
561
562
    same_insts occ = eqMaybeBy	(eqListBy eqIfInst) 
				(lookupOccEnv old_non_orph_insts occ)
				(lookupOccEnv new_non_orph_insts occ)
  
563
564
565
566
    (old_non_orph_rules, old_orph_rules) = 
        mkOrphMap ifRuleOrph (mi_rules old_iface)
    (new_non_orph_rules, new_orph_rules) = 
        mkOrphMap ifRuleOrph (mi_rules new_iface)
567
568
569
570
571
572
573
    same_rules occ = eqMaybeBy	(eqListBy eqIfRule)
				(lookupOccEnv old_non_orph_rules occ)
				(lookupOccEnv new_non_orph_rules occ)
    -------------------
    -- Computing what changed
    no_output_change = no_decl_change   && no_rule_change && 
    		       no_export_change && no_deprec_change
574
575
    no_export_change = mi_exports new_iface == mi_exports old_iface
                                -- Kept sorted
576
    no_decl_change   = isEmptyOccSet changed_occs
577
    no_rule_change   = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules)
578
579
	    		 || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)
	    		 || changedWrtNames changed_occs (eqListBy eqIfFamInst old_fam_insts new_fam_insts))
580
581
582
    no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface

	-- If the usages havn't changed either, we don't need to write the interface file
583
    no_other_changes = mi_usages new_iface == mi_usages old_iface && 
584
585
		       mi_deps new_iface == mi_deps old_iface &&
		       mi_hpc new_iface == mi_hpc old_iface
586
587
    no_change_at_all = no_output_change && no_other_changes
 
588
    pp_diffs = vcat [pp_change no_export_change "Export list" 
589
590
591
592
			(ppr old_exp_vers <+> arrow <+> ppr (mi_exp_vers final_iface)),
 		     pp_change no_rule_change "Rules"
			(ppr old_rule_vers <+> arrow <+> ppr (mi_rule_vers final_iface)),
 		     pp_change no_deprec_change "Deprecations" empty,
593
594
 		     pp_change no_other_changes  "Usages" empty,
		     pp_decl_diffs]
595
596
597
598
599
600
601
602
603
    pp_change True  what info = empty
    pp_change False what info = text what <+> ptext SLIT("changed") <+> info

    -------------------
    old_decl_env = mkOccEnv [(ifName decl, decl) | (_,decl) <- old_decls]
    same_fixity n = bool (old_fixities n == new_fixities n)

    -------------------
    -- Adding version info
604
605
606
607
608
609
    new_version = bumpVersion old_mod_vers
                        -- Start from the old module version, not from
                        -- zero so that if you remove f, and then add
                        -- it again, you don't thereby reduce f's
                        -- version number

610
    add_vers decl | occ `elemOccSet` changed_occs = new_version
611
		  | otherwise = snd (expectJust "add_vers" (old_decl_vers occ))
612
613
614
615
616
				-- If it's unchanged, there jolly well 
		  where		-- should be an old version number
		    occ = ifName decl

    -------------------
617
618
619
620
    -- Deciding which declarations have changed
            
    -- For each local decl, the IfaceEq gives the list of things that
    -- must be unchanged for the declaration as a whole to be unchanged.
621
622
    eq_info :: [(OccName, IfaceEq)]
    eq_info = map check_eq new_decls
623
624
625
626
627
628
629
    check_eq new_decl
         | Just old_decl <- lookupOccEnv old_decl_env occ 
	 = (occ, new_decl `eqIfDecl` old_decl &&& eq_indirects new_decl)
         | otherwise {- No corresponding old decl -}      
	 = (occ, NotEqual)	
        where
          occ = ifName new_decl
630
631
632
633
634
635
636
637
638
639

    eq_indirects :: IfaceDecl -> IfaceEq
		-- When seeing if two decls are the same, remember to
		-- check whether any relevant fixity or rules have changed
    eq_indirects (IfaceId {ifName = occ}) = eq_ind_occ occ
    eq_indirects (IfaceClass {ifName = cls_occ, ifSigs = sigs})
	= same_insts cls_occ &&& 
	  eq_ind_occs [op | IfaceClassOp op _ _ <- sigs] 
    eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons})
	= same_insts tc_occ &&& same_fixity tc_occ &&&	-- The TyCon can have a fixity too
640
	  eq_ind_occs (map ifConOcc (visibleIfConDecls cons))
641
642
643
644
645
    eq_indirects other = Equal	-- Synonyms and foreign declarations

    eq_ind_occ :: OccName -> IfaceEq	-- For class ops and Ids; check fixity and rules
    eq_ind_occ occ = same_fixity occ &&& same_rules occ
    eq_ind_occs = foldr ((&&&) . eq_ind_occ) Equal 
646
647
648
649
650
651
     
    -- The Occs of declarations that changed.
    changed_occs :: OccSet
    changed_occs = computeChangedOccs ver_fn (mi_module new_iface)
                         (mi_usages old_iface) eq_info

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
    -------------------
    -- Diffs
    pp_decl_diffs :: SDoc	-- Nothing => no changes
    pp_decl_diffs 
	| isEmptyOccSet changed_occs = empty
	| otherwise 
	= vcat [ptext SLIT("Changed occs:") <+> ppr (occSetElts changed_occs),
		ptext SLIT("Version change for these decls:"),
		nest 2 (vcat (map show_change new_decls))]

    eq_env = mkOccEnv eq_info
    show_change new_decl
	| not (occ `elemOccSet` changed_occs) = empty
	| otherwise
	= vcat [ppr occ <+> ppr (old_decl_vers occ) <+> arrow <+> ppr new_version, 
		nest 2 why]
	where
	  occ = ifName new_decl
	  why = case lookupOccEnv eq_env occ of
671
		    Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:") <> ppr names,
672
673
					      nest 2 (braces (fsep (map ppr (occSetElts 
						(occs `intersectOccSet` changed_occs)))))]
674
                           where occs = mkOccSet (map nameOccName (nameSetToList names))
675
676
677
678
679
680
681
682
		    Just NotEqual  
			| Just old_decl <- lookupOccEnv old_decl_env occ 
			-> vcat [ptext SLIT("Old:") <+> ppr old_decl,
			 ptext SLIT("New:") <+> ppr new_decl]
			| otherwise 
			-> ppr occ <+> ptext SLIT("only in new interface")
		    other -> pprPanic "MkIface.show_change" (ppr occ)
	
683
684
    pp_orphs = pprOrphans new_orph_insts new_orph_rules

685

686
pprOrphans insts rules
687
688
689
690
691
692
693
694
695
696
  | null insts && null rules = Nothing
  | otherwise
  = Just $ vcat [
	if null insts then empty else
	     hang (ptext SLIT("Warning: orphan instances:"))
		2 (vcat (map ppr insts)),
	if null rules then empty else
	     hang (ptext SLIT("Warning: orphan rules:"))
		2 (vcat (map ppr rules))
    ]
697

698
699
700
701
702
703
704
computeChangedOccs
        :: (Name -> (OccName,Version))     -- get parents and versions
        -> Module                       -- This module
        -> [Usage]                      -- Usages from old iface
        -> [(OccName, IfaceEq)]         -- decl names, equality conditions
        -> OccSet                       -- set of things that have changed
computeChangedOccs ver_fn this_module old_usages eq_info
705
706
  = foldl add_changes emptyOccSet (stronglyConnComp edges)
  where
707
708
709
710

    -- return True if an external name has changed
    name_changed :: Name -> Bool
    name_changed nm
711
712
	| isWiredInName nm	-- Wired-in things don't get into interface
	= False			-- files and hence don't get into the ver_fn
713
714
715
716
717
718
719
720
        | Just ents <- lookupUFM usg_modmap (moduleName mod),
          Just v    <- lookupUFM ents parent_occ
        = v < new_version
        | modulePackageId mod == this_pkg
        = WARN(True, ptext SLIT("computeChangedOccs") <+> ppr nm) True
        -- should really be a panic, see #1959.  The problem is that the usages doesn't
        -- contain all the names that might be referred to by unfoldings.  So as a
        -- conservative workaround we just assume these names have changed.
721
722
723
724
725
        | otherwise = False -- must be in another package
      where
         mod = nameModule nm
         (parent_occ, new_version) = ver_fn nm

726
727
    this_pkg = modulePackageId this_module

728
    -- Turn the usages from the old ModIface into a mapping
729
    usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg))
730
731
732
733
734
735
736
737
738
739
740
741
742
743
                           | usg <- old_usages ]

    get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet
    get_local_eq_info Equal = Equal
    get_local_eq_info NotEqual = NotEqual
    get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
        where f name eq | nameModule name == this_module =         
                          EqBut (unitOccSet (nameOccName name)) `and_occifeq` eq
                        | name_changed name = NotEqual
                        | otherwise = eq

    local_eq_infos = mapSnd get_local_eq_info eq_info

    edges :: [((OccName, OccIfaceEq), Unique, [Unique])]
744
    edges = [ (node, getUnique occ, map getUnique occs)
745
	    | node@(occ, iface_eq) <- local_eq_infos
746
747
748
749
750
	    , let occs = case iface_eq of
			   EqBut occ_set -> occSetElts occ_set
			   other -> [] ]

    -- Changes in declarations
751
    add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet
752
    add_changes so_far (AcyclicSCC (occ, iface_eq)) 
753
	| changedWrt so_far iface_eq -- This one has changed
754
755
	= extendOccSet so_far occ
    add_changes so_far (CyclicSCC pairs)
756
757
758
759
	| changedWrt so_far (foldr1 and_occifeq iface_eqs)
        	-- One of this group has changed
	= extendOccSetList so_far occs
        where (occs, iface_eqs) = unzip pairs
760
761
    add_changes so_far other = so_far

762
763
type OccIfaceEq = GenIfaceEq OccSet

764
765
766
767
768
instance Outputable OccIfaceEq where
  ppr Equal          = ptext SLIT("Equal")
  ppr NotEqual       = ptext SLIT("NotEqual")
  ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset)

769
changedWrt :: OccSet -> OccIfaceEq -> Bool
770
771
772
773
changedWrt so_far Equal        = False
changedWrt so_far NotEqual     = True
changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids

774
775
776
777
778
779
780
781
782
783
784
785
786
changedWrtNames :: OccSet -> IfaceEq -> Bool
changedWrtNames so_far Equal        = False
changedWrtNames so_far NotEqual     = True
changedWrtNames so_far (EqBut kids) = 
  so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids))

and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq
Equal       `and_occifeq` x 	    = x
NotEqual    `and_occifeq` x	    = NotEqual
EqBut nms   `and_occifeq` Equal       = EqBut nms
EqBut nms   `and_occifeq` NotEqual    = NotEqual
EqBut nms1  `and_occifeq` EqBut nms2  = EqBut (nms1 `unionOccSets` nms2)

787
----------------------
788
-- mkOrphMap partitions instance decls or rules into
789
790
791
-- 	(a) an OccEnv for ones that are not orphans, 
--	    mapping the local OccName to a list of its decls
--	(b) a list of orphan decls
792
mkOrphMap :: (decl -> Maybe OccName)	-- (Just occ) for a non-orphan decl, keyed by occ
793
794
795
796
797
					-- Nothing for an orphan decl
	  -> [decl] 			-- Sorted into canonical order
	  -> (OccEnv [decl],	 	-- Non-orphan decls associated with their key;
					--	each sublist in canonical order
	      [decl])			-- Orphan decls; in canonical order
798
mkOrphMap get_key decls
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
  = foldl go (emptyOccEnv, []) decls
  where
    go (non_orphs, orphs) d
	| Just occ <- get_key d
	= (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
	| otherwise = (non_orphs, d:orphs)

----------------------
bump_unless :: Bool -> Version -> Version
bump_unless True  v = v	-- True <=> no change
bump_unless False v = bumpVersion v
\end{code}


%*********************************************************
%*							*
\subsection{Keeping track of what we've slurped, and version numbers}
%*							*
%*********************************************************


\begin{code}
821
mkUsageInfo :: HscEnv 
822
	    -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
Simon Marlow's avatar
Simon Marlow committed
823
	    -> [(ModuleName, IsBootInterface)]
824
	    -> NameSet -> IO [Usage]
Simon Marlow's avatar
Simon Marlow committed
825
mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
826
  = do	{ eps <- hscEPS hsc_env
Simon Marlow's avatar
Simon Marlow committed
827
	; let usages = mk_usage_info (eps_PIT eps) hsc_env 
828
829
830
831
832
				     dir_imp_mods dep_mods used_names
	; usages `seqList`  return usages }
	 -- seq the list of Usages returned: occasionally these
	 -- don't get evaluated for a while and we can end up hanging on to
	 -- the entire collection of Ifaces.
833

834
835
836
837
838
839
mk_usage_info :: PackageIfaceTable
              -> HscEnv
              -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
              -> [(ModuleName, IsBootInterface)]
              -> NameSet
              -> [Usage]
840
mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names
841
842
  = mapCatMaybes mkUsage dep_mods
	-- ToDo: do we need to sort into canonical order?
843
  where
844
    hpt = hsc_HPT hsc_env
Simon Marlow's avatar
Simon Marlow committed
845
    dflags = hsc_dflags hsc_env
846

847
848
849
850
    -- ent_map groups together all the things imported and used
    -- from a particular module in this package
    ent_map :: ModuleEnv [OccName]
    ent_map  = foldNameSet add_mv emptyModuleEnv used_names
851
852
853
854
855
856
    add_mv name mv_map
        | isWiredInName name = mv_map  -- ignore wired-in names
        | otherwise
        = case nameModule_maybe name of
             Nothing  -> mv_map         -- ignore internal names
             Just mod -> extendModuleEnv_C add_item mv_map mod [occ]
857
858
859
860
    		   where
		     occ = nameOccName name
    		     add_item occs _ = occ:occs
    
861
    depend_on_exports mod = case lookupModuleEnv dir_imp_mods mod of
862
863
    				Just (_, xs) -> any (\(_, no_imp, _) -> not no_imp) xs
	    			Nothing		 -> True
864
865
866
867
868
    
    -- We want to create a Usage for a home module if 
    --	a) we used something from; has something in used_names
    --	b) we imported all of it, even if we used nothing from it
    --		(need to recompile if its export list changes: export_vers)
869
870
    --	c) is a home-package orphan or family-instance module (need to
    --	        recompile if its instance decls change: rules_vers)
Simon Marlow's avatar
Simon Marlow committed
871
    mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage
872
    mkUsage (mod_name, _)
Simon Marlow's avatar
Simon Marlow committed
873
874
      |  isNothing maybe_iface		-- We can't depend on it if we didn't
      || (null used_occs		-- load its interface.
875
	  && isNothing export_vers
876
877
	  && not orphan_mod
	  && not finsts_mod)
878
879
880
      = Nothing			-- Record no usage info
    
      | otherwise	
Simon Marlow's avatar
Simon Marlow committed
881
      = Just (Usage { usg_name     = mod_name,
882
883
    	  	      usg_mod      = mod_vers,
    		      usg_exports  = export_vers,
884
    		      usg_entities = fmToList ent_vers,
885
886
    		      usg_rules    = rules_vers })
      where
Simon Marlow's avatar
Simon Marlow committed
887
	maybe_iface  = lookupIfaceByModule dflags hpt pit mod
888
889
890
		-- In one-shot mode, the interfaces for home-package 
		-- modules accumulate in the PIT not HPT.  Sigh.

Simon Marlow's avatar
Simon Marlow committed
891
892
        mod = mkModule (thisPackage dflags) mod_name

893
894
        Just iface   = maybe_iface
	orphan_mod   = mi_orphan    iface
895
	finsts_mod   = mi_finsts    iface
896
897
898
        version_env  = mi_ver_fn    iface
        mod_vers     = mi_mod_vers  iface
        rules_vers   = mi_rule_vers iface
899
900
        export_vers | depend_on_exports mod = Just (mi_exp_vers iface)
    		    | otherwise 	    = Nothing
901
902
    
        used_occs = lookupModuleEnv ent_map mod `orElse` []
903
904
905
906
907
908
909
910
911
912
913
914
915
916

    	-- Making a FiniteMap here ensures that (a) we remove duplicates
        -- when we have usages on several subordinates of a single parent,
        -- and (b) that the usages emerge in a canonical order, which
        -- is why we use FiniteMap rather than OccEnv: FiniteMap works
        -- using Ord on the OccNames, which is a lexicographic ordering.
	ent_vers :: FiniteMap OccName Version
        ent_vers = listToFM (map lookup_occ used_occs)
        
        lookup_occ occ = 
            case version_env occ of
                Nothing -> pprTrace "hmm, strange" (ppr mod <+> ppr occ) $
                           (occ, initialVersion) -- does this ever happen?
                Just (parent, version) -> (parent, version)
917
918
919
\end{code}

\begin{code}
920
921
mkIfaceExports :: [AvailInfo]
               -> [(Module, [GenAvailInfo OccName])]
922
923
  -- Group by module and sort by occurrence
  -- This keeps the list in canonical order
924
925
mkIfaceExports exports
  = [ (mod, eltsFM avails)
Simon Marlow's avatar
Simon Marlow committed
926
    | (mod, avails) <- fmToList groupFM
927
928
    ]
  where
929
930
	-- Group by the module where the exported entities are defined
	-- (which may not be the same for all Names in an Avail)
931
	-- Deliberately use FiniteMap rather than UniqFM so we
932
	-- get a canonical ordering
933
934
    groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
    groupFM = foldl add emptyModuleEnv exports
935

936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
    add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
	    -> Module -> GenAvailInfo OccName
	    -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
    add_one env mod avail 
      =  extendModuleEnv_C plusFM env mod 
		(unitFM (occNameFS (availName avail)) avail)

	-- NB: we should not get T(X) and T(Y) in the export list
	--     else the plusFM will simply discard one!  They
	--     should have been combined by now.
    add env (Avail n)
      = add_one env (nameModule n) (Avail (nameOccName n))

    add env (AvailTC tc ns)
      = foldl add_for_mod env mods
951
      where
952
953
954
955
956
	tc_occ = nameOccName tc
	mods   = nub (map nameModule ns)
		-- Usually just one, but see Note [Original module]

	add_for_mod env mod
957
958
	    = add_one env mod (AvailTC tc_occ (sort names_from_mod))
              -- NB. sort the children, we need a canonical order
959
960
	    where
	      names_from_mod = [nameOccName n | n <- ns, nameModule n == mod]
961
962
\end{code}

963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
Note [Orignal module]
~~~~~~~~~~~~~~~~~~~~~
Consider this:
	module X where { data family T }
	module Y( T(..) ) where { import X; data instance T Int = MkT Int }
The exported Avail from Y will look like
	X.T{X.T, Y.MkT}
That is, in Y, 
  - only MkT is brought into scope by the data instance;
  - but the parent (used for grouping and naming in T(..) exports) is X.T
  - and in this case we export X.T too

In the result of MkIfaceExports, the names are grouped by defining module,
so we may need to split up a single Avail into multiple ones.

978

979
980
981
982
983
984
985
986
987
988
%************************************************************************
%*									*
	Load the old interface file for this module (unless
	we have it aleady), and check whether it is up to date
	
%*									*
%************************************************************************

\begin{code}
checkOldIface :: HscEnv
989
	      -> ModSummary
990
991
992
993
	      -> Bool 			-- Source unchanged
	      -> Maybe ModIface 	-- Old interface from compilation manager, if any
	      -> IO (RecompileRequired, Maybe ModIface)

994
checkOldIface hsc_env mod_summary source_unchanged maybe_iface
995
  = do	{ showPass (hsc_dflags hsc_env) 
Simon Marlow's avatar
Simon Marlow committed
996
997
	           ("Checking old interface for " ++ 
			showSDoc (ppr (ms_mod mod_summary))) ;
998

999
	; initIfaceCheck hsc_env $
Simon Marlow's avatar
Simon Marlow committed
1000
	  check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1001
1002
     }

Simon Marlow's avatar
Simon Marlow committed
1003
check_old_iface hsc_env mod_summary source_unchanged maybe_iface
1004
1005
1006
 =  do 	-- CHECK WHETHER THE SOURCE HAS CHANGED
    { ifM (not source_unchanged)
	   (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
1007
1008
1009

     -- If the source has changed and we're in interactive mode, avoid reading
     -- an interface; just return the one we might have been supplied with.
1010
1011
    ; let dflags = hsc_dflags hsc_env
    ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then
1012
1013
1014
1015
1016
         return (outOfDate, maybe_iface)
      else
      case maybe_iface of {
        Just old_iface -> do -- Use the one we already have
	  { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary))
1017
	  ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface
1018
1019
1020
	  ; return (recomp, Just old_iface) }

      ; Nothing -> do
1021
1022
1023

	-- Try and read the old interface for the current module
	-- from the .hi file left from the last time we compiled it
1024
1025
1026
1027
1028
1029
1030
    { let iface_path = msHiFilePath mod_summary
    ; read_result <- readIface (ms_mod mod_summary) iface_path False
    ; case read_result of {
         Failed err -> do	-- Old interface file not found, or garbled; give up
		{ traceIf (text "FYI: cannot read old interface file:"
			   	 $$ nest 4 err)
	        ; return (outOfDate, Nothing) }
1031

1032
      ;  Succeeded iface -> do
1033
1034

	-- We have got the old iface; check its versions
1035
    { traceIf (text "Read the interface file" <+> text iface_path)
1036
    ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface
1037
1038
    ; returnM (recomp, Just iface)
    }}}}}
1039

1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
\end{code}

@recompileRequired@ is called from the HscMain.   It checks whether
a recompilation is required.  It needs access to the persistent state,
finder, etc, because it may have to load lots of interface files to
check their versions.

\begin{code}
type RecompileRequired = Bool
upToDate  = False	-- Recompile not required
outOfDate = True	-- Recompile required

Simon Marlow's avatar
Simon Marlow committed
1052
1053
checkVersions :: HscEnv
	      -> Bool		-- True <=> source unchanged
1054
              -> ModSummary
1055
1056
	      -> ModIface 	-- Old interface
	      -> IfG RecompileRequired
1057
checkVersions hsc_env source_unchanged mod_summary iface
1058
1059
1060
  | not source_unchanged
  = returnM outOfDate
  | otherwise
1061
1062
  = do	{ traceHiDiffs (text "Considering whether compilation is required for" <+> 
		        ppr (mi_module iface) <> colon)
1063

1064
1065
1066
        ; recomp <- checkDependencies hsc_env mod_summary iface
        ; if recomp then return outOfDate else do {

1067
	-- Source code unchanged and no errors yet... carry on 
1068

1069
	-- First put the dependent-module info, read from the old interface, into the envt, 
1070
	-- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
1071
	-- 
1072
1073
1074
	-- It's just temporary because either the usage check will succeed 
	-- (in which case we are done with this module) or it'll fail (in which
	-- case we'll compile the module from scratch anyhow).
1075
	--	
1076
1077
1078
	-- We do this regardless of compilation mode, although in --make mode
	-- all the dependent modules should be in the HPT already, so it's
	-- quite redundant
1079
	  updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
1080

Simon Marlow's avatar
Simon Marlow committed
1081
1082
	; let this_pkg = thisPackage (hsc_dflags hsc_env)
	; checkList [checkModUsage this_pkg u | u <- mi_usages iface]
1083
    }}
1084
1085
  where
	-- This is a bit of a hack really
Simon Marlow's avatar
Simon Marlow committed
1086
    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
1087
1088
    mod_deps = mkModDeps (dep_mods (mi_deps iface))

1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135

-- If the direct imports of this module are resolved to targets that
-- are not among the dependencies of the previous interface file,
-- then we definitely need to recompile.  This catches cases like
--   - an exposed package has been upgraded
--   - we are compiling with different package flags
--   - a home module that was shadowing a package module has been removed
--   - a new home module has been added that shadows a package module
-- See bug #1372.
--
-- Returns True if recompilation is required.
checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
checkDependencies hsc_env summary iface
 = orM (map dep_missing (ms_imps summary ++ ms_srcimps summary))
  where
   prev_dep_mods = dep_mods (mi_deps iface)
   prev_dep_pkgs = dep_pkgs (mi_deps iface)

   this_pkg = thisPackage (hsc_dflags hsc_env)

   orM = foldr f (return False)
    where f m rest = do b <- m; if b then return True else rest

   dep_missing (L _ mod) = do
     find_res <- ioToIOEnv $ findImportedModule hsc_env mod Nothing
     case find_res of
        Found _ mod
          | pkg == this_pkg
           -> if moduleName mod `notElem` map fst prev_dep_mods
                 then do traceHiDiffs $
                           text "imported module " <> quotes (ppr mod) <>
                           text " not among previous dependencies"
                         return outOfDate
                 else
                         return upToDate
          | otherwise
           -> if pkg `notElem` prev_dep_pkgs
                 then do traceHiDiffs $
                           text "imported module " <> quotes (ppr mod) <>
                           text " is from package " <> quotes (ppr pkg) <>
                           text ", which is not among previous dependencies"
                         return outOfDate
                 else
                         return upToDate
           where pkg = modulePackageId mod
        _otherwise  -> return outOfDate

Simon Marlow's avatar
Simon Marlow committed
1136
checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
1137
1138
1139
1140
-- Given the usage information extracted from the old
-- M.hi file for the module being compiled, figure out
-- whether M needs to be recompiled.

Simon Marlow's avatar
Simon Marlow committed
1141
1142
1143
1144
checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers,
		       		usg_rules = old_rule_vers,
		       		usg_exports = maybe_old_export_vers, 
		       		usg_entities = old_decl_vers })
1145
1146
1147
1148
1149
1150
  = 	-- Load the imported interface is possible
    let
    	doc_str = sep [ptext SLIT("need version info for"), ppr mod_name]
    in
    traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_`

Simon Marlow's avatar
Simon Marlow committed
1151
1152
1153
1154
    let
	mod = mkModule this_pkg mod_name
    in
    loadInterface doc_str mod ImportBySystem		`thenM` \ mb_iface ->
1155
1156
1157
1158
	-- Load the interface, but don't complain on failure;
	-- Instead, get an Either back which we can test

    case mb_iface of {
1159
	Failed exn ->  (out_of_date (sep [ptext SLIT("Can't find version number for module"), 
1160
1161
1162
1163
1164
				       ppr mod_name]));
		-- Couldn't find or parse a module mentioned in the
		-- old interface file.  Don't complain -- it might just be that
		-- the current module doesn't need that import and it's been deleted

1165
	Succeeded iface -> 
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
    let
	new_mod_vers    = mi_mod_vers  iface
	new_decl_vers 	= mi_ver_fn    iface
	new_export_vers = mi_exp_vers  iface
	new_rule_vers   = mi_rule_vers iface
    in
	-- CHECK MODULE
    checkModuleVersion old_mod_vers new_mod_vers	`thenM` \ recompile ->
    if not recompile then
	returnM upToDate
    else
				 
	-- CHECK EXPORT LIST
    if checkExportList maybe_old_export_vers new_export_vers then
	out_of_date_vers (ptext SLIT("  Export list changed"))
1181
		         (expectJust "checkModUsage" maybe_old_export_vers) 
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
		         new_export_vers
    else

	-- CHECK RULES
    if old_rule_vers /= new_rule_vers then
	out_of_date_vers (ptext SLIT("  Rules changed")) 
			 old_rule_vers new_rule_vers
    else

	-- CHECK ITEMS ONE BY ONE
    checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers]	`thenM` \ recompile ->
    if recompile then
	returnM outOfDate	-- This one failed, so just bail out now
    else
	up_to_date (ptext SLIT("  Great!  The bits I use are up to date"))
    }

------------------------
checkModuleVersion old_mod_vers new_mod_vers
  | new_mod_vers == old_mod_vers
  = up_to_date (ptext SLIT("Module version unchanged"))

  | otherwise
  = out_of_date_vers (ptext SLIT("  Module version has changed"))
		     old_mod_vers new_mod_vers

------------------------
checkExportList Nothing  new_vers = upToDate
checkExportList (Just v) new_vers = v /= new_vers

------------------------
checkEntityUsage new_vers (name,old_vers)
  = case new_vers name of

	Nothing       -> 	-- We used it before, but it ain't there now
			  out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])

1219
	Just (_, new_vers) 	-- It's there, but is it up to date?
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
	  | new_vers == old_vers -> traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_`
			  	    returnM upToDate
	  | otherwise	 	 -> out_of_date_vers (ptext SLIT("  Out of date:") <+> ppr name)
						     old_vers new_vers

up_to_date  msg = traceHiDiffs msg `thenM_` returnM upToDate
out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate
out_of_date_vers msg old_vers new_vers 
  = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers])

----------------------
checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
-- This helper is used in two places
checkList []		 = returnM upToDate
checkList (check:checks) = check	`thenM` \ recompile ->
			   if recompile then 
				returnM outOfDate
			   else
				checkList checks
\end{code}

%************************************************************************
%*				 					*
1243
		Converting things to their Iface equivalents
1244
1245
1246
1247
%*				 					*
%************************************************************************

\begin{code}
1248
tyThingToIfaceDecl :: TyThing -> IfaceDecl
1249
1250
1251
1252
-- Assumption: the thing is already tidied, so that locally-bound names
-- 	       (lambdas, for-alls) already have non-clashing OccNames
-- Reason: Iface stuff uses OccNames, and the conversion here does
--	   not do tidying on the way
1253
1254
1255
tyThingToIfaceDecl (AnId id)
  = IfaceId { ifName   = getOccName id,
	      ifType   = toIfaceType (idType id),
1256
1257
	      ifIdInfo = info }
  where
1258
    info = case toIfaceIdInfo (idInfo id) of
1259
1260
1261
		[]    -> NoInfo
		items -> HasInfo items

1262
1263
tyThingToIfaceDecl (AClass clas)
  = IfaceClass { ifCtxt	  = toIfaceContext sc_theta,
1264
1265
1266
		 ifName	  = getOccName clas,
		 ifTyVars = toIfaceTvBndrs clas_tyvars,
		 ifFDs    = map toIfaceFD clas_fds,
1267
		 ifATs	  = map (tyThingToIfaceDecl . ATyCon) clas_ats,
1268
		 ifSigs	  = map toIfaceClassOp op_stuff,
1269
	  	 ifRec    = boolToRecFlag (isRecursiveTyCon tycon) }
1270
  where
1271
1272
    (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) 
      = classExtraBigSig clas
1273
    tycon = classTyCon clas
1274

1275
1276
    toIfaceClassOp (sel_id, def_meth)
	= ASSERT(sel_tyvars == clas_tyvars)
1277
	  IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
1278
1279
1280
1281
1282
1283
1284
1285
1286
	where
		-- Be careful when splitting the type, because of things
		-- like  	class Foo a where
		--		  op :: (?x :: String) => a -> a
		-- and  	class Baz a where
		--		  op :: (Ord a) => a -> a
	  (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
	  op_ty		       = funResultTy rho_ty

1287
    toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
1288

1289
tyThingToIfaceDecl (ATyCon tycon)
1290
  | isSynTyCon tycon
1291
1292
  = IfaceSyn {	ifName    = getOccName tycon,
		ifTyVars  = toIfaceTvBndrs tyvars,
1293
		ifOpenSyn = syn_isOpen,
1294
1295
1296
		ifSynRhs  = toIfaceType syn_tyki,
                ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
             }
1297
1298
1299
1300

  | isAlgTyCon tycon
  = IfaceData {	ifName    = getOccName tycon,
		ifTyVars  = toIfaceTvBndrs tyvars,
1301
		ifCtxt    = toIfaceContext (tyConStupidTheta tycon),
1302
1303
1304
		ifCons    = ifaceConDecls (algTyConRhs tycon),
	  	ifRec     = boolToRecFlag (isRecursiveTyCon tycon),
		ifGadtSyntax = isGadtSyntaxTyCon tycon,
1305
		ifGeneric = tyConHasGenerics tycon,
1306
		ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
1307
1308
1309
1310
1311
1312

  | isForeignTyCon tycon
  = IfaceForeign { ifName    = getOccName tycon,
	    	   ifExtName = tyConExtName tycon }

  | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
1313
  where
1314
    tyvars = tyConTyVars tycon
1315
    (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
1316
1317
			       OpenSynTyCon ki _ -> (True , ki)
			       SynonymTyCon ty   -> (False, ty)
1318

1319
    ifaceConDecls (NewTyCon { data_con = con })     = 
1320
      IfNewTyCon  (ifaceConDecl con)
1321
    ifaceConDecls (DataTyCon { data_cons = cons })  = 
1322
      IfDataTyCon (map ifaceConDecl cons)
1323
    ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
1324
    ifaceConDecls AbstractTyCon			    = IfAbstractTyCon
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
	-- The last case happens when a TyCon has been trimmed during tidying
	-- Furthermore, tyThingToIfaceDecl is also used
	-- in TcRnDriver for GHCi, when browsing a module, in which case the
	-- AbstractTyCon case is perfectly sensible.

    ifaceConDecl data_con 
	= IfCon   { ifConOcc   	 = getOccName (dataConName data_con),
		    ifConInfix 	 = dataConIsInfix data_con,
		    ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
		    ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
		    ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
1336
		    ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
1337
		    ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
1338
1339
		    ifConFields  = map getOccName 
				       (dataConFieldLabels data_con),
1340
		    ifConStricts = dataConStrictMarks data_con }
1341

1342
    to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
1343

1344
1345
    famInstToIface Nothing                    = Nothing
    famInstToIface (Just (famTyCon, instTys)) = 
1346
      Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
1347

1348
tyThingToIfaceDecl (ADataCon dc)
1349
1350
1351
 = pprPanic "toIfaceDecl" (ppr dc)	-- Should be trimmed out earlier


1352
1353
getFS x = occNameFS (getOccName x)

1354
--------------------------
1355
1356
instanceToIfaceInst :: Instance -> IfaceInst
instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
1357
1358
1359
				      is_cls = cls_name, is_tcs = mb_tcs })
  = ASSERT( cls_name == className cls )
    IfaceInst { ifDFun    = dfun_name,
1360
		ifOFlag   = oflag,
1361
		ifInstCls = cls_name,
1362
1363
1364
1365
		ifInstTys = map do_rough mb_tcs,
		ifInstOrph = orph }
  where
    do_rough Nothing  = Nothing
1366
    do_rough (Just n) = Just (toIfaceTyCon_name n)
1367

1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
    dfun_name = idName dfun_id
    mod       = nameModule dfun_name
    is_local name = nameIsLocalOrFrom mod name

	-- Compute orphanhood.  See Note [Orphans] in IfaceSyn
    (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
		-- Slightly awkward: we need the Class to get the fundeps
    (tvs, fds) = classTvsFds cls
    arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]
    orph | is_local cls_name = Just (nameOccName cls_name)
	 | all isJust mb_ns  = head mb_ns
	 | otherwise	     = Nothing
    
    mb_ns :: [Maybe OccName]	-- One for each fundep; a locally-defined name
				-- that is not in the "determined" arguments
    mb_ns | null fds   = [choose_one arg_names]
	  | otherwise  = map do_one fds
    do_one (ltvs,rtvs) = choose_one [ns | (tv,ns) <- tvs `zip` arg_names
					, not (tv `elem` rtvs)]

    choose_one :: [NameSet] -> Maybe OccName
    choose_one nss = case nameSetToList (unionManyNameSets nss) of
			[]     -> Nothing
			(n:ns) -> Just (nameOccName n)

1393
--------------------------
1394
1395
famInstToIfaceFamInst :: FamInst -> IfaceFamInst
famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon,
1396
					    fi_fam = fam, fi_tcs = mb_tcs })
1397
1398
  = IfaceFamInst { ifFamInstTyCon  = toIfaceTyCon tycon
		 , ifFamInstFam    = fam
1399
1400
1401
		 , ifFamInstTys    = map do_rough mb_tcs }
  where
    do_rough Nothing  = Nothing
1402
    do_rough (Just n) = Just (toIfaceTyCon_name n)
1403

1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
--------------------------
toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))
			       (toIfaceType (idType id)) 
			       prag_info
  where
	-- Stripped-down version of tcIfaceIdInfo
	-- Change this if you want to export more IdInfo for
	-- non-top-level Ids.  Don't forget to change
	-- CoreTidy.tidyLetBndr too!
	--
	-- See Note [IdInfo on nested let-bindings] in IfaceSyn
    id_info = idInfo id
    inline_prag = inlinePragInfo id_info
    prag_info | isAlwaysActive inline_prag = NoInfo
	      | otherwise		   = HasInfo [HsInline inline_prag]

1420
--------------------------
1421
1422
toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
toIfaceIdInfo id_info
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
  = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, 
	       inline_hsinfo, wrkr_hsinfo,  unfold_hsinfo] 
  where
    ------------  Arity  --------------
    arity_info = arityInfo id_info
    arity_hsinfo | arity_info == 0 = Nothing
		 | otherwise       = Just (HsArity arity_info)

    ------------ Caf Info --------------
    caf_info   = cafInfo id_info
    caf_hsinfo = case caf_info of
		   NoCafRefs -> Just HsNoCafRefs
		   _other    -> Nothing

    ------------  Strictness  --------------
	-- No point in explicitly exporting TopSig
    strict_hsinfo = case newStrictnessInfo id_info of
			Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
			_other			      -> Nothing

    ------------  Worker  --------------
    work_info   = workerInfo id_info
Simon Marlow's avatar
Simon Marlow committed
1445
    has_worker  = workerExists work_info
1446
1447
    wrkr_hsinfo = case work_info of
		    HasWorker work_id wrap_arity -> 
1448
			Just (HsWorker ((idName work_id)) wrap_arity)
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
		    NoWorker -> Nothing

    ------------  Unfolding  --------------
    -- The unfolding is redundant if there is a worker
    unfold_info  = unfoldingInfo id_info
    rhs		 = unfoldingTemplate unfold_info
    no_unfolding = neverUnfold unfold_info
		  	-- The CoreTidy phase retains unfolding info iff
			-- we want to expose the unfolding, taking into account
			-- unconditional NOINLINE, etc.  See TidyPgm.addExternal
    unfold_hsinfo | no_unfolding = Nothing			
		  | has_worker   = Nothing	-- Unfolding is implicit
1461
		  | otherwise	 = Just (HsUnfold (toIfaceExpr rhs))
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
					
    ------------  Inline prag  --------------
    inline_prag = inlinePragInfo id_info
    inline_hsinfo | isAlwaysActive inline_prag     = Nothing
		  | no_unfolding && not has_worker = Nothing
			-- If the iface file give no unfolding info, we 
			-- don't need to say when inlining is OK!
		  | otherwise			   = Just (HsInline inline_prag)

--------------------------
1472
1473
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
coreRuleToIfaceRule mod (BuiltinRule { ru_fn = fn})
1474
  = pprTrace "toHsRule: builtin" (ppr fn) $
1475
    bogusIfaceRule fn
1476

1477
1478
1479
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn, 
                                ru_act = act, ru_bndrs = bndrs,
	                        ru_args = args, ru_rhs = rhs })
1480
  = IfaceRule { ifRuleName  = name, ifActivation = act, 
1481
1482
		ifRuleBndrs = map toIfaceBndr bndrs,
		ifRuleHead  = fn,