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,
modulePackageId, moduleName,
pprModule,
mkModule,
+ stableModuleCmp,
-- * The ModuleLocation type
ModLocation(..),
import LazyUniqFM
import FastString
import Binary
+import Util
import System.FilePath
\end{code}
moduleNameSlashes :: ModuleName -> String
moduleNameSlashes = dots_to_slashes . moduleNameString
where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
+
\end{code}
%************************************************************************
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
%************************************************************************
\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)
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}
\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
\begin{code}
module OccName (
+ mk_deriv,
-- * The NameSpace type; abstact
NameSpace, tcName, clsName, tcClsName, dataName, varName,
tvName, srcDataName,
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
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
import ErrUtils
import Config
import FastMutInt
+import Unique
import Outputable
+import FastString
import Data.List
import Data.Word
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
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")
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")
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
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,
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
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
-- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
- -- Equality
- GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
- eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
-
+ -- Free Names
+ freeNamesIfDecl, freeNamesIfRule,
+
-- Pretty printing
pprIfaceExpr, pprIfaceDeclHead
) where
import NewDemand
import Class
-import UniqFM
-import UniqSet
import NameSet
import Name
import CostCentre
import Data.Maybe
infixl 3 &&&
-infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
\end{code}
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}
import Panic
import Util
import FastString
+import Fingerprint
import Control.Monad
import Data.List
addDeclsToPTE pte things = extendNameEnvList pte things
loadDecls :: Bool
- -> [(Version, IfaceDecl)]
+ -> [(Fingerprint, IfaceDecl)]
-> IfL [(Name,TyThing)]
loadDecls ignore_prags ver_decls
= do { mod <- getIfModule
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)
-- 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))
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:
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,
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
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
-
- <version> f :: Int -> Int {- Unfolding: \x -> Wib.t[2] x -}
- -- The [2] says that f's unfolding
- -- mentions verison 2 of Wib.t
+ Baz xxxxxxxxxxxxxxxx -- Module version
+ [yyyyyyyyyyyyyyyy] -- The export-list version
+ -- ( if Foo depended on it)
+ (g,zzzzzzzzzzzzzzzz) -- Function and its version
+ (T,wwwwwwwwwwwwwwww) -- Type and its version
+
+ <fingerprint> f :: Int -> Int {- Unfolding: \x -> Wib.t x -}
-----------------------------------------------
Basic idea
Basic idea:
* 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
~~~~~~~~
~~~~~
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
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
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:
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
\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,
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
-- 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,
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
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
-- 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,
-- 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
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)
-- -----------------------------------------------------------------------------
-- 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
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
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,
| 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
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` []
-- 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}
; 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
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
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.
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)
-- 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,
icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
substInteractiveContext,
- ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
+ ModIface(..), mkIfaceDepCache, mkIfaceHashCache, mkIfaceFixCache,
emptyIfaceDepCache,
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
import Packages hiding ( Version(..) )
import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) )
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
-import BasicTypes ( Version, initialVersion, IPName,
- Fixity, defaultFixity, DeprecTxt )
+import BasicTypes ( IPName, Fixity, defaultFixity, DeprecTxt )
import IfaceSyn
import FiniteMap ( FiniteMap )
import CoreSyn ( CoreRule )
import UniqSupply ( UniqSupply )
import FastString
import StringBuffer ( StringBuffer )
+import Fingerprint
import System.FilePath
import System.Time ( ClockTime )
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
-- 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
-- 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)],
-- 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
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
-- 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.
-- 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 {
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 = [],
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}
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
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
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()
-- (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
"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,
_ -> 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,
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
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
| 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
-- 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
_ -> 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)]
import CoreSyn
import ErrUtils
import Id
+import VarEnv
import Var
import Module
import LazyUniqFM
import HscTypes
import ListSetOps
import Outputable
+import DataCon
+import Type
+import Class
#ifdef GHCI
import Linker
-import DataCon
import TcHsType
import TcMType
import TcMatches
import Control.Monad
import Data.Maybe ( isJust )
+#include "HsVersions.h"
\end{code}
-- 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 ;
-- 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
-- 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)
-- 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")
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")
\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
-- 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
(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
-- Comparison
coreEqType, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
+ tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
-- Seq
seqType, seqTypes,
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
-- closeBin,
seekBin,
+ seekBy,
tellBin,
castBin,
writeBinMem,
readBinMem,
+ fingerprintBinMem,
isEOFBin,
UserData(..), getUserData, setUserData,
newReadState, newWriteState,
- putDictionary, getDictionary,
+ putDictionary, getDictionary, putFS,
) where
#include "HsVersions.h"
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 )
openBinaryFile f mode = openFileEx f (BinaryMode mode)
#endif
-type BinArray = IOUArray Int Word8
+type BinArray = ForeignPtr Word8
---------------------------------------------------------------
-- 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
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
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
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
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 $
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
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
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
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)
+
\begin{code}
module FastMutInt(
FastMutInt, newFastMutInt,
- readFastMutInt, writeFastMutInt
+ readFastMutInt, writeFastMutInt,
+
+ FastMutPtr, newFastMutPtr,
+ readFastMutPtr, writeFastMutPtr
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.IOBase
+import GHC.Ptr
#else /* ! __GLASGOW_HASKELL__ */
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}
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
-- 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}
--- /dev/null
+-- ----------------------------------------------------------------------------
+--
+-- (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 ()
--- /dev/null
+/*
+ * This code implements the MD5 message-digest algorithm.
+ * The algorithm is due to Ron Rivest. This code was
+ * written by Colin Plumb in 1993, no copyright is claimed.
+ * This code is in the public domain; do with it what you wish.
+ *
+ * Equivalent code is available from RSA Data Security, Inc.
+ * This code has been tested against that, and is equivalent,
+ * except that you don't need to include two pages of legalese
+ * with every copy.
+ *
+ * To compute the message digest of a chunk of bytes, declare an
+ * MD5Context structure, pass it to MD5Init, call MD5Update as
+ * needed on buffers full of bytes, and then call MD5Final, which
+ * will fill a supplied 16-byte array with the digest.
+ */
+
+#include "HsFFI.h"
+#include "md5.h"
+#include <string.h>
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
+
+
+/*
+ * Shuffle the bytes into little-endian order within words, as per the
+ * MD5 spec. Note: this code works regardless of the byte order.
+ */
+void
+byteSwap(word32 *buf, unsigned words)
+{
+ byte *p = (byte *)buf;
+
+ do {
+ *buf++ = (word32)((unsigned)p[3] << 8 | p[2]) << 16 |
+ ((unsigned)p[1] << 8 | p[0]);
+ p += 4;
+ } while (--words);
+}
+
+/*
+ * Start MD5 accumulation. Set bit count to 0 and buffer to mysterious
+ * initialization constants.
+ */
+void
+MD5Init(struct MD5Context *ctx)
+{
+ ctx->buf[0] = 0x67452301;
+ ctx->buf[1] = 0xefcdab89;
+ ctx->buf[2] = 0x98badcfe;
+ ctx->buf[3] = 0x10325476;
+
+ ctx->bytes[0] = 0;
+ ctx->bytes[1] = 0;
+}
+
+/*
+ * Update context to reflect the concatenation of another buffer full
+ * of bytes.
+ */
+void
+MD5Update(struct MD5Context *ctx, byte const *buf, int len)
+{
+ word32 t;
+
+ /* Update byte count */
+
+ t = ctx->bytes[0];
+ if ((ctx->bytes[0] = t + len) < t)
+ ctx->bytes[1]++; /* Carry from low to high */
+
+ t = 64 - (t & 0x3f); /* Space available in ctx->in (at least 1) */
+ if ((unsigned)t > len) {
+ memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, len);
+ return;
+ }
+ /* First chunk is an odd size */
+ memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);
+ byteSwap(ctx->in, 16);
+ MD5Transform(ctx->buf, ctx->in);
+ buf += (unsigned)t;
+ len -= (unsigned)t;
+
+ /* Process data in 64-byte chunks */
+ while (len >= 64) {
+ memcpy(ctx->in, buf, 64);
+ byteSwap(ctx->in, 16);
+ MD5Transform(ctx->buf, ctx->in);
+ buf += 64;
+ len -= 64;
+ }
+
+ /* Handle any remaining bytes of data. */
+ memcpy(ctx->in, buf, len);
+}
+
+/*
+ * Final wrapup - pad to 64-byte boundary with the bit pattern
+ * 1 0* (64-bit count of bits processed, MSB-first)
+ */
+void
+MD5Final(byte digest[16], struct MD5Context *ctx)
+{
+ int count = (int)(ctx->bytes[0] & 0x3f); /* Bytes in ctx->in */
+ byte *p = (byte *)ctx->in + count; /* First unused byte */
+
+ /* Set the first char of padding to 0x80. There is always room. */
+ *p++ = 0x80;
+
+ /* Bytes of padding needed to make 56 bytes (-8..55) */
+ count = 56 - 1 - count;
+
+ if (count < 0) { /* Padding forces an extra block */
+ memset(p, 0, count+8);
+ byteSwap(ctx->in, 16);
+ MD5Transform(ctx->buf, ctx->in);
+ p = (byte *)ctx->in;
+ count = 56;
+ }
+ memset(p, 0, count+8);
+ byteSwap(ctx->in, 14);
+
+ /* Append length in bits and transform */
+ ctx->in[14] = ctx->bytes[0] << 3;
+ ctx->in[15] = ctx->bytes[1] << 3 | ctx->bytes[0] >> 29;
+ MD5Transform(ctx->buf, ctx->in);
+
+ byteSwap(ctx->buf, 4);
+ memcpy(digest, ctx->buf, 16);
+ memset(ctx,0,sizeof(ctx));
+}
+
+
+/* The four core functions - F1 is optimized somewhat */
+
+/* #define F1(x, y, z) (x & y | ~x & z) */
+#define F1(x, y, z) (z ^ (x & (y ^ z)))
+#define F2(x, y, z) F1(z, x, y)
+#define F3(x, y, z) (x ^ y ^ z)
+#define F4(x, y, z) (y ^ (x | ~z))
+
+/* This is the central step in the MD5 algorithm. */
+#define MD5STEP(f,w,x,y,z,in,s) \
+ (w += f(x,y,z) + in, w = (w<<s | w>>(32-s)) + x)
+
+/*
+ * The core of the MD5 algorithm, this alters an existing MD5 hash to
+ * reflect the addition of 16 longwords of new data. MD5Update blocks
+ * the data and converts bytes into longwords for this routine.
+ */
+
+void
+MD5Transform(word32 buf[4], word32 const in[16])
+{
+ register word32 a, b, c, d;
+
+ a = buf[0];
+ b = buf[1];
+ c = buf[2];
+ d = buf[3];
+
+ MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);
+ MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);
+ MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);
+ MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);
+ MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);
+ MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);
+ MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);
+ MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);
+ MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);
+ MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);
+ MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);
+ MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);
+ MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);
+ MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);
+ MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);
+ MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);
+
+ MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);
+ MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);
+ MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);
+ MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);
+ MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);
+ MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);
+ MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);
+ MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);
+ MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);
+ MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);
+ MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);
+ MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);
+ MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);
+ MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);
+ MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);
+ MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);
+
+ MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);
+ MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);
+ MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);
+ MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);
+ MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);
+ MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);
+ MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);
+ MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);
+ MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);
+ MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);
+ MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);
+ MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);
+ MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);
+ MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);
+ MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);
+ MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);
+
+ MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);
+ MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);
+ MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);
+ MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);
+ MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);
+ MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);
+ MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);
+ MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);
+ MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);
+ MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);
+ MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);
+ MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);
+ MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);
+ MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);
+ MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);
+ MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);
+
+ buf[0] += a;
+ buf[1] += b;
+ buf[2] += c;
+ buf[3] += d;
+}
+
--- /dev/null
+/* 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 */
+
+
+
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)
projects / ghc-hetmet.git / commitdiff