X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=549fce6165062e204ca511c5efae2cf7e4186d29;hp=478d7d3e0b8f6ced9feebdc30a295765ea69b34a;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hpb=b410846772e0ee630b82df31990bf9805b2d1849 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 478d7d3..549fce6 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -51,7 +51,6 @@ Basic idea: #include "HsVersions.h" import IfaceSyn -import IfaceType import LoadIface import Id import IdInfo @@ -77,7 +76,6 @@ import Name import RdrName import NameEnv import NameSet -import OccName import Module import BinIface import ErrUtils @@ -95,7 +93,6 @@ import ListSetOps import Binary import Fingerprint import Bag -import Panic import Control.Monad import Data.List @@ -188,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 @@ -511,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 @@ -926,11 +912,15 @@ mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = \begin{code} mkIfaceExports :: [AvailInfo] -> [(Module, [GenAvailInfo OccName])] - -- Group by module and sort by occurrence - -- This keeps the list in canonical order + -- Group by module and sort by occurrence mkIfaceExports exports = [ (mod, eltsFM avails) - | (mod, avails) <- 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 + -- using the stable Module ordering. ] where -- Group by the module where the exported entities are defined @@ -1400,12 +1390,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 +1442,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 +1451,7 @@ 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] where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1480,35 +1470,32 @@ toIfaceIdInfo id_info 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 (unfoldingInfo 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 :: Unfolding -> Maybe IfaceInfoItem +toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) + = case guidance of + InlineRule { ug_ir_info = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs))) + InlineRule { ug_ir_info = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs))) + InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w))) + UnfoldNever -> Nothing + UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs))) + UnfoldAlways -> panic "toIfUnfolding:UnfoldAlways" + -- Never happens because we never have + -- bindings for unfold-always things +toIfUnfolding (DFunUnfolding _con ops) + = Just (HsUnfold (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 +1552,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 ---------------------