From: Simon Marlow Date: Wed, 28 May 2008 12:52:58 +0000 (+0000) Subject: Use MD5 checksums for recompilation checking (fixes #1372, #1959) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=526c3af1dc98987b6949f4df73c0debccf9875bd Use MD5 checksums for recompilation checking (fixes #1372, #1959) 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. --- diff --git a/compiler/Makefile b/compiler/Makefile index 216e5f8..a16cd21 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -572,7 +572,7 @@ SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) 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, diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 5047be1..8d9cb3b 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -42,6 +42,7 @@ module Module modulePackageId, moduleName, pprModule, mkModule, + stableModuleCmp, -- * The ModuleLocation type ModLocation(..), @@ -71,6 +72,7 @@ import FiniteMap import LazyUniqFM import FastString import Binary +import Util 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) + \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) -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 @@ -235,9 +243,17 @@ pprPackagePrefix p mod = getPprStyle doc %************************************************************************ \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 +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) diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index aa253cf..7dfed64 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -40,16 +40,13 @@ import {-# SOURCE #-} TypeRep( TyThing ) import OccName import Module import SrcLoc -import UniqFM import Unique import Maybes import Binary -import FastMutInt import FastTypes import FastString import Outputable -import Data.IORef import Data.Array \end{code} @@ -309,20 +306,9 @@ instance NamedThing 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 diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index b6181fb..debaa28 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -5,6 +5,7 @@ \begin{code} module OccName ( + mk_deriv, -- * The NameSpace type; abstact NameSpace, tcName, clsName, tcClsName, dataName, varName, tvName, srcDataName, diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index f7c63f8..de9830b 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -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) + + ; 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 diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 26c4a88..a49109a 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1635,7 +1635,8 @@ showPackages = do 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 diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 321eac1..152381c 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -32,7 +32,9 @@ import SrcLoc import ErrUtils import Config import FastMutInt +import Unique import Outputable +import FastString 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 - 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 @@ -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 - 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") @@ -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 - 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") @@ -248,6 +262,51 @@ serialiseName bh name _ = do 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 @@ -300,70 +359,74 @@ instance Binary ModIface where 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_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_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 - 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 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 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 - 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 - 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 - 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, - 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_exp_vers = exp_vers, + mi_exp_hash = exp_hash, 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_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_ver_fn = mkIfaceVerCache decls }) + mi_hash_fn = mkIfaceHashCache decls }) getWayDescr :: IO String getWayDescr = do @@ -421,22 +484,31 @@ instance (Binary name) => Binary (GenAvailInfo name) 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_rules usg) 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 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 062cd30..21080ee 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -15,10 +15,9 @@ module IfaceSyn ( -- Misc ifaceDeclSubBndrs, visibleIfConDecls, - -- Equality - GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy, - eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl, - + -- Free Names + freeNamesIfDecl, freeNamesIfRule, + -- Pretty printing pprIfaceExpr, pprIfaceDeclHead ) where @@ -30,8 +29,6 @@ import IfaceType import NewDemand import Class -import UniqFM -import UniqSet import NameSet import Name import CostCentre @@ -46,7 +43,6 @@ import Data.List import Data.Maybe infixl 3 &&& -infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` \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 -\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 +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} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index ec41e75..3e42fd4 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -51,6 +51,7 @@ import BinIface import Panic import Util import FastString +import Fingerprint import Control.Monad import Data.List @@ -323,7 +324,7 @@ addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv addDeclsToPTE pte things = extendNameEnvList pte things loadDecls :: Bool - -> [(Version, IfaceDecl)] + -> [(Fingerprint, IfaceDecl)] -> 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 - -> (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) @@ -616,13 +617,16 @@ pprModIface :: ModIface -> SDoc -- 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 - <+> 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)) @@ -637,12 +641,6 @@ pprModIface iface 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: @@ -666,16 +664,16 @@ pprExport (mod, items) 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, @@ -690,13 +688,9 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, ppr_boot True = text "[boot]" ppr_boot False = empty -pprIfaceDecl :: (Version, IfaceDecl) -> SDoc +pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc 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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 188aa45..a46e823 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -25,20 +25,19 @@ module MkIface ( 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 - 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 - - 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 + + f :: Int -> Int {- Unfolding: \x -> Wib.t x -} ----------------------------------------------- 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 - 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 - the actual version info for all each thing recorded in mi_usages - + the actual fingerprint for all each thing recorded in mi_usages 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 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. - * 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, - 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 @@ -91,13 +90,13 @@ In an iface file we have 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, -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 @@ -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. -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: @@ -210,18 +209,21 @@ import NameSet import OccName import Module import BinIface -import Unique 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 Binary +import Fingerprint +import Panic import Control.Monad import Data.List @@ -239,14 +241,15 @@ import System.FilePath \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 - -> 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, @@ -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 } - = 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 @@ -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 - -> 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) -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, @@ -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 - 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 @@ -303,7 +306,7 @@ mkDependencies 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 @@ -334,13 +337,13 @@ mkDependencies -- 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 - -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) + -> ImportedMods -> 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, @@ -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 - = 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 @@ -396,32 +397,33 @@ mkIface_ hsc_env maybe_old_iface 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_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 } + } - -- 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 - } -- 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) @@ -471,15 +473,15 @@ writeIfaceFile dflags location new_iface -- ----------------------------------------------------------------------------- -- 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. -mkParentVerFun +mkHashFun :: 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 @@ -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 - 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 ------------------------------------------------------------------------------ --- 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 - 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 @@ -694,90 +845,6 @@ pprOrphans insts 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, @@ -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) - ----------------------- -bump_unless :: Bool -> Version -> Version -bump_unless True v = v -- True <=> no change -bump_unless False v = bumpVersion v \end{code} %********************************************************* %* * -\subsection{Keeping track of what we've slurped, and version numbers} +\subsection{Keeping track of what we've slurped, and fingerprints} %* * %********************************************************* \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 - ; 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 @@ -827,70 +886,81 @@ mkUsageInfo hsc_env dir_imp_mods dep_mods used_names mk_usage_info :: PackageIfaceTable -> HscEnv - -> ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) - -> [(ModuleName, IsBootInterface)] + -> Module + -> ImportedMods -> 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 + 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 - -- from a particular module in this package + -- from a particular module 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 - 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 - -- 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 + -- 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 - = 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. - mod = mkModule (thisPackage dflags) mod_name + is_direct_import = mod `elemModuleEnv` direct_imports Just iface = maybe_iface - orphan_mod = mi_orphan 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` [] @@ -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. - 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 = - 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} @@ -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 - - -- 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 @@ -1130,104 +1216,113 @@ checkDependencies hsc_env summary iface 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 - 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 - -- 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 - 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 - 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 - 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 - 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 - = 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 -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]) - 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 - | 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 -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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index f686f34..9ded3f5 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -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 - 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. @@ -548,7 +548,7 @@ hscSimpleIface tc_result 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) @@ -573,7 +573,8 @@ hscNormalIface simpl_result -- 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, diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 48fb2b4..bba10e4 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -32,7 +32,7 @@ module HscTypes ( icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, substInteractiveContext, - ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, + ModIface(..), mkIfaceDepCache, mkIfaceHashCache, mkIfaceFixCache, 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 BasicTypes ( Version, initialVersion, IPName, - Fixity, defaultFixity, DeprecTxt ) +import BasicTypes ( IPName, Fixity, defaultFixity, DeprecTxt ) 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 Fingerprint 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, - 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 @@ -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 - -- 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 @@ -428,7 +429,7 @@ data ModIface -- 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)], @@ -439,11 +440,11 @@ data ModIface -- 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 - -- 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 @@ -464,7 +465,7 @@ data ModIface 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 @@ -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 - mi_ver_fn :: OccName -> Maybe (OccName, Version), + mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint), -- 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. @@ -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. -type ImportedMods = ModuleEnv (Module, [(ModuleName, Bool, SrcSpan)]) +type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] data ModGuts = ModGuts { @@ -635,14 +636,15 @@ data ForeignStubs = NoStubs 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_exp_vers = initialVersion, + mi_exp_hash = fingerprint0, mi_fixities = [], mi_deprecs = NoDeprecs, mi_insts = [], @@ -650,12 +652,12 @@ emptyModIface mod mi_rules = [], mi_decls = [], mi_globals = Nothing, - mi_rule_vers = initialVersion, + mi_orphan_hash = fingerprint0, 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} @@ -965,19 +967,10 @@ tyThingId (ADataCon dc) = dataConWrapId dc 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} -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 @@ -987,9 +980,20 @@ mkIfaceVerCache pairs 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 @@ -1146,26 +1150,29 @@ noDependencies :: Dependencies 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 - -- 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 - -- 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() @@ -1210,7 +1217,7 @@ data ExternalPackageState -- (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 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 64f3498..3779a0a 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -310,7 +310,7 @@ tidyProgram hsc_env "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, diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index ae730c7..67b1dd1 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -225,7 +225,7 @@ rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot _ -> 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, @@ -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 - | (_, xs) <- moduleEnvElts $ imp_mods imports, + | xs <- moduleEnvElts $ imp_mods imports, (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 = 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 diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index fb72577..295cb6d 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -497,14 +497,14 @@ reOrderCycle (bind : binds) | 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 - | 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 @@ -513,9 +513,12 @@ reOrderCycle (bind : binds) -- 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] + | not (neverUnfold (idUnfolding bndr)) = 1 + -- the Id has some kind of unfolding + | otherwise = 0 inlineCandidate :: Id -> CoreExpr -> Bool diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 45ef88a..d7353dd 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1425,6 +1425,10 @@ prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rh _ -> 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)] diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index b5d5f16..00f7114 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -66,6 +66,7 @@ import PprCore import CoreSyn import ErrUtils import Id +import VarEnv import Var import Module import LazyUniqFM @@ -78,10 +79,12 @@ import SrcLoc import HscTypes import ListSetOps import Outputable +import DataCon +import Type +import Class #ifdef GHCI import Linker -import DataCon import TcHsType import TcMType import TcMatches @@ -103,6 +106,7 @@ import Bag import Control.Monad import Data.Maybe ( isJust ) +#include "HsVersions.h" \end{code} @@ -251,8 +255,7 @@ tcRnImports hsc_env this_mod import_decls -- 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 ; @@ -550,6 +553,7 @@ checkHiBootIface -- 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 @@ -560,7 +564,8 @@ checkHiBootIface -- 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) @@ -568,13 +573,14 @@ checkHiBootIface -- 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") @@ -604,6 +610,103 @@ checkHiBootIface 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") diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 0ef30a8..a72caa4 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -517,7 +517,7 @@ It is used * when processing the export list \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 @@ -526,8 +526,6 @@ data ImportAvails -- 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 @@ -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 = 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 - 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 diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 4be386c..6eaac8c 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -87,7 +87,7 @@ module Type ( -- Comparison coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, + tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, -- Seq seqType, seqTypes, @@ -1018,6 +1018,9 @@ tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 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 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 2ebc856..076ae16 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -20,11 +20,13 @@ module Binary -- closeBin, seekBin, + seekBy, tellBin, castBin, writeBinMem, readBinMem, + fingerprintBinMem, isEOFBin, @@ -47,7 +49,7 @@ module Binary UserData(..), getUserData, setUserData, newReadState, newWriteState, - putDictionary, getDictionary, + putDictionary, getDictionary, putFS, ) where #include "HsVersions.h" @@ -57,21 +59,19 @@ module Binary import {-# SOURCE #-} Name (Name) import FastString -import Unique import Panic import UniqFM import FastMutInt import Util +import Fingerprint 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.Base ( unsafeRead, unsafeWrite ) 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 -type BinArray = IOUArray Int Word8 +type BinArray = ForeignPtr Word8 --------------------------------------------------------------- -- BinHandle @@ -168,7 +168,7 @@ openBinMem :: Int -> IO BinHandle 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 @@ -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 +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 @@ -203,7 +217,7 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do 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 @@ -212,10 +226,10 @@ readBinMem filename = do 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 @@ -224,15 +238,23 @@ readBinMem filename = do 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 - 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 $ @@ -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 - unsafeWrite arr ix w + withForeignPtr arr $ \p -> pokeByteOff p ix w 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 - w <- unsafeRead arr ix + w <- withForeignPtr arr $ \p -> peekByteOff p ix 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_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 - 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 @@ -693,20 +698,16 @@ getFS bh = do 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) + +-- 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) + diff --git a/compiler/utils/FastMutInt.lhs b/compiler/utils/FastMutInt.lhs index 2039ee5..00aba34 100644 --- a/compiler/utils/FastMutInt.lhs +++ b/compiler/utils/FastMutInt.lhs @@ -7,7 +7,10 @@ \begin{code} module FastMutInt( FastMutInt, newFastMutInt, - readFastMutInt, writeFastMutInt + readFastMutInt, writeFastMutInt, + + FastMutPtr, newFastMutPtr, + readFastMutPtr, writeFastMutPtr ) where #ifdef __GLASGOW_HASKELL__ @@ -19,6 +22,7 @@ module FastMutInt( import GHC.Base import GHC.IOBase +import GHC.Ptr #else /* ! __GLASGOW_HASKELL__ */ @@ -29,6 +33,10 @@ import Data.IORef 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} @@ -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, () #) } + +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 @@ -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 + + +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} diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc new file mode 100644 index 0000000..d5a2409 --- /dev/null +++ b/compiler/utils/Fingerprint.hsc @@ -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 index 0000000..0570cbb --- /dev/null +++ b/compiler/utils/md5.c @@ -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 + +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<>(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 index 0000000..8d375df --- /dev/null +++ b/compiler/utils/md5.h @@ -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 */ + + + diff --git a/utils/hsc2hs/Makefile b/utils/hsc2hs/Makefile index 7518841..c30269d 100644 --- a/utils/hsc2hs/Makefile +++ b/utils/hsc2hs/Makefile @@ -97,6 +97,14 @@ install:: 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)