import LoadIface
import Id
import IdInfo
-import NewDemand
+import Demand
import Annotations
import CoreSyn
import CoreFVs
import TyCon
import DataCon
import Type
+import Coercion
import TcType
import InstEnv
import FamInstEnv
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 Control.Monad
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.IORef
import System.FilePath
\end{code}
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
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
-- 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 an IfaceDecl
+%* *
+%************************************************************************
+
+Note [The ABI of an IfaceDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ABI of a declaration consists of:
--- 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
+ (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 Fixity [IfaceInstABI] [(Fixity,[IfaceRule])]
- | IfaceSynExtras Fixity
- | IfaceOtherDeclExtras
-
freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
freeNamesDeclExtras (IfaceIdExtras _ rules)
= unionManyNameSets (map freeNamesIfRule rules)
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
= 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 -> -- 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
toIfaceIdInfo id_info
= catMaybes [arity_hsinfo, caf_hsinfo, strict_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
--------------------------
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!
+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 -> IfWrapper arity (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
- vanilla_unfold = Just (HsUnfold lb (IfCoreUnfold (toIfaceExpr rhs)))
+ 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
+
toIfUnfolding _ _
= Nothing