import TyCon
import DataCon
import Type
+import Coercion
import TcType
import InstEnv
import FamInstEnv
import UniqFM
import Unique
import Util hiding ( eqListBy )
-import FiniteMap
import FastString
import Maybes
import ListSetOps
import Control.Monad
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.IORef
import System.FilePath
\end{code}
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
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 ]
; if errorsFound dflags errs_and_warns
then return ( errs_and_warns, Nothing )
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
| 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)
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.
-- 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:
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.
+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)
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
(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 (fix_fn n)
- (map IfaceInstABI $ lookupOccEnvL inst_env n)
+ (map ifDFun $ lookupOccEnvL inst_env n)
[id_extras op | IfaceClassOp op _ _ <- sigs]
IfaceSyn{} -> IfaceSynExtras (fix_fn n)
_other -> IfaceOtherDeclExtras
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` []
| otherwise
= case nameModule_maybe name of
Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name)
- Just mod -> -- We use this fiddly lambda function rather than
- -- (++) as the argument to extendModuleEnv_C to
+ Just mod -> -- This lambda function is really just a
+ -- specialised (++); originally came about to
-- avoid quadratic behaviour (trac #2680)
- extendModuleEnv_C (\xs _ -> occ:xs) mv_map mod [occ]
+ 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
-> [(Module, [GenAvailInfo OccName])]
-- Group by module and sort by occurrence
mkIfaceExports exports
- = [ (mod, eltsFM avails)
+ = [ (mod, Map.elems avails)
| (mod, avails) <- sortBy (stableModuleCmp `on` fst)
(moduleEnvToList groupFM)
- -- NB. the fmToList is in a random order,
+ -- 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 )
= IfaceId { ifName = getOccName id,
ifType = toIfaceType (idType id),
ifIdDetails = toIfaceIdDetails (idDetails id),
- ifIdInfo = info }
- where
- info = case toIfaceIdInfo (idInfo id) of
- [] -> NoInfo
- items -> HasInfo items
+ 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
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 | isDefaultInlinePragma 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
--------------------------
toIfaceIdDetails :: IdDetails -> IfaceIdDetails
toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)
IfVanillaId -- Unexpected
-toIfaceIdInfo :: IdInfo -> [IfaceInfoItem]
+toIfaceIdInfo :: IdInfo -> IfaceIdInfo
toIfaceIdInfo id_info
- = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
- inline_hsinfo, unfold_hsinfo]
- -- NB: strictness must be before unfolding
+ = 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 --------------
--------------------------
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
-toIfUnfolding lb unf@(CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
- , uf_src = src, uf_guidance = guidance })
+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
+ , uf_src = src, uf_guidance = guidance })
= Just $ HsUnfold lb $
case src of
- InlineRule {}
+ InlineStable
-> 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)
+ 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 _con ops)
+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
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
projects / ghc-hetmet.git / blobdiff