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}
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
-- 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:
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"
| 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 -> -- We use this fiddly lambda function rather than
- -- (++) as the argument to extendModuleEnv_C to
+ 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)
- 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 )
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
--------------------------
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)
+ UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
+ _other -> IfCoreUnfold True if_rhs
InlineWrapper w -> IfWrapper arity (idName w)
- InlineCompulsory -> IfCompulsory (toIfaceExpr rhs)
- InlineRhs -> IfCoreUnfold (toIfaceExpr rhs)
+ 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