#include "HsVersions.h"
import IfaceSyn
-import IfaceType
import LoadIface
import Id
import IdInfo
-import NewDemand
+import Demand
+import Annotations
import CoreSyn
import CoreFVs
import Class
import InstEnv
import FamInstEnv
import TcRnMonad
+import HsSyn
import HscTypes
import Finder
import DynFlags
import RdrName
import NameEnv
import NameSet
-import OccName
import Module
import BinIface
import ErrUtils
import SrcLoc
import Outputable
import BasicTypes hiding ( SuccessFlag(..) )
-import LazyUniqFM
+import UniqFM
import Unique
import Util hiding ( eqListBy )
import FiniteMap
import ListSetOps
import Binary
import Fingerprint
-import Panic
+import Bag
import Control.Monad
import Data.List
-> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- The trimmed, tidied interface
-> ModGuts -- Usages, deprecations, etc
- -> IO (ModIface, -- The new one
- Bool) -- True <=> there was an old Iface, and the
+ -> IO (Messages,
+ Maybe (ModIface, -- The new one
+ Bool)) -- True <=> there was an old Iface, and the
-- new one is identical, so no need
-- to write it
mg_dir_imps = dir_imp_mods,
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
- mg_deprecs = deprecs,
+ mg_warns = warns,
mg_hpc_info = hpc_info }
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env
- fix_env deprecs hpc_info dir_imp_mods mod_details
-
+ fix_env warns hpc_info dir_imp_mods mod_details
+
-- | make an interface from the results of typechecking only. Useful
-- for non-optimising compilation, or where we aren't generating any
-- object code at all ('HscNothing').
-> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- gotten from mkBootModDetails, probably
-> TcGblEnv -- Usages, deprecations, etc
- -> IO (ModIface,
- Bool)
+ -> IO (Messages, Maybe (ModIface, Bool))
mkIfaceTc hsc_env maybe_old_fingerprint mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
tcg_imports = imports,
tcg_rdr_env = rdr_env,
tcg_fix_env = fix_env,
- tcg_deprecs = deprecs,
+ tcg_warns = warns,
tcg_hpc = other_hpc_info
}
= do
let hpc_info = emptyHpcInfo other_hpc_info
mkIface_ hsc_env maybe_old_fingerprint
this_mod (isHsBoot hsc_src) used_names deps rdr_env
- fix_env deprecs hpc_info (imp_mods imports) mod_details
+ fix_env warns hpc_info (imp_mods imports) mod_details
mkUsedNames :: TcGblEnv -> IO NameSet
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
-- 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
- -> NameEnv FixItem -> Deprecations -> HpcInfo
+ -> NameEnv FixItem -> Warnings -> HpcInfo
-> ImportedMods
-> ModDetails
- -> IO (ModIface, Bool)
+ -> IO (Messages, Maybe (ModIface, Bool))
mkIface_ hsc_env maybe_old_fingerprint
- this_mod is_boot used_names deps rdr_env fix_env src_deprecs hpc_info
+ this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info
dir_imp_mods
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
+ md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports }
-- Sigh: see Note [Root-main Id] in TcRnDriver
; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
- ; deprecs = src_deprecs
+ ; warns = src_warns
; iface_rules = map (coreRuleToIfaceRule this_mod) rules
; iface_insts = map instanceToIfaceInst insts
; iface_fam_insts = map famInstToIfaceFamInst fam_insts
mi_vect_info = iface_vect_info,
mi_fixities = fixities,
- mi_deprecs = deprecs,
+ mi_warns = warns,
+ mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
-- Left out deliberately: filled in by addVersionInfo
mi_hpc = isHpcUsed hpc_info,
-- And build the cached values
- mi_dep_fn = mkIfaceDepCache deprecs,
+ mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities }
}
- ; (new_iface, no_change_at_all, pp_orphs)
+ ; (new_iface, no_change_at_all)
<- {-# SCC "versioninfo" #-}
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
- -- Debug printing
- ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags)
- (printDump (expectJust "mkIface" pp_orphs))
+ -- Warn about orphans
+ ; let orph_warnings --- Laziness means no work done unless -fwarn-orphans
+ | dopt Opt_WarnOrphans dflags = rule_warns `unionBags` inst_warns
+ | otherwise = emptyBag
+ errs_and_warns = (orph_warnings, emptyBag)
+ unqual = mkPrintUnqualified dflags rdr_env
+ inst_warns = listToBag [ instOrphWarn unqual d
+ | (d,i) <- insts `zip` iface_insts
+ , isNothing (ifInstOrph i) ]
+ rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
+ | r <- iface_rules
+ , isNothing (ifRuleOrph r) ]
+
+ ; if errorsFound dflags errs_and_warns
+ then return ( errs_and_warns, Nothing )
+ else do {
-- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs)
-
+
+ -- Debug printing
; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
(pprModIface new_iface)
-- with the old GlobalRdrEnv (mi_globals).
; let final_iface = new_iface{ mi_globals = Just rdr_env }
- ; return (final_iface, no_change_at_all) }
+ ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
where
r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2
i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2
mkHashFun hsc_env eps
= \name ->
let
- mod = nameModule name
+ mod = ASSERT2( isExternalName name, ppr name ) nameModule name
occ = nameOccName name
iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse`
pprPanic "lookupVers2" (ppr mod <+> ppr occ)
-> ModIface -- The new interface (lacking decls)
-> [IfaceDecl] -- The new decls
-> IO (ModIface, -- Updated interface
- Bool, -- True <=> no changes at all;
+ Bool) -- True <=> no changes at all;
-- no need to write Iface
- Maybe SDoc) -- Warnings about orphans
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
, let out = localOccs $ freeNamesDeclABI abi
]
+ name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
localOccs = map (getUnique . getParent . getOccName)
- . filter ((== this_mod) . nameModule)
+ . filter ((== this_mod) . name_module)
. nameSetToList
where getParent occ = lookupOccEnv parent_map occ `orElse` occ
where n = ifName d
-- strongly-connected groups of declarations, in dependency order
- groups = stronglyConnComp edges
+ groups = stronglyConnCompFromEdgedVertices edges
global_hash_fn = mkHashFun hsc_env eps
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
| otherwise
- = let hash | nameModule name /= this_mod = global_hash_fn name
+ = ASSERT( isExternalName name )
+ let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise =
snd (lookupOccEnv local_env (getOccName name)
`orElse` pprPanic "urk! lookup local fingerprint"
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
-- 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 $
(map fst sorted_decls,
export_hash,
orphan_hash,
- mi_deprecs iface0)
+ mi_warns iface0)
-- The interface hash depends on:
-- - the ABI hash, plus
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
--
- return (final_iface, no_change_at_all, pp_orphs)
+ return (final_iface, no_change_at_all)
where
this_mod = mi_module iface0
-- non-orphans?
fam_insts = mi_fam_insts iface0
fix_fn = mi_fix_fn iface0
- pp_orphs = pprOrphans orph_insts orph_rules
getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
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 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
+
+%************************************************************************
+%* *
+ 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).
+
+ (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
freeNamesDeclABI (_mod, decl, extras) =
freeNamesIfDecl decl `unionNameSets` freeNamesDeclExtras extras
-data IfaceDeclExtras
- = IfaceIdExtras Fixity [IfaceRule]
- | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
- | IfaceClassExtras [IfaceInstABI] [(Fixity,[IfaceRule])]
- | IfaceOtherDeclExtras
-
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras _ rules)
= unionManyNameSets (map freeNamesIfRule rules)
freeNamesDeclExtras (IfaceDataExtras _ _insts subs)
= unionManyNameSets (map freeNamesSub subs)
-freeNamesDeclExtras (IfaceClassExtras _insts 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 insts methods) = do
- putByte bh 3; put_ bh insts; put_ bh methods
+ 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 4
+ putByte bh 5
declExtras :: (OccName -> Fixity)
-> OccEnv [IfaceRule]
(map IfaceInstABI $ lookupOccEnvL inst_env n)
(map (id_extras . ifConOcc) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs} ->
- IfaceClassExtras
+ 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
-- 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 = do
- put_ bh $! nameModule name
- put_ bh $! nameOccName name
+putNameLiterally bh name = ASSERT( isExternalName name )
+ do { put_ bh $! nameModule name
+ ; put_ bh $! nameOccName name }
computeFingerprint :: Binary a
=> DynFlags
return $! readHexFingerprint hash_str
-}
-pprOrphans :: [IfaceInst] -> [IfaceRule] -> Maybe SDoc
-pprOrphans insts rules
- | null insts && null rules = Nothing
- | otherwise
- = Just $ vcat [
- if null insts then empty else
- hang (ptext (sLit "Warning: orphan instances:"))
- 2 (vcat (map ppr insts)),
- if null rules then empty else
- hang (ptext (sLit "Warning: orphan rules:"))
- 2 (vcat (map ppr rules))
- ]
+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
----------------------
-- mkOrphMap partitions instance decls or rules into
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]
| otherwise
= case nameModule_maybe name of
Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
- Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
+ Just mod -> -- We use this fiddly lambda function rather than
+ -- (++) as the argument to extendModuleEnv_C to
+ -- avoid quadratic behaviour (trac #2680)
+ extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
-- We want to create a Usage for a home module if
\end{code}
\begin{code}
+mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
+mkIfaceAnnotations = map mkIfaceAnnotation
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
+ ifAnnotatedTarget = fmap nameOccName target,
+ ifAnnotatedValue = serialized
+ }
+\end{code}
+
+\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
-- else the plusFM will simply discard one! They
-- should have been combined by now.
add env (Avail n)
- = add_one env (nameModule n) (Avail (nameOccName n))
+ = ASSERT( isExternalName n )
+ add_one env (nameModule n) (Avail (nameOccName n))
add env (AvailTC tc ns)
- = foldl add_for_mod env mods
+ = ASSERT( all isExternalName ns )
+ foldl add_for_mod env mods
where
tc_occ = nameOccName tc
mods = nub (map nameModule ns)
orM = foldr f (return False)
where f m rest = do b <- m; if b then return True else rest
- dep_missing (L _ mod) = do
- find_res <- liftIO $ findImportedModule hsc_env mod Nothing
+ dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
+ find_res <- liftIO $ findImportedModule hsc_env mod pkg
case find_res of
Found _ mod
| pkg == this_pkg
-- Instead, get an Either back which we can test
case mb_iface of
- Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
- ppr mod]));
- -- Couldn't find or parse a module mentioned in the
- -- old interface file. Don't complain: it might
- -- just be that the current module doesn't need that
- -- import and it's been deleted
- Succeeded iface -> continue iface
+ Failed _ -> (out_of_date (sep [ptext (sLit "Couldn't load interface for module"),
+ ppr mod]))
+ -- Couldn't find or parse a module mentioned in the
+ -- old interface file. Don't complain: it might
+ -- just be that the current module doesn't need that
+ -- import and it's been deleted
+ Succeeded iface -> continue iface
checkModUsage :: PackageId ->Usage -> IfG RecompileRequired
-- Reason: Iface stuff uses OccNames, and the conversion here does
-- not do tidying on the way
tyThingToIfaceDecl (AnId id)
- = IfaceId { ifName = getOccName id,
- ifType = toIfaceType (idType id),
- ifIdInfo = info }
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType (idType id),
+ ifIdDetails = toIfaceIdDetails (idDetails id),
+ ifIdInfo = info }
where
info = case toIfaceIdInfo (idInfo id) of
[] -> NoInfo
| isSynTyCon tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
- ifOpenSyn = syn_isOpen,
- ifSynRhs = toIfaceType syn_tyki,
+ ifSynRhs = syn_rhs,
+ ifSynKind = syn_ki,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)
}
| otherwise = pprPanic "toIfaceDecl" (ppr tycon)
where
tyvars = tyConTyVars tycon
- (syn_isOpen, syn_tyki) = case synTyConRhs tycon of
- OpenSynTyCon ki _ -> (True , ki)
- SynonymTyCon ty -> (False, ty)
+ (syn_rhs, syn_ki)
+ = case synTyConRhs tycon of
+ OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
+ SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
ifaceConDecl data_con
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
+ ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
do_rough (Just n) = Just (toIfaceTyCon_name n)
dfun_name = idName dfun_id
- mod = nameModule dfun_name
+ mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name
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
-- See Note [IdInfo on nested let-bindings] in IfaceSyn
id_info = idInfo id
inline_prag = inlinePragInfo id_info
- prag_info | isAlwaysActive inline_prag = NoInfo
- | otherwise = HasInfo [HsInline inline_prag]
+ prag_info | isDefaultInlinePragma inline_prag = NoInfo
+ | otherwise = HasInfo [HsInline inline_prag]
--------------------------
+toIfaceIdDetails :: IdDetails -> IfaceIdDetails
+toIfaceIdDetails VanillaId = IfVanillaId
+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]
+ -- NB: strictness must be before unfolding
+ -- See TcIface.tcUnfolding
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 | isAlwaysActive inline_prag = Nothing
- | no_unfolding && not has_worker = Nothing
- -- If the iface file give no unfolding info, we
- -- don't need to say when inlining is OK!
- | otherwise = Just (HsInline inline_prag)
+ inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing
+ | 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
---------------------
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
-toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
projects / ghc-hetmet.git / blobdiff