X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=ce6f4a30ab6e8b00aed6e7d6e05e7ce5f2315584;hp=0bfdae7b1dfd6addc15d9fd0b3d584140671c4a1;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=d2241e6301bf56acf89ffd0d78922b90a58dafb1 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 0bfdae7..ce6f4a3 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -54,7 +54,7 @@ import IfaceSyn import LoadIface import Id import IdInfo -import NewDemand +import Demand import Annotations import CoreSyn import CoreFVs @@ -83,7 +83,7 @@ import Digraph import SrcLoc import Outputable import BasicTypes hiding ( SuccessFlag(..) ) -import LazyUniqFM +import UniqFM import Unique import Util hiding ( eqListBy ) import FiniteMap @@ -164,9 +164,8 @@ mkUsedNames TcGblEnv{ tcg_inst_uses = dfun_uses_var, tcg_dus = dus } - = do - dfun_uses <- readIORef dfun_uses_var -- What dfuns are used - return (allUses dus `unionNameSets` dfun_uses) + = do { dfun_uses <- readIORef dfun_uses_var -- What dfuns are used + ; return (allUses dus `unionNameSets` dfun_uses) } mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies @@ -385,7 +384,7 @@ 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 + -- 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 @@ -512,7 +511,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- 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) + (mi_exports iface0, + orphan_hash, + dep_orphan_hashes, + dep_pkgs (mi_deps iface0)) + -- dep_pkgs: see "Package Version Changes" on + -- wiki/Commentary/Compiler/RecompilationAvoidance -- put the declarations in a canonical order, sorted by OccName let sorted_decls = eltsFM $ listToFM $ @@ -589,20 +593,47 @@ sortDependencies d dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } +\end{code} + + +%************************************************************************ +%* * + The ABI of an IfaceDecl +%* * +%************************************************************************ + +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). --- 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 + (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 @@ -614,13 +645,6 @@ freeNamesDeclABI :: IfaceDeclABI -> NameSet freeNamesDeclABI (_mod, decl, extras) = freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras -data IfaceDeclExtras - = IfaceIdExtras Fixity [IfaceRule] - | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] - | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] - | IfaceSynExtras Fixity - | IfaceOtherDeclExtras - freeNamesDeclExtras :: IfaceDeclExtras -> NameSet freeNamesDeclExtras (IfaceIdExtras _ rules) = unionManyNameSets (map freeNamesIfRule rules) @@ -636,6 +660,25 @@ freeNamesDeclExtras IfaceOtherDeclExtras 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 "") + +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 @@ -741,7 +784,7 @@ ruleOrphWarn unqual mod rule = mkWarnMsg silly_loc unqual $ ptext (sLit "Orphan rule:") <+> ppr rule where - silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 0) + 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 @@ -761,17 +804,16 @@ mkOrphMap get_key decls where go (non_orphs, orphs) d | Just occ <- get_key d - = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs) + = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) | otherwise = (non_orphs, d:orphs) \end{code} -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and fingerprints} -%* * -%********************************************************* - +%************************************************************************ +%* * + Keeping track of what we've slurped, and fingerprints +%* * +%************************************************************************ \begin{code} mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> IO [Usage] @@ -1452,6 +1494,8 @@ toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, inline_hsinfo, unfold_hsinfo] + -- NB: strictness must be before unfolding + -- See TcIface.tcUnfolding where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1466,12 +1510,13 @@ toIfaceIdInfo id_info ------------ Strictness -------------- -- No point in explicitly exporting TopSig - strict_hsinfo = case newStrictnessInfo id_info of + strict_hsinfo = case strictnessInfo id_info of Just sig | not (isTopSig sig) -> Just (HsStrictness sig) _other -> Nothing ------------ Unfolding -------------- - unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info) + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isNonRuleLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info @@ -1479,20 +1524,29 @@ toIfaceIdInfo id_info | otherwise = Just (HsInline inline_prag) -------------------------- -toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem -toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) - = case guidance of - InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w))) - InlineRule { ir_sat = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs))) - InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs))) - UnfoldNever -> Nothing - UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs))) - -toIfUnfolding (DFunUnfolding _con ops) - = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops))) +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity + , uf_src = src, uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineRule {} + -> case guidance of + UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok (toIfaceExpr rhs) + _other -> pprPanic "toIfUnfolding" (ppr unf) + InlineWrapper w -> IfWrapper arity (idName w) + InlineCompulsory -> IfCompulsory (toIfaceExpr rhs) + InlineRhs -> IfCoreUnfold (toIfaceExpr rhs) + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + +toIfUnfolding lb (DFunUnfolding _con ops) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun -toIfUnfolding _ + +toIfUnfolding _ _ = Nothing --------------------------