#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 TyCon
import DataCon
import Type
+import Coercion
import TcType
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 FastString
import Maybes
import ListSetOps
import Binary
import Fingerprint
import Bag
-import Panic
import Control.Monad
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.IORef
import System.FilePath
-import System.Exit ( exitWith, ExitCode(..) )
\end{code}
-> 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
= mkIface_ hsc_env maybe_old_fingerprint
this_mod is_boot used_names deps rdr_env
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_hpc = other_hpc_info
}
= do
- used_names <- mkUsedNames tc_result
+ let used_names = mkUsedNames tc_result
deps <- mkDependencies tc_result
let hpc_info = emptyHpcInfo other_hpc_info
mkIface_ hsc_env maybe_old_fingerprint
fix_env warns hpc_info (imp_mods imports) mod_details
-mkUsedNames :: TcGblEnv -> IO NameSet
-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)
+mkUsedNames :: TcGblEnv -> NameSet
+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
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 -> 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_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 }
mi_fixities = fixities,
mi_warns = warns,
+ mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
-- Left out deliberately: filled in by addVersionInfo
intermediate_iface decls
-- 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
+ ; let warn_orphs = dopt Opt_WarnOrphans dflags
+ warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags
+ orph_warnings --- Laziness means no work done unless -fwarn-orphans
+ | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
+ | otherwise = emptyBag
errs_and_warns = (orph_warnings, emptyBag)
unqual = mkPrintUnqualified dflags rdr_env
inst_warns = listToBag [ instOrphWarn unqual d
, isNothing (ifInstOrph i) ]
rule_warns = listToBag [ ruleOrphWarn unqual this_mod r
| r <- iface_rules
- , isNothing (ifRuleOrph r) ]
+ , isNothing (ifRuleOrph r)
+ , if ifRuleAuto r then warn_auto_orphs
+ else warn_orphs ]
- ; when (not (isEmptyBag orph_warnings))
- (do { printErrorsAndWarnings dflags errs_and_warns -- XXX
- ; when (errorsFound dflags errs_and_warns)
- (exitWith (ExitFailure 1)) })
+ ; 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)
-- 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
le_occ n1 n2 = nameOccName n1 <= nameOccName n2
dflags = hsc_dflags hsc_env
+
+ deliberatelyOmitted :: String -> a
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
flattenVectInfo (VectInfo { vectInfoVar = vVar
= 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 = 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
| isWiredInName name = putNameLiterally bh name
-- wired-in names don't have fingerprints
| otherwise
- = ASSERT( isExternalName name )
+ = ASSERT2( isExternalName name, ppr name )
let hash | nameModule name /= this_mod = global_hash_fn name
| otherwise =
snd (lookupOccEnv local_env (getOccName name)
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
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
orphan_hash <- computeFingerprint dflags (mk_put_name local_env)
- (map IfaceInstABI orph_insts, orph_rules, fam_insts)
+ (map ifDFun orph_insts, orph_rules, fam_insts)
-- 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 $
+ let sorted_decls = Map.elems $ Map.fromList $
[(ifName d, e) | e@(_, d) <- decls_w_hashes]
-- the ABI hash depends on:
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 declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
+and fingerprinting that as part of the declaration.
+
+\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)
- = unionManyNameSets (map freeNamesSub subs)
+freeNamesDeclExtras (IfaceDataExtras _ insts subs)
+ = unionManyNameSets (mkNameSet insts : map freeNamesSub subs)
+freeNamesDeclExtras (IfaceClassExtras _ insts subs)
+ = unionManyNameSets (mkNameSet insts : 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]
(lookupOccEnvL rule_env n)
IfaceData{ifCons=cons} ->
IfaceDataExtras (fix_fn n)
- (map IfaceInstABI $ lookupOccEnvL inst_env n)
+ (map ifDFun $ lookupOccEnvL inst_env n)
(map (id_extras . ifConOcc) (visibleIfConDecls cons))
IfaceClass{ifSigs=sigs} ->
- IfaceClassExtras
- (map IfaceInstABI $ lookupOccEnvL inst_env n)
+ IfaceClassExtras (fix_fn n)
+ (map ifDFun $ lookupOccEnvL inst_env n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
+ IfaceSyn{} -> IfaceSynExtras (fix_fn n)
_other -> IfaceOtherDeclExtras
where
n = ifName decl
id_extras occ = (fix_fn occ, lookupOccEnvL rule_env occ)
--
--- When hashing an instance, we hash only its structure, not the
--- fingerprints of the things it mentions. See the section on instances
--- in the commentary,
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+-- When hashing an instance, we hash only the DFunId, because that
+-- depends on all the information about the instance.
--
-newtype IfaceInstABI = IfaceInstABI IfaceInst
-
-instance Binary IfaceInstABI where
- get = panic "no get for IfaceInstABI"
- put_ bh (IfaceInstABI inst) = do
- let ud = getUserData bh
- bh' = setUserData bh (ud{ ud_put_name = putNameLiterally })
- put_ bh' inst
+type IfaceInstABI = IfExtName
lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
lookupOccEnvL env k = lookupOccEnv env k `orElse` []
= 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
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]
| isWiredInName name = mv_map -- ignore wired-in names
| otherwise
= case nameModule_maybe name of
- Nothing -> pprTrace "mkUsageInfo: internal name?" (ppr name) mv_map
- Just mod -> extendModuleEnv_C (++) mv_map mod [occ]
+ Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name)
+ Just mod -> -- This lambda function is really just a
+ -- specialised (++); originally came about to
+ -- avoid quadratic behaviour (trac #2680)
+ extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ]
where occ = nameOccName name
-- We want to create a Usage for a home module if
usg_mod_name = moduleName mod,
usg_mod_hash = mod_hash,
usg_exports = export_hash,
- usg_entities = fmToList ent_hashs }
+ usg_entities = Map.toList ent_hashs }
where
maybe_iface = lookupIfaceByModule dflags hpt pit mod
-- In one-shot mode, the interfaces for home-package
used_occs = lookupModuleEnv ent_map mod `orElse` []
- -- Making a FiniteMap here ensures that (a) we remove duplicates
+ -- Making a Map here ensures that (a) we remove duplicates
-- when we have usages on several subordinates of a single parent,
-- and (b) that the usages emerge in a canonical order, which
- -- is why we use FiniteMap rather than OccEnv: FiniteMap works
+ -- is why we use Map rather than OccEnv: Map works
-- using Ord on the OccNames, which is a lexicographic ordering.
- ent_hashs :: FiniteMap OccName Fingerprint
- ent_hashs = listToFM (map lookup_occ used_occs)
+ ent_hashs :: Map OccName Fingerprint
+ ent_hashs = Map.fromList (map lookup_occ used_occs)
lookup_occ occ =
case hash_env occ of
\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, Map.elems avails)
+ | (mod, avails) <- sortBy (stableModuleCmp `on` fst)
+ (moduleEnvToList groupFM)
+ -- NB. the Map.toList 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
-- (which may not be the same for all Names in an Avail)
- -- Deliberately use FiniteMap rather than UniqFM so we
+ -- Deliberately use Map rather than UniqFM so we
-- get a canonical ordering
- groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+ groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName))
groupFM = foldl add emptyModuleEnv exports
- add_one :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+ add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName))
-> Module -> GenAvailInfo OccName
- -> ModuleEnv (FiniteMap FastString (GenAvailInfo OccName))
+ -> ModuleEnv (Map FastString (GenAvailInfo OccName))
add_one env mod avail
- = extendModuleEnv_C plusFM env mod
- (unitFM (occNameFS (availName avail)) avail)
+ -- XXX Is there a need to flip Map.union here?
+ = extendModuleEnvWith (flip Map.union) env mod
+ (Map.singleton (occNameFS (availName avail)) avail)
-- NB: we should not get T(X) and T(Y) in the export list
- -- else the plusFM will simply discard one! They
+ -- else the Map.union will simply discard one! They
-- should have been combined by now.
add env (Avail n)
= ASSERT( isExternalName n )
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
-- 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 }
- where
- info = case toIfaceIdInfo (idInfo id) of
- [] -> NoInfo
- items -> HasInfo items
+ = IfaceId { ifName = getOccName id,
+ ifType = toIfaceType (idType id),
+ ifIdDetails = toIfaceIdDetails (idDetails id),
+ ifIdInfo = toIfaceIdInfo (idInfo id) }
tyThingToIfaceDecl (AClass clas)
= IfaceClass { ifCtxt = toIfaceContext sc_theta,
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
- IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
+ IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty)
where
-- Be careful when splitting the type, because of things
-- like class Foo a where
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
+ toDmSpec NoDefMeth = NoDM
+ toDmSpec GenDefMeth = GenericDM
+ toDmSpec (DefMeth _) = VanillaDM
+
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
tyThingToIfaceDecl (ATyCon tycon)
tyvars = tyConTyVars tycon
(syn_rhs, syn_ki)
= case synTyConRhs tycon of
- OpenSynTyCon ki _ -> (Nothing, toIfaceType ki)
- SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
+ SynFamilyTyCon -> (Nothing, toIfaceType (synTyConResKind tycon))
+ SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
ifaceConDecls (NewTyCon { data_con = con }) =
IfNewTyCon (ifaceConDecl con)
ifaceConDecls (DataTyCon { data_cons = cons }) =
IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls OpenTyCon {} = IfOpenDataTyCon
+ ifaceConDecls DataFamilyTyCon {} = IfOpenDataTyCon
ifaceConDecls AbstractTyCon = IfAbstractTyCon
-- The last case happens when a TyCon has been trimmed during tidying
-- Furthermore, tyThingToIfaceDecl is also used
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),
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
toIfaceLetBndr :: Id -> IfaceLetBndr
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
- prag_info
- where
- -- Stripped-down version of tcIfaceIdInfo
- -- Change this if you want to export more IdInfo for
- -- non-top-level Ids. Don't forget to change
- -- CoreTidy.tidyLetBndr too!
- --
- -- 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]
+ (toIfaceIdInfo (idInfo id))
+ -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr
+ -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn
--------------------------
-toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
+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 -> IfaceIdInfo
toIfaceIdInfo id_info
- = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
- inline_hsinfo, wrkr_hsinfo, unfold_hsinfo]
+ = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
+ inline_hsinfo, unfold_hsinfo] of
+ [] -> NoInfo
+ infos -> HasInfo infos
+ -- NB: strictness must appear in the list 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 (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+ , uf_src = src, uf_guidance = guidance })
+ = Just $ HsUnfold lb $
+ case src of
+ InlineStable
+ -> case guidance of
+ UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+ _other -> IfCoreUnfold True if_rhs
+ InlineWrapper w | isExternalName n -> IfExtWrapper arity n
+ | otherwise -> IfLclWrapper arity (getFS n)
+ where
+ n = idName w
+ InlineCompulsory -> IfCompulsory if_rhs
+ InlineRhs -> IfCoreUnfold False if_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!
+ where
+ if_rhs = toIfaceExpr rhs
+
+toIfUnfolding lb (DFunUnfolding _ar _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
coreRuleToIfaceRule mod (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs })
+ ru_args = args, ru_rhs = rhs,
+ ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
ifRuleArgs = map do_arg args,
ifRuleRhs = toIfaceExpr rhs,
+ ifRuleAuto = auto,
ifRuleOrph = orph }
where
-- For type args we must remove synonyms from the outermost
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
- ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
+ ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing, ifRuleAuto = True }
---------------------
toIfaceExpr :: CoreExpr -> IfaceExpr
---------------------
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
-toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
projects / ghc-hetmet.git / blobdiff