- -- return True if an external name has changed
- name_changed :: Name -> Bool
- name_changed nm
- | Just ents <- lookupUFM usg_modmap (moduleName mod)
- = case lookupUFM ents parent_occ of
- Nothing -> pprPanic "computeChangedOccs" (ppr nm)
- Just v -> v < new_version
- | otherwise = False -- must be in another package
- where
- mod = nameModule nm
- (parent_occ, new_version) = ver_fn nm
-
- -- Turn the usages from the old ModIface into a mapping
- usg_modmap = listToUFM [ (usg_mod usg, listToUFM (usg_entities usg))
- | usg <- old_usages ]
-
- get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet
- get_local_eq_info Equal = Equal
- get_local_eq_info NotEqual = NotEqual
- get_local_eq_info (EqBut ns) = foldNameSet f Equal ns
- where f name eq | nameModule name == this_module =
- EqBut (unitOccSet (nameOccName name)) `and_occifeq` eq
- | name_changed name = NotEqual
- | otherwise = eq
-
- local_eq_infos = mapSnd get_local_eq_info eq_info
-
- edges :: [((OccName, OccIfaceEq), Unique, [Unique])]
- 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
- other -> [] ]
-
- -- 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 other = so_far
-
-type OccIfaceEq = GenIfaceEq OccSet
-
-changedWrt :: OccSet -> OccIfaceEq -> Bool
-changedWrt so_far Equal = False
-changedWrt so_far NotEqual = True
-changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids
-
-changedWrtNames :: OccSet -> IfaceEq -> Bool
-changedWrtNames so_far Equal = False
-changedWrtNames so_far NotEqual = True
-changedWrtNames so_far (EqBut kids) =
- so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids))
-
-and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq
-Equal `and_occifeq` x = x
-NotEqual `and_occifeq` x = NotEqual
-EqBut nms `and_occifeq` Equal = EqBut nms
-EqBut nms `and_occifeq` NotEqual = NotEqual
-EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2)
+Note [The ABI of an IfaceDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ABI of a declaration consists of:
+
+ (a) 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).
+
+ (b) 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.
+
+ (c) the fixity of the identifier
+ (d) for Ids: rules
+ (e) for classes: instances, fixity & rules for methods
+ (f) for datatypes: instances, fixity & rules for constrs
+
+Items (c)-(f) are not stored in the IfaceDecl, but instead appear
+elsewhere in the interface file. But they are *fingerprinted* with
+the Id itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
+and fingerprinting that as part of the Id.
+
+\begin{code}
+type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
+
+data IfaceDeclExtras
+ = IfaceIdExtras Fixity [IfaceRule]
+ | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
+ | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
+ | IfaceSynExtras Fixity
+ | IfaceOtherDeclExtras
+
+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
+
+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 (IfaceSynExtras _)
+ = emptyNameSet
+freeNamesDeclExtras IfaceOtherDeclExtras
+ = emptyNameSet
+
+freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet
+freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule rules)
+
+instance Outputable IfaceDeclExtras where
+ ppr IfaceOtherDeclExtras = empty
+ ppr (IfaceIdExtras fix rules) = ppr_id_extras fix rules
+ ppr (IfaceSynExtras fix) = ppr fix
+ ppr (IfaceDataExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
+ ppr_id_extras_s stuff]
+ ppr (IfaceClassExtras fix insts stuff) = vcat [ppr fix, ppr_insts insts,
+ ppr_id_extras_s stuff]
+
+ppr_insts :: [IfaceInstABI] -> SDoc
+ppr_insts _ = ptext (sLit "<insts>")
+
+ppr_id_extras_s :: [(Fixity, [IfaceRule])] -> SDoc
+ppr_id_extras_s stuff = vcat [ppr_id_extras f r | (f,r)<- stuff]
+
+ppr_id_extras :: Fixity -> [IfaceRule] -> SDoc
+ppr_id_extras fix rules = ppr fix $$ vcat (map ppr rules)
+
+-- This instance is used only to compute fingerprints
+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 fix insts methods) = do
+ putByte bh 3; put_ bh fix; put_ bh insts; put_ bh methods
+ put_ bh (IfaceSynExtras fix) = do
+ putByte bh 4; put_ bh fix
+ put_ bh IfaceOtherDeclExtras = do
+ putByte bh 5
+
+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 (fix_fn n)
+ (map IfaceInstABI $ lookupOccEnvL inst_env n)
+ [id_extras op | IfaceClassOp op _ _ <- sigs]
+ IfaceSyn{} -> IfaceSynExtras (fix_fn n)
+ _other -> IfaceOtherDeclExtras
+ where
+ n = ifName decl
+ id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
+
+--
+-- When hashing an instance, we hash only its structure, not the
+-- fingerprints of the things it mentions. See the section on instances
+-- in the commentary,
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+--
+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 = ASSERT( isExternalName 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
+-}
+
+instOrphWarn :: PrintUnqualified -> Instance -> WarnMsg
+instOrphWarn unqual inst
+ = mkWarnMsg (getSrcSpan inst) unqual $
+ hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst)
+
+ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
+ruleOrphWarn unqual mod rule
+ = mkWarnMsg silly_loc unqual $
+ ptext (sLit "Orphan rule:") <+> ppr rule
+ where
+ silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
+ -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
+ -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to