#include "HsVersions.h"
import IfaceSyn
-import IfaceType
import LoadIface
import Id
import IdInfo
-import NewDemand
+import Demand
import Annotations
import CoreSyn
import CoreFVs
import RdrName
import NameEnv
import NameSet
-import OccName
import Module
import BinIface
import ErrUtils
import Binary
import Fingerprint
import Bag
-import Panic
import Control.Monad
import Data.List
-- 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
, 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
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
= 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
\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
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
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails VanillaId = IfVanillaId
-toIfaceIdDetails DFunId = IfVanillaId
-toIfaceIdDetails (RecSelId { sel_naughty = n }) = IfRecSelId n
+toIfaceIdDetails (DFunId {}) = IfDFunId
+toIfaceIdDetails (RecSelId { sel_naughty = n
+ , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId -- Unexpected
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
------------ 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 (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance })
+ = case guidance of
+ InlineRule { ir_info = InlWrapper w } -> Just (HsUnfold lb (IfWrapper arity (idName w)))
+ InlineRule { ir_sat = InlSat } -> Just (HsUnfold lb (IfInlineRule arity True (toIfaceExpr rhs)))
+ InlineRule { ir_sat = InlUnSat } -> Just (HsUnfold lb (IfInlineRule arity False (toIfaceExpr rhs)))
+ UnfoldIfGoodArgs {} -> vanilla_unfold
+ UnfoldNever -> vanilla_unfold -- Yes, even if guidance is UnfoldNever, 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!
+ where
+ vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
+
+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
---------------------
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
-toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------