Use MD5 checksums for recompilation checking (fixes #1372, #1959)
authorSimon Marlow <marlowsd@gmail.com>
Wed, 28 May 2008 12:52:58 +0000 (12:52 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Wed, 28 May 2008 12:52:58 +0000 (12:52 +0000)
This is a much more robust way to do recompilation checking.  The idea
is to create a fingerprint of the ABI of an interface, and track
dependencies by recording the fingerprints of ABIs that a module
depends on.  If any of those ABIs have changed, then we need to
recompile.

In bug #1372 we weren't recording dependencies on package modules,
this patch fixes that by recording fingerprints of package modules
that we depend on.  Within a package there is still fine-grained
recompilation avoidance as before.

We currently use MD5 for fingerprints, being a good compromise between
efficiency and security.  We're not worried about attackers, but we
are worried about accidental collisions.

All the MD5 sums do make interface files a bit bigger, but compile
times on the whole are about the same as before.  Recompilation
avoidance should be a bit more accurate than in 6.8.2 due to fixing
#1959, especially when using -O.

25 files changed:
compiler/Makefile
compiler/basicTypes/Module.lhs
compiler/basicTypes/Name.lhs
compiler/basicTypes/OccName.lhs
compiler/coreSyn/CoreLint.lhs
compiler/ghci/InteractiveUI.hs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/TidyPgm.lhs
compiler/rename/RnNames.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplUtils.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/types/Type.lhs
compiler/utils/Binary.hs
compiler/utils/FastMutInt.lhs
compiler/utils/Fingerprint.hsc [new file with mode: 0644]
compiler/utils/md5.c [new file with mode: 0644]
compiler/utils/md5.h [new file with mode: 0644]
utils/hsc2hs/Makefile

index 216e5f8..a16cd21 100644 (file)
@@ -572,7 +572,7 @@ SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
 
 SRC_HC_OPTS += \
   -cpp -fglasgow-exts -fno-generics -Rghc-timing \
 
 SRC_HC_OPTS += \
   -cpp -fglasgow-exts -fno-generics -Rghc-timing \
-  -I. -Iparser
+  -I. -Iparser -Iutil
 
 # Omitted:     -I$(GHC_INCLUDE_DIR)
 # We should have -I$(GHC_INCLUDE_DIR) in SRC_HC_OPTS, 
 
 # Omitted:     -I$(GHC_INCLUDE_DIR)
 # We should have -I$(GHC_INCLUDE_DIR) in SRC_HC_OPTS, 
index 5047be1..8d9cb3b 100644 (file)
@@ -42,6 +42,7 @@ module Module
        modulePackageId, moduleName,
        pprModule,
        mkModule,
        modulePackageId, moduleName,
        pprModule,
        mkModule,
+        stableModuleCmp,
 
        -- * The ModuleLocation type
        ModLocation(..),
 
        -- * The ModuleLocation type
        ModLocation(..),
@@ -71,6 +72,7 @@ import FiniteMap
 import LazyUniqFM
 import FastString
 import Binary
 import LazyUniqFM
 import FastString
 import Binary
+import Util
 
 import System.FilePath
 \end{code}
 
 import System.FilePath
 \end{code}
@@ -182,6 +184,7 @@ mkModuleNameFS s = ModuleName s
 moduleNameSlashes :: ModuleName -> String
 moduleNameSlashes = dots_to_slashes . moduleNameString
   where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
 moduleNameSlashes :: ModuleName -> String
 moduleNameSlashes = dots_to_slashes . moduleNameString
   where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
+
 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************
@@ -205,8 +208,13 @@ instance Binary Module where
   put_ bh (Module p n) = put_ bh p >> put_ bh n
   get bh = do p <- get bh; n <- get bh; return (Module p n)
 
   put_ bh (Module p n) = put_ bh p >> put_ bh n
   get bh = do p <- get bh; n <- get bh; return (Module p n)
 
-instance Uniquable PackageId where
- getUnique pid = getUnique (packageIdFS pid)
+-- This gives a stable ordering, as opposed to the Ord instance which
+-- gives an ordering based on the Uniques of the components, which may
+-- not be stable from run to run of the compiler.
+stableModuleCmp :: Module -> Module -> Ordering
+stableModuleCmp (Module p1 n1) (Module p2 n2) 
+   = (packageIdFS  p1 `compare` packageIdFS  p2) `thenCmp`
+     (moduleNameFS n1 `compare` moduleNameFS n2)
 
 mkModule :: PackageId -> ModuleName -> Module
 mkModule = Module
 
 mkModule :: PackageId -> ModuleName -> Module
 mkModule = Module
@@ -235,9 +243,17 @@ pprPackagePrefix p mod = getPprStyle doc
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-newtype PackageId = PId FastString deriving( Eq, Ord )  -- includes the version
+newtype PackageId = PId FastString deriving( Eq )  -- includes the version
     -- here to avoid module loops with PackageConfig
 
     -- here to avoid module loops with PackageConfig
 
+instance Uniquable PackageId where
+ getUnique pid = getUnique (packageIdFS pid)
+
+-- Note: *not* a stable lexicographic ordering, a faster unique-based
+-- ordering.
+instance Ord PackageId where
+  nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
+
 instance Outputable PackageId where
    ppr pid = text (packageIdString pid)
 
 instance Outputable PackageId where
    ppr pid = text (packageIdString pid)
 
index aa253cf..7dfed64 100644 (file)
@@ -40,16 +40,13 @@ import {-# SOURCE #-} TypeRep( TyThing )
 import OccName
 import Module
 import SrcLoc
 import OccName
 import Module
 import SrcLoc
-import UniqFM
 import Unique
 import Maybes
 import Binary
 import Unique
 import Maybes
 import Binary
-import FastMutInt
 import FastTypes
 import FastString
 import Outputable
 
 import FastTypes
 import FastString
 import Outputable
 
-import Data.IORef
 import Data.Array
 \end{code}
 
 import Data.Array
 \end{code}
 
@@ -309,20 +306,9 @@ instance NamedThing Name where
 
 \begin{code}
 instance Binary Name where
 
 \begin{code}
 instance Binary Name where
-   put_ bh name = do
-      case getUserData bh of { 
-        UserData { ud_symtab_map = symtab_map_ref,
-                   ud_symtab_next = symtab_next } -> do
-         symtab_map <- readIORef symtab_map_ref
-         case lookupUFM symtab_map name of
-           Just (off,_) -> put_ bh off
-           Nothing -> do
-              off <- readFastMutInt symtab_next
-              writeFastMutInt symtab_next (off+1)
-              writeIORef symtab_map_ref
-                  $! addToUFM symtab_map name (off,name)
-              put_ bh off          
-     }
+   put_ bh name =
+      case getUserData bh of 
+        UserData{ ud_put_name = put_name } -> put_name bh name
 
    get bh = do
         i <- get bh
 
    get bh = do
         i <- get bh
index b6181fb..debaa28 100644 (file)
@@ -5,6 +5,7 @@
 
 \begin{code}
 module OccName (
 
 \begin{code}
 module OccName (
+        mk_deriv,
        -- * The NameSpace type; abstact
        NameSpace, tcName, clsName, tcClsName, dataName, varName, 
        tvName, srcDataName,
        -- * The NameSpace type; abstact
        NameSpace, tcName, clsName, tcClsName, dataName, varName, 
        tvName, srcDataName,
index f7c63f8..de9830b 100644 (file)
@@ -363,6 +363,17 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
   do { scrut_ty <- lintCoreExpr scrut
      ; alt_ty   <- lintTy alt_ty  
      ; var_ty   <- lintTy (idType var) 
   do { scrut_ty <- lintCoreExpr scrut
      ; alt_ty   <- lintTy alt_ty  
      ; var_ty   <- lintTy (idType var) 
+
+     ; let mb_tc_app = splitTyConApp_maybe (idType var)
+     ; case mb_tc_app of 
+         Just (tycon, _)
+              | debugIsOn &&
+                isAlgTyCon tycon && 
+                null (tyConDataCons tycon) -> 
+                  pprTrace "case binder's type has no constructors" (ppr e)
+                      $ return ()
+         _otherwise -> return ()
+
        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
 
      ; subst <- getTvSubst 
        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
 
      ; subst <- getTvSubst 
index 26c4a88..a49109a 100644 (file)
@@ -1635,7 +1635,8 @@ showPackages = do
   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
   io $ putStrLn $ showSDoc $ vcat $
     text "packages currently loaded:" 
   pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
   io $ putStrLn $ showSDoc $ vcat $
     text "packages currently loaded:" 
-    : map (nest 2 . text . packageIdString) (sort pkg_ids)
+    : map (nest 2 . text . packageIdString) 
+               (sortBy (compare `on` packageIdFS) pkg_ids)
   where showFlag (ExposePackage p) = text $ "  -package " ++ p
         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
   where showFlag (ExposePackage p) = text $ "  -package " ++ p
         showFlag (HidePackage p)   = text $ "  -hide-package " ++ p
         showFlag (IgnorePackage p) = text $ "  -ignore-package " ++ p
index 321eac1..152381c 100644 (file)
@@ -32,7 +32,9 @@ import SrcLoc
 import ErrUtils
 import Config
 import FastMutInt
 import ErrUtils
 import Config
 import FastMutInt
+import Unique
 import Outputable
 import Outputable
+import FastString
 
 import Data.List
 import Data.Word
 
 import Data.List
 import Data.Word
@@ -149,7 +151,19 @@ writeBinIface dflags hi_path mod_iface = do
   put_ bh symtab_p_p
 
        -- Make some intial state
   put_ bh symtab_p_p
 
        -- Make some intial state
-  ud <- newWriteState
+  symtab_next <- newFastMutInt
+  writeFastMutInt symtab_next 0
+  symtab_map <- newIORef emptyUFM
+  let bin_symtab = BinSymbolTable {
+                      bin_symtab_next = symtab_next,
+                      bin_symtab_map  = symtab_map }
+  dict_next_ref <- newFastMutInt
+  writeFastMutInt dict_next_ref 0
+  dict_map_ref <- newIORef emptyUFM
+  let bin_dict = BinDictionary {
+                      bin_dict_next = dict_next_ref,
+                      bin_dict_map  = dict_map_ref }
+  ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
 
        -- Put the main thing, 
   bh <- return $ setUserData bh ud
 
        -- Put the main thing, 
   bh <- return $ setUserData bh ud
@@ -161,8 +175,8 @@ writeBinIface dflags hi_path mod_iface = do
   seekBin bh symtab_p          -- Seek back to the end of the file
 
         -- Write the symbol table itself
   seekBin bh symtab_p          -- Seek back to the end of the file
 
         -- Write the symbol table itself
-  symtab_next <- readFastMutInt (ud_symtab_next ud)
-  symtab_map  <- readIORef (ud_symtab_map  ud)
+  symtab_next <- readFastMutInt symtab_next
+  symtab_map  <- readIORef symtab_map
   putSymbolTable bh symtab_next symtab_map
   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next 
                                 <+> text "Names")
   putSymbolTable bh symtab_next symtab_map
   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next 
                                 <+> text "Names")
@@ -176,8 +190,8 @@ writeBinIface dflags hi_path mod_iface = do
   seekBin bh dict_p            -- Seek back to the end of the file
 
        -- Write the dictionary itself
   seekBin bh dict_p            -- Seek back to the end of the file
 
        -- Write the dictionary itself
-  dict_next <- readFastMutInt (ud_dict_next ud)
-  dict_map  <- readIORef (ud_dict_map  ud)
+  dict_next <- readFastMutInt dict_next_ref
+  dict_map  <- readIORef dict_map_ref
   putDictionary bh dict_next dict_map
   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
                                  <+> text "dict entries")
   putDictionary bh dict_next dict_map
   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
                                  <+> text "dict entries")
@@ -248,6 +262,51 @@ serialiseName bh name _ = do
   let mod = nameModule name
   put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 
   let mod = nameModule name
   put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 
+
+putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
+putName BinSymbolTable{ 
+            bin_symtab_map = symtab_map_ref,
+            bin_symtab_next = symtab_next }    bh name
+  = do
+    symtab_map <- readIORef symtab_map_ref
+    case lookupUFM symtab_map name of
+      Just (off,_) -> put_ bh off
+      Nothing -> do
+         off <- readFastMutInt symtab_next
+         writeFastMutInt symtab_next (off+1)
+         writeIORef symtab_map_ref
+             $! addToUFM symtab_map name (off,name)
+         put_ bh off          
+
+
+data BinSymbolTable = BinSymbolTable {
+        bin_symtab_next :: !FastMutInt, -- The next index to use
+        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
+                                -- indexed by Name
+  }
+
+
+putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putFastString BinDictionary { bin_dict_next = j_r,
+                              bin_dict_map  = out_r}  bh f
+  = do
+    out <- readIORef out_r
+    let uniq = getUnique f
+    case lookupUFM out uniq of
+        Just (j, _)  -> put_ bh j
+        Nothing -> do
+           j <- readFastMutInt j_r
+           put_ bh j
+           writeFastMutInt j_r (j + 1)
+           writeIORef out_r $! addToUFM out uniq (j, f)
+
+
+data BinDictionary = BinDictionary {
+        bin_dict_next :: !FastMutInt, -- The next index to use
+        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
+                                -- indexed by FastString
+  }
+
 -- -----------------------------------------------------------------------------
 -- All the binary instances
 
 -- -----------------------------------------------------------------------------
 -- All the binary instances
 
@@ -300,70 +359,74 @@ instance Binary ModIface where
    put_ bh (ModIface {
                 mi_module    = mod,
                 mi_boot      = is_boot,
    put_ bh (ModIface {
                 mi_module    = mod,
                 mi_boot      = is_boot,
-                mi_mod_vers  = mod_vers,
+                mi_iface_hash= iface_hash,
+                mi_mod_hash  = mod_hash,
                 mi_orphan    = orphan,
                 mi_finsts    = hasFamInsts,
                 mi_deps      = deps,
                 mi_usages    = usages,
                 mi_exports   = exports,
                 mi_orphan    = orphan,
                 mi_finsts    = hasFamInsts,
                 mi_deps      = deps,
                 mi_usages    = usages,
                 mi_exports   = exports,
-                mi_exp_vers  = exp_vers,
+                mi_exp_hash  = exp_hash,
                 mi_fixities  = fixities,
                 mi_deprecs   = deprecs,
                 mi_decls     = decls,
                 mi_insts     = insts,
                 mi_fam_insts = fam_insts,
                 mi_rules     = rules,
                 mi_fixities  = fixities,
                 mi_deprecs   = deprecs,
                 mi_decls     = decls,
                 mi_insts     = insts,
                 mi_fam_insts = fam_insts,
                 mi_rules     = rules,
-                mi_rule_vers = rule_vers,
+                mi_orphan_hash = orphan_hash,
                  mi_vect_info = vect_info,
                 mi_hpc       = hpc_info }) = do
        put_ bh mod
        put_ bh is_boot
                  mi_vect_info = vect_info,
                 mi_hpc       = hpc_info }) = do
        put_ bh mod
        put_ bh is_boot
-       put_ bh mod_vers
+       put_ bh iface_hash
+       put_ bh mod_hash
        put_ bh orphan
        put_ bh hasFamInsts
        lazyPut bh deps
        lazyPut bh usages
        put_ bh exports
        put_ bh orphan
        put_ bh hasFamInsts
        lazyPut bh deps
        lazyPut bh usages
        put_ bh exports
-       put_ bh exp_vers
+       put_ bh exp_hash
        put_ bh fixities
        lazyPut bh deprecs
         put_ bh decls
        put_ bh insts
        put_ bh fam_insts
        lazyPut bh rules
        put_ bh fixities
        lazyPut bh deprecs
         put_ bh decls
        put_ bh insts
        put_ bh fam_insts
        lazyPut bh rules
-       put_ bh rule_vers
+       put_ bh orphan_hash
         put_ bh vect_info
        put_ bh hpc_info
 
    get bh = do
        mod_name  <- get bh
        is_boot   <- get bh
         put_ bh vect_info
        put_ bh hpc_info
 
    get bh = do
        mod_name  <- get bh
        is_boot   <- get bh
-       mod_vers  <- get bh
+       iface_hash <- get bh
+       mod_hash  <- get bh
        orphan    <- get bh
        hasFamInsts <- get bh
        deps      <- lazyGet bh
        usages    <- {-# SCC "bin_usages" #-} lazyGet bh
        exports   <- {-# SCC "bin_exports" #-} get bh
        orphan    <- get bh
        hasFamInsts <- get bh
        deps      <- lazyGet bh
        usages    <- {-# SCC "bin_usages" #-} lazyGet bh
        exports   <- {-# SCC "bin_exports" #-} get bh
-       exp_vers  <- get bh
+       exp_hash  <- get bh
        fixities  <- {-# SCC "bin_fixities" #-} get bh
        deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
         decls    <- {-# SCC "bin_tycldecls" #-} get bh
        insts     <- {-# SCC "bin_insts" #-} get bh
        fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
        rules     <- {-# SCC "bin_rules" #-} lazyGet bh
        fixities  <- {-# SCC "bin_fixities" #-} get bh
        deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
         decls    <- {-# SCC "bin_tycldecls" #-} get bh
        insts     <- {-# SCC "bin_insts" #-} get bh
        fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
        rules     <- {-# SCC "bin_rules" #-} lazyGet bh
-       rule_vers <- get bh
+       orphan_hash <- get bh
         vect_info <- get bh
         hpc_info  <- get bh
        return (ModIface {
                 mi_module    = mod_name,
                 mi_boot      = is_boot,
         vect_info <- get bh
         hpc_info  <- get bh
        return (ModIface {
                 mi_module    = mod_name,
                 mi_boot      = is_boot,
-                mi_mod_vers  = mod_vers,
+                mi_iface_hash = iface_hash,
+                mi_mod_hash  = mod_hash,
                 mi_orphan    = orphan,
                 mi_finsts    = hasFamInsts,
                 mi_deps      = deps,
                 mi_usages    = usages,
                 mi_exports   = exports,
                 mi_orphan    = orphan,
                 mi_finsts    = hasFamInsts,
                 mi_deps      = deps,
                 mi_usages    = usages,
                 mi_exports   = exports,
-                mi_exp_vers  = exp_vers,
+                mi_exp_hash  = exp_hash,
                 mi_fixities  = fixities,
                 mi_deprecs   = deprecs,
                 mi_decls     = decls,
                 mi_fixities  = fixities,
                 mi_deprecs   = deprecs,
                 mi_decls     = decls,
@@ -371,13 +434,13 @@ instance Binary ModIface where
                 mi_insts     = insts,
                 mi_fam_insts = fam_insts,
                 mi_rules     = rules,
                 mi_insts     = insts,
                 mi_fam_insts = fam_insts,
                 mi_rules     = rules,
-                mi_rule_vers = rule_vers,
+                mi_orphan_hash = orphan_hash,
                  mi_vect_info = vect_info,
                 mi_hpc       = hpc_info,
                        -- And build the cached values
                 mi_dep_fn    = mkIfaceDepCache deprecs,
                 mi_fix_fn    = mkIfaceFixCache fixities,
                  mi_vect_info = vect_info,
                 mi_hpc       = hpc_info,
                        -- And build the cached values
                 mi_dep_fn    = mkIfaceDepCache deprecs,
                 mi_fix_fn    = mkIfaceFixCache fixities,
-                mi_ver_fn    = mkIfaceVerCache decls })
+                mi_hash_fn   = mkIfaceHashCache decls })
 
 getWayDescr :: IO String
 getWayDescr = do
 
 getWayDescr :: IO String
 getWayDescr = do
@@ -421,22 +484,31 @@ instance (Binary name) => Binary (GenAvailInfo name) where
                      return (AvailTC ab ac)
 
 instance Binary Usage where
                      return (AvailTC ab ac)
 
 instance Binary Usage where
-    put_ bh usg        = do 
-       put_ bh (usg_name     usg)
-       put_ bh (usg_mod      usg)
+    put_ bh usg@UsagePackageModule{} = do 
+        putByte bh 0
+       put_ bh (usg_mod usg)
+       put_ bh (usg_mod_hash usg)
+    put_ bh usg@UsageHomeModule{} = do 
+        putByte bh 1
+       put_ bh (usg_mod_name usg)
+       put_ bh (usg_mod_hash usg)
        put_ bh (usg_exports  usg)
        put_ bh (usg_entities usg)
        put_ bh (usg_exports  usg)
        put_ bh (usg_entities usg)
-       put_ bh (usg_rules    usg)
 
     get bh = do
 
     get bh = do
-       nm    <- get bh
-       mod   <- get bh
-       exps  <- get bh
-       ents  <- get bh
-       rules <- get bh
-       return (Usage { usg_name = nm, usg_mod = mod,
-                       usg_exports = exps, usg_entities = ents,
-                       usg_rules = rules })
+        h <- getByte bh
+        case h of
+          0 -> do
+            nm    <- get bh
+            mod   <- get bh
+            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
+          _ -> do
+            nm    <- get bh
+            mod   <- get bh
+            exps  <- get bh
+            ents  <- get bh
+            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
+                            usg_exports = exps, usg_entities = ents }
 
 instance Binary Deprecations where
     put_ bh NoDeprecs     = putByte bh 0
 
 instance Binary Deprecations where
     put_ bh NoDeprecs     = putByte bh 0
index 062cd30..21080ee 100644 (file)
@@ -15,10 +15,9 @@ module IfaceSyn (
        -- Misc
         ifaceDeclSubBndrs, visibleIfConDecls,
 
        -- Misc
         ifaceDeclSubBndrs, visibleIfConDecls,
 
-       -- Equality
-       GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
-       eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
-       
+        -- Free Names
+        freeNamesIfDecl, freeNamesIfRule,
+
        -- Pretty printing
        pprIfaceExpr, pprIfaceDeclHead 
     ) where
        -- Pretty printing
        pprIfaceExpr, pprIfaceDeclHead 
     ) where
@@ -30,8 +29,6 @@ import IfaceType
 
 import NewDemand
 import Class
 
 import NewDemand
 import Class
-import UniqFM
-import UniqSet
 import NameSet 
 import Name
 import CostCentre
 import NameSet 
 import Name
 import CostCentre
@@ -46,7 +43,6 @@ import Data.List
 import Data.Maybe
 
 infixl 3 &&&
 import Data.Maybe
 
 infixl 3 &&&
-infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
 \end{code}
 
 
 \end{code}
 
 
@@ -648,385 +644,128 @@ instance Outputable IfaceInfoItem where
   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
   ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
   ppr (HsWorker w a)    = ptext (sLit "Worker:") <+> ppr w <+> int a
   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
   ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
   ppr (HsWorker w a)    = ptext (sLit "Worker:") <+> ppr w <+> int a
-\end{code}
 
 
 
 
-%************************************************************************
-%*                                                                     *
-       Equality, for interface file version generaion only
-%*                                                                     *
-%************************************************************************
-
-Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new
-constructor is EqBut, which gives the set of things whose version must
-be equal for the whole thing to be equal.  So the key function is
-eqIfExt, which compares Names.
-
-Of course, equality is also done modulo alpha conversion.
+-- -----------------------------------------------------------------------------
+-- Finding the Names in IfaceSyn
+
+-- This is used for dependency analysis in MkIface, so that we
+-- fingerprint a declaration before the things that depend on it.  It
+-- is specific to interface-file fingerprinting in the sense that we
+-- don't collect *all* Names: for example, the DFun of an instance is
+-- recorded textually rather than by its fingerprint when
+-- fingerprinting the instance, so DFuns are not dependencies.
+
+freeNamesIfDecl :: IfaceDecl -> NameSet
+freeNamesIfDecl (IfaceId _s t i) = 
+  freeNamesIfType t &&&
+  freeNamesIfIdInfo i
+freeNamesIfDecl IfaceForeign{} = 
+  emptyNameSet
+freeNamesIfDecl d@IfaceData{} =
+  freeNamesIfTcFam (ifFamInst d) &&&
+  freeNamesIfContext (ifCtxt d) &&&
+  freeNamesIfConDecls (ifCons d)
+freeNamesIfDecl d@IfaceSyn{} =
+  freeNamesIfType    (ifSynRhs d) &&&
+  freeNamesIfTcFam (ifFamInst d)
+freeNamesIfDecl d@IfaceClass{} =
+  freeNamesIfContext (ifCtxt d) &&&
+  freeNamesIfDecls   (ifATs d) &&&
+  fnList freeNamesIfClsSig (ifSigs d)
 
 
-\begin{code}
-data GenIfaceEq a
-  = Equal              -- Definitely exactly the same
-  | NotEqual           -- Definitely different
-  | EqBut (UniqSet a)   -- The same provided these things have not changed
-
-type IfaceEq = GenIfaceEq Name
-
-instance Outputable a => Outputable (GenIfaceEq a) where
-  ppr Equal          = ptext (sLit "Equal")
-  ppr NotEqual       = ptext (sLit "NotEqual")
-  ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset)
-
-bool :: Bool -> IfaceEq
-bool True  = Equal
-bool False = NotEqual
-
-toBool :: IfaceEq -> Bool
-toBool Equal     = True
-toBool (EqBut _) = True
-toBool NotEqual  = False
-
-zapEq :: IfaceEq -> IfaceEq    -- Used to forget EqBut information
-zapEq (EqBut _) = Equal
-zapEq other    = other
-
-(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
-Equal       &&& x           = x
-NotEqual    &&& _           = NotEqual
-EqBut nms   &&& Equal       = EqBut nms
-EqBut _     &&& NotEqual    = NotEqual
-EqBut nms1  &&& EqBut nms2  = EqBut (nms1 `unionNameSets` nms2)
-
--- This function is the core of the EqBut stuff
--- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
--- any Names in the left-hand arg have the correct parent in them.
-eqIfExt :: Name -> Name -> IfaceEq
-eqIfExt name1 name2 
-  | name1 == name2 = EqBut (unitNameSet name1)
-  | otherwise      = NotEqual
-
----------------------
-checkBootDecl :: IfaceDecl     -- The boot decl
-             -> IfaceDecl      -- The real decl
-             -> Bool           -- True <=> compatible
-checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
-  = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
-
-checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
-  = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
-
-checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
-  = ASSERT( ifName d1 == ifName d2 )
-    toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> 
-          eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
-
-checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
--- We don't check the recursion flags because the boot-one is
--- recursive, to be conservative, but the real one may not be.
--- I'm not happy with the way recursive flags are dealt with.
-  = ASSERT( ifName d1    == ifName d2 ) 
-    toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> 
-       eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& 
-       case ifCons d1 of
-           IfAbstractTyCon -> Equal
-           cons1           -> eq_hsCD env cons1 (ifCons d2)
-
-checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
-  = ASSERT( ifName d1 == ifName d2 )
-    toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> 
-         eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
-         case (ifCtxt d1, ifSigs d1) of
-            ([], [])      -> Equal
-            (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
-                             eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
-
-checkBootDecl _ _ = False      -- default case
-
----------------------
-eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
-eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
-  = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
-
-eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
-  = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
-
-eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
-  = bool (ifName d1    == ifName d2 && 
-         ifRec d1     == ifRec   d2 && 
-         ifGadtSyntax d1 == ifGadtSyntax   d2 && 
-         ifGeneric d1 == ifGeneric d2) &&&
-    ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
-    eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
-           eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& 
-           eq_hsCD env (ifCons d1) (ifCons d2) 
-       )
-       -- The type variables of the data type do not scope
-       -- over the constructors (any more), but they do scope
-       -- over the stupid context in the IfaceConDecls
-
-eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
-  = bool (ifName d1 == ifName d2) &&&
-    ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
-    eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
-          eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
-        )
-
-eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
-  = bool (ifName d1 == ifName d2 && 
-         ifRec d1  == ifRec  d2) &&&
-    eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
-         eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
-         eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
-         eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
-         eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
-       )
-
-eqIfDecl _ _ = NotEqual        -- default case
-
--- Helper
-eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
-eqWith = eq_ifTvBndrs emptyEqEnv
-
-eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType]) 
-           -> Maybe (IfaceTyCon, [IfaceType])
-           -> IfaceEq
-Nothing             `eqIfTc_fam` Nothing             = Equal
-(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = 
-  fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
-_                      `eqIfTc_fam` _               = NotEqual
-
-
------------------------
-eqIfInst :: IfaceInst -> IfaceInst -> IfaceEq
-eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
--- All other changes are handled via the version info on the dfun
-
-eqIfFamInst :: IfaceFamInst -> IfaceFamInst -> IfaceEq
-eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
 -- All other changes are handled via the version info on the tycon
 -- All other changes are handled via the version info on the tycon
+freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
+freeNamesIfTcFam (Just (tc,tys)) = 
+  freeNamesIfTc tc &&& fnList freeNamesIfType tys
+freeNamesIfTcFam Nothing =
+  emptyNameSet
+
+freeNamesIfContext :: IfaceContext -> NameSet
+freeNamesIfContext = fnList freeNamesIfPredType
+
+freeNamesIfDecls :: [IfaceDecl] -> NameSet
+freeNamesIfDecls = fnList freeNamesIfDecl
+
+freeNamesIfClsSig :: IfaceClassOp -> NameSet
+freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
+
+freeNamesIfConDecls :: IfaceConDecls -> NameSet
+freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon c)  = freeNamesIfConDecl c
+freeNamesIfConDecls _               = emptyNameSet
+
+freeNamesIfConDecl :: IfaceConDecl -> NameSet
+freeNamesIfConDecl c = 
+  freeNamesIfContext (ifConCtxt c) &&& 
+  fnList freeNamesIfType (ifConArgTys c) &&&
+  fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
+
+freeNamesIfPredType :: IfacePredType -> NameSet
+freeNamesIfPredType (IfaceClassP cl tys) = 
+   unitNameSet cl &&& fnList freeNamesIfType tys
+freeNamesIfPredType (IfaceIParam _n ty) =
+   freeNamesIfType ty
+freeNamesIfPredType (IfaceEqPred ty1 ty2) =
+   freeNamesIfType ty1 &&& freeNamesIfType ty2
+
+freeNamesIfType :: IfaceType -> NameSet
+freeNamesIfType (IfaceTyVar _)        = emptyNameSet
+freeNamesIfType (IfaceAppTy s t)      = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfacePredTy st)      = freeNamesIfPredType st
+freeNamesIfType (IfaceTyConApp tc ts) = 
+   freeNamesIfTc tc &&& fnList freeNamesIfType ts
+freeNamesIfType (IfaceForAllTy _tv t)  = freeNamesIfType t
+freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
+
+freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
+freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
+
+freeNamesItem :: IfaceInfoItem -> NameSet
+freeNamesItem (HsUnfold u)     = freeNamesIfExpr u
+freeNamesItem (HsWorker wkr _) = unitNameSet wkr
+freeNamesItem _                = emptyNameSet
+
+freeNamesIfExpr :: IfaceExpr -> NameSet
+freeNamesIfExpr (IfaceExt v)     = unitNameSet v
+freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
+freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
+freeNamesIfExpr (IfaceLam _ body) = freeNamesIfExpr body
+freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
+freeNamesIfExpr (IfaceNote _n r)   = freeNamesIfExpr r
+
+freeNamesIfExpr (IfaceCase s _ ty alts)
+  = freeNamesIfExpr s &&& freeNamesIfType ty &&& fnList freeNamesIfaceAlt alts
+  where
+    -- no need to look at the constructor, because we'll already have its
+    -- parent recorded by the type on the case expression.
+    freeNamesIfaceAlt (_con,_bs,r) = freeNamesIfExpr r
 
 
-eqIfRule :: IfaceRule -> IfaceRule -> IfaceEq
-eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
-        (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
-       = bool (n1==n2 && a1==a2 && o1 == o2) &&&
-        f1 `eqIfExt` f2 &&&
-         eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> 
-        zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
-               -- zapEq: for the LHSs, ignore the EqBut part
-         eq_ifaceExpr env rhs1 rhs2)
-
-eq_hsCD :: EqEnv -> IfaceConDecls -> IfaceConDecls -> IfaceEq
-eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) 
-  = eqListBy (eq_ConDecl env) c1 c2
-
-eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
-eq_hsCD _   IfAbstractTyCon  IfAbstractTyCon  = Equal
-eq_hsCD _   IfOpenDataTyCon  IfOpenDataTyCon  = Equal
-eq_hsCD _   _                _                = NotEqual
-
-eq_ConDecl :: EqEnv -> IfaceConDecl -> IfaceConDecl -> IfaceEq
-eq_ConDecl env c1 c2
-  = bool (ifConOcc c1     == ifConOcc c2 && 
-         ifConInfix c1   == ifConInfix c2 && 
-         ifConStricts c1 == ifConStricts c2 && 
-         ifConFields c1  == ifConFields c2) &&&
-    eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
-    eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
-       eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
-       eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
-
-eq_hsFD :: EqEnv
-        -> ([FastString], [FastString])
-        -> ([FastString], [FastString])
-        -> IfaceEq
-eq_hsFD env (ns1,ms1) (ns2,ms2)
-  = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
-
-eq_cls_sig :: EqEnv -> IfaceClassOp -> IfaceClassOp -> IfaceEq
-eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
-  = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
-\end{code}
-
+freeNamesIfExpr (IfaceLet (IfaceNonRec _bndr r) x)
+  = freeNamesIfExpr r &&& freeNamesIfExpr x
 
 
-\begin{code}
------------------
-eqIfIdInfo :: IfaceIdInfo -> IfaceIdInfo -> GenIfaceEq Name
-eqIfIdInfo NoInfo        NoInfo        = Equal
-eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
-eqIfIdInfo _             _             = NotEqual
-
-eq_item :: IfaceInfoItem -> IfaceInfoItem -> IfaceEq
-eq_item (HsInline a1)     (HsInline a2)      = bool (a1 == a2)
-eq_item (HsArity a1)      (HsArity a2)       = bool (a1 == a2)
-eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
-eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
-eq_item HsNoCafRefs        HsNoCafRefs       = Equal
-eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
-eq_item _ _ = NotEqual
-
------------------
-eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
-eq_ifaceExpr env (IfaceLcl v1)       (IfaceLcl v2)        = eqIfOcc env v1 v2
-eq_ifaceExpr _   (IfaceExt v1)       (IfaceExt v2)        = eqIfExt v1 v2
-eq_ifaceExpr _   (IfaceLit l1)        (IfaceLit l2)       = bool (l1 == l2)
-eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
-eq_ifaceExpr _   (IfaceTick m1 ix1)   (IfaceTick m2 ix2)   = bool (m1==m2) &&& bool (ix1 == ix2)
-eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)     = eq_ifType env ty1 ty2
-eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
-eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
-eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)    = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
-eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
-eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
-
-eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
-  = eq_ifaceExpr env s1 s2 &&&
-    eq_ifType env ty1 ty2 &&&
-    eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
-  where
-    eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
-       = bool (eq_ifaceConAlt c1 c2) &&& 
-         eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
+freeNamesIfExpr (IfaceLet (IfaceRec as) x)
+  = fnList freeNamesIfExpr (map snd as) &&& freeNamesIfExpr x
 
 
-eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
-  = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
+freeNamesIfExpr _ = emptyNameSet
 
 
-eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
-  = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
-  where
-    (bs1,rs1) = unzip as1
-    (bs2,rs2) = unzip as2
-
-
-eq_ifaceExpr _ _ _ = NotEqual
-
------------------
-eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
-eq_ifaceConAlt IfaceDefault      IfaceDefault          = True
-eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)    = n1==n2
-eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)   = c1==c2
-eq_ifaceConAlt (IfaceLitAlt l1)          (IfaceLitAlt l2)      = l1==l2
-eq_ifaceConAlt _ _ = False
-
------------------
-eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
-eq_ifaceNote _   (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
-eq_ifaceNote _   IfaceInlineMe    IfaceInlineMe        = Equal
-eq_ifaceNote _   (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
-eq_ifaceNote _   _ _ = NotEqual
-\end{code}
 
 
-\begin{code}
----------------------
-eqIfType :: IfaceType -> IfaceType -> IfaceEq
-eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
-
--------------------
-eq_ifType :: EqEnv -> IfaceType -> IfaceType -> IfaceEq
-eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
-eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
-eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
-eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
-eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
-eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
-eq_ifType _ _ _ = NotEqual
-
--------------------
-eq_ifTypes :: EqEnv -> [IfaceType] -> [IfaceType] -> IfaceEq
-eq_ifTypes env = eqListBy (eq_ifType env)
-
--------------------
-eq_ifContext :: EqEnv -> [IfacePredType] -> [IfacePredType] -> IfaceEq
-eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
-
--------------------
-eq_ifPredType :: EqEnv -> IfacePredType -> IfacePredType -> IfaceEq
-eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
-eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
-eq_ifPredType _   _ _ = NotEqual
-
--------------------
-eqIfTc :: IfaceTyCon -> IfaceTyCon -> IfaceEq
-eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
-eqIfTc IfaceIntTc    IfaceIntTc           = Equal
-eqIfTc IfaceCharTc   IfaceCharTc   = Equal
-eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
-eqIfTc IfaceListTc   IfaceListTc   = Equal
-eqIfTc IfacePArrTc   IfacePArrTc   = Equal
-eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
-eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
-eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
-eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
-eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
-eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
-eqIfTc _                      _                       = NotEqual
-\end{code}
+freeNamesIfTc :: IfaceTyCon -> NameSet
+freeNamesIfTc (IfaceTc tc) = unitNameSet tc
+-- ToDo: shouldn't we include IfaceIntTc & co.?
+freeNamesIfTc _ = emptyNameSet
 
 
------------------------------------------------------------
-       Support code for equality checking
------------------------------------------------------------
+freeNamesIfRule :: IfaceRule -> NameSet
+freeNamesIfRule (IfaceRule _n _a _bs f es rhs _o)
+  = unitNameSet f &&& fnList freeNamesIfExpr es &&& freeNamesIfExpr rhs
 
 
-\begin{code}
-------------------------------------
-type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
-
-eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
-eqIfOcc env n1 n2 = case lookupUFM env n1 of
-                       Just n1 -> bool (n1 == n2)
-                       Nothing -> bool (n1 == n2)
-
-extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
-extendEqEnv env n1 n2 | n1 == n2  = env
-                     | otherwise = addToUFM env n1 n2
-
-emptyEqEnv :: EqEnv
-emptyEqEnv = emptyUFM
-
-------------------------------------
-type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
-
-eq_ifNakedBndr :: ExtEnv FastString
-eq_ifBndr      :: ExtEnv IfaceBndr
-eq_ifTvBndr    :: ExtEnv IfaceTvBndr
-eq_ifIdBndr    :: ExtEnv IfaceIdBndr
-
-eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
-
-eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
-eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
-eq_ifBndr _ _ _ _ = NotEqual
-
-eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
-eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
-
-eq_ifLetBndr :: EqEnv -> IfaceLetBndr -> IfaceLetBndr -> (EqEnv -> IfaceEq)
-             -> IfaceEq
-eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k 
-  = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
-
-eq_ifBndrs     :: ExtEnv [IfaceBndr]
-eq_ifLetBndrs  :: ExtEnv [IfaceLetBndr]
-eq_ifTvBndrs   :: ExtEnv [IfaceTvBndr]
-eq_ifNakedBndrs :: ExtEnv [FastString]
-eq_ifBndrs     = eq_bndrs_with eq_ifBndr
-eq_ifTvBndrs   = eq_bndrs_with eq_ifTvBndr
-eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
-eq_ifLetBndrs   = eq_bndrs_with eq_ifLetBndr
-
--- eq_bndrs_with :: (a -> a -> IfaceEq) -> ExtEnv a
-eq_bndrs_with :: ExtEnv a -> ExtEnv [a]
-eq_bndrs_with _  env []       []       k = k env
-eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
-eq_bndrs_with _  _   _       _        _ = NotEqual
-\end{code}
+-- helpers
+(&&&) :: NameSet -> NameSet -> NameSet
+(&&&) = unionNameSets
 
 
-\begin{code}
-eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
-eqListBy _  []     []     = Equal
-eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
-eqListBy _  _      _      = NotEqual
-
-eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
-eqMaybeBy _  Nothing  Nothing  = Equal
-eqMaybeBy eq (Just x) (Just y) = eq x y
-eqMaybeBy _  _        _        = NotEqual
+fnList :: (a -> NameSet) -> [a] -> NameSet
+fnList f = foldr (&&&) emptyNameSet . map f
 \end{code}
 \end{code}
index ec41e75..3e42fd4 100644 (file)
@@ -51,6 +51,7 @@ import BinIface
 import Panic
 import Util
 import FastString
 import Panic
 import Util
 import FastString
+import Fingerprint
 
 import Control.Monad
 import Data.List
 
 import Control.Monad
 import Data.List
@@ -323,7 +324,7 @@ addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
 addDeclsToPTE pte things = extendNameEnvList pte things
 
 loadDecls :: Bool
 addDeclsToPTE pte things = extendNameEnvList pte things
 
 loadDecls :: Bool
-         -> [(Version, IfaceDecl)]
+         -> [(Fingerprint, IfaceDecl)]
          -> IfL [(Name,TyThing)]
 loadDecls ignore_prags ver_decls
    = do { mod <- getIfModule
          -> IfL [(Name,TyThing)]
 loadDecls ignore_prags ver_decls
    = do { mod <- getIfModule
@@ -333,7 +334,7 @@ loadDecls ignore_prags ver_decls
 
 loadDecl :: Bool                   -- Don't load pragmas into the decl pool
         -> Module
 
 loadDecl :: Bool                   -- Don't load pragmas into the decl pool
         -> Module
-         -> (Version, IfaceDecl)
+         -> (Fingerprint, IfaceDecl)
          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
                                    -- TyThings are forkM'd thunks
 loadDecl ignore_prags mod (_version, decl)
          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
                                    -- TyThings are forkM'd thunks
 loadDecl ignore_prags mod (_version, decl)
@@ -616,13 +617,16 @@ pprModIface :: ModIface -> SDoc
 -- Show a ModIface
 pprModIface iface
  = vcat [ ptext (sLit "interface")
 -- Show a ModIface
 pprModIface iface
  = vcat [ ptext (sLit "interface")
-               <+> ppr (mi_module iface) <+> pp_boot 
-               <+> ppr (mi_mod_vers iface) <+> pp_sub_vers
+               <+> ppr (mi_module iface) <+> pp_boot
                <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
                <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
                <+> (if mi_hpc    iface then ptext (sLit "[hpc]") else empty)
                <+> integer opt_HiVersion
                <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
                <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
                <+> (if mi_hpc    iface then ptext (sLit "[hpc]") else empty)
                <+> integer opt_HiVersion
-               <+> ptext (sLit "where")
+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
+        , nest 2 (ptext (sLit "where"))
        , vcat (map pprExport (mi_exports iface))
        , pprDeps (mi_deps iface)
        , vcat (map pprUsage (mi_usages iface))
        , vcat (map pprExport (mi_exports iface))
        , pprDeps (mi_deps iface)
        , vcat (map pprUsage (mi_usages iface))
@@ -637,12 +641,6 @@ pprModIface iface
   where
     pp_boot | mi_boot iface = ptext (sLit "[boot]")
            | otherwise     = empty
   where
     pp_boot | mi_boot iface = ptext (sLit "[boot]")
            | otherwise     = empty
-
-    exp_vers  = mi_exp_vers iface
-    rule_vers = mi_rule_vers iface
-
-    pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
-               | otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
 \end{code}
 
 When printing export lists, we print like this:
 \end{code}
 
 When printing export lists, we print like this:
@@ -666,16 +664,16 @@ pprExport (mod, items)
     pp_export names = braces (hsep (map ppr names))
 
 pprUsage :: Usage -> SDoc
     pp_export names = braces (hsep (map ppr names))
 
 pprUsage :: Usage -> SDoc
-pprUsage usage
-  = hsep [ptext (sLit "import"), ppr (usg_name usage), 
-         int (usg_mod usage), 
-         pp_export_version (usg_exports usage),
-         int (usg_rules usage),
-         pp_versions (usg_entities usage) ]
-  where
-    pp_versions nvs = hsep [ ppr n <+> int v | (n,v) <- nvs ]
-    pp_export_version Nothing  = empty
-    pp_export_version (Just v) = int v
+pprUsage usage@UsagePackageModule{}
+  = hsep [ptext (sLit "import"), ppr (usg_mod usage), 
+         ppr (usg_mod_hash usage)]
+pprUsage usage@UsageHomeModule{}
+  = hsep [ptext (sLit "import"), ppr (usg_mod_name usage), 
+         ppr (usg_mod_hash usage)] $$
+    nest 2 (
+       maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
+        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
+        )
 
 pprDeps :: Dependencies -> SDoc
 pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
 
 pprDeps :: Dependencies -> SDoc
 pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
@@ -690,13 +688,9 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
     ppr_boot True  = text "[boot]"
     ppr_boot False = empty
 
     ppr_boot True  = text "[boot]"
     ppr_boot False = empty
 
-pprIfaceDecl :: (Version, IfaceDecl) -> SDoc
+pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc
 pprIfaceDecl (ver, decl)
 pprIfaceDecl (ver, decl)
-  = ppr_vers ver <+> ppr decl
-  where
-       -- Print the version for the decl
-    ppr_vers v | v == initialVersion = empty
-              | otherwise           = int v
+  = ppr ver $$ nest 2 (ppr decl)
 
 pprFixities :: [(OccName, Fixity)] -> SDoc
 pprFixities []    = empty
 
 pprFixities :: [(OccName, Fixity)] -> SDoc
 pprFixities []    = empty
index 188aa45..a46e823 100644 (file)
@@ -25,20 +25,19 @@ module MkIface (
                MkIface.lhs deals with versioning
        -----------------------------------------------
 
                MkIface.lhs deals with versioning
        -----------------------------------------------
 
-Here's the version-related info in an interface file
+Here's the fingerprint-related info in an interface file
 
 
-  module Foo 8         -- module-version 
-            3          -- export-list-version
-            2          -- rule-version
+  module Foo xxxxxxxxxxxxxxxx  -- module fingerprint
+             yyyyyyyyyyyyyyyy  -- export list fingerprint
+             zzzzzzzzzzzzzzzz  -- rule fingerprint
     Usages:    -- Version info for what this compilation of Foo imported
     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
+       Baz xxxxxxxxxxxxxxxx    -- Module version
+           [yyyyyyyyyyyyyyyy]  -- The export-list version
+                                -- ( if Foo depended on it)
+           (g,zzzzzzzzzzzzzzzz) -- Function and its version
+           (T,wwwwwwwwwwwwwwww) -- Type and its version
+
+    <fingerprint> f :: Int -> Int {- Unfolding: \x -> Wib.t x -}
        
        -----------------------------------------------
                        Basic idea
        
        -----------------------------------------------
                        Basic idea
@@ -46,16 +45,16 @@ Here's the version-related info in an interface file
 
 Basic idea: 
   * In the mi_usages information in an interface, we record the 
 
 Basic idea: 
   * In the mi_usages information in an interface, we record the 
-    version number of each free variable of the module
+    fingerprint 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 mkIface, we compute the fingerprint of each exported thing A.f.
+    For each external thing that A.f refers to, we include the fingerprint
+    of the external reference when computing the fingerprint of A.f.  So
+    if anything that A.f depends on changes, then A.f's fingerprint will
+    change.
 
   * In checkOldIface we compare the mi_usages for the module with
 
   * In checkOldIface we compare the mi_usages for the module with
-    the actual version info for all each thing recorded in mi_usages
-
+    the actual fingerprint for all each thing recorded in mi_usages
 
 Fixities
 ~~~~~~~~
 
 Fixities
 ~~~~~~~~
@@ -65,19 +64,19 @@ 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 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
+If module M defines f, and a rule for f, just arrange that the fingerprint
+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.
 
 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 
+  * We have a per-module orphan-rule fingerprint 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,
     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 
+    giving the orphan-rule fingerprint.  We recompile if this 
     changes. 
 
 The net effect is that if an orphan rule changes, we recompile every
     changes. 
 
 The net effect is that if an orphan rule changes, we recompile every
@@ -91,13 +90,13 @@ In an iface file we have
        instance Eq a => Eq [a]  =  dfun29
        dfun29 :: ... 
 
        instance Eq a => Eq [a]  =  dfun29
        dfun29 :: ... 
 
-We have a version number for dfun29, covering its unfolding
+We have a fingerprint 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,
 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.
+then so will dfun29's fingerprint, 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
 
 Adding an instance declaration, or changing an instance decl that is
 not currently used, is more tricky.  (This really only makes a
@@ -126,7 +125,7 @@ compiled:
 to record the fact that A does import B indirectly.  This is used to decide
 to look for B.hi rather than B.hi-boot when compiling a module that
 imports A.  This line says that A imports B, but uses nothing in it.
 to record the fact that A does import B indirectly.  This is used to decide
 to look for B.hi rather than B.hi-boot when compiling a module that
 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.
+So we'll get an early bale-out when compiling A if B's fingerprint changes.
 
 The usage information records:
 
 
 The usage information records:
 
@@ -210,18 +209,21 @@ import NameSet
 import OccName
 import Module
 import BinIface
 import OccName
 import Module
 import BinIface
-import Unique
 import ErrUtils
 import Digraph
 import SrcLoc
 import Outputable
 import BasicTypes       hiding ( SuccessFlag(..) )
 import LazyUniqFM
 import ErrUtils
 import Digraph
 import SrcLoc
 import Outputable
 import BasicTypes       hiding ( SuccessFlag(..) )
 import LazyUniqFM
+import Unique
 import Util             hiding ( eqListBy )
 import FiniteMap
 import FastString
 import Maybes
 import ListSetOps
 import Util             hiding ( eqListBy )
 import FiniteMap
 import FastString
 import Maybes
 import ListSetOps
+import Binary
+import Fingerprint
+import Panic
 
 import Control.Monad
 import Data.List
 
 import Control.Monad
 import Data.List
@@ -239,14 +241,15 @@ import System.FilePath
 
 \begin{code}
 mkIface :: HscEnv
 
 \begin{code}
 mkIface :: HscEnv
-       -> Maybe ModIface       -- The old interface, if we have it
+       -> Maybe Fingerprint    -- The old fingerprint, if we have it
        -> ModDetails           -- The trimmed, tidied interface
        -> ModGuts              -- Usages, deprecations, etc
        -> ModDetails           -- The trimmed, tidied interface
        -> ModGuts              -- Usages, deprecations, etc
-       -> 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
+       -> IO (ModIface,        -- The new one
+              Bool)            -- True <=> there was an old Iface, and the 
+                                --          new one is identical, so no need
+                                --          to write it
 
 
-mkIface hsc_env maybe_old_iface mod_details
+mkIface hsc_env maybe_old_fingerprint mod_details
         ModGuts{     mg_module    = this_mod,
                      mg_boot      = is_boot,
                      mg_used_names = used_names,
         ModGuts{     mg_module    = this_mod,
                      mg_boot      = is_boot,
                      mg_used_names = used_names,
@@ -256,7 +259,7 @@ mkIface hsc_env maybe_old_iface mod_details
                      mg_fix_env   = fix_env,
                      mg_deprecs   = deprecs,
                      mg_hpc_info  = hpc_info }
                      mg_fix_env   = fix_env,
                      mg_deprecs   = deprecs,
                      mg_hpc_info  = hpc_info }
-        = mkIface_ hsc_env maybe_old_iface
+        = mkIface_ hsc_env maybe_old_fingerprint
                    this_mod is_boot used_names deps rdr_env 
                    fix_env deprecs hpc_info dir_imp_mods mod_details
        
                    this_mod is_boot used_names deps rdr_env 
                    fix_env deprecs hpc_info dir_imp_mods mod_details
        
@@ -264,12 +267,12 @@ mkIface hsc_env maybe_old_iface mod_details
 -- for non-optimising compilation, or where we aren't generating any
 -- object code at all ('HscNothing').
 mkIfaceTc :: HscEnv
 -- 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
+          -> Maybe Fingerprint -- The old fingerprint, if we have it
           -> ModDetails                -- gotten from mkBootModDetails, probably
           -> TcGblEnv          -- Usages, deprecations, etc
          -> IO (ModIface,
                 Bool)
           -> ModDetails                -- gotten from mkBootModDetails, probably
           -> TcGblEnv          -- Usages, deprecations, etc
          -> IO (ModIface,
                 Bool)
-mkIfaceTc hsc_env maybe_old_iface mod_details
+mkIfaceTc hsc_env maybe_old_fingerprint mod_details
   tc_result@TcGblEnv{ tcg_mod = this_mod,
                       tcg_src = hsc_src,
                       tcg_imports = imports,
   tc_result@TcGblEnv{ tcg_mod = this_mod,
                       tcg_src = hsc_src,
                       tcg_imports = imports,
@@ -282,7 +285,7 @@ mkIfaceTc hsc_env maybe_old_iface mod_details
           used_names <- mkUsedNames tc_result
           deps <- mkDependencies tc_result
           let hpc_info = emptyHpcInfo other_hpc_info
           used_names <- mkUsedNames tc_result
           deps <- mkDependencies tc_result
           let hpc_info = emptyHpcInfo other_hpc_info
-          mkIface_ hsc_env maybe_old_iface
+          mkIface_ hsc_env maybe_old_fingerprint
                    this_mod (isHsBoot hsc_src) used_names deps rdr_env 
                    fix_env deprecs hpc_info (imp_mods imports) mod_details
         
                    this_mod (isHsBoot hsc_src) used_names deps rdr_env 
                    fix_env deprecs hpc_info (imp_mods imports) mod_details
         
@@ -303,7 +306,7 @@ mkDependencies
                     tcg_th_used = th_var
                   }
  = do 
                     tcg_th_used = th_var
                   }
  = do 
-      th_used   <- readIORef th_var                        -- Whether TH is used
+      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
       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
@@ -334,13 +337,13 @@ mkDependencies
                 -- sort to get into canonical order
 
 
                 -- sort to get into canonical order
 
 
-mkIface_ :: HscEnv -> Maybe ModIface -> Module -> IsBootInterface
+mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface
          -> NameSet -> Dependencies -> GlobalRdrEnv
          -> NameEnv FixItem -> Deprecations -> HpcInfo
          -> NameSet -> Dependencies -> GlobalRdrEnv
          -> NameEnv FixItem -> Deprecations -> HpcInfo
-         -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
+         -> ImportedMods
          -> ModDetails
          -> IO (ModIface, Bool)
          -> ModDetails
          -> IO (ModIface, Bool)
-mkIface_ hsc_env maybe_old_iface 
+mkIface_ hsc_env maybe_old_fingerprint 
          this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
          dir_imp_mods
         ModDetails{  md_insts     = insts, 
          this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
          dir_imp_mods
         ModDetails{  md_insts     = insts, 
@@ -354,9 +357,7 @@ mkIface_ hsc_env maybe_old_iface
 --     put exactly the info into the TypeEnv that we want
 --     to expose in the interface
 
 --     put exactly the info into the TypeEnv that we want
 --     to expose in the interface
 
-  = do {eps <- hscEPS hsc_env
-
-       ; usages <- mkUsageInfo hsc_env dir_imp_mods (dep_mods deps) used_names
+  = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names
 
        ; let   { entities = typeEnvElts type_env ;
                   decls  = [ tyThingToIfaceDecl entity
 
        ; let   { entities = typeEnvElts type_env ;
                   decls  = [ tyThingToIfaceDecl entity
@@ -396,32 +397,33 @@ mkIface_ hsc_env maybe_old_iface
                        mi_globals  = Just rdr_env,
 
                        -- Left out deliberately: filled in by addVersionInfo
                        mi_globals  = Just rdr_env,
 
                        -- Left out deliberately: filled in by addVersionInfo
-                       mi_mod_vers  = initialVersion,
-                       mi_exp_vers  = initialVersion,
-                       mi_rule_vers = initialVersion,
+                       mi_iface_hash = fingerprint0,
+                       mi_mod_hash  = fingerprint0,
+                       mi_exp_hash  = fingerprint0,
+                       mi_orphan_hash = fingerprint0,
                        mi_orphan    = False,   -- Always set by addVersionInfo, but
                                                -- it's a strict field, so we can't omit it.
                         mi_finsts    = False,   -- Ditto
                        mi_decls     = deliberatelyOmitted "decls",
                        mi_orphan    = False,   -- Always set by addVersionInfo, but
                                                -- it's a strict field, so we can't omit it.
                         mi_finsts    = False,   -- Ditto
                        mi_decls     = deliberatelyOmitted "decls",
-                       mi_ver_fn    = deliberatelyOmitted "ver_fn",
+                       mi_hash_fn   = deliberatelyOmitted "hash_fn",
                        mi_hpc       = isHpcUsed hpc_info,
 
                        -- And build the cached values
                        mi_dep_fn = mkIfaceDepCache deprecs,
                        mi_fix_fn = mkIfaceFixCache fixities }
                        mi_hpc       = isHpcUsed hpc_info,
 
                        -- And build the cached values
                        mi_dep_fn = mkIfaceDepCache deprecs,
                        mi_fix_fn = mkIfaceFixCache fixities }
+               }
 
 
-               -- Add version information
-                ; ext_ver_fn = mkParentVerFun hsc_env eps
-               ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) 
-                       = {-# SCC "versioninfo" #-}
-                        addVersionInfo ext_ver_fn maybe_old_iface
+        ; (new_iface, no_change_at_all, pp_orphs) 
+               <- {-# SCC "versioninfo" #-}
+                        addFingerprints hsc_env maybe_old_fingerprint
                                          intermediate_iface decls
                                          intermediate_iface decls
-               }
 
                -- Debug printing
        ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) 
               (printDump (expectJust "mkIface" pp_orphs))
 
                -- Debug printing
        ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) 
               (printDump (expectJust "mkIface" pp_orphs))
-       ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
+
+-- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
+
        ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
                        (pprModIface new_iface)
 
        ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" 
                        (pprModIface new_iface)
 
@@ -471,15 +473,15 @@ writeIfaceFile dflags location new_iface
 -- -----------------------------------------------------------------------------
 -- Look up parents and versions of Names
 
 -- -----------------------------------------------------------------------------
 -- Look up parents and versions of Names
 
--- 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
+-- This is like a global version of the mi_hash_fn field in each ModIface.
+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
 -- the parent and version info.
 
 -- the parent and version info.
 
-mkParentVerFun
+mkHashFun
         :: HscEnv                       -- needed to look up versions
         -> ExternalPackageState         -- ditto
         :: HscEnv                       -- needed to look up versions
         -> ExternalPackageState         -- ditto
-        -> (Name -> (OccName,Version))
-mkParentVerFun hsc_env eps
+        -> (Name -> Fingerprint)
+mkHashFun hsc_env eps
   = \name -> 
       let 
         mod = nameModule name
   = \name -> 
       let 
         mod = nameModule name
@@ -487,199 +489,348 @@ mkParentVerFun hsc_env eps
         iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` 
                    pprPanic "lookupVers2" (ppr mod <+> ppr occ)
       in  
         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)
+        snd (mi_hash_fn iface occ `orElse` 
+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
   where
       hpt = hsc_HPT hsc_env
       pit = eps_PIT eps
 
   where
       hpt = hsc_HPT hsc_env
       pit = eps_PIT eps
 
------------------------------------------------------------------------------
--- Compute version numbers for local decls
-
-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 _ Nothing new_iface new_decls
--- No old interface, so definitely write a new one!
-  = (new_iface { mi_orphan = not (null orph_insts && null orph_rules)
-               , 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)
-              },
-     False, 
-     ptext (sLit "No old interface file"),
-     pprOrphans orph_insts orph_rules)
-  where
-    orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface)
-    orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface)
-
-addVersionInfo ver_fn (Just old_iface@(ModIface { 
-                                           mi_mod_vers  = old_mod_vers, 
-                                          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
- | 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),
-                mi_finsts    = not . null $ mi_fam_insts new_iface,
-                mi_decls     = decls_w_vers,
-                mi_ver_fn    = mkIfaceVerCache decls_w_vers }
-
-    decls_w_vers = [(add_vers decl, decl) | decl <- new_decls]
-
-    -------------------
-    (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)
-    old_fam_insts = mi_fam_insts old_iface
-    new_fam_insts = mi_fam_insts new_iface
-    same_insts occ = eqMaybeBy (eqListBy eqIfInst) 
-                               (lookupOccEnv old_non_orph_insts occ)
-                               (lookupOccEnv new_non_orph_insts occ)
-  
-    (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)
-    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
-    no_export_change = mi_exports new_iface == mi_exports old_iface
-                                -- Kept sorted
-    no_decl_change   = isEmptyOccSet changed_occs
-    no_rule_change   = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules)
-                        || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)
-                        || changedWrtNames changed_occs (eqListBy eqIfFamInst old_fam_insts new_fam_insts))
-    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
-    no_other_changes = mi_usages new_iface == mi_usages old_iface && 
-                      mi_deps new_iface == mi_deps old_iface &&
-                      mi_hpc new_iface == mi_hpc old_iface
-    no_change_at_all = no_output_change && no_other_changes
-    pp_diffs = vcat [pp_change no_export_change "Export list" 
-                       (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,
-                    pp_change no_other_changes  "Usages" empty,
-                    pp_decl_diffs]
-    pp_change True  _    _    = 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
-    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
-
-    add_vers decl | occ `elemOccSet` changed_occs = new_version
-                 | otherwise = snd (expectJust "add_vers" (old_decl_vers occ))
-                               -- If it's unchanged, there jolly well 
-                 where         -- should be an old version number
-                   occ = ifName decl
-
-    -------------------
-    -- 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.
-    eq_info :: [(OccName, IfaceEq)]
-    eq_info = map check_eq new_decls
-    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)      
+-- ---------------------------------------------------------------------------
+-- Compute fingerprints for the interface
+
+addFingerprints
+        :: HscEnv
+        -> Maybe Fingerprint -- the old fingerprint, if any
+        -> ModIface         -- The new interface (lacking decls)
+        -> [IfaceDecl]       -- The new decls
+        -> IO (ModIface,     -- Updated interface
+               Bool,        -- True <=> no changes at all; 
+                             -- no need to write Iface
+               Maybe SDoc)   -- Warnings about orphans
+
+addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
+ = do
+   eps <- hscEPS hsc_env
+   let
+        -- the ABI of a declaration represents everything that is made
+        -- visible about the declaration that a client can depend on.
+        -- see IfaceDeclABI below.
+       declABI :: IfaceDecl -> IfaceDeclABI 
+       declABI decl = (this_mod, decl, extras)
+        where extras = declExtras fix_fn non_orph_rules non_orph_insts decl
+
+       edges :: [(IfaceDeclABI, Unique, [Unique])]
+       edges = [ (abi, getUnique (ifName decl), out)
+              | decl <- new_decls
+               , let abi = declABI decl
+              , let out = localOccs $ freeNamesDeclABI abi
+               ]
+
+       localOccs = map (getUnique . getParent . getOccName) 
+                        . filter ((== this_mod) . nameModule)
+                        . nameSetToList
+          where getParent occ = lookupOccEnv parent_map occ `orElse` occ
+
+        -- maps OccNames to their parents in the current module.
+        -- e.g. a reference to a constructor must be turned into a reference
+        -- to the TyCon for the purposes of calculating dependencies.
+       parent_map :: OccEnv OccName
+       parent_map = foldr extend emptyOccEnv new_decls
+          where extend d env = 
+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclSubBndrs d ]
+                  where n = ifName d
+
+        -- strongly-connected groups of declarations, in dependency order
+       groups = stronglyConnComp edges
+
+       global_hash_fn = mkHashFun hsc_env eps
+
+        -- how to output Names when generating the data to fingerprint.
+        -- Here we want to output the fingerprint for each top-level
+        -- Name, whether it comes from the current module or another
+        -- module.  In this way, the fingerprint for a declaration will
+        -- change if the fingerprint for anything it refers to (transitively)
+        -- changes.
+       mk_put_name :: (OccEnv (OccName,Fingerprint))
+                   -> BinHandle -> Name -> IO  ()
+       mk_put_name local_env bh name
+          | isWiredInName name  =  putNameLiterally bh name 
+           -- wired-in names don't have fingerprints
+          | otherwise
+          = let hash | nameModule name /= this_mod =  global_hash_fn name
+                     | otherwise = 
+                        snd (lookupOccEnv local_env (getOccName name)
+                           `orElse` pprPanic "urk! lookup local fingerprint" 
+                                       (ppr name)) -- (undefined,fingerprint0))
+            in 
+            put_ bh hash
+
+        -- take a strongly-connected group of declarations and compute
+        -- its fingerprint.
+
+       fingerprint_group :: (OccEnv (OccName,Fingerprint), 
+                             [(Fingerprint,IfaceDecl)])
+                         -> SCC IfaceDeclABI
+                         -> IO (OccEnv (OccName,Fingerprint), 
+                                [(Fingerprint,IfaceDecl)])
+
+       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
+          = do let hash_fn = mk_put_name local_env
+                   decl = abiDecl abi
+               -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
+               hash <- computeFingerprint dflags hash_fn abi
+               return (extend_hash_env (hash,decl) local_env,
+                       (hash,decl) : decls_w_hashes)
+
+       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
+          = do let decls = map abiDecl abis
+                   local_env' = foldr extend_hash_env local_env 
+                                   (zip (repeat fingerprint0) decls)
+                   hash_fn = mk_put_name local_env'
+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
+               let stable_abis = sortBy cmp_abiNames abis
+                -- put the cycle in a canonical order
+               hash <- computeFingerprint dflags hash_fn stable_abis
+               let pairs = zip (repeat hash) decls
+               return (foldr extend_hash_env local_env pairs,
+                       pairs ++ decls_w_hashes)
+
+       extend_hash_env :: (Fingerprint,IfaceDecl)
+                       -> OccEnv (OccName,Fingerprint)
+                       -> OccEnv (OccName,Fingerprint)
+       extend_hash_env (hash,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
         where
         where
-          occ = ifName new_decl
-
-    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
-         eq_ind_occs (map ifConOcc (visibleIfConDecls cons))
-    eq_indirects _ = 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 
-     
-    -- The Occs of declarations that changed.
-    changed_occs :: OccSet
-    changed_occs = computeChangedOccs ver_fn (mi_module new_iface)
-                         (mi_usages old_iface) eq_info
-
-    -------------------
-    -- 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
-                   Just (EqBut names) -> sep [ppr occ <> colon, ptext (sLit "Free vars (only) changed:") <> ppr names,
-                                             nest 2 (braces (fsep (map ppr (occSetElts 
-                                               (occs `intersectOccSet` changed_occs)))))]
-                           where occs = mkOccSet (map nameOccName (nameSetToList names))
-                   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")
-                   _ -> pprPanic "MkIface.show_change" (ppr occ)
-       
-    pp_orphs = pprOrphans new_orph_insts new_orph_rules
+          decl_name = ifName d
+          item = (decl_name, hash)
+          env1 = extendOccEnv env0 decl_name item
+          add_imp bndr env = extendOccEnv env bndr item
+            
+   --
+   (local_env, decls_w_hashes) <- 
+       foldM fingerprint_group (emptyOccEnv, []) groups
+
+   -- the export hash of a module depends on the orphan hashes of the
+   -- orphan modules below us in the dependeny tree.  This is the way
+   -- that changes in orphans get propagated all the way up the
+   -- dependency tree.  We only care about orphan modules in the current
+   -- package, because changes to orphans outside this package will be
+   -- tracked by the usage on the ABI hash of package modules that we import.
+   let orph_mods = sortBy (compare `on` (moduleNameFS.moduleName))
+                        . filter ((== this_pkg) . modulePackageId)
+                        $ dep_orphs (mi_deps iface0)
+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
+
+   orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
+                      (map IfaceInstABI orph_insts, orph_rules, fam_insts)
+
+   -- the export list hash doesn't depend on the fingerprints of
+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
+   export_hash <- computeFingerprint dflags putNameLiterally 
+                      (mi_exports iface0, orphan_hash, dep_orphan_hashes)
+
+   -- put the declarations in a canonical order, sorted by OccName
+   let sorted_decls = eltsFM $ listToFM $
+                          [(ifName d, e) | e@(_, d) <- decls_w_hashes]
+
+   -- the ABI hash depends on:
+   --   - decls
+   --   - export list
+   --   - orphans
+   --   - deprecations
+   --   - XXX vect info?
+   mod_hash <- computeFingerprint dflags putNameLiterally
+                      (map fst sorted_decls,
+                       export_hash,
+                       orphan_hash,
+                       mi_deprecs iface0)
+
+   -- The interface hash depends on:
+   --    - the ABI hash, plus
+   --    - usages
+   --    - deps
+   --    - hpc
+   iface_hash <- computeFingerprint dflags putNameLiterally
+                      (mod_hash, 
+                       mi_usages iface0,
+                       mi_deps iface0,
+                       mi_hpc iface0)
+
+   let
+    no_change_at_all = Just iface_hash == mb_old_fingerprint
+
+    final_iface = iface0 {
+                mi_mod_hash    = mod_hash,
+                mi_iface_hash  = iface_hash,
+                mi_exp_hash    = export_hash,
+                mi_orphan_hash = orphan_hash,
+                mi_orphan      = not (null orph_rules && null orph_insts),
+                mi_finsts      = not . null $ mi_fam_insts iface0,
+                mi_decls       = sorted_decls,
+                mi_hash_fn     = lookupOccEnv local_env }
+   --
+   return (final_iface, no_change_at_all, pp_orphs)
 
 
+  where
+    this_mod = mi_module iface0
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0)
+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0)
+        -- ToDo: shouldn't we be splitting fam_insts into orphans and
+        -- non-orphans?
+    fam_insts = mi_fam_insts iface0
+    fix_fn = mi_fix_fn iface0
+    pp_orphs = pprOrphans orph_insts orph_rules
+
+
+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
+getOrphanHashes hsc_env mods = do
+  eps <- hscEPS hsc_env
+  let 
+    hpt        = hsc_HPT hsc_env
+    pit        = eps_PIT eps
+    dflags     = hsc_dflags hsc_env
+    get_orph_hash mod = 
+          case lookupIfaceByModule dflags hpt pit mod of
+            Nothing    -> pprPanic "moduleOrphanHash" (ppr mod)
+            Just iface -> mi_orphan_hash iface
+  --
+  return (map get_orph_hash mods)
+
+
+-- The ABI of a declaration consists of:
+     -- the full name of the identifier (inc. module and package, because
+     --   these are used to construct the symbol name by which the 
+     --   identifier is known externally).
+     -- the fixity of the identifier
+     -- the declaration itself, as exposed to clients.  That is, the
+     --   definition of an Id is included in the fingerprint only if
+     --   it is made available as as unfolding in the interface.
+     -- for Ids: rules
+     -- for classes: instances, fixity & rules for methods
+     -- for datatypes: instances, fixity & rules for constrs
+type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
+
+abiDecl :: IfaceDeclABI -> IfaceDecl
+abiDecl (_, decl, _) = decl
+
+cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
+cmp_abiNames abi1 abi2 = ifName (abiDecl abi1) `compare` 
+                         ifName (abiDecl abi2)
+
+freeNamesDeclABI :: IfaceDeclABI -> NameSet
+freeNamesDeclABI (_mod, decl, extras) =
+  freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
+
+data IfaceDeclExtras 
+  = IfaceIdExtras    Fixity [IfaceRule]
+  | IfaceDataExtras  Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
+  | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])]
+  | IfaceOtherDeclExtras
+
+freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
+freeNamesDeclExtras (IfaceIdExtras    _ rules)
+  = unionManyNameSets (map freeNamesIfRule rules)
+freeNamesDeclExtras (IfaceDataExtras  _ _insts subs)
+  = unionManyNameSets (map freeNamesSub subs)
+freeNamesDeclExtras (IfaceClassExtras _insts subs)
+  = unionManyNameSets (map freeNamesSub subs)
+freeNamesDeclExtras IfaceOtherDeclExtras
+  = emptyNameSet
+
+freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
+freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
+
+instance Binary IfaceDeclExtras where
+  get _bh = panic "no get for IfaceDeclExtras"
+  put_ bh (IfaceIdExtras fix rules) = do
+   putByte bh 1; put_ bh fix; put_ bh rules
+  put_ bh (IfaceDataExtras fix insts cons) = do
+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh cons
+  put_ bh (IfaceClassExtras insts methods) = do
+   putByte bh 3; put_ bh insts; put_ bh methods
+  put_ bh IfaceOtherDeclExtras = do
+   putByte bh 4
+
+declExtras :: (OccName -> Fixity)
+           -> OccEnv [IfaceRule]
+           -> OccEnv [IfaceInst]
+           -> IfaceDecl
+           -> IfaceDeclExtras
+
+declExtras fix_fn rule_env inst_env decl
+  = case decl of
+      IfaceId{} -> IfaceIdExtras (fix_fn n) 
+                        (lookupOccEnvL rule_env n)
+      IfaceData{ifCons=cons} -> 
+                     IfaceDataExtras (fix_fn n)
+                        (map IfaceInstABI $ lookupOccEnvL inst_env n)
+                        (map (id_extras . ifConOcc) (visibleIfConDecls cons))
+      IfaceClass{ifSigs=sigs} -> 
+                     IfaceClassExtras 
+                        (map IfaceInstABI $ lookupOccEnvL inst_env n)
+                        [id_extras op | IfaceClassOp op _ _ <- sigs]
+      _other -> IfaceOtherDeclExtras
+  where
+        n = ifName decl
+        id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
+
+-- When hashing an instance, we omit the DFun.  This is because if a
+-- DFun is used it will already have a separate entry in the usages
+-- list, and we don't want changes to the DFun to cause the hash of
+-- the instnace to change - that would cause unnecessary changes to
+-- orphans, for example.
+newtype IfaceInstABI = IfaceInstABI IfaceInst
+
+instance Binary IfaceInstABI where
+  get = panic "no get for IfaceInstABI"
+  put_ bh (IfaceInstABI inst) = do
+    let ud  = getUserData bh
+        bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
+    put_ bh' inst
+
+lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
+lookupOccEnvL env k = lookupOccEnv env k `orElse` []
+
+-- used when we want to fingerprint a structure without depending on the
+-- fingerprints of external Names that it refers to.
+putNameLiterally :: BinHandle -> Name -> IO ()
+putNameLiterally bh name = do
+  put_ bh $! nameModule name
+  put_ bh $! nameOccName name
+
+computeFingerprint :: Binary a
+                   => DynFlags 
+                   -> (BinHandle -> Name -> IO ())
+                   -> a
+                   -> IO Fingerprint
+
+computeFingerprint _dflags put_name a = do
+  bh <- openBinMem (3*1024) -- just less than a block
+  ud <- newWriteState put_name putFS
+  bh <- return $ setUserData bh ud
+  put_ bh a
+  fingerprintBinMem bh
+
+{-
+-- for testing: use the md5sum command to generate fingerprints and
+-- compare the results against our built-in version.
+  fp' <- oldMD5 dflags bh
+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
+               else return fp
+
+oldMD5 dflags bh = do
+  tmp <- newTempName dflags "bin"
+  writeBinMem bh tmp
+  tmp2 <- newTempName dflags "md5"
+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
+  r <- system cmd
+  case r of
+    ExitFailure _ -> ghcError (PhaseFailed cmd r)
+    ExitSuccess -> do
+        hash_str <- readFile tmp2
+        return $! readHexFingerprint hash_str
+-}
 
 pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc
 pprOrphans insts rules
 
 pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc
 pprOrphans insts rules
@@ -694,90 +845,6 @@ pprOrphans insts rules
                2 (vcat (map ppr rules))
     ]
 
                2 (vcat (map ppr rules))
     ]
 
-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
-  = foldl add_changes emptyOccSet (stronglyConnComp edges)
-  where
-
-    -- return True if an external name has changed
-    name_changed :: Name -> Bool
-    name_changed nm
-       | isWiredInName nm      -- Wired-in things don't get into interface
-       = False                 -- files and hence don't get into the ver_fn
-        | 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.
-        | otherwise = False -- must be in another package
-      where
-         mod = nameModule nm
-         (parent_occ, new_version) = ver_fn nm
-
-    this_pkg = modulePackageId this_module
-
-    -- Turn the usages from the old ModIface into a mapping
-    usg_modmap = listToUFM [ (usg_name usg, listToUFM (usg_entities usg))
-                           | usg <- old_usages ]
-
-    get_local_eq_info :: GenIfaceEq Name -> GenIfaceEq OccName
-    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])]
-    edges = [ (node, getUnique occ, map getUnique occs)
-           | node@(occ, iface_eq) <- local_eq_infos
-           , let occs = case iface_eq of
-                          EqBut occ_set -> occSetElts occ_set
-                          _ -> [] ]
-
-    -- Changes in declarations
-    add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet
-    add_changes so_far (AcyclicSCC (occ, iface_eq)) 
-       | changedWrt so_far iface_eq -- This one has changed
-       = extendOccSet so_far occ
-    add_changes so_far (CyclicSCC pairs)
-       | changedWrt so_far (foldr1 and_occifeq iface_eqs)
-               -- One of this group has changed
-       = extendOccSetList so_far occs
-        where (occs, iface_eqs) = unzip pairs
-    add_changes so_far _ = so_far
-
-type OccIfaceEq = GenIfaceEq OccName
-
-changedWrt :: OccSet -> OccIfaceEq -> Bool
-changedWrt _      Equal        = False
-changedWrt _      NotEqual     = True
-changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids
-
-changedWrtNames :: OccSet -> IfaceEq -> Bool
-changedWrtNames _      Equal        = False
-changedWrtNames _      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` _        = NotEqual
-EqBut nms   `and_occifeq` Equal       = EqBut nms
-EqBut _     `and_occifeq` NotEqual    = NotEqual
-EqBut nms1  `and_occifeq` EqBut nms2  = EqBut (nms1 `unionOccSets` nms2)
-
 ----------------------
 -- mkOrphMap partitions instance decls or rules into
 --     (a) an OccEnv for ones that are not orphans, 
 ----------------------
 -- mkOrphMap partitions instance decls or rules into
 --     (a) an OccEnv for ones that are not orphans, 
@@ -796,30 +863,22 @@ mkOrphMap get_key decls
        | Just occ <- get_key d
        = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs)
        | otherwise = (non_orphs, d:orphs)
        | 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}
 
 
 %*********************************************************
 %*                                                     *
 \end{code}
 
 
 %*********************************************************
 %*                                                     *
-\subsection{Keeping track of what we've slurped, and version numbers}
+\subsection{Keeping track of what we've slurped, and fingerprints}
 %*                                                     *
 %*********************************************************
 
 
 \begin{code}
 %*                                                     *
 %*********************************************************
 
 
 \begin{code}
-mkUsageInfo :: HscEnv 
-           -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
-           -> [(ModuleName, IsBootInterface)]
-           -> NameSet -> IO [Usage]
-mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage]
+mkUsageInfo hsc_env this_mod dir_imp_mods used_names
   = do { eps <- hscEPS hsc_env
   = do { eps <- hscEPS hsc_env
-       ; let usages = mk_usage_info (eps_PIT eps) hsc_env 
-                                    dir_imp_mods dep_mods used_names
+       ; let usages = mk_usage_info (eps_PIT eps) hsc_env this_mod
+                                    dir_imp_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
        ; 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
@@ -827,70 +886,81 @@ mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
 
 mk_usage_info :: PackageIfaceTable
               -> HscEnv
 
 mk_usage_info :: PackageIfaceTable
               -> HscEnv
-              -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
-              -> [(ModuleName, IsBootInterface)]
+              -> Module
+              -> ImportedMods
               -> NameSet
               -> [Usage]
               -> NameSet
               -> [Usage]
-mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names
-  = mapCatMaybes mkUsage dep_mods
-       -- ToDo: do we need to sort into canonical order?
+mk_usage_info pit hsc_env this_mod direct_imports used_names
+  = mapCatMaybes mkUsage usage_mods
   where
     hpt = hsc_HPT hsc_env
     dflags = hsc_dflags hsc_env
   where
     hpt = hsc_HPT hsc_env
     dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+    used_mods    = moduleEnvKeys ent_map
+    dir_imp_mods = (moduleEnvKeys direct_imports)
+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
+    usage_mods   = sortBy stableModuleCmp all_mods
+                        -- canonical order is imported, to avoid interface-file
+                        -- wobblage.
 
     -- ent_map groups together all the things imported and used
 
     -- ent_map groups together all the things imported and used
-    -- from a particular module in this package
+    -- from a particular module
     ent_map :: ModuleEnv [OccName]
     ent_map  = foldNameSet add_mv emptyModuleEnv used_names
     ent_map :: ModuleEnv [OccName]
     ent_map  = foldNameSet add_mv emptyModuleEnv used_names
-    add_mv name mv_map
+     where
+      add_mv name mv_map
         | isWiredInName name = mv_map  -- ignore wired-in names
         | otherwise
         = case nameModule_maybe name of
         | 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]
-                  where
-                    occ = nameOccName name
-                    add_item occs _ = occ:occs
-    
-    depend_on_exports mod = case lookupModuleEnv dir_imp_mods mod of
-                               Just (_, xs) -> any (\(_, no_imp, _) -> not no_imp) xs
-                               Nothing          -> True
+             Nothing  -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
+             Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
+                  where occ = nameOccName name
     
     -- We want to create a Usage for a home module if 
     
     -- 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)
-    -- c) is a home-package orphan or family-instance module (need to
-    --         recompile if its instance decls change: rules_vers)
-    mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage
-    mkUsage (mod_name, _)
-      |  isNothing maybe_iface         -- We can't depend on it if we didn't
-      || (null used_occs               -- load its interface.
-         && isNothing export_vers
-         && not orphan_mod
+    -- a) we used something from it; has something in used_names
+    -- b) we imported it, even if we used nothing from it
+    --    (need to recompile if its export list changes: export_fprint)
+    mkUsage :: Module -> Maybe Usage
+    mkUsage mod
+      | isNothing maybe_iface          -- We can't depend on it if we didn't
+                                       -- load its interface.
+      || mod == this_mod                -- We don't care about usages of
+                                        -- things in *this* module
+      = Nothing
+
+      | modulePackageId mod /= this_pkg
+      = Just UsagePackageModule{ usg_mod      = mod,
+                                 usg_mod_hash = mod_hash }
+        -- for package modules, we record the module hash only
+
+      | (null used_occs
+         && isNothing export_hash
+          && not is_direct_import
          && not finsts_mod)
       = Nothing                        -- Record no usage info
          && not finsts_mod)
       = Nothing                        -- Record no usage info
+        -- for directly-imported modules, we always want to record a usage
+        -- on the orphan hash.  This is what triggers a recompilation if
+        -- an orphan is added or removed somewhere below us in the future.
     
       | otherwise      
     
       | otherwise      
-      = Just (Usage { usg_name     = mod_name,
-                     usg_mod      = mod_vers,
-                     usg_exports  = export_vers,
-                     usg_entities = fmToList ent_vers,
-                     usg_rules    = rules_vers })
+      = Just UsageHomeModule { 
+                      usg_mod_name = moduleName mod,
+                     usg_mod_hash = mod_hash,
+                     usg_exports  = export_hash,
+                     usg_entities = fmToList ent_hashs }
       where
        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
                -- In one-shot mode, the interfaces for home-package 
                -- modules accumulate in the PIT not HPT.  Sigh.
 
       where
        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
                -- In one-shot mode, the interfaces for home-package 
                -- modules accumulate in the PIT not HPT.  Sigh.
 
-        mod = mkModule (thisPackage dflags) mod_name
+        is_direct_import = mod `elemModuleEnv` direct_imports
 
         Just iface   = maybe_iface
 
         Just iface   = maybe_iface
-       orphan_mod   = mi_orphan    iface
        finsts_mod   = mi_finsts    iface
        finsts_mod   = mi_finsts    iface
-        version_env  = mi_ver_fn    iface
-        mod_vers     = mi_mod_vers  iface
-        rules_vers   = mi_rule_vers iface
-        export_vers | depend_on_exports mod = Just (mi_exp_vers iface)
+        hash_env     = mi_hash_fn   iface
+        mod_hash     = mi_mod_hash  iface
+        export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
                    | otherwise             = Nothing
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
                    | otherwise             = Nothing
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
@@ -900,14 +970,29 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names
         -- 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.
         -- 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)
+       ent_hashs :: FiniteMap OccName Fingerprint
+        ent_hashs = listToFM (map lookup_occ used_occs)
         
         lookup_occ occ = 
         
         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)
+            case hash_env occ of
+                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
+                Just r  -> r
+
+        depend_on_exports mod = 
+           case lookupModuleEnv direct_imports mod of
+               Just _ -> True
+                  -- Even if we used 'import M ()', we have to register a
+                  -- usage on the export list because we are sensitive to
+                  -- changes in orphan instances/rules.
+               Nothing -> False
+                  -- In GHC 6.8.x the above line read "True", and in
+                  -- fact it recorded a dependency on *all* the
+                  -- modules underneath in the dependency tree.  This
+                  -- happens to make orphans work right, but is too
+                  -- expensive: it'll read too many interface files.
+                  -- The 'isNothing maybe_iface' check above saved us
+                  -- from generating many of these usages (at least in
+                  -- one-shot mode), but that's even more bogus!
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
@@ -1062,9 +1147,10 @@ checkVersions hsc_env source_unchanged mod_summary iface
         ; if recomp then return outOfDate else do {
 
        -- Source code unchanged and no errors yet... carry on 
         ; if recomp then return outOfDate else do {
 
        -- Source code unchanged and no errors yet... carry on 
-
-       -- First put the dependent-module info, read from the old interface, into the envt, 
-       -- so that when we look for interfaces we look for the right one (.hi or .hi-boot)
+        --
+       -- First put the dependent-module info, read from the old
+       -- interface, into the envt, so that when we look for
+       -- interfaces we look for the right one (.hi or .hi-boot)
        -- 
        -- 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
        -- 
        -- 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
@@ -1130,104 +1216,113 @@ checkDependencies hsc_env summary iface
            where pkg = modulePackageId mod
         _otherwise  -> return outOfDate
 
            where pkg = modulePackageId mod
         _otherwise  -> return outOfDate
 
-checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
--- Given the usage information extracted from the old
--- M.hi file for the module being compiled, figure out
--- whether M needs to be recompiled.
-
-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 })
-  = do -- Load the imported interface is possible
-    let doc_str = sep [ptext (sLit "need version info for"), ppr mod_name]
-    traceHiDiffs (text "Checking usages for module" <+> ppr mod_name)
-
-    let mod = mkModule this_pkg mod_name
+needInterface :: Module -> (ModIface -> IfG RecompileRequired)
+              -> IfG RecompileRequired
+needInterface mod continue
+  = do -- Load the imported interface if possible
+    let doc_str = sep [ptext (sLit "need version info for"), ppr mod]
+    traceHiDiffs (text "Checking usages for module" <+> ppr mod)
 
     mb_iface <- loadInterface doc_str mod ImportBySystem
        -- Load the interface, but don't complain on failure;
        -- Instead, get an Either back which we can test
 
 
     mb_iface <- loadInterface doc_str mod ImportBySystem
        -- Load the interface, but don't complain on failure;
        -- Instead, get an Either back which we can test
 
-    case mb_iface of {
-       Failed _ ->  (out_of_date (sep [ptext (sLit "Can't find version number for module"), 
-                                      ppr mod_name]));
+    case mb_iface of
+       Failed _ ->  (out_of_date (sep [ptext (sLit "Couldn't load interface for module"), 
+                                      ppr mod]));
                -- Couldn't find or parse a module mentioned in the
                -- 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
+               -- old interface file.  Don't complain: it might
+               -- just be that the current module doesn't need that
+               -- import and it's been deleted
+       Succeeded iface -> continue iface
+
+
+checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
+-- Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
+
+checkModUsage _this_pkg UsagePackageModule{
+                                usg_mod = mod,
+                                usg_mod_hash = old_mod_hash }
+  = needInterface mod $ \iface -> do
+    checkModuleFingerprint old_mod_hash (mi_mod_hash iface)
+        -- We only track the ABI hash of package modules, rather than
+        -- individual entity usages, so if the ABI hash changes we must
+        -- recompile.  This is safe but may entail more recompilation when
+        -- a dependent package has changed.
+
+checkModUsage this_pkg UsageHomeModule{ 
+                                usg_mod_name = mod_name, 
+                                usg_mod_hash = old_mod_hash,
+                               usg_exports = maybe_old_export_hash,
+                               usg_entities = old_decl_hash }
+  = do
+    let mod = mkModule this_pkg mod_name
+    needInterface mod $ \iface -> do
 
 
-       Succeeded iface -> 
     let
     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
+       new_mod_hash    = mi_mod_hash    iface
+       new_decl_hash   = mi_hash_fn     iface
+       new_export_hash = mi_exp_hash    iface
+
        -- CHECK MODULE
        -- CHECK MODULE
-    checkModuleVersion old_mod_vers new_mod_vers       >>= \ recompile ->
-    if not recompile then
-       return upToDate
-    else
+    recompile <- checkModuleFingerprint old_mod_hash new_mod_hash
+    if not recompile then return upToDate else do
                                 
        -- CHECK EXPORT LIST
                                 
        -- CHECK EXPORT LIST
-    if checkExportList maybe_old_export_vers new_export_vers then
-       out_of_date_vers (ptext (sLit "  Export list changed"))
-                        (expectJust "checkModUsage" maybe_old_export_vers) 
-                        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
+    checkMaybeHash maybe_old_export_hash new_export_hash
+        (ptext (sLit "  Export list changed")) $ do
 
        -- CHECK ITEMS ONE BY ONE
 
        -- CHECK ITEMS ONE BY ONE
-    checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers]  >>= \ recompile ->
-    if recompile then
-       return outOfDate        -- This one failed, so just bail out now
-    else
-       up_to_date (ptext (sLit "  Great!  The bits I use are up to date"))
-    }
+    recompile <- checkList [ checkEntityUsage new_decl_hash u 
+                           | u <- old_decl_hash]
+    if recompile 
+      then return 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 :: Version -> Version -> IfG Bool
-checkModuleVersion old_mod_vers new_mod_vers
-  | new_mod_vers == old_mod_vers
-  = up_to_date (ptext (sLit "Module version unchanged"))
+checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG Bool
+checkModuleFingerprint old_mod_hash new_mod_hash
+  | new_mod_hash == old_mod_hash
+  = up_to_date (ptext (sLit "Module fingerprint unchanged"))
 
   | otherwise
 
   | otherwise
-  = out_of_date_vers (ptext (sLit "  Module version has changed"))
-                    old_mod_vers new_mod_vers
+  = out_of_date_hash (ptext (sLit "  Module fingerprint has changed"))
+                    old_mod_hash new_mod_hash
 
 ------------------------
 
 ------------------------
-checkExportList :: Maybe Version -> Version -> Bool
-checkExportList Nothing  _        = upToDate
-checkExportList (Just v) new_vers = v /= new_vers
+checkMaybeHash :: Maybe Fingerprint -> Fingerprint -> SDoc
+               -> IfG RecompileRequired -> IfG RecompileRequired
+checkMaybeHash maybe_old_hash new_hash doc continue
+  | Just hash <- maybe_old_hash, hash /= new_hash
+  = out_of_date_hash doc hash new_hash
+  | otherwise
+  = continue
 
 ------------------------
 
 ------------------------
-checkEntityUsage :: (OccName -> Maybe (OccName, Version))
-                 -> (OccName, Version)
+checkEntityUsage :: (OccName -> Maybe (OccName, Fingerprint))
+                 -> (OccName, Fingerprint)
                  -> IfG Bool
                  -> IfG Bool
-checkEntityUsage new_vers (name,old_vers)
-  = case new_vers name of
+checkEntityUsage new_hash (name,old_hash)
+  = case new_hash name of
 
        Nothing       ->        -- We used it before, but it ain't there now
                          out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
 
 
        Nothing       ->        -- We used it before, but it ain't there now
                          out_of_date (sep [ptext (sLit "No longer exported:"), ppr name])
 
-       Just (_, new_vers)      -- It's there, but is it up to date?
-         | new_vers == old_vers -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_vers))
+       Just (_, new_hash)      -- It's there, but is it up to date?
+         | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
                                       return upToDate
                                       return upToDate
-         | otherwise            -> out_of_date_vers (ptext (sLit "  Out of date:") <+> ppr name)
-                                                    old_vers new_vers
+         | otherwise            -> out_of_date_hash (ptext (sLit "  Out of date:") <+> ppr name)
+                                                    old_hash new_hash
 
 up_to_date, out_of_date :: SDoc -> IfG Bool
 up_to_date  msg = traceHiDiffs msg >> return upToDate
 out_of_date msg = traceHiDiffs msg >> return outOfDate
 
 
 up_to_date, out_of_date :: SDoc -> IfG Bool
 up_to_date  msg = traceHiDiffs msg >> return upToDate
 out_of_date msg = traceHiDiffs msg >> return outOfDate
 
-out_of_date_vers :: SDoc -> Version -> Version -> IfG Bool
-out_of_date_vers msg old_vers new_vers 
-  = out_of_date (hsep [msg, ppr old_vers, ptext (sLit "->"), ppr new_vers])
+out_of_date_hash :: SDoc -> Fingerprint -> Fingerprint -> IfG Bool
+out_of_date_hash msg old_hash new_hash 
+  = out_of_date (hsep [msg, ppr old_hash, ptext (sLit "->"), ppr new_hash])
 
 ----------------------
 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
 
 ----------------------
 checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
index f686f34..9ded3f5 100644 (file)
@@ -216,7 +216,7 @@ deSugarModule hsc_env mod_summary tc_result
 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
                 -> IO (ModIface,Bool)
 makeSimpleIface hsc_env maybe_old_iface tc_result details = do
 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
                 -> IO (ModIface,Bool)
 makeSimpleIface hsc_env maybe_old_iface tc_result details = do
-  mkIfaceTc hsc_env maybe_old_iface details tc_result
+  mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
 
 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 -- typechecking only, as opposed to full compilation.
 
 -- | Make a 'ModDetails' from the results of typechecking.  Used when
 -- typechecking only, as opposed to full compilation.
@@ -548,7 +548,7 @@ hscSimpleIface tc_result
        details <- mkBootModDetailsTc hsc_env tc_result
        (new_iface, no_change) 
            <- {-# SCC "MkFinalIface" #-}
        details <- mkBootModDetailsTc hsc_env tc_result
        (new_iface, no_change) 
            <- {-# SCC "MkFinalIface" #-}
-              mkIfaceTc hsc_env maybe_old_iface details tc_result
+              mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
        -- And the answer is ...
        dumpIfaceStats hsc_env
        return (new_iface, no_change, details, tc_result)
        -- And the answer is ...
        dumpIfaceStats hsc_env
        return (new_iface, no_change, details, tc_result)
@@ -573,7 +573,8 @@ hscNormalIface simpl_result
            -- until after code output
        (new_iface, no_change)
                <- {-# SCC "MkFinalIface" #-}
            -- until after code output
        (new_iface, no_change)
                <- {-# SCC "MkFinalIface" #-}
-                  mkIface hsc_env maybe_old_iface details simpl_result
+                  mkIface hsc_env (fmap mi_iface_hash maybe_old_iface)
+                         details simpl_result
        -- Emit external core
        -- This should definitely be here and not after CorePrep,
        -- because CorePrep produces unqualified constructor wrapper declarations,
        -- Emit external core
        -- This should definitely be here and not after CorePrep,
        -- because CorePrep produces unqualified constructor wrapper declarations,
index 48fb2b4..bba10e4 100644 (file)
@@ -32,7 +32,7 @@ module HscTypes (
        icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
         substInteractiveContext,
 
        icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
         substInteractiveContext,
 
-       ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
+       ModIface(..), mkIfaceDepCache, mkIfaceHashCache, mkIfaceFixCache,
        emptyIfaceDepCache,
 
        FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
        emptyIfaceDepCache,
 
        FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
@@ -101,8 +101,7 @@ import PrelNames    ( gHC_PRIM )
 import Packages hiding ( Version(..) )
 import DynFlags                ( DynFlags(..), isOneShot, HscTarget (..) )
 import DriverPhases    ( HscSource(..), isHsBoot, hscSourceString, Phase )
 import Packages hiding ( Version(..) )
 import DynFlags                ( DynFlags(..), isOneShot, HscTarget (..) )
 import DriverPhases    ( HscSource(..), isHsBoot, hscSourceString, Phase )
-import BasicTypes      ( Version, initialVersion, IPName, 
-                         Fixity, defaultFixity, DeprecTxt )
+import BasicTypes      ( IPName, Fixity, defaultFixity, DeprecTxt )
 import IfaceSyn
 import FiniteMap       ( FiniteMap )
 import CoreSyn         ( CoreRule )
 import IfaceSyn
 import FiniteMap       ( FiniteMap )
 import CoreSyn         ( CoreRule )
@@ -114,6 +113,7 @@ import LazyUniqFM           ( lookupUFM, eltsUFM, emptyUFM )
 import UniqSupply      ( UniqSupply )
 import FastString
 import StringBuffer    ( StringBuffer )
 import UniqSupply      ( UniqSupply )
 import FastString
 import StringBuffer    ( StringBuffer )
+import Fingerprint
 
 import System.FilePath
 import System.Time     ( ClockTime )
 
 import System.FilePath
 import System.Time     ( ClockTime )
@@ -408,7 +408,8 @@ the declarations into a single indexed map in the @PersistentRenamerState@.
 data ModIface 
    = ModIface {
         mi_module   :: !Module,
 data ModIface 
    = ModIface {
         mi_module   :: !Module,
-        mi_mod_vers :: !Version,           -- Module version: changes when anything changes
+        mi_iface_hash :: !Fingerprint,      -- Hash of the whole interface
+        mi_mod_hash :: !Fingerprint,       -- Hash of the ABI only
 
         mi_orphan   :: !WhetherHasOrphans,  -- Whether this module has orphans
         mi_finsts   :: !WhetherHasFamInst,  -- Whether module has family insts
 
         mi_orphan   :: !WhetherHasOrphans,  -- Whether this module has orphans
         mi_finsts   :: !WhetherHasFamInst,  -- Whether module has family insts
@@ -420,7 +421,7 @@ data ModIface
 
                -- Usages; kept sorted so that it's easy to decide
                -- whether to write a new iface file (changing usages
 
                -- Usages; kept sorted so that it's easy to decide
                -- whether to write a new iface file (changing usages
-               -- doesn't affect the version of this module)
+               -- doesn't affect the hash of this module)
         mi_usages   :: [Usage],
                -- NOT STRICT!  we read this field lazily from the interface file
                -- It is *only* consulted by the recompilation checker
         mi_usages   :: [Usage],
                -- NOT STRICT!  we read this field lazily from the interface file
                -- It is *only* consulted by the recompilation checker
@@ -428,7 +429,7 @@ data ModIface
                -- Exports
                -- Kept sorted by (mod,occ), to make version comparisons easier
         mi_exports  :: ![IfaceExport],
                -- Exports
                -- Kept sorted by (mod,occ), to make version comparisons easier
         mi_exports  :: ![IfaceExport],
-        mi_exp_vers :: !Version,       -- Version number of export list
+        mi_exp_hash :: !Fingerprint,   -- Hash of export list
 
                -- Fixities
         mi_fixities :: [(OccName,Fixity)],
 
                -- Fixities
         mi_fixities :: [(OccName,Fixity)],
@@ -439,11 +440,11 @@ data ModIface
                -- NOT STRICT!  we read this field lazily from the interface file
 
                -- Type, class and variable declarations
                -- NOT STRICT!  we read this field lazily from the interface file
 
                -- Type, class and variable declarations
-               -- The version of an Id changes if its fixity or deprecations change
+               -- The hash of an Id changes if its fixity or deprecations change
                --      (as well as its type of course)
                -- Ditto data constructors, class operations, except that 
                --      (as well as its type of course)
                -- Ditto data constructors, class operations, except that 
-               -- the version of the parent class/tycon changes
-       mi_decls :: [(Version,IfaceDecl)],      -- Sorted
+               -- the hash of the parent class/tycon changes
+       mi_decls :: [(Fingerprint,IfaceDecl)],  -- Sorted
 
         mi_globals  :: !(Maybe GlobalRdrEnv),
                -- Binds all the things defined at the top level in
 
         mi_globals  :: !(Maybe GlobalRdrEnv),
                -- Binds all the things defined at the top level in
@@ -464,7 +465,7 @@ data ModIface
        mi_insts     :: [IfaceInst],                    -- Sorted
        mi_fam_insts :: [IfaceFamInst],                 -- Sorted
        mi_rules     :: [IfaceRule],                    -- Sorted
        mi_insts     :: [IfaceInst],                    -- Sorted
        mi_fam_insts :: [IfaceFamInst],                 -- Sorted
        mi_rules     :: [IfaceRule],                    -- Sorted
-       mi_rule_vers :: !Version,       -- Version number for rules and 
+       mi_orphan_hash :: !Fingerprint, -- Hash for orphan rules and 
                                        -- instances (for classes and families)
                                        -- combined
 
                                        -- instances (for classes and families)
                                        -- combined
 
@@ -476,9 +477,9 @@ data ModIface
                -- and are not put into the interface file
        mi_dep_fn  :: Name -> Maybe DeprecTxt,  -- Cached lookup for mi_deprecs
        mi_fix_fn  :: OccName -> Fixity,        -- Cached lookup for mi_fixities
                -- and are not put into the interface file
        mi_dep_fn  :: Name -> Maybe DeprecTxt,  -- Cached lookup for mi_deprecs
        mi_fix_fn  :: OccName -> Fixity,        -- Cached lookup for mi_fixities
-       mi_ver_fn  :: OccName -> Maybe (OccName, Version),
+       mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
                         -- Cached lookup for mi_decls
                         -- Cached lookup for mi_decls
-                       -- The Nothing in mi_ver_fn means that the thing
+                       -- The Nothing in mi_hash_fn means that the thing
                        -- isn't in decls. It's useful to know that when
                        -- seeing if we are up to date wrt the old interface
                         -- The 'OccName' is the parent of the name, if it has one.
                        -- isn't in decls. It's useful to know that when
                        -- seeing if we are up to date wrt the old interface
                         -- The 'OccName' is the parent of the name, if it has one.
@@ -512,7 +513,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
 -- being compiled right now.  Once it is compiled, a ModIface and 
 -- ModDetails are extracted and the ModGuts is dicarded.
 
 -- being compiled right now.  Once it is compiled, a ModIface and 
 -- ModDetails are extracted and the ModGuts is dicarded.
 
-type ImportedMods = ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)])
+type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
 
 data ModGuts
   = ModGuts {
 
 data ModGuts
   = ModGuts {
@@ -635,14 +636,15 @@ data ForeignStubs = NoStubs
 emptyModIface :: Module -> ModIface
 emptyModIface mod
   = ModIface { mi_module   = mod,
 emptyModIface :: Module -> ModIface
 emptyModIface mod
   = ModIface { mi_module   = mod,
-              mi_mod_vers = initialVersion,
+              mi_iface_hash = fingerprint0,
+              mi_mod_hash = fingerprint0,
               mi_orphan   = False,
               mi_finsts   = False,
               mi_boot     = False,
               mi_deps     = noDependencies,
               mi_usages   = [],
               mi_exports  = [],
               mi_orphan   = False,
               mi_finsts   = False,
               mi_boot     = False,
               mi_deps     = noDependencies,
               mi_usages   = [],
               mi_exports  = [],
-              mi_exp_vers = initialVersion,
+              mi_exp_hash = fingerprint0,
               mi_fixities = [],
               mi_deprecs  = NoDeprecs,
               mi_insts     = [],
               mi_fixities = [],
               mi_deprecs  = NoDeprecs,
               mi_insts     = [],
@@ -650,12 +652,12 @@ emptyModIface mod
               mi_rules     = [],
               mi_decls     = [],
               mi_globals   = Nothing,
               mi_rules     = [],
               mi_decls     = [],
               mi_globals   = Nothing,
-              mi_rule_vers = initialVersion,
+              mi_orphan_hash = fingerprint0,
                mi_vect_info = noIfaceVectInfo,
                mi_vect_info = noIfaceVectInfo,
-              mi_dep_fn = emptyIfaceDepCache,
-              mi_fix_fn = emptyIfaceFixCache,
-              mi_ver_fn = emptyIfaceVerCache,
-              mi_hpc    = False
+              mi_dep_fn    = emptyIfaceDepCache,
+              mi_fix_fn    = emptyIfaceFixCache,
+              mi_hash_fn   = emptyIfaceHashCache,
+              mi_hpc       = False
     }          
 \end{code}
 
     }          
 \end{code}
 
@@ -965,19 +967,10 @@ tyThingId (ADataCon dc) = dataConWrapId dc
 tyThingId other         = pprPanic "tyThingId" (pprTyThing other)
 \end{code}
 
 tyThingId other         = pprPanic "tyThingId" (pprTyThing other)
 \end{code}
 
-%************************************************************************
-%*                                                                     *
-\subsection{Auxiliary types}
-%*                                                                     *
-%************************************************************************
-
-These types are defined here because they are mentioned in ModDetails,
-but they are mostly elaborated elsewhere
-
 \begin{code}
 \begin{code}
-mkIfaceVerCache :: [(Version,IfaceDecl)]
-                -> (OccName -> Maybe (OccName, Version))
-mkIfaceVerCache pairs 
+mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
+                 -> (OccName -> Maybe (OccName, Fingerprint))
+mkIfaceHashCache pairs 
   = \occ -> lookupOccEnv env occ
   where
     env = foldr add_decl emptyOccEnv pairs
   = \occ -> lookupOccEnv env occ
   where
     env = foldr add_decl emptyOccEnv pairs
@@ -987,9 +980,20 @@ mkIfaceVerCache pairs
           env1 = extendOccEnv env0 decl_name (decl_name, v)
           add_imp bndr env = extendOccEnv env bndr (decl_name, v)
 
           env1 = extendOccEnv env0 decl_name (decl_name, v)
           add_imp bndr env = extendOccEnv env bndr (decl_name, v)
 
-emptyIfaceVerCache :: OccName -> Maybe (OccName, Version)
-emptyIfaceVerCache _occ = Nothing
+emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
+emptyIfaceHashCache _occ = Nothing
+\end{code}
 
 
+%************************************************************************
+%*                                                                     *
+\subsection{Auxiliary types}
+%*                                                                     *
+%************************************************************************
+
+These types are defined here because they are mentioned in ModDetails,
+but they are mostly elaborated elsewhere
+
+\begin{code}
 ------------------ Deprecations -------------------------
 data Deprecations
   = NoDeprecs
 ------------------ Deprecations -------------------------
 data Deprecations
   = NoDeprecs
@@ -1146,26 +1150,29 @@ noDependencies :: Dependencies
 noDependencies = Deps [] [] [] []
          
 data Usage
 noDependencies = Deps [] [] [] []
          
 data Usage
-  = Usage { usg_name     :: ModuleName,                        -- Name of the module
-           usg_mod      :: Version,                    -- Module version
-           usg_entities :: [(OccName,Version)],        -- Sorted by occurrence name
-                -- NB. usages are for parent names only, eg. tycon but not constructors.
-           usg_exports  :: Maybe Version,              -- Export-list version, if we depend on it
-           usg_rules    :: Version                     -- Orphan-rules version (for non-orphan
-                                                       -- modules this will always be initialVersion)
-    }      deriving( Eq )
-       -- This type doesn't let you say "I imported f but none of the rules in
-       -- the module". If you use anything in the module you get its rule version
-       -- So if the rules change, you'll recompile, even if you don't use them.
-       -- This is easy to implement, and it's safer: you might not have used the rules last
-       -- time round, but if someone has added a new rule you might need it this time
-
+  = UsagePackageModule {
+        usg_mod      :: Module,
+        usg_mod_hash :: Fingerprint
+    }
+  | UsageHomeModule {
+        usg_mod_name :: ModuleName,            -- Name of the module
+       usg_mod_hash :: Fingerprint,            -- Module fingerprint
+                                                -- (optimisation only)
+       usg_entities :: [(OccName,Fingerprint)],
+               -- Sorted by occurrence name.
+            -- NB. usages are for parent names only, 
+            -- eg. tycon but not constructors.
+       usg_exports  :: Maybe Fingerprint
+            -- Export-list fingerprint, if we depend on it
+    }
+    deriving( Eq )
        -- The export list field is (Just v) if we depend on the export list:
        --      i.e. we imported the module directly, whether or not we
        -- The export list field is (Just v) if we depend on the export list:
        --      i.e. we imported the module directly, whether or not we
-       --           enumerated the things we imported, or just imported everything
+       --           enumerated the things we imported, or just imported 
+        --           everything
        -- We need to recompile if M's exports change, because 
        -- We need to recompile if M's exports change, because 
-       -- if the import was    import M,       we might now have a name clash in the 
-       --                                      importing module.
+       -- if the import was    import M,       we might now have a name clash
+        --                                      in the importing module.
        -- if the import was    import M(x)     M might no longer export x
        -- The only way we don't depend on the export list is if we have
        --                      import M()
        -- if the import was    import M(x)     M might no longer export x
        -- The only way we don't depend on the export list is if we have
        --                      import M()
@@ -1210,7 +1217,7 @@ data ExternalPackageState
                -- (below), not in the mi_decls fields of the iPIT.  
                -- What _is_ in the iPIT is:
                --      * The Module 
                -- (below), not in the mi_decls fields of the iPIT.  
                -- What _is_ in the iPIT is:
                --      * The Module 
-               --      * Version info
+               --      * Fingerprint info
                --      * Its exports
                --      * Fixities
                --      * Deprecations
                --      * Its exports
                --      * Fixities
                --      * Deprecations
index 64f3498..3779a0a 100644 (file)
@@ -310,7 +310,7 @@ tidyProgram hsc_env
                "Tidy Core Rules"
                (pprRules tidy_rules)
 
                "Tidy Core Rules"
                (pprRules tidy_rules)
 
-        ; let dir_imp_mods = map fst (moduleEnvElts dir_imps)
+        ; let dir_imp_mods = moduleEnvKeys dir_imps
 
        ; return (CgGuts { cg_module   = mod, 
                           cg_tycons   = alg_tycons,
 
        ; return (CgGuts { cg_module   = mod, 
                           cg_tycons   = alg_tycons,
index ae730c7..67b1dd1 100644 (file)
@@ -225,7 +225,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot
                        _                    -> False
 
        imports   = ImportAvails { 
                        _                    -> False
 
        imports   = ImportAvails { 
-                       imp_mods     = unitModuleEnv imp_mod (imp_mod, [(qual_mod_name, import_all, loc)]),
+                       imp_mods     = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc)],
                        imp_orphs    = orphans,
                        imp_finsts   = finsts,
                        imp_dep_mods = mkModDeps dependent_mods,
                        imp_orphs    = orphans,
                        imp_finsts   = finsts,
                        imp_dep_mods = mkModDeps dependent_mods,
@@ -805,7 +805,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
     kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
 
     imported_modules = [ qual_name
     kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
 
     imported_modules = [ qual_name
-                       | (_, xs) <- moduleEnvElts $ imp_mods imports,
+                       | xs <- moduleEnvElts $ imp_mods imports,
                          (qual_name, _, _) <- xs ]
 
     exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
                          (qual_name, _, _) <- xs ]
 
     exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
@@ -1176,7 +1176,7 @@ reportUnusedNames export_decls gbl_env
 
     direct_import_mods :: [(Module, [(ModuleName, Bool, SrcSpan)])]
        -- See the type of the imp_mods for this triple
 
     direct_import_mods :: [(Module, [(ModuleName, Bool, SrcSpan)])]
        -- See the type of the imp_mods for this triple
-    direct_import_mods = moduleEnvElts (imp_mods imports)
+    direct_import_mods = fmToList (imp_mods imports)
 
     -- unused_imp_mods are the directly-imported modules 
     -- that are not mentioned in minimal_imports1
 
     -- unused_imp_mods are the directly-imported modules 
     -- that are not mentioned in minimal_imports1
index fb72577..295cb6d 100644 (file)
@@ -497,14 +497,14 @@ reOrderCycle (bind : binds)
         | workerExists (idWorkerInfo bndr)      = 10
                 -- Note [Worker inline loop]
 
         | workerExists (idWorkerInfo bndr)      = 10
                 -- Note [Worker inline loop]
 
-        | exprIsTrivial rhs        = 4  -- Practically certain to be inlined
+        | exprIsTrivial rhs        = 5  -- Practically certain to be inlined
                 -- Used to have also: && not (isExportedId bndr)
                 -- But I found this sometimes cost an extra iteration when we have
                 --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }
                 -- where df is the exported dictionary. Then df makes a really
                 -- bad choice for loop breaker
 
                 -- Used to have also: && not (isExportedId bndr)
                 -- But I found this sometimes cost an extra iteration when we have
                 --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }
                 -- where df is the exported dictionary. Then df makes a really
                 -- bad choice for loop breaker
 
-        | is_con_app rhs = 2    -- Data types help with cases
+        | is_con_app rhs = 3    -- Data types help with cases
                 -- Note [conapp]
 
 -- If an Id is marked "never inline" then it makes a great loop breaker
                 -- Note [conapp]
 
 -- If an Id is marked "never inline" then it makes a great loop breaker
@@ -513,9 +513,12 @@ reOrderCycle (bind : binds)
 -- so it probably isn't worth the time to test on every binder
 --     | isNeverActive (idInlinePragma bndr) = -10
 
 -- so it probably isn't worth the time to test on every binder
 --     | isNeverActive (idInlinePragma bndr) = -10
 
-        | inlineCandidate bndr rhs = 1  -- Likely to be inlined
+        | inlineCandidate bndr rhs = 2  -- Likely to be inlined
                 -- Note [Inline candidates]
 
                 -- Note [Inline candidates]
 
+        | not (neverUnfold (idUnfolding bndr)) = 1
+                -- the Id has some kind of unfolding
+
         | otherwise = 0
 
     inlineCandidate :: Id -> CoreExpr -> Bool
         | otherwise = 0
 
     inlineCandidate :: Id -> CoreExpr -> Bool
index 45ef88a..d7353dd 100644 (file)
@@ -1425,6 +1425,10 @@ prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rh
 
        _ -> return [(DEFAULT, [], deflt_rhs)]
 
 
        _ -> return [(DEFAULT, [], deflt_rhs)]
 
+  | debugIsOn, isAlgTyCon tycon, [] <- tyConDataCons tycon
+  = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon <+> ppr deflt_rhs)
+        $ return [(DEFAULT, [], deflt_rhs)]
+
 --------- Catch-all cases -----------
 prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs)
   = return [(DEFAULT, [], deflt_rhs)]
 --------- Catch-all cases -----------
 prepareDefault _dflags _env _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs)
   = return [(DEFAULT, [], deflt_rhs)]
index b5d5f16..00f7114 100644 (file)
@@ -66,6 +66,7 @@ import PprCore
 import CoreSyn
 import ErrUtils
 import Id
 import CoreSyn
 import ErrUtils
 import Id
+import VarEnv
 import Var
 import Module
 import LazyUniqFM
 import Var
 import Module
 import LazyUniqFM
@@ -78,10 +79,12 @@ import SrcLoc
 import HscTypes
 import ListSetOps
 import Outputable
 import HscTypes
 import ListSetOps
 import Outputable
+import DataCon
+import Type
+import Class
 
 #ifdef GHCI
 import Linker
 
 #ifdef GHCI
 import Linker
-import DataCon
 import TcHsType
 import TcMType
 import TcMatches
 import TcHsType
 import TcMType
 import TcMatches
@@ -103,6 +106,7 @@ import Bag
 import Control.Monad
 import Data.Maybe      ( isJust )
 
 import Control.Monad
 import Data.Maybe      ( isJust )
 
+#include "HsVersions.h"
 \end{code}
 
 
 \end{code}
 
 
@@ -251,8 +255,7 @@ tcRnImports hsc_env this_mod import_decls
 
                -- Check type-familily consistency
        ; traceRn (text "rn1: checking family instance consistency")
 
                -- Check type-familily consistency
        ; traceRn (text "rn1: checking family instance consistency")
-       ; let { dir_imp_mods = map (\ (mod, _) -> mod) 
-                            . moduleEnvElts 
+       ; let { dir_imp_mods = moduleEnvKeys
                             . imp_mods 
                             $ imports }
        ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
                             . imp_mods 
                             $ imports }
        ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
@@ -550,6 +553,7 @@ checkHiBootIface
             --       be the equivalent to the dfun bindings returned for class
             --       instances?  We can't easily equate tycons...
 
             --       be the equivalent to the dfun bindings returned for class
             --       instances?  We can't easily equate tycons...
 
+        ; failIfErrsM
        ; return tcg_env' }
   where
     check_export boot_avail    -- boot_avail is exported by the boot iface
        ; return tcg_env' }
   where
     check_export boot_avail    -- boot_avail is exported by the boot iface
@@ -560,7 +564,8 @@ checkHiBootIface
 
        -- Check that the actual module exports the same thing
       | not (null missing_names)
 
        -- Check that the actual module exports the same thing
       | not (null missing_names)
-      = addErrTc (missingBootThing (head missing_names) "exported by")
+      = addErrAt (nameSrcSpan (head missing_names)) 
+                 (missingBootThing (head missing_names) "exported by")
 
        -- If the boot module does not *define* the thing, we are done
        -- (it simply re-exports it, and names match, so nothing further to do)
 
        -- If the boot module does not *define* the thing, we are done
        -- (it simply re-exports it, and names match, so nothing further to do)
@@ -568,13 +573,14 @@ checkHiBootIface
 
        -- Check that the actual module also defines the thing, and 
        -- then compare the definitions
 
        -- Check that the actual module also defines the thing, and 
        -- then compare the definitions
-      | Just real_thing <- lookupTypeEnv local_type_env name
-      = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing)
-                real_decl = tyThingToIfaceDecl real_thing
-          ; checkTc (checkBootDecl boot_decl real_decl)
-                    (bootMisMatch real_thing boot_decl real_decl) }
-               -- The easiest way to check compatibility is to convert to
-               -- iface syntax, where we already have good comparison functions
+      | Just real_thing <- lookupTypeEnv local_type_env name,
+        Just boot_thing <- mb_boot_thing
+      = when (not (checkBootDecl boot_thing real_thing))
+            $ addErrAt (nameSrcSpan (getName boot_thing))
+                       (let boot_decl = tyThingToIfaceDecl 
+                                               (fromJust mb_boot_thing)
+                            real_decl = tyThingToIfaceDecl real_thing
+                        in bootMisMatch real_thing boot_decl real_decl)
 
       | otherwise
       = addErrTc (missingBootThing name "defined in")
 
       | otherwise
       = addErrTc (missingBootThing name "defined in")
@@ -604,6 +610,103 @@ checkHiBootIface
          local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
 
 
          local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
 
 
+-- This has to compare the TyThing from the .hi-boot file to the TyThing
+-- in the current source file.  We must be careful to allow alpha-renaming
+-- where appropriate, and also the boot declaration is allowed to omit
+-- constructors and class methods.
+--
+-- See rnfail055 for a good test of this stuff.
+
+checkBootDecl :: TyThing -> TyThing -> Bool
+
+checkBootDecl (AnId id1) (AnId id2)
+  = ASSERT(id1 == id2) 
+    (idType id1 `tcEqType` idType id2)
+
+checkBootDecl (ATyCon tc1) (ATyCon tc2)
+  | isSynTyCon tc1 && isSynTyCon tc2
+  = ASSERT(tc1 == tc2)
+    let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
+        env = rnBndrs2 env0 tvs1 tvs2
+
+        eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _)
+            = tcEqTypeX env k1 k2
+        eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
+            = tcEqTypeX env t1 t2
+    in
+    equalLength tvs1 tvs2 &&
+    eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
+
+  | isAlgTyCon tc1 && isAlgTyCon tc2
+  = ASSERT(tc1 == tc2)
+    eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2)
+    && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+
+  | isForeignTyCon tc1 && isForeignTyCon tc2
+  = tyConExtName tc1 == tyConExtName tc2
+  where 
+        env0 = mkRnEnv2 emptyInScopeSet
+
+        eqAlgRhs AbstractTyCon _ = True
+        eqAlgRhs OpenTyCon{} OpenTyCon{} = True
+        eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
+            eqListBy eqCon (data_cons tc1) (data_cons tc2)
+        eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
+            eqCon (data_con tc1) (data_con tc2)
+        eqAlgRhs _ _ = False
+
+        eqCon c1 c2
+          =  dataConName c1 == dataConName c2
+          && dataConIsInfix c1 == dataConIsInfix c2
+          && dataConStrictMarks c1 == dataConStrictMarks c2
+          && dataConFieldLabels c1 == dataConFieldLabels c2
+          && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
+                 tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
+                 env = rnBndrs2 env0 tvs1 tvs2
+             in
+              equalLength tvs1 tvs2 &&              
+              eqListBy (tcEqPredX env)
+                        (dataConEqTheta c1 ++ dataConDictTheta c1)
+                        (dataConEqTheta c2 ++ dataConDictTheta c2) &&
+              eqListBy (tcEqTypeX env)
+                        (dataConOrigArgTys c1)
+                        (dataConOrigArgTys c2)
+
+checkBootDecl (AClass c1)  (AClass c2)
+  = let 
+       (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) 
+          = classExtraBigSig c1
+       (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2) 
+          = classExtraBigSig c2
+
+       env0 = mkRnEnv2 emptyInScopeSet
+       env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
+
+       eqSig (id1, def_meth1) (id2, def_meth2)
+         = idName id1 == idName id2 &&
+           tcEqTypeX env op_ty1 op_ty2
+         where
+         (_, rho_ty1) = splitForAllTys (idType id1)
+         op_ty1 = funResultTy rho_ty1
+         (_, rho_ty2) = splitForAllTys (idType id2)
+          op_ty2 = funResultTy rho_ty2
+
+       eqFD (as1,bs1) (as2,bs2) = 
+         eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+         eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+    in
+       equalLength clas_tyvars1 clas_tyvars2 &&
+       eqListBy eqFD clas_fds1 clas_fds2 &&
+       (null sc_theta1 && null op_stuff1
+        ||
+        eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
+        eqListBy eqSig op_stuff1 op_stuff2)
+
+checkBootDecl (ADataCon dc1) (ADataCon dc2)
+  = pprPanic "checkBootDecl" (ppr dc1)
+
+checkBootDecl _ _ = False -- probably shouldn't happen
+
 ----------------
 missingBootThing thing what
   = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") 
 ----------------
 missingBootThing thing what
   = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not") 
index 0ef30a8..a72caa4 100644 (file)
@@ -517,7 +517,7 @@ It is used  * when processing the export list
 \begin{code}
 data ImportAvails 
    = ImportAvails {
 \begin{code}
 data ImportAvails 
    = ImportAvails {
-       imp_mods :: ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]),
+       imp_mods :: ModuleEnv [(ModuleName, Bool, SrcSpan)],
                -- Domain is all directly-imported modules
         -- The ModuleName is what the module was imported as, e.g. in
         --     import Foo as Bar
                -- Domain is all directly-imported modules
         -- The ModuleName is what the module was imported as, e.g. in
         --     import Foo as Bar
@@ -526,8 +526,6 @@ data ImportAvails
                --   True => import was "import Foo ()"
                --   False  => import was some other form
                --
                --   True => import was "import Foo ()"
                --   False  => import was some other form
                --
-               -- We need the Module in the range because we can't get
-               --      the keys of a ModuleEnv
                -- Used 
                --   (a) to help construct the usage information in 
                --       the interface file; if we import somethign we
                -- Used 
                --   (a) to help construct the usage information in 
                --       the interface file; if we import somethign we
@@ -584,13 +582,12 @@ plusImportAvails
   (ImportAvails { imp_mods = mods2,
                  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
                   imp_orphs = orphs2, imp_finsts = finsts2 })
   (ImportAvails { imp_mods = mods2,
                  imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
                   imp_orphs = orphs2, imp_finsts = finsts2 })
-  = ImportAvails { imp_mods     = plusModuleEnv_C plus_mod mods1 mods2,        
+  = ImportAvails { imp_mods     = plusModuleEnv_C (++) mods1 mods2,    
                   imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, 
                   imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
                   imp_orphs    = orphs1 `unionLists` orphs2,
                   imp_finsts   = finsts1 `unionLists` finsts2 }
   where
                   imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, 
                   imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
                   imp_orphs    = orphs1 `unionLists` orphs2,
                   imp_finsts   = finsts1 `unionLists` finsts2 }
   where
-    plus_mod (m1, xs1) (_, xs2) = (m1, xs1 ++ xs2)
     plus_mod_dep (m1, boot1) (m2, boot2) 
        = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
                -- Check mod-names match
     plus_mod_dep (m1, boot1) (m2, boot2) 
        = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
                -- Check mod-names match
index 4be386c..6eaac8c 100644 (file)
@@ -87,7 +87,7 @@ module Type (
 
        -- Comparison
        coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
 
        -- Comparison
        coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
-       tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
+       tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
 
        -- Seq
        seqType, seqTypes,
 
        -- Seq
        seqType, seqTypes,
@@ -1018,6 +1018,9 @@ tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
 tcEqPred :: PredType -> PredType -> Bool
 tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
 
 tcEqPred :: PredType -> PredType -> Bool
 tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
 
+tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool
+tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
+
 tcCmpPred :: PredType -> PredType -> Ordering
 tcCmpPred p1 p2 = cmpPred p1 p2
 
 tcCmpPred :: PredType -> PredType -> Ordering
 tcCmpPred p1 p2 = cmpPred p1 p2
 
index 2ebc856..076ae16 100644 (file)
@@ -20,11 +20,13 @@ module Binary
 --   closeBin,
 
    seekBin,
 --   closeBin,
 
    seekBin,
+   seekBy,
    tellBin,
    castBin,
 
    writeBinMem,
    readBinMem,
    tellBin,
    castBin,
 
    writeBinMem,
    readBinMem,
+   fingerprintBinMem,
 
    isEOFBin,
 
 
    isEOFBin,
 
@@ -47,7 +49,7 @@ module Binary
 
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
 
    UserData(..), getUserData, setUserData,
    newReadState, newWriteState,
-   putDictionary, getDictionary,
+   putDictionary, getDictionary, putFS,
   ) where
 
 #include "HsVersions.h"
   ) where
 
 #include "HsVersions.h"
@@ -57,21 +59,19 @@ module Binary
 
 import {-# SOURCE #-} Name (Name)
 import FastString
 
 import {-# SOURCE #-} Name (Name)
 import FastString
-import Unique
 import Panic
 import UniqFM
 import FastMutInt
 import Util
 import Panic
 import UniqFM
 import FastMutInt
 import Util
+import Fingerprint
 
 import Foreign
 
 import Foreign
-import Data.Array.IO
 import Data.Array
 import Data.Bits
 import Data.Int
 import Data.Word
 import Data.IORef
 import Data.Char                ( ord, chr )
 import Data.Array
 import Data.Bits
 import Data.Int
 import Data.Word
 import Data.IORef
 import Data.Char                ( ord, chr )
-import Data.Array.Base          ( unsafeRead, unsafeWrite )
 import Control.Monad            ( when )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import Control.Monad            ( when )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
@@ -92,7 +92,7 @@ import System.IO                ( openBinaryFile )
 openBinaryFile f mode = openFileEx f (BinaryMode mode)
 #endif
 
 openBinaryFile f mode = openFileEx f (BinaryMode mode)
 #endif
 
-type BinArray = IOUArray Int Word8
+type BinArray = ForeignPtr Word8
 
 ---------------------------------------------------------------
 -- BinHandle
 
 ---------------------------------------------------------------
 -- BinHandle
@@ -168,7 +168,7 @@ openBinMem :: Int -> IO BinHandle
 openBinMem size
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
  | otherwise = do
 openBinMem size
  | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
  | otherwise = do
-   arr <- newArray_ (0,size-1)
+   arr <- mallocForeignPtrBytes size
    arr_r <- newIORef arr
    ix_r <- newFastMutInt
    writeFastMutInt ix_r 0
    arr_r <- newIORef arr
    ix_r <- newFastMutInt
    writeFastMutInt ix_r 0
@@ -190,6 +190,20 @@ seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do
         then do expandBin h p; writeFastMutInt ix_r p
         else writeFastMutInt ix_r p
 
         then do expandBin h p; writeFastMutInt ix_r p
         else writeFastMutInt ix_r p
 
+seekBy :: BinHandle -> Int -> IO ()
+seekBy (BinIO _ ix_r h) off = do
+  ix <- readFastMutInt ix_r
+  let ix' = ix + off
+  writeFastMutInt ix_r ix'
+  hSeek h AbsoluteSeek (fromIntegral ix')
+seekBy h@(BinMem _ ix_r sz_r _) off = do
+  sz <- readFastMutInt sz_r
+  ix <- readFastMutInt ix_r
+  let ix' = ix + off
+  if (ix' >= sz)
+        then do expandBin h ix'; writeFastMutInt ix_r ix'
+        else writeFastMutInt ix_r ix'
+
 isEOFBin :: BinHandle -> IO Bool
 isEOFBin (BinMem _ ix_r sz_r _) = do
   ix <- readFastMutInt ix_r
 isEOFBin :: BinHandle -> IO Bool
 isEOFBin (BinMem _ ix_r sz_r _) = do
   ix <- readFastMutInt ix_r
@@ -203,7 +217,7 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
   ix  <- readFastMutInt ix_r
   h <- openBinaryFile fn WriteMode
   arr <- readIORef arr_r
   ix  <- readFastMutInt ix_r
-  hPutArray h arr ix
+  withForeignPtr arr $ \p -> hPutBuf h p ix
   hClose h
 
 readBinMem :: FilePath -> IO BinHandle
   hClose h
 
 readBinMem :: FilePath -> IO BinHandle
@@ -212,10 +226,10 @@ readBinMem filename = do
   h <- openBinaryFile filename ReadMode
   filesize' <- hFileSize h
   let filesize = fromIntegral filesize'
   h <- openBinaryFile filename ReadMode
   filesize' <- hFileSize h
   let filesize = fromIntegral filesize'
-  arr <- newArray_ (0,filesize-1)
-  count <- hGetArray h arr filesize
-  when (count /= filesize)
-       (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
+  arr <- mallocForeignPtrBytes (filesize*2)
+  count <- withForeignPtr arr $ \p -> hGetBuf h p filesize
+  when (count /= filesize) $
+       error ("Binary.readBinMem: only read " ++ show count ++ " bytes")
   hClose h
   arr_r <- newIORef arr
   ix_r <- newFastMutInt
   hClose h
   arr_r <- newIORef arr
   ix_r <- newFastMutInt
@@ -224,15 +238,23 @@ readBinMem filename = do
   writeFastMutInt sz_r filesize
   return (BinMem noUserData ix_r sz_r arr_r)
 
   writeFastMutInt sz_r filesize
   return (BinMem noUserData ix_r sz_r arr_r)
 
+fingerprintBinMem :: BinHandle -> IO Fingerprint
+fingerprintBinMem (BinIO _ _ _) = error "Binary.md5BinMem: not a memory handle"
+fingerprintBinMem (BinMem _ ix_r _ arr_r) = do
+  arr <- readIORef arr_r
+  ix <- readFastMutInt ix_r
+  withForeignPtr arr $ \p -> fingerprintData p ix
+
 -- expand the size of the array to include a specified offset
 expandBin :: BinHandle -> Int -> IO ()
 expandBin (BinMem _ _ sz_r arr_r) off = do
    sz <- readFastMutInt sz_r
    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
    arr <- readIORef arr_r
 -- expand the size of the array to include a specified offset
 expandBin :: BinHandle -> Int -> IO ()
 expandBin (BinMem _ _ sz_r arr_r) off = do
    sz <- readFastMutInt sz_r
    let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
    arr <- readIORef arr_r
-   arr' <- newArray_ (0,sz'-1)
-   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
-             | i <- [ 0 .. sz-1 ] ]
+   arr' <- mallocForeignPtrBytes sz'
+   withForeignPtr arr $ \old ->
+     withForeignPtr arr' $ \new ->
+       copyBytes new old sz 
    writeFastMutInt sz_r sz'
    writeIORef arr_r arr'
    when debugIsOn $
    writeFastMutInt sz_r sz'
    writeIORef arr_r arr'
    when debugIsOn $
@@ -253,7 +275,7 @@ putWord8 h@(BinMem _ ix_r sz_r arr_r) w = do
         then do expandBin h ix
                 putWord8 h w
         else do arr <- readIORef arr_r
         then do expandBin h ix
                 putWord8 h w
         else do arr <- readIORef arr_r
-                unsafeWrite arr ix w
+                withForeignPtr arr $ \p -> pokeByteOff p ix w
                 writeFastMutInt ix_r (ix+1)
                 return ()
 putWord8 (BinIO _ ix_r h) w = do
                 writeFastMutInt ix_r (ix+1)
                 return ()
 putWord8 (BinIO _ ix_r h) w = do
@@ -269,7 +291,7 @@ getWord8 (BinMem _ ix_r sz_r arr_r) = do
     when (ix >= sz) $
         ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
     arr <- readIORef arr_r
     when (ix >= sz) $
         ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
     arr <- readIORef arr_r
-    w <- unsafeRead arr ix
+    w <- withForeignPtr arr $ \p -> peekByteOff p ix
     writeFastMutInt ix_r (ix+1)
     return w
 getWord8 (BinIO _ ix_r h) = do
     writeFastMutInt ix_r (ix+1)
     return w
 getWord8 (BinIO _ ix_r h) = do
@@ -581,43 +603,26 @@ data UserData =
         ud_symtab :: SymbolTable,
 
         -- for *serialising* only:
         ud_symtab :: SymbolTable,
 
         -- for *serialising* only:
-        ud_dict_next :: !FastMutInt, -- The next index to use
-        ud_dict_map  :: !(IORef (UniqFM (Int,FastString))),
-                                -- indexed by FastString
-
-        ud_symtab_next :: !FastMutInt, -- The next index to use
-        ud_symtab_map  :: !(IORef (UniqFM (Int,Name)))
-                                -- indexed by Name
+        ud_put_name :: BinHandle -> Name       -> IO (),
+        ud_put_fs   :: BinHandle -> FastString -> IO ()
    }
 
 newReadState :: Dictionary -> IO UserData
 newReadState dict = do
    }
 
 newReadState :: Dictionary -> IO UserData
 newReadState dict = do
-  dict_next <- newFastMutInt
-  dict_map <- newIORef (undef "dict_map")
-  symtab_next <- newFastMutInt
-  symtab_map <- newIORef (undef "symtab_map")
-  return UserData { ud_dict = dict,
-                    ud_symtab = undef "symtab",
-                    ud_dict_next = dict_next,
-                    ud_dict_map = dict_map,
-                    ud_symtab_next = symtab_next,
-                    ud_symtab_map = symtab_map
+  return UserData { ud_dict     = dict,
+                    ud_symtab   = undef "symtab",
+                    ud_put_name = undef "put_name",
+                    ud_put_fs   = undef "put_fs"
                    }
 
                    }
 
-newWriteState :: IO UserData
-newWriteState = do
-  dict_next <- newFastMutInt
-  writeFastMutInt dict_next 0
-  dict_map <- newIORef emptyUFM
-  symtab_next <- newFastMutInt
-  writeFastMutInt symtab_next 0
-  symtab_map <- newIORef emptyUFM
-  return UserData { ud_dict = undef "dict",
-                    ud_symtab = undef "symtab",
-                    ud_dict_next = dict_next,
-                    ud_dict_map = dict_map,
-                    ud_symtab_next = symtab_next,
-                    ud_symtab_map = symtab_map
+newWriteState :: (BinHandle -> Name       -> IO ()) 
+              -> (BinHandle -> FastString -> IO ())
+              -> IO UserData
+newWriteState put_name put_fs = do
+  return UserData { ud_dict     = undef "dict",
+                    ud_symtab   = undef "symtab",
+                    ud_put_name = put_name,
+                    ud_put_fs   = put_fs
                    }
 
 noUserData :: a
                    }
 
 noUserData :: a
@@ -693,20 +698,16 @@ getFS bh = do
 
 instance Binary FastString where
   put_ bh f =
 
 instance Binary FastString where
   put_ bh f =
-    case getUserData bh of {
-        UserData { ud_dict_next = j_r,
-                   ud_dict_map = out_r} -> do
-    out <- readIORef out_r
-    let uniq = getUnique f
-    case lookupUFM out uniq of
-        Just (j, _)  -> put_ bh j
-        Nothing -> do
-           j <- readFastMutInt j_r
-           put_ bh j
-           writeFastMutInt j_r (j + 1)
-           writeIORef out_r $! addToUFM out uniq (j, f)
-    }
+    case getUserData bh of
+        UserData { ud_put_fs = put_fs } -> put_fs bh f
 
   get bh = do
         j <- get bh
         return $! (ud_dict (getUserData bh) ! j)
 
   get bh = do
         j <- get bh
         return $! (ud_dict (getUserData bh) ! j)
+
+-- Here to avoid loop
+
+instance Binary Fingerprint where
+  put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2
+  get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)
+
index 2039ee5..00aba34 100644 (file)
@@ -7,7 +7,10 @@
 \begin{code}
 module FastMutInt(
        FastMutInt, newFastMutInt,
 \begin{code}
 module FastMutInt(
        FastMutInt, newFastMutInt,
-       readFastMutInt, writeFastMutInt
+       readFastMutInt, writeFastMutInt,
+
+       FastMutPtr, newFastMutPtr,
+       readFastMutPtr, writeFastMutPtr
   ) where
 
 #ifdef __GLASGOW_HASKELL__
   ) where
 
 #ifdef __GLASGOW_HASKELL__
@@ -19,6 +22,7 @@ module FastMutInt(
 
 import GHC.Base
 import GHC.IOBase
 
 import GHC.Base
 import GHC.IOBase
+import GHC.Ptr
 
 #else /* ! __GLASGOW_HASKELL__ */
 
 
 #else /* ! __GLASGOW_HASKELL__ */
 
@@ -29,6 +33,10 @@ import Data.IORef
 newFastMutInt :: IO FastMutInt
 readFastMutInt :: FastMutInt -> IO Int
 writeFastMutInt :: FastMutInt -> Int -> IO ()
 newFastMutInt :: IO FastMutInt
 readFastMutInt :: FastMutInt -> IO Int
 writeFastMutInt :: FastMutInt -> Int -> IO ()
+
+newFastMutPtr :: IO FastMutPtr
+readFastMutPtr :: FastMutPtr -> IO (Ptr a)
+writeFastMutPtr :: FastMutPtr -> Ptr a -> IO ()
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
@@ -47,6 +55,21 @@ readFastMutInt (FastMutInt arr) = IO $ \s ->
 writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
   case writeIntArray# arr 0# i s of { s ->
   (# s, () #) }
 writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
   case writeIntArray# arr 0# i s of { s ->
   (# s, () #) }
+
+data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld)
+
+newFastMutPtr = IO $ \s ->
+  case newByteArray# size s of { (# s, arr #) ->
+  (# s, FastMutPtr arr #) }
+  where I# size = SIZEOF_VOID_P
+
+readFastMutPtr (FastMutPtr arr) = IO $ \s ->
+  case readAddrArray# arr 0# s of { (# s, i #) ->
+  (# s, Ptr i #) }
+
+writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s ->
+  case writeAddrArray# arr 0# i s of { s ->
+  (# s, () #) }
 #else /* ! __GLASGOW_HASKELL__ */
 --maybe someday we could use
 --http://haskell.org/haskellwiki/Library/ArrayRef
 #else /* ! __GLASGOW_HASKELL__ */
 --maybe someday we could use
 --http://haskell.org/haskellwiki/Library/ArrayRef
@@ -67,6 +90,23 @@ readFastMutInt (FastMutInt ioRefInt) = readIORef ioRefInt
 
 -- FastMutInt is strict in the value it contains.
 writeFastMutInt (FastMutInt ioRefInt) i = i `seq` writeIORef ioRefInt i
 
 -- FastMutInt is strict in the value it contains.
 writeFastMutInt (FastMutInt ioRefInt) i = i `seq` writeIORef ioRefInt i
+
+
+newtype FastMutPtr = FastMutPtr (IORef (Ptr ()))
+
+-- If any default value was chosen, it surely would be 0,
+-- so we will use that since IORef requires a default value.
+-- Or maybe it would be more interesting to package an error,
+-- assuming nothing relies on being able to read a bogus Ptr?
+-- That could interfere with its strictness for smart optimizers
+-- (are they allowed to optimize a 'newtype' that way?) ...
+-- Well, maybe that can be added (in DEBUG?) later.
+newFastMutPtr = fmap FastMutPtr (newIORef (castPtr nullPtr))
+
+readFastMutPtr (FastMutPtr ioRefPtr) = readIORef ioRefPtr
+
+-- FastMutPtr is strict in the value it contains.
+writeFastMutPtr (FastMutPtr ioRefPtr) i = i `seq` writeIORef ioRefPtr i
 #endif
 \end{code}
 
 #endif
 \end{code}
 
diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc
new file mode 100644 (file)
index 0000000..d5a2409
--- /dev/null
@@ -0,0 +1,77 @@
+-- ----------------------------------------------------------------------------
+-- 
+--  (c) The University of Glasgow 2006
+--
+-- Fingerprints for recompilation checking and ABI versioning.
+--
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+--
+-- ----------------------------------------------------------------------------
+
+module Fingerprint (
+        Fingerprint(..), fingerprint0, 
+        readHexFingerprint,
+        fingerprintData
+   ) where
+
+#include "md5.h"
+##include "HsVersions.h"
+
+import Outputable
+
+import Foreign
+import Foreign.C
+import Text.Printf
+import Data.Word
+import Numeric          ( readHex )
+
+-- Using 128-bit MD5 fingerprints for now.
+
+data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
+  deriving (Eq, Ord)
+        -- or ByteString?
+
+fingerprint0 :: Fingerprint
+fingerprint0 = Fingerprint 0 0
+
+instance Outputable Fingerprint where
+  ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
+
+-- useful for parsing the output of 'md5sum', should we want to do that.
+readHexFingerprint :: String -> Fingerprint
+readHexFingerprint s = Fingerprint w1 w2
+ where (s1,s2) = splitAt 16 s
+       [(w1,"")] = readHex s1
+       [(w2,"")] = readHex (take 16 s2)
+
+peekFingerprint :: Ptr Word8 -> IO Fingerprint
+peekFingerprint p = do
+      let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
+          STRICT3(peekW64)
+          peekW64 _ 0 i = return i
+          peekW64 p n i = do 
+                w8 <- peek p
+                peekW64 (p `plusPtr` 1) (n-1) 
+                    ((i `shiftL` 8) .|. fromIntegral w8)
+
+      high <- peekW64 p 8 0
+      low  <- peekW64 (p `plusPtr` 8) 8 0
+      return (Fingerprint high low)
+
+fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
+fingerprintData buf len = do
+  allocaBytes (#const sizeof(struct MD5Context)) $ \pctxt -> do
+    c_MD5Init pctxt
+    c_MD5Update pctxt buf (fromIntegral len)
+    allocaBytes 16 $ \pdigest -> do
+      c_MD5Final pdigest pctxt
+      peekFingerprint (castPtr pdigest)
+
+data MD5Context
+
+foreign import ccall unsafe "MD5Init"
+   c_MD5Init   :: Ptr MD5Context -> IO ()
+foreign import ccall unsafe "MD5Update"
+   c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
+foreign import ccall unsafe "MD5Final"
+   c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()
diff --git a/compiler/utils/md5.c b/compiler/utils/md5.c
new file mode 100644 (file)
index 0000000..0570cbb
--- /dev/null
@@ -0,0 +1,238 @@
+/*
+ * This code implements the MD5 message-digest algorithm.
+ * The algorithm is due to Ron Rivest.  This code was
+ * written by Colin Plumb in 1993, no copyright is claimed.
+ * This code is in the public domain; do with it what you wish.
+ *
+ * Equivalent code is available from RSA Data Security, Inc.
+ * This code has been tested against that, and is equivalent,
+ * except that you don't need to include two pages of legalese
+ * with every copy.
+ *
+ * To compute the message digest of a chunk of bytes, declare an
+ * MD5Context structure, pass it to MD5Init, call MD5Update as
+ * needed on buffers full of bytes, and then call MD5Final, which
+ * will fill a supplied 16-byte array with the digest.
+ */
+
+#include "HsFFI.h"
+#include "md5.h"
+#include <string.h>
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
+
+
+/*
+ * Shuffle the bytes into little-endian order within words, as per the
+ * MD5 spec.  Note: this code works regardless of the byte order.
+ */
+void
+byteSwap(word32 *buf, unsigned words)
+{
+       byte *p = (byte *)buf;
+
+       do {
+               *buf++ = (word32)((unsigned)p[3] << 8 | p[2]) << 16 |
+                       ((unsigned)p[1] << 8 | p[0]);
+               p += 4;
+       } while (--words);
+}
+
+/*
+ * Start MD5 accumulation.  Set bit count to 0 and buffer to mysterious
+ * initialization constants.
+ */
+void
+MD5Init(struct MD5Context *ctx)
+{
+       ctx->buf[0] = 0x67452301;
+       ctx->buf[1] = 0xefcdab89;
+       ctx->buf[2] = 0x98badcfe;
+       ctx->buf[3] = 0x10325476;
+
+       ctx->bytes[0] = 0;
+       ctx->bytes[1] = 0;
+}
+
+/*
+ * Update context to reflect the concatenation of another buffer full
+ * of bytes.
+ */
+void
+MD5Update(struct MD5Context *ctx, byte const *buf, int len)
+{
+       word32 t;
+
+       /* Update byte count */
+
+       t = ctx->bytes[0];
+       if ((ctx->bytes[0] = t + len) < t)
+               ctx->bytes[1]++;        /* Carry from low to high */
+
+       t = 64 - (t & 0x3f);    /* Space available in ctx->in (at least 1) */
+       if ((unsigned)t > len) {
+               memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, len);
+               return;
+       }
+       /* First chunk is an odd size */
+       memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);
+       byteSwap(ctx->in, 16);
+       MD5Transform(ctx->buf, ctx->in);
+       buf += (unsigned)t;
+       len -= (unsigned)t;
+
+       /* Process data in 64-byte chunks */
+       while (len >= 64) {
+               memcpy(ctx->in, buf, 64);
+               byteSwap(ctx->in, 16);
+               MD5Transform(ctx->buf, ctx->in);
+               buf += 64;
+               len -= 64;
+       }
+
+       /* Handle any remaining bytes of data. */
+       memcpy(ctx->in, buf, len);
+}
+
+/*
+ * Final wrapup - pad to 64-byte boundary with the bit pattern 
+ * 1 0* (64-bit count of bits processed, MSB-first)
+ */
+void
+MD5Final(byte digest[16], struct MD5Context *ctx)
+{
+       int count = (int)(ctx->bytes[0] & 0x3f); /* Bytes in ctx->in */
+       byte *p = (byte *)ctx->in + count;      /* First unused byte */
+
+       /* Set the first char of padding to 0x80.  There is always room. */
+       *p++ = 0x80;
+
+       /* Bytes of padding needed to make 56 bytes (-8..55) */
+       count = 56 - 1 - count;
+
+       if (count < 0) {        /* Padding forces an extra block */
+               memset(p, 0, count+8);
+               byteSwap(ctx->in, 16);
+               MD5Transform(ctx->buf, ctx->in);
+               p = (byte *)ctx->in;
+               count = 56;
+       }
+       memset(p, 0, count+8);
+       byteSwap(ctx->in, 14);
+
+       /* Append length in bits and transform */
+       ctx->in[14] = ctx->bytes[0] << 3;
+       ctx->in[15] = ctx->bytes[1] << 3 | ctx->bytes[0] >> 29;
+       MD5Transform(ctx->buf, ctx->in);
+
+       byteSwap(ctx->buf, 4);
+       memcpy(digest, ctx->buf, 16);
+       memset(ctx,0,sizeof(ctx));
+}
+
+
+/* The four core functions - F1 is optimized somewhat */
+
+/* #define F1(x, y, z) (x & y | ~x & z) */
+#define F1(x, y, z) (z ^ (x & (y ^ z)))
+#define F2(x, y, z) F1(z, x, y)
+#define F3(x, y, z) (x ^ y ^ z)
+#define F4(x, y, z) (y ^ (x | ~z))
+
+/* This is the central step in the MD5 algorithm. */
+#define MD5STEP(f,w,x,y,z,in,s) \
+        (w += f(x,y,z) + in, w = (w<<s | w>>(32-s)) + x)
+
+/*
+ * The core of the MD5 algorithm, this alters an existing MD5 hash to
+ * reflect the addition of 16 longwords of new data.  MD5Update blocks
+ * the data and converts bytes into longwords for this routine.
+ */
+
+void
+MD5Transform(word32 buf[4], word32 const in[16])
+{
+       register word32 a, b, c, d;
+
+       a = buf[0];
+       b = buf[1];
+       c = buf[2];
+       d = buf[3];
+
+       MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);
+       MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);
+       MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);
+       MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);
+       MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);
+       MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);
+       MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);
+       MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);
+       MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);
+       MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);
+       MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);
+       MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);
+       MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);
+       MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);
+       MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);
+       MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);
+
+       MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);
+       MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);
+       MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);
+       MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);
+       MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);
+       MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);
+       MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);
+       MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);
+       MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);
+       MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);
+       MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);
+       MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);
+       MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);
+       MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);
+       MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);
+       MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);
+
+       MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);
+       MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);
+       MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);
+       MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);
+       MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);
+       MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);
+       MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);
+       MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);
+       MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);
+       MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);
+       MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);
+       MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);
+       MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);
+       MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);
+       MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);
+       MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);
+
+       MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);
+       MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);
+       MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);
+       MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);
+       MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);
+       MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);
+       MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);
+       MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);
+       MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);
+       MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);
+       MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);
+       MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);
+       MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);
+       MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);
+       MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);
+       MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);
+
+       buf[0] += a;
+       buf[1] += b;
+       buf[2] += c;
+       buf[3] += d;
+}
+
diff --git a/compiler/utils/md5.h b/compiler/utils/md5.h
new file mode 100644 (file)
index 0000000..8d375df
--- /dev/null
@@ -0,0 +1,24 @@
+/* MD5 message digest */
+#ifndef _MD5_H
+#define _MD5_H
+
+#include "HsFFI.h"
+
+typedef HsWord32 word32;
+typedef HsWord8  byte;
+
+struct MD5Context {
+       word32 buf[4];
+       word32 bytes[2];
+       word32 in[16];
+};
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
+
+#endif /* _MD5_H */
+
+
+
index 7518841..c30269d 100644 (file)
@@ -97,6 +97,14 @@ install::
 endif
 endif
 
 endif
 endif
 
+# hsc2hs-inplace is needed to 'make boot' in compiler.
+# Do a recursive 'make all' after generating dependencies, because this
+# will work with 'make -j'.
+ifneq "$(BootingFromHc)" "YES"
+boot :: depend
+       $(MAKE) all
+endif
+
 # -----------------------------------------------------------------------------
 
 override datadir=$(libdir)
 # -----------------------------------------------------------------------------
 
 override datadir=$(libdir)