X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=702a744d34fc0353cf213fc8be761057904feb56;hp=17a379bbad7e47ffa21a6fbcd622b3aad47b8905;hb=77166b1729061531eeb77c33f4d3b2581f7d4c41;hpb=5aeae7aaf9f831a97a55eea61f553795f23a2d1b diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 17a379b..702a744 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 @@ -185,26 +185,15 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - -- Modules don't compare lexicographically usually, - -- but we want them to do so here. - le_mod :: Module -> Module -> Bool - le_mod m1 m2 = moduleNameFS (moduleName m1) - <= moduleNameFS (moduleName m2) - - le_dep_mod :: (ModuleName, IsBootInterface) - -> (ModuleName, IsBootInterface) -> Bool - le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2 - - pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) | otherwise = imp_dep_pkgs imports - return Deps { dep_mods = sortLe le_dep_mod dep_mods, - dep_pkgs = sortLe (<=) pkgs, - dep_orphs = sortLe le_mod (imp_orphs imports), - dep_finsts = sortLe le_mod (imp_finsts imports) } + return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, + dep_pkgs = sortBy stablePackageIdCmp pkgs, + dep_orphs = sortBy stableModuleCmp (imp_orphs imports), + dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } -- sort to get into canonical order - + -- NB. remember to use lexicographic ordering mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameSet -> Dependencies -> GlobalRdrEnv @@ -396,7 +385,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 @@ -410,7 +399,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls , let out = localOccs $ freeNamesDeclABI abi ] - name_module n = ASSERT( isExternalName n ) nameModule n + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n localOccs = map (getUnique . getParent . getOccName) . filter ((== this_mod) . name_module) . nameSetToList @@ -508,7 +497,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls let sorted_deps = sortDependencies (mi_deps iface0) -- 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 + -- orphan modules below us in the dependency 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 @@ -600,20 +589,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 +%* * +%************************************************************************ --- 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 +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 @@ -625,13 +641,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) @@ -647,6 +656,7 @@ freeNamesDeclExtras IfaceOtherDeclExtras freeNamesSub :: (Fixity,[IfaceRule]) -> NameSet freeNamesSub (_,rules) = unionManyNameSets (map freeNamesIfRule 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 @@ -752,7 +762,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 @@ -772,17 +782,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] @@ -926,7 +935,8 @@ mkIfaceExports :: [AvailInfo] -- Group by module and sort by occurrence mkIfaceExports exports = [ (mod, eltsFM avails) - | (mod, avails) <- sortBy (stableModuleCmp `on` fst) (fmToList groupFM) + | (mod, avails) <- sortBy (stableModuleCmp `on` fst) + (moduleEnvToList groupFM) -- NB. the fmToList is in a random order, -- because Ord Module is not a predictable -- ordering. Hence we perform a final sort @@ -1400,12 +1410,12 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, is_local name = nameIsLocalOrFrom mod name -- Compute orphanhood. See Note [Orphans] in IfaceSyn - (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) + (_, cls, tys) = tcSplitDFunTy (idType dfun_id) -- Slightly awkward: we need the Class to get the fundeps (tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] orph | is_local cls_name = Just (nameOccName cls_name) - | all isJust mb_ns = head mb_ns + | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns | otherwise = Nothing mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name @@ -1452,7 +1462,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -------------------------- toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails DFunId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) @@ -1461,7 +1471,9 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, unfold_hsinfo] + -- NB: strictness must be before unfolding + -- See TcIface.tcUnfolding where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1476,39 +1488,44 @@ 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 - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = workerExists work_info - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker ((idName work_id)) wrap_arity) - NoWorker -> Nothing - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - rhs = unfoldingTemplate unfold_info - no_unfolding = neverUnfold unfold_info - -- The CoreTidy phase retains unfolding info iff - -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - unfold_hsinfo | no_unfolding = Nothing - | has_worker = Nothing -- Unfolding is implicit - | otherwise = Just (HsUnfold (toIfaceExpr rhs)) + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isNonRuleLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | no_unfolding && not has_worker - && isFunLike (inlinePragmaRuleMatchInfo inline_prag) - = Nothing - -- If the iface file give no unfolding info, we - -- don't need to say when inlining is OK! - | otherwise = Just (HsInline inline_prag) + | otherwise = Just (HsInline inline_prag) + +-------------------------- +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 _ _ + = Nothing -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule @@ -1565,7 +1582,6 @@ toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- toIfaceNote :: Note -> IfaceNote toIfaceNote (SCC cc) = IfaceSCC cc -toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s ---------------------