------------------------------------
+ GHCI hacking
+ ------------------------------------
+
+* Don't forget to put deferred-type-decls back into RnIfaces
+
+* Do we want to record a package name in a .hi file?
+ Does pi_mod have a ModuleName or a Module?
+
+* Does teh finder
+
+ ------------------------------------
Mainly PredTypes (28 Sept 00)
------------------------------------
#include "HsVersions.h"
import OccName -- All of it
-import Module ( Module, moduleName, pprModule, mkVanillaModule,
+import Module ( Module, moduleName, mkVanillaModule,
isModuleInThisPackage )
import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc,
rdrNameModule )
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
-getOccString x = occNameString (getOccName x)
+getOccString = occNameString . getOccName
toRdrName = ifaceNameRdrName . getName
\end{code}
noUnfolding, mkOtherCon,
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
- hasUnfolding, hasSomeUnfolding,
+ hasUnfolding, hasSomeUnfolding, neverUnfold,
-- Seq stuff
seqRules, seqExpr, seqExprs, seqUnfolding,
-- Core rules
CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
+ IdCoreRule,
RuleName,
emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
isBuiltinRule
#include "HsVersions.h"
import CostCentre ( CostCentre, noCostCentre )
-import Var ( Var, Id, TyVar, isTyVar, isId, idType )
-import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType )
-import Literal ( Literal(MachStr), mkMachInt )
+import Var ( Var, Id, TyVar, isTyVar, isId )
+import Type ( Type, UsageAnn, mkTyVarTy, seqType )
+import Literal ( Literal, mkMachInt )
import DataCon ( DataCon, dataConId )
import VarSet
import Outputable
\begin{code}
type RuleName = FAST_STRING
+type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
data CoreRule
= Rule RuleName
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding other = True
+
+neverUnfold :: Unfolding -> Bool
+neverUnfold NoUnfolding = True
+neverUnfold (OtherCon _) = True
+neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
+neverUnfold other = False
\end{code}
type CoreArg = Arg CoreBndr
type CoreBind = Bind CoreBndr
type CoreAlt = Alt CoreBndr
-type CoreNote = Note
\end{code}
Binders are ``tagged'' with a \tr{t}:
import CoreSyn
import CoreUnfold ( noUnfolding )
import CoreLint ( beginPass, endPass )
-import Rules ( ProtoCoreRule(..), RuleBase )
import UsageSPInf ( doUsageSPInf )
import VarEnv
import VarSet
from the uniques for local thunks etc.]
\begin{code}
-tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase
- -> IO ([CoreBind], [ProtoCoreRule])
-tidyCorePgm dflags module_name binds_in rulebase_in
+tidyCorePgm :: DynFlags -> Module
+ -> [CoreBind] -> [IdCoreRule]
+ -> IO ([CoreBind], [IdCoreRule])
+tidyCorePgm dflags module_name binds_in orphans_in
= do
us <- mkSplitUniqSupply 'u'
let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name))
init_tidy_env binds_in1
- rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in)
+ orphans_out = tidyIdRules tidy_env1 orphans_in
endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags ||
dopt Opt_D_verbose_core2core dflags)
binds_out
- return (binds_out, rules_out)
+ return (binds_out, orphans_out)
where
-- We also make sure to avoid any exported binders. Consider
-- f{-u1-} = 1 -- Local decl
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
exportWithOrigOccName bndr]
- mk_local_protos :: RuleBase -> [ProtoCoreRule]
- mk_local_protos (rule_ids, _)
- = [ProtoCoreRule True id rule | id <- varSetElems rule_ids,
- rule <- rulesRules (idSpecialisation id)]
-
tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested
-> TidyEnv
-> CoreBind
| otherwise = info `setSpecInfo` tidyRules env rules
info3 = info2 `setUnfoldingInfo` noUnfolding
- info4 = info3 `setDemandInfo` wwLazy -- I don't understand why...
+ info4 = info3 `setDemandInfo` wwLazy
info5 = case workerInfo info of
NoWorker -> info4
HasWorker w a -> info4 `setWorkerInfo` HasWorker (tidyVarOcc env w) a
-tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule]
-tidyProtoRules env rules
- = [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule)
- | ProtoCoreRule is_local fn rule <- rules
- ]
+tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
+tidyIdRules env rules
+ = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ]
tidyRules :: TidyEnv -> CoreRules -> CoreRules
tidyRules env (Rules rules fvs)
mkOtherCon, otherCons,
unfoldingTemplate, maybeUnfoldingTemplate,
isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
- hasUnfolding, hasSomeUnfolding,
+ hasUnfolding, hasSomeUnfolding, neverUnfold,
couldBeSmallEnoughToInline,
certainlyWillInline,
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprIdBndr,
pprCoreBinding, pprCoreBindings,
- pprCoreRules, pprCoreRule
+ pprCoreRules, pprCoreRule, pprIdCoreRule
) where
#include "HsVersions.h"
pprCoreRules :: Id -> CoreRules -> SDoc
pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules)
+pprIdCoreRule :: IdCoreRule -> SDoc
+pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule
+
pprCoreRule :: SDoc -> CoreRule -> SDoc
pprCoreRule pp_fn (BuiltinRule _)
= ifPprDebug (ptext SLIT("A built in rule"))
import TcHsSyn ( TypecheckedRuleDecl )
import TcModule ( TcResults(..) )
import CoreSyn
-import Rules ( ProtoCoreRule(..), pprProtoCoreRule )
+import PprCore ( pprIdCoreRule )
import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
-> UniqSupply
-> HomeSymbolTable
-> TcResults
- -> IO ([CoreBind], RuleEnv, SDoc, SDoc, [CoreBndr])
+ -> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr])
deSugar dflags mod_name us hst
(TcResults {tc_env = global_val_env,
ppr_ds_rules [] = empty
ppr_ds_rules rules
= text "" $$ text "-------------- DESUGARED RULES -----------------" $$
- vcat (map pprProtoCoreRule rules)
+ vcat (map pprIdCoreRule rules)
\end{code}
%************************************************************************
\begin{code}
-dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule
+dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
- returnDs (ProtoCoreRule True {- local -} fn
- (Rule name tpl_vars args core_rhs))
+ returnDs (fn, Rule name tpl_vars args core_rhs)
where
tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
BangType(..), getBangType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
- isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
+ isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl,
getClassDeclSysNames
) where
import HsExpr ( HsExpr )
import HsTypes
import PprCore ( pprCoreRule )
-import HsCore ( UfExpr(UfVar), UfBinder, HsIdInfo, pprHsIdInfo,
- eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr
+import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
+ eq_ufBinders, eq_ufExpr, pprUfExpr
)
import CoreSyn ( CoreRule(..) )
import BasicTypes ( NewOrData(..) )
import CallConv ( CallConv, pprCallConv )
-import Name ( getName )
-- others:
import FunDeps ( pprFundeps )
import Class ( FunDep )
import CStrings ( CLabelString, pprCLabelString )
import Outputable
-import SrcLoc ( SrcLoc, noSrcLoc )
+import SrcLoc ( SrcLoc )
\end{code}
(MonoBinds name pat) -- default methods
(ClassDeclSysNames name)
SrcLoc
+\end{code}
+
+Simple classifiers
+
+\begin{code}
+isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+
+isIfaceSigDecl (IfaceSig _ _ _ _) = True
+isIfaceSigDecl other = False
+
+isSynDecl (TySynonym _ _ _ _) = True
+isSynDecl other = False
+
+isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
+isDataDecl other = False
+
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
+isClassDecl other = False
+\end{code}
+
+Dealing with names
+\begin{code}
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
\end{code}
\begin{code}
-isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
-
-isSynDecl (TySynonym _ _ _ _) = True
-isSynDecl other = False
-
-isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
-isDataDecl other = False
-
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
-isClassDecl other = False
-\end{code}
-
-\begin{code}
instance Ord name => Eq (TyClDecl name pat) where
-- Used only when building interface files
(==) (IfaceSig n1 t1 i1 _)
instance Outputable name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
-
-toHsRule id (BuiltinRule _)
- = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
-
-toHsRule id (Rule name bndrs args rhs)
- = IfaceRule name (map toUfBndr bndrs) (getName id)
- (map toUfExpr args) (toUfExpr rhs) noSrcLoc
-
-bogusIfaceRule id
- = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
import HsMatches
import HsPat
import HsTypes
-import HsCore
import BasicTypes ( Fixity, Version, NewOrData )
-- others:
)
import Rules ( RuleBase )
import VarSet ( TyVarSet )
-import VarEnv ( emptyVarEnv )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl )
import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
-import CoreSyn ( CoreRule )
+import CoreSyn ( CoreRule, IdCoreRule )
import Type ( Type )
import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
-- The next three fields are created by the typechecker
md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
- md_rules :: [(Id,CoreRule)] -- Domain may include Ids from other modules
+ md_rules :: [IdCoreRule] -- Domain may include Ids from other modules
}
\end{code}
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars )
import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars )
-import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline )
+import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold )
import Name ( isLocallyDefined, getName, nameModule,
Name, NamedThing(..),
plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts
completeModDetails :: ModDetails
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
-- code generator; they have authoritative arity info
- -> [ProtoCoreRule] -- Tidy orphan rules
+ -> [IdCoreRule] -- Tidy orphan rules
-> ModDetails
+completeModDetails mds tidy_binds stg_ids orphan_rules
+ = ModDetails {
+
+ where
+ dfun_ids = md_insts mds
+
+ final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
+ (mkVarSet stg_ids)
+ tidy_binds
+
+ rule_dcls | opt_OmitInterfacePragmas = []
+ | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
+
+ orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
+ | (_, rule) <- tidy_orphan_rules]
+
completeIface :: Maybe ModIface -- The old interface, if we have it
-> ModIface -- The new one, minus the decls and versions
-- The IO in the type is solely for debug output
-- In particular, dumping a record of what has changed
completeIface maybe_old_iface new_iface mod_details
- tidy_binds final_ids tidy_orphan_rules
- = let
- new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules
- in
- addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
-
-declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls
-declsFromDetails details tidy_binds final_ids tidy_orphan_rules
- = IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls,
- dcl_insts = inst_dcls,
- dcl_rules = rule_dcls }
- where
- dfun_ids = md_insts details
- inst_dcls = map ifaceInstance dfun_ids
- ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details)))
-
- (val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids)
- final_ids tidy_binds
-
- rule_dcls | opt_OmitInterfacePragmas = []
- | otherwise = ifaceRules tidy_orphan_rules emitted_ids
-
- orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule
- | ProtoCoreRule _ _ rule <- tidy_orphan_rules]
+ = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
+ where
+ new_decls = IfaceDecls { dcl_tycl = ty_cls_dcls,
+ dcl_insts = inst_dcls,
+ dcl_rules = rule_dcls }
+ inst_dcls = map ifaceInstance (mk_insts mds)
+ ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types details))
+ rule_dcls = map ifaceRule (md_rules details)
\end{code}
+
%************************************************************************
%* *
\subsection{Types and classes}
%************************************************************************
\begin{code}
-emitTyCls :: TyThing -> Bool
-emitTyCls (ATyCon tc) = True -- Could filter out wired in ones, but it's not
- -- strictly necessary, and it costs extra time
-emitTyCls (AClass cl) = True
-emitTyCls (AnId _) = False
-
-
ifaceTyCls :: TyThing -> RenamedTyClDecl
ifaceTyCls (AClass clas)
= ClassDecl (toHsContext sc_theta)
= ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label))
ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon)
+
+ifaceTyCls (AnId id)
+ = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc
+ where
+ id_type = idType id
+ id_info = idInfo id
+
+ hs_idinfo | opt_OmitInterfacePragmas = []
+ | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
+ strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
+
+ ------------ Arity --------------
+ arity_hsinfo = case arityInfo id_info of
+ a@(ArityExactly n) -> [HsArity a]
+ other -> []
+
+ ------------ Caf Info --------------
+ caf_hsinfo = case cafInfo id_info of
+ NoCafRefs -> [HsNoCafRefs]
+ otherwise -> []
+
+ ------------ CPR Info --------------
+ cpr_hsinfo = case cprInfo id_info of
+ ReturnsCPR -> [HsCprInfo]
+ NoCPRInfo -> []
+
+ ------------ Strictness --------------
+ strict_hsinfo = case strictnessInfo id_info of
+ NoStrictnessInfo -> []
+ info -> [HsStrictness info]
+
+
+ ------------ Worker --------------
+ wkr_hsinfo = case workerInfo id_info of
+ HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
+ NoWorker -> []
+
+ ------------ Unfolding --------------
+ unfold_info = unfoldInfo id_info
+ inine_prag = inlinePragInfo id_info
+ rhs = unfoldingTempate unfold_info
+ unfold_hsinfo | neverUnfold unfold_info = []
+ | otherwise = [HsUnfold inline_prag (toUfExpr rhs)]
\end{code}
-- instance Foo Tibble where ...
-- and this instance decl wouldn't get imported into a module
-- that mentioned T but not Tibble.
-\end{code}
-\begin{code}
-ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl]
-ifaceRules rules emitted
- = orphan_rules ++ local_rules
- where
- orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ]
- local_rules = [ toHsRule fn rule
- | fn <- varSetElems emitted,
- rule <- rulesRules (idSpecialisation fn),
- not (isBuiltinRule rule),
- -- We can't print builtin rules in interface files
- -- Since they are built in, an importing module
- -- will have access to them anyway
+ifaceRule (id, BuiltinRule _)
+ = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)
- -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
- -- from coming out, and to make it work properly we need to add ????
- -- (put it back in for now)
- all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
- -- Spit out a rule only if all its lhs free vars are emitted
- -- This is a good reason not to do it when we emit the Id itself
- ]
+ifaceRule (id, Rule name bndrs args rhs)
+ = IfaceRule name (map toUfBndr bndrs) (getName id)
+ (map toUfExpr args) (toUfExpr rhs) noSrcLoc
+
+bogusIfaceRule id
+ = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc
\end{code}
%************************************************************************
%* *
-\subsection{Value bindings}
+\subsection{Compute final Ids}
%* *
%************************************************************************
+A "final Id" has exactly the IdInfo for going into an interface file, or
+exporting to another module.
+
\begin{code}
-ifaceBinds :: IdSet -- These Ids are needed already
- -> [Id] -- Ids used at code-gen time; they have better pragma info!
+bindsToIds :: IdSet -- These Ids are needed already
+ -> IdSet -- Ids used at code-gen time; they have better pragma info!
-> [CoreBind] -- In dependency order, later depend on earlier
- -> (Bag RenamedIfaceSig, IdSet) -- Set of Ids actually spat out
+ -> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo
+ -- they need for exporting to another module
-ifaceBinds needed_ids final_ids binds
- = go needed_ids (reverse binds) emptyBag emptyVarSet
+bindsToIds needed_ids codegen_ids binds
+ = go needed_ids (reverse binds) []
-- Reverse so that later things will
-- provoke earlier ones to be emitted
where
- final_id_map = listToUFM [(id,id) | id <- final_ids]
- get_idinfo id = case lookupUFM final_id_map id of
- Just id' -> idInfo id'
- Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
- idInfo id
-
-- The 'needed' set contains the Ids that are needed by earlier
-- interface file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
go needed [] decls emitted
| not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:"
(sep (map ppr (varSetElems needed)))
- (decls, emitted)
- | otherwise = (decls, emitted)
+ emitted
+ | otherwise = emitted
- go needed (NonRec id rhs : binds) decls emitted
+ go needed (NonRec id rhs : binds) emitted
| need_id needed id
= if omitIfaceSigForId id then
- go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id)
+ go (needed `delVarSet` id) binds (id:emitted)
else
go ((needed `unionVarSet` extras) `delVarSet` id)
binds
- (decl `consBag` decls)
- (emitted `extendVarSet` id)
+ (new_id:emitted)
| otherwise
= go needed binds decls emitted
where
- (decl, extras) = ifaceId get_idinfo False id rhs
+ (new_id, extras) = mkFinalId codegen_ids False id rhs
-- Recursive groups are a bit more of a pain. We may only need one to
-- start with, but it may call out the next one, and so on. So we
-- because without -O we may only need the first one (if we don't emit
-- its unfolding)
go needed (Rec pairs : binds) decls emitted
- = go needed' binds decls' emitted'
+ = go needed' binds emitted'
where
- (new_decls, new_emitted, extras) = go_rec needed pairs
- decls' = new_decls `unionBags` decls
+ (new_emitted, extras) = go_rec needed pairs
needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs)
- emitted' = emitted `unionVarSet` new_emitted
+ emitted' = new_emitted ++ emitted
- go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RenamedIfaceSig, IdSet, IdSet)
+ go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet)
go_rec needed pairs
- | null decls = (emptyBag, emptyVarSet, emptyVarSet)
- | otherwise = (more_decls `unionBags` listToBag decls,
- more_emitted `unionVarSet` mkVarSet (map fst needed_prs),
- more_extras `unionVarSet` extras)
+ | null needed_prs = ([], emptyVarSet)
+ | otherwise = (emitted ++ more_emitted,
+ extras `unionVarSet` more_extras)
where
- (needed_prs,leftover_prs) = partition is_needed pairs
- (decls, extras_s) = unzip [ifaceId get_idinfo True id rhs
- | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
- extras = unionVarSets extras_s
- (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs
+ (needed_prs,leftover_prs) = partition is_needed pairs
+ (emitted, extras_s) = unzip [ mkFinalId codegen_ids True id rhs
+ | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)]
+ extras = unionVarSets extras_s
+ (more_emitted, more_extras) = go_rec extras leftover_prs
+
is_needed (id,_) = need_id needed id
\end{code}
+
\begin{code}
-ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
- -- by the STG passes. Sigh
- -> Bool -- True <=> recursive, so don't print unfolding
- -> Id
- -> CoreExpr -- The Id's right hand side
- -> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids
-
-ifaceId get_idinfo is_rec id rhs
- = (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids)
+mkFinalId :: IdSet -- The Ids with arity info from the code generator
+ -> Bool -- True <=> recursive, so don't include unfolding
+ -> Id
+ -> CoreExpr -- The Id's right hand side
+ -> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids
+
+mkFinalId codegen_ids is_rec id rhs
+ = (id `setIdInfo` new_idinfo, new_needed_ids)
where
id_type = idType id
core_idinfo = idInfo id
- stg_idinfo = get_idinfo id
+ stg_idinfo = case lookupVarSet codegen_ids id of
+ Just id' -> idInfo id'
+ Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
+ idInfo id
- hs_idinfo | opt_OmitInterfacePragmas = []
- | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
- strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
+ new_idinfo | opt_OmitInterfacePragmas
+ = vanillaIdInfo
+ | otherwise
+ = core_idinfo `setArityInfo` stg_arity_info
+ `setCafInfo` cafInfo stg_idinfo
+ `setUnfoldingInfo` unfold_info
+ `setWorkerInfo` worker_info
+ `setSpecInfo` emptyCoreRules
+ -- We zap the specialisations because they are
+ -- passed on separately through the modules IdCoreRules
------------ Arity --------------
- arity_info = arityInfo stg_idinfo
- stg_arity = arityLowerBound arity_info
- arity_hsinfo = case arityInfo stg_idinfo of
- a@(ArityExactly n) -> [HsArity a]
- other -> []
-
- ------------ Caf Info --------------
- caf_hsinfo = case cafInfo stg_idinfo of
- NoCafRefs -> [HsNoCafRefs]
- otherwise -> []
-
- ------------ CPR Info --------------
- cpr_hsinfo = case cprInfo core_idinfo of
- ReturnsCPR -> [HsCprInfo]
- NoCPRInfo -> []
-
- ------------ Strictness --------------
- strict_info = strictnessInfo core_idinfo
- bottoming_fn = isBottomingStrictness strict_info
- strict_hsinfo = case strict_info of
- NoStrictnessInfo -> []
- info -> [HsStrictness info]
-
+ stg_arity_info = arityInfo stg_idinfo
+ stg_arity = arityLowerBound arity_info
------------ Worker --------------
-- We only treat a function as having a worker if
-- top level lambdas are there" in interface files; but during the
-- compilation of this module it means "how many things can I apply
-- this to".
- work_info = workerInfo core_idinfo
- HasWorker work_id _ = work_info
+ worker_info = case workerInfo core_idinfo of
+ HasWorker work_id wrap_arity
+ | wrap_arity == stg_arity -> worker_info_in
+ | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
+ NoWorker
+ NoWorker -> NoWorker
- has_worker = case work_info of
- HasWorker work_id wrap_arity
- | wrap_arity == stg_arity -> True
- | otherwise -> pprTrace "ifaceId: arity change:" (ppr id)
- False
-
- other -> False
+ has_worker = case worker_info of
+ HasWorker _ _ -> True
+ other -> False
- wrkr_hsinfo | has_worker = [HsWorker (getName work_id)]
- | otherwise = []
+ HasWorker work_id _ = worker_info
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
dont_inline = isNeverInlinePrag inline_pragma
+ loop_breaker = isLoopBreaker (occInfo core_idinfo)
+ bottoming_fn = isBottomingStrictness (strictnessInfo core_idinfo)
- unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)]
- | otherwise = []
+ unfolding = mkTopUnfolding rhs
+ rhs_is_small = neverUnfold unfolding
+
+ unfold_info | show_unfold = unfolding
+ | otherwise = noUnfolding
show_unfold = not has_worker && -- Not unnecessary
not bottoming_fn && -- Not necessary
rhs_is_small && -- Small enough
okToUnfoldInHiFile rhs -- No casms etc
- rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs
-
- ------------ Specialisations --------------
- spec_info = specInfo core_idinfo
-
- ------------ Occ info --------------
- loop_breaker = isLoopBreaker (occInfo core_idinfo)
------------ Extra free Ids --------------
new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
unfold_ids `unionVarSet`
spec_ids
+ spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo))
+
worker_ids | has_worker && interestingId work_id = unitVarSet work_id
-- Conceivably, the worker might come from
-- another module
| otherwise = emptyVarSet
- spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info)
-
unfold_ids | show_unfold = find_fvs rhs
| otherwise = emptyVarSet
\end{code}
+\begin{code}
+getRules :: [IdCoreRule] -- Orphan rules
+ -> [CoreBind] -- Bindings, with rules in the top-level Ids
+ -> IdSet -- Ids that are exported, so we need their rules
+ -> [IdCoreRule]
+getRules orphan_rules binds emitted
+ = orphan_rules ++ local_rules
+ where
+ local_rules = [ (fn, rule)
+ | fn <- bindersOfBinds binds,
+ fn `elemVarSet` emitted,
+ rule <- rulesRules (idSpecialisation fn),
+ not (isBuiltinRule rule),
+ -- We can't print builtin rules in interface files
+ -- Since they are built in, an importing module
+ -- will have access to them anyway
+
+ -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
+ -- from coming out, and to make it work properly we need to add ????
+ -- (put it back in for now)
+ all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
+ -- Spit out a rule only if all its lhs free vars are emitted
+ -- This is a good reason not to do it when we emit the Id itself
+ ]
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Checking if the new interface is up to date
wrap_rdr = nameRdrName name
wrap_occ = rdrNameOcc wrap_rdr
+
mod = nameModule name
wrap_id = mkDataConWrapId data_con
RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl
)
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
- extractHsTyNames, extractHsCtxtTyNames,
+ extractHsTyNames,
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
import RnNames ( getGlobalNames )
-import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl )
+import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo,
- getInterfaceExports,
+ getInterfaceExports, closeDecls,
RecompileRequired, recompileRequired
)
import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs )
import RnEnv ( availName, availsToNameSet,
emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
- lookupOrigNames, lookupGlobalRn, newGlobalName,
- FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV
+ lookupOrigNames, lookupGlobalRn, newGlobalName
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
lookupModuleEnv
)
import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc,
- nameOccName, nameUnique, nameModule,
+ nameOccName, nameModule,
mkNameEnv, nameEnvElts, extendNameEnv
)
import OccName ( occNameFlavour )
-import Id ( idType )
-import TyCon ( isSynTyCon, getSynTyConDefn )
import NameSet
-import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon )
+import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
ioTyCon_RDR,
unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
eqString_RDR
)
-import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv )
-import Type ( namesOfType, funTyCon )
+import PrelInfo ( derivingOccurrences )
+import Type ( funTyCon )
import ErrUtils ( dumpIfSet )
import Bag ( bagToList )
import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM,
import Outputable
import IO ( openFile, IOMode(..) )
import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable,
- ModIface(..), TyThing(..), WhatsImported(..),
+ ModIface(..), WhatsImported(..),
VersionInfo(..), ImportVersion, IfaceDecls(..),
GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo,
Provenance(..), ImportReason(..), initialVersionInfo,
-> (Version, RdrNameTyClDecl)
-> RnMS (NameEnv Version, [RenamedTyClDecl])
loadHomeDecl (version_map, decls) (version, decl)
- = rnTyClDecl decl `thenRn` \ (decl', _) ->
+ = rnTyClDecl decl `thenRn` \ decl' ->
returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls)
------------------
loadHomeRules :: (Version, [RdrNameRuleDecl])
-> RnMS (Version, [RenamedRuleDecl])
loadHomeRules (version, rules)
- = mapAndUnzipRn rnRuleDecl rules `thenRn` \ (rules', _) ->
+ = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' ->
returnRn (version, rules')
------------------
loadHomeInsts :: [RdrNameInstDecl]
-> RnMS [RenamedInstDecl]
-loadHomeInsts insts = mapAndUnzipRn rnInstDecl insts `thenRn` \ (insts', _) ->
- returnRn insts'
+loadHomeInsts insts = mapRn rnInstDecl insts
------------------
loadHomeUsage :: ImportVersion OccName
-> ModIface -- Get the decls from here
-> IO (PersistentCompilerState, Bool, [RenamedHsDecl])
-- True <=> errors happened
-closeIfaceDecls dflags finder hit hst pcs mod
+closeIfaceDecls dflags finder hit hst pcs
mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls })
= initRn dflags finder hit hst pcs mod $
map InstD inst_decls ++
map TyClD tycl_decls
needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
- unionManyNameSets (map instDeclFVs rule_decls) `unionNameSets`
- unionManyNameSets (map tyClDeclFVs rule_decls)
+ unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
+ unionManyNameSets (map tyClDeclFVs tycl_decls)
in
closeDecls decls needed
\end{code}
\begin{code}
getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc
getRnStats imported_decls ifaces
- = hcat [text "Renamer stats: ", stats])
+ = hcat [text "Renamer stats: ", stats]
where
n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)]
_exports_
RnBinds rnBinds;
_declarations_
-1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, RnEnv.FreeVars)) -> RnMonad.RnMS (b, RnEnv.FreeVars) ;;
+1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;;
__interface RnBinds 1 0 where
__export RnBinds rnBinds;
-1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, RnEnv.FreeVars)) -> RnMonad.RnMS (b, RnEnv.FreeVars) ;
+1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;
\begin{code}
module RnBinds (
rnTopBinds, rnTopMonoBinds,
- rnMethodBinds, renameSigs,
+ rnMethodBinds, renameSigs, renameSigsFVs,
rnBinds,
unknownSigErr
) where
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn,
lookupGlobalOccRn, lookupSigOccRn,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
- FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV
)
import CmdLineOpts ( DynFlag(..) )
import Digraph ( stronglyConnComp, SCC(..) )
let
bndr_name_set = mkNameSet binder_names
in
- renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) ->
- doptRn Opt_WarnMissingSigs `thenRn` \ warnMissing ->
+ renameSigsFVs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) ->
+ doptRn Opt_WarnMissingSigs `thenRn` \ warnMissing ->
let
type_sig_vars = [n | Sig n _ _ <- siglist]
un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet
binder_set = mkNameSet new_mbinders
in
-- Rename the signatures
- renameSigs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) ->
+ renameSigsFVs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) ->
-- Report the fixity declarations in this group that
-- don't refer to any of the group's binders.
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
+renameSigsFVs ok_sig sigs
+ = renameSigs ok_sig sigs `thenRn` \ sigs' ->
+ returnRn (sigs', hsSigsFVs sigs')
+
renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
-> [RdrNameSig]
- -> RnMS ([RenamedSig], FreeVars)
+ -> RnMS [RenamedSig]
-renameSigs ok_sig []
- = returnRn ([], emptyFVs) -- Common shortcut
+renameSigs ok_sig [] = returnRn []
renameSigs ok_sig sigs
= -- Rename the signatures
(goods, bads) = partition ok_sig in_scope
in
mapRn_ unknownSigErr bads `thenRn_`
- returnRn (goods, hsSigFVs goods)
+ returnRn goods
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
Just name -> pushSrcLocRn loc $
addWarnRn (shadowedNameWarn rdr_name)
-bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
+bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
-- A specialised variant when renaming stuff from interface
-- files (of which there is a lot)
-- * one at a time
-- * no checks for shadowing
-- * always imported
-- * deal with free vars
-bindCoreLocalFVRn rdr_name enclosed_scope
+bindCoreLocalRn rdr_name enclosed_scope
= getSrcLocRn `thenRn` \ loc ->
getLocalNameEnv `thenRn` \ name_env ->
getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
new_name_env = extendRdrEnv name_env rdr_name name
in
- setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) ->
- returnRn (result, delFromNameSet fvs name)
+ setLocalNameEnv new_name_env (enclosed_scope name)
-bindCoreLocalsFVRn [] thing_inside = thing_inside []
-bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' ->
- bindCoreLocalsFVRn bs $ \ names' ->
- thing_inside (name':names')
+bindCoreLocalsRn [] thing_inside = thing_inside []
+bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' ->
+ bindCoreLocalsRn bs $ \ names' ->
+ thing_inside (name':names')
bindLocalNames names enclosed_scope
= getLocalNameEnv `thenRn` \ name_env ->
returnRn (thing, delListFromNameSet fvs names)
-------------------------------------
-bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars)
-bindUVarRn = bindLocalRn
+bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a
+bindUVarRn = bindCoreLocalRn
-------------------------------------
extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
extractHsTyRdrNames
)
-import BasicTypes ( Version )
+import BasicTypes ( Version, defaultFixity )
import RnEnv
import RnMonad
import ParseIface ( parseIface, IfaceStuff(..) )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule,
+ nameModule, isLocallyDefined,
NamedThing(..),
mkNameEnv, extendNameEnv
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
import SrcLoc ( mkSrcLoc, SrcLoc )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
plusFVs (map extractFunDepNames fds) `plusFV`
- plusFVs (map hsSigFVs sigs)
+ hsSigsFVs sigs
----------------
+hsSigsFVs sigs = plusFVs (map hsSigFVs sigs)
+
hsSigFVs (Sig v ty _) = extractHsTyNames ty `addOneFV` v
hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty
hsSigFVs (SpecSig v ty _) = extractHsTyNames ty `addOneFV` v
recordLocalSlurps,
mkImportInfo,
- slurpImpDecls,
+ slurpImpDecls, closeDecls,
RecompileRequired, outOfDate, upToDate, recompileRequired
)
import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
import HscTypes
-import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) )
+import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..),
+ InstDecl(..), HsType(..), hsTyVarNames, getBangType
+ )
import HsImpExp ( ImportDecl(..) )
-import BasicTypes ( Version, defaultFixity )
import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl )
+import RnHsSyn ( RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames, tyClDeclFVs )
import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface,
loadOrphanModules
)
import RnSource ( rnTyClDecl, rnDecl )
import RnEnv
import RnMonad
+import Id ( idType )
+import Type ( namesOfType )
+import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocallyDefined,
+ nameModule, isLocallyDefined, nameUnique,
NamedThing(..),
elemNameEnv
)
extendModuleEnv_C, lookupWithDefaultModuleEnv
)
import NameSet
-import PrelInfo ( wiredInThingEnv )
+import PrelInfo ( wiredInThingEnv, fractionalClassKeys )
+import TysWiredIn ( doubleTyCon )
import Maybes ( orElse )
import FiniteMap
import Outputable
rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
-rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)
+rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' ->
+ returnRn (decl', tyClDeclFVs decl')
\end{code}
addListToRdrEnv, rdrEnvToList, rdrEnvElts
)
import Name ( Name, OccName, NamedThing(..), getSrcLoc,
- isLocallyDefinedName, nameModule, nameOccName,
+ isLocallyDefinedName, nameOccName,
decode, mkLocalName, mkKnownKeyGlobal,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
extendNameEnvList
RnSource rnHsType rnHsSigType rnHsTypeFVs;
_declarations_
1 rnHsTypeFVs _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
+ -> RnMonad.RnMS (RnHsSyn.RenamedHsType, NameSet.FreeVars) ;;
2 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS RnHsSyn.RenamedHsType ;;
2 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
__interface RnSource 1 0 where
-__export RnSource rnHsType rnHsSigType rnHsPolyType;
-1 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
-1 rnHsSigType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
-1 rnHsPolyType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
- -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
+__export RnSource rnHsType rnHsSigType rnHsTypeFVs;
+1 rnHsTypeFVs :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS (RnHsSyn.RenamedHsType, NameSet.FreeVars) ;
+2 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS RnHsSyn.RenamedHsType ;
+2 rnHsSigType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS RnHsSyn.RenamedHsType ;
\section[RnSource]{Main pass of renamer}
\begin{code}
-module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, rnSourceDecls,
+module RnSource ( rnDecl, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls,
rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs
) where
import HsSyn
import HsTypes ( hsTyVarNames, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
-import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
+import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars
)
import RnHsSyn
import HsCore
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
+import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName,
lookupOrigNames, lookupSysBinder, newLocalsRn,
bindLocalsFVRn, bindUVarRn,
- bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
- bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames,
- checkDupOrQualNames, checkDupNames,
- FreeVars, emptyFVs, plusFV, plusFVs, unitFV,
- addOneFV, mapFvRn
+ bindTyVarsRn, bindTyVars2Rn,
+ bindTyVarsFV2Rn, extendTyVarEnvFVRn,
+ bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
+ checkDupOrQualNames, checkDupNames, mapFvRn
)
import RnMonad
returnRn (ValD new_binds, fvs)
rnDecl (TyClD tycl_decl)
- = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
- rnClassBinds new_decl `thenRn` \ (new_decl', fvs) ->
+ = rnTyClDecl tycl_decl `thenRn` \ new_decl ->
+ rnClassBinds tycl_decl new_decl `thenRn` \ (new_decl', fvs) ->
returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl')
rnDecl (InstD inst)
= rnInstDecl inst `thenRn` \ new_inst ->
- rnInstBinds new_inst `thenRn` \ (new_inst', fvs)
+ rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) ->
returnRn (InstD new_inst, fvs `plusFV` instDeclFVs new_inst')
rnDecl (RuleD rule)
= rnIfaceRuleDecl rule `thenRn` \ new_rule ->
returnRn (RuleD new_rule, ruleDeclFVs new_rule)
| otherwise
- = rnHsRuleDecl rule
+ = rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) ->
+ returnRn (RuleD new_rule, fvs)
rnDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
) `thenRn` \ maybe_dfun_name ->
-- The typechecker checks that all the bindings are for the right class.
- returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc)
- where
- meth_doc = text "the bindings in an instance declaration"
- meth_names = collectLocatedMonoBinders mbinds
+ returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
-- Compare rnClassBinds
rnInstBinds (InstDecl _ mbinds uprags _ _ )
- (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
+ (InstDecl inst_ty _ _ maybe_dfun_rdr_name src_loc)
= let
+ meth_doc = text "the bindings in an instance declaration"
+ meth_names = collectLocatedMonoBinders mbinds
inst_tyvars = case inst_ty of
HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
other -> []
--
-- But the (unqualified) method names are in scope
bindLocalNames binders (
- renameSigs (okInstDclSig binder_set) uprags
+ renameSigsFVs (okInstDclSig binder_set) uprags
) `thenRn` \ (uprags', prag_fvs) ->
returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc,
= pushSrcLocRn src_loc $
lookupOccRn fn `thenRn` \ fn' ->
rnCoreBndrs vars $ \ vars' ->
- mapFvRn rnCoreExpr args `thenRn` \ args' ->
+ mapRn rnCoreExpr args `thenRn` \ args' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc)
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
- mapFvRn rnConDecl condecls `thenRn` \ condecls' ->
+ mapRn rnConDecl condecls `thenRn` \ condecls' ->
lookupSysBinder gen_name1 `thenRn` \ name1' ->
lookupSysBinder gen_name2 `thenRn` \ name2' ->
rnDerivs derivings `thenRn` \ derivings' ->
-- The renamer *could* check this for class decls, but can't
-- for instance decls.
- returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' names' src_loc)
+ returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds names' src_loc)
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
- meth_doc = text "the default-methods for class" <+> ppr cname
rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn)
= pushSrcLocRn locn $
newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
+ where
+ meth_doc = text "the default-methods for class" <+> ppr cname
\end{code}
%*********************************************************
\begin{code}
-rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars)
+rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name])
rnDerivs Nothing -- derivs not specified
- = returnRn (Nothing, emptyFVs)
+ = returnRn Nothing
rnDerivs (Just clss)
= mapRn do_one clss `thenRn` \ clss' ->
- returnRn (Just clss', mkNameSet clss')
+ returnRn (Just clss')
where
do_one cls = lookupOccRn cls `thenRn` \ clas_name ->
checkRn (getUnique clas_name `elem` derivableClassKeys)
rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys)
-- Don't do lookupOccRn, because this is built-in syntax
-- so it doesn't need to be in scope
- = mapFvRn (rnHsType doc) tys `thenRn` \ tys' ->
+ = mapRn (rnHsType doc) tys `thenRn` \ tys' ->
returnRn (HsTupleTy (HsTupCon n' boxity) tys')
where
n' = tupleTyCon_name boxity (length tys)
returnRn (HsPredTy pred')
rnHsType doc (HsUsgForAllTy uv_rdr ty)
- = bindUVarRn doc uv_rdr $ \ uv_name ->
- rnHsType doc ty `thenRn` \ ty' ->
+ = bindUVarRn uv_rdr $ \ uv_name ->
+ rnHsType doc ty `thenRn` \ ty' ->
returnRn (HsUsgForAllTy uv_name ty')
rnHsType doc (HsUsgTy usg ty)
\begin{code}
rnForAll doc forall_tyvars ctxt ty
- = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
+ = bindTyVarsRn doc forall_tyvars $ \ new_tyvars ->
rnContext doc ctxt `thenRn` \ new_ctxt ->
rnHsType doc ty `thenRn` \ new_ty ->
returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty)
\end{code}
\begin{code}
-rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars)
+rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name]
rnFds doc fds
- = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) ->
- returnRn (theta, plusFVs fvs_s)
+ = mapRn rn_fds fds
where
rn_fds (tys1, tys2)
- = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) ->
- rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) ->
- returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2)
+ = rnHsTyVars doc tys1 `thenRn` \ tys1' ->
+ rnHsTyVars doc tys2 `thenRn` \ tys2' ->
+ returnRn (tys1', tys2')
-rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs
-rnHsTyvar doc tyvar
- = lookupOccRn tyvar `thenRn` \ tyvar' ->
- returnRn (tyvar', unitFV tyvar')
+rnHsTyVars doc tvs = mapRn (rnHsTyvar doc) tvs
+rnHsTyvar doc tyvar = lookupOccRn tyvar
\end{code}
%*********************************************************
rnCoreExpr (UfCase scrut bndr alts)
= rnCoreExpr scrut `thenRn` \ scrut' ->
- bindCoreLocalFVRn bndr $ \ bndr' ->
+ bindCoreLocalRn bndr $ \ bndr' ->
mapRn rnCoreAlt alts `thenRn` \ alts' ->
returnRn (UfCase scrut' bndr' alts')
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
= rnHsType doc ty `thenRn` \ ty' ->
- bindCoreLocalFVRn name ( \ name' ->
- thing_inside (UfValBinder name' ty')
- ) `thenRn` \ (result, fvs2) ->
- returnRn (result, fvs1 `plusFV` fvs2)
+ bindCoreLocalRn name $ \ name' ->
+ thing_inside (UfValBinder name' ty')
where
doc = text "unfolding id"
import CoreLint ( beginPass, endPass )
import CoreSyn
import CSE ( cseProgram )
-import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareLocalRuleBase,
- prepareOrphanRuleBase, unionRuleBase, localRule )
+import Rules ( RuleBase, extendRuleBaseList, addRuleBaseFVs )
import CoreUnfold
-import PprCore ( pprCoreBindings )
+import PprCore ( pprCoreBindings, pprCoreRulePair )
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( exprIsTrivial, etaReduceExpr, coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
\begin{code}
core2core :: DynFlags
+ -> PackageRuleBase -- Rule-base accumulated from imported packages
+ -> HomeSymbolTable
-> [CoreToDo] -- Spec of what core-to-core passes to do
-> [CoreBind] -- Binds in
- -> [ProtoCoreRule] -- Rules in
- -> IO ([CoreBind], RuleBase) -- binds, local orphan rules out
+ -> [IdCoreRule] -- Rules in
+ -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
-core2core dflags core_todos binds rules
+core2core dflags pkg_rule_base hst core_todos binds rules
= do
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
- let (local_rules, imported_rules) = partition localRule rules
+ -- COMPUTE THE RULE BASE TO USE
+ (rule_base, binds1, orphan_rules) <- prepareRules pkg_rule_base hst binds rules
- better_local_rules <- simplRules dflags ru_us local_rules binds
- let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules
- imported_rule_base = prepareOrphanRuleBase imported_rules
-
- -- Do the main business
- (stats, processed_binds, processed_local_rules)
- <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 local_rule_base
- imported_rule_base Nothing core_todos
+ -- DO THE BUSINESS
+ (stats, processed_binds)
+ <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 rule_base core_todos
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
-- Return results
-- We only return local orphan rules, i.e., local rules not attached to an Id
- return (processed_binds, processed_local_rules)
+ -- The bindings cotain more rules, embedded in the Ids
+ return (processed_binds, orphan_rules)
doCorePasses :: DynFlags
+ -> RuleBase -- the main rule base
-> SimplCount -- simplifier stats
-> UniqSupply -- uniques
-> [CoreBind] -- local binds in (with rules attached)
- -> RuleBase -- local orphan rules
- -> RuleBase -- imported and builtin rules
- -> Maybe RuleBase -- combined rulebase, or Nothing to ask for it to be rebuilt
-> [CoreToDo] -- which passes to do
- -> IO (SimplCount, [CoreBind], RuleBase) -- stats, binds, local orphan rules
+ -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
-doCorePasses dflags stats us binds lrb irb rb0 []
- = return (stats, binds, lrb)
+doCorePasses dflags rb stats us binds []
+ = return (stats, binds)
-doCorePasses dflags stats us binds lrb irb rb0 (to_do : to_dos)
+doCorePasses dflags rb stats us binds (to_do : to_dos)
= do
let (us1, us2) = splitUniqSupply us
- -- recompute rulebase if necessary
- let rb = maybe (irb `unionRuleBase` lrb) id rb0
-
- (stats1, binds1, mlrb1) <- doCorePass dflags us1 binds lrb rb to_do
+ (stats1, binds1, mlrb1) <- doCorePass dflags rb us1 binds to_do
- -- request rulebase recomputation if pass returned a new local rulebase
- let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1
+ doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
- doCorePasses dflags (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos
-
-doCorePass dfs us binds lrb rb (CoreDoSimplify sw_chkr)
+doCorePass dfs rb us binds (CoreDoSimplify sw_chkr)
= _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
-doCorePass dfs us binds lrb rb CoreCSE
+doCorePass dfs rb us binds CoreCSE
= _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
-doCorePass dfs us binds lrb rb CoreLiberateCase
+doCorePass dfs rb us binds CoreLiberateCase
= _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
-doCorePass dfs us binds lrb rb CoreDoFloatInwards
+doCorePass dfs rb us binds CoreDoFloatInwards
= _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
-doCorePass dfs us binds lrb rb (CoreDoFloatOutwards f)
+doCorePass dfs rb us binds (CoreDoFloatOutwards f)
= _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
-doCorePass dfs us binds lrb rb CoreDoStaticArgs
+doCorePass dfs rb us binds CoreDoStaticArgs
= _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
-doCorePass dfs us binds lrb rb CoreDoStrictness
+doCorePass dfs rb us binds CoreDoStrictness
= _scc_ "Stranal" noStats dfs (saBinds dfs binds)
-doCorePass dfs us binds lrb rb CoreDoWorkerWrapper
+doCorePass dfs rb us binds CoreDoWorkerWrapper
= _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
-doCorePass dfs us binds lrb rb CoreDoSpecialising
+doCorePass dfs rb us binds CoreDoSpecialising
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
-doCorePass dfs us binds lrb rb CoreDoCPResult
+doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
-doCorePass dfs us binds lrb rb CoreDoPrintCore
+doCorePass dfs us binds CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
-doCorePass dfs us binds lrb rb CoreDoUSPInf
- = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds lrb)
-doCorePass dfs us binds lrb rb CoreDoGlomBinds
+doCorePass dfs rb us binds CoreDoUSPInf
+ = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
+doCorePass dfs rb us binds CoreDoGlomBinds
= noStats dfs (glomBinds dfs binds)
printCore binds = do dumpIfSet True "Print Core"
return binds
-- most passes return no stats and don't change rules
-noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds, Nothing) }
+noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
\end{code}
%* *
%************************************************************************
-We must do some gentle simplification on the template (but not the RHS)
-of each rule. The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
- fold k z (build (/\a. g a)) ==> ...
-This doesn't match unless you do eta reduction on the build argument.
+-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
+-- It attaches those rules that are for local Ids to their binders, and
+-- returns the remainder attached to Ids in an IdSet. It also returns
+-- Ids mentioned on LHS of some rule; these should be blacklisted.
+
+-- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
+-- so that the opportunity to apply the rule isn't lost too soon
\begin{code}
-simplRules :: DynFlags -> UniqSupply -> [ProtoCoreRule] -> [CoreBind]
- -> IO [ProtoCoreRule]
-simplRules dflags us rules binds
- = do let (better_rules,_)
- = initSmpl dflags sw_chkr us bind_vars black_list_all
- (mapSmpl simplRule rules)
-
- dumpIfSet_dyn dflags Opt_D_dump_rules
- "Transformation rules"
- (vcat (map pprProtoCoreRule better_rules))
-
- return better_rules
+prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+ -> UniqSupply
+ -> [CoreBind] -> [IdCoreRule] -- Local bindings and rules
+ -> IO (RuleBase, -- Full rule base
+ [CoreBind], -- Bindings augmented with rules
+ [IdCoreRule]) -- Orphan rules
+
+prepareRules dflags pkg_rule_base hst us binds rules
+ = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
+ (mapSmpl simplRule rules)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat (map pprCoreRulePair better_rules))
+
+ ; let (local_id_rules, orphan_rules) = partition (`elemVarSet` local_ids . fst) better_rules
+ (binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules
+ imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
+ rule_base = extendRuleBaseList imp_rule_base orphan_rules
+ final_rule_base = addRuleBaseFVs rule_base local_rule_fvs
+ -- The last step black-lists the free vars of local rules too
+
+ ; return (rule_base, binds1, orphan_rules)
+ }
where
+ sw_chkr any = SwBool False -- A bit bogus
black_list_all v = not (isDataConWrapId v)
-- This stops all inlining except the
-- wrappers for data constructors
- sw_chkr any = SwBool False -- A bit bogus
+ add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
-- Boringly, we need to gather the in-scope set.
- -- Typically this thunk won't even be force, but the test in
- -- simpVar fails if it isn't right, and it might conceivably matter
- bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+ -- Typically this thunk won't even be forced, but the test in
+ -- simpVar fails if it isn't right, and it might conceiveably matter
+ local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
+
+addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], FreeVars)
+ -- A horrible function
+
+ -- Attach the rules for each locally-defined Id to that Id.
+ -- - This makes the rules easier to look up
+ -- - It means that transformation rules and specialisations for
+ -- locally defined Ids are handled uniformly
+ -- - It keeps alive things that are referred to only from a rule
+ -- (the occurrence analyser knows about rules attached to Ids)
+ -- - It makes sure that, when we apply a rule, the free vars
+ -- of the RHS are more likely to be in scope
+ --
+ -- The LHS and RHS Ids are marked 'no-discard'.
+ -- This means that the binding won't be discarded EVEN if the binding
+ -- ends up being trivial (v = w) -- the simplifier would usually just
+ -- substitute w for v throughout, but we don't apply the substitution to
+ -- the rules (maybe we should?), so this substitution would make the rule
+ -- bogus.
+
+addRulesToBinds binds imported_rule_base local_rules
+ = (map zap_bind binds, rule_lhs_fvs)
+ where
+ RuleBase rule_ids rule_lhs_fvs = extendRuleBaseList emptyRuleBase local_rules
+
+ imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
+
+ -- rule_fvs is the set of all variables mentioned in this module's rules
+ rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
+
+ zap_bind (NonRec b r) = NonRec (zap_bndr b) r
+ zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
+
+ zap_bndr bndr = case lookupVarSet rule_ids bndr of
+ Just bndr' -> setIdNoDiscard bndr'
+ Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
+ | otherwise -> bndr
+\end{code}
+
+We must do some gentle simplification on the template (but not the RHS)
+of each rule. The case that forced me to add this was the fold/build rule,
+which without simplification looked like:
+ fold k z (build (/\a. g a)) ==> ...
+This doesn't match unless you do eta reduction on the build argument.
-simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _))
+\begin{code}
+simplRule rule@(id, BuiltinRule _)
= returnSmpl rule
-simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
- | not is_local
- = returnSmpl rule -- No need to fiddle with imported rules
- | otherwise
+simplRule rule@(id, Rule name bndrs args rhs)
= simplBinders bndrs $ \ bndrs' ->
mapSmpl simpl_arg args `thenSmpl` \ args' ->
simplExpr rhs `thenSmpl` \ rhs' ->
- returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
+ returnSmpl (id, Rule name bndrs' args' rhs')
simpl_arg e
-- I've seen rules in which a LHS like
returnSmpl (etaReduceExpr e')
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Glomming}
+%* *
+%************************************************************************
+
\begin{code}
glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-- Glom all binds together in one Rec, in case any
-- just consumes output bandwidth
\end{code}
+
%************************************************************************
%* *
\subsection{The driver for the simplifier}
-> RuleBase
-> (SimplifierSwitch -> SwitchResult)
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings
+ -> [CoreBind] -- Input
+ -> IO (SimplCount, [CoreBind]) -- New bindings
simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs)
sw_chkr us binds
&& not (dopt Opt_D_dump_simpl_iterations dflags))
binds' ;
- return (counts_out, binds', Nothing)
+ return (counts_out, binds')
}
where
max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
\begin{code}
module Rules (
- RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList,
- prepareLocalRuleBase, prepareOrphanRuleBase,
- unionRuleBase, lookupRule, addRule, addIdSpecialisations,
- ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase,
- localRule, orphanRule
+ RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, pprRuleBase,
+ addRuleBaseFVs,
+
+ lookupRule, addRule, addIdSpecialisations
) where
#include "HsVersions.h"
import CoreSyn -- All of it
import OccurAnal ( occurAnalyseRule )
-import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
+import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleSomeLhsFreeVars )
import CoreUnfold ( isCheapUnfolding, unfoldingTemplate )
import CoreUtils ( eqExpr )
import PprCore ( pprCoreRule )
bindSubstList, unBindSubstList, substInScope, uniqAway
)
import Id ( Id, idUnfolding, zapLamIdInfo,
- idSpecialisation, setIdSpecialisation,
- setIdNoDiscard
+ idSpecialisation, setIdSpecialisation
)
-import Name ( isLocallyDefined )
import Var ( isTyVar, isId )
import VarSet
import VarEnv
import Type ( mkTyVarTy )
import qualified Unify ( match )
-import UniqFM
import Outputable
import Maybes ( maybeToBool )
import Util ( sortLt )
Nothing -> Nothing
eta_complete other vars = Nothing
--}
zapOccInfo bndr | isTyVar bndr = bndr
| otherwise = zapLamIdInfo bndr
+-}
\end{code}
\begin{code}
%************************************************************************
\begin{code}
-data ProtoCoreRule
- = ProtoCoreRule
- Bool -- True <=> this rule was defined in this module,
- Id -- What Id is it for
- CoreRule -- The rule itself
-
-
-pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (ppr fn) rule
-
lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
lookupRule in_scope fn args
= case idSpecialisation fn of
Rules rules _ -> matchRules in_scope rules args
-
-localRule :: ProtoCoreRule -> Bool
-localRule (ProtoCoreRule local _ _) = local
-
-orphanRule :: ProtoCoreRule -> Bool
--- An "orphan rule" is one that is defined in this
--- module, but for an *imported* function. We need
--- to track these separately when generating the interface file
-orphanRule (ProtoCoreRule local fn _)
- = local && not (isLocallyDefined fn)
\end{code}
IdSet -- Ids (whether local or imported) mentioned on
-- LHS of some rule; these should be black listed
+ -- This representation is a bit cute, and I wonder if we should
+ -- change it to use (IdEnv CoreRule) which seems a bit more natural
+
emptyRuleBase = RuleBase emptyVarSet emptyVarSet
+addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase
+addRuleBaseFVs (RuleBase rules fvs) extra_fvs
+ = RuleBase rules (fvs `unionVarSet` extra_fvs)
+
extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase
extendRuleBaseList rule_base new_guys
= foldl extendRuleBase rule_base new_guys
-- Find *all* the free Ids of the LHS, not just
-- locally defined ones!!
-unionRuleBase (RuleBase rule_ids1 black_ids1) (RuleBase rule_ids2 black_ids2)
- = RuleBase (plusUFM_C merge_rules rule_ids1 rule_ids2)
- (unionVarSet black_ids1 black_ids2)
- where
-
-merge_rules id1 id2 = let rules1 = idSpecialisation id1
- rules2 = idSpecialisation id2
- new_rules = foldl (addRule id1) rules1 (rulesRules rules2)
- in
- setIdSpecialisation id1 new_rules
-
pprRuleBase :: RuleBase -> SDoc
pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs
| id <- varSetElems rules,
rs <- rulesRules $ idSpecialisation id ]
-
--- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
--- It attaches those rules that are for local Ids to their binders, and
--- returns the remainder attached to Ids in an IdSet. It also returns
--- Ids mentioned on LHS of some rule; these should be blacklisted.
-
--- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
--- so that the opportunity to apply the rule isn't lost too soon
-
-prepareLocalRuleBase :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], RuleBase)
-prepareLocalRuleBase binds local_rules
- = error "urk"
-{-
- = (map zap_bind binds, RuleBase imported_id_rule_ids rule_lhs_fvs)
- where
- RuleBase rule_ids rule_lhs_fvs = extendRuleBaseList emptyRuleBase local_rules
- imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids
-
- -- rule_fvs is the set of all variables mentioned in this module's rules
- rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids
-
- -- Attach the rules for each locally-defined Id to that Id.
- -- - This makes the rules easier to look up
- -- - It means that transformation rules and specialisations for
- -- locally defined Ids are handled uniformly
- -- - It keeps alive things that are referred to only from a rule
- -- (the occurrence analyser knows about rules attached to Ids)
- -- - It makes sure that, when we apply a rule, the free vars
- -- of the RHS are more likely to be in scope
- --
- -- The LHS and RHS Ids are marked 'no-discard'.
- -- This means that the binding won't be discarded EVEN if the binding
- -- ends up being trivial (v = w) -- the simplifier would usually just
- -- substitute w for v throughout, but we don't apply the substitution to
- -- the rules (maybe we should?), so this substitution would make the rule
- -- bogus.
- zap_bind (NonRec b r) = NonRec (zap_bndr b) r
- zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
-
- zap_bndr bndr = case lookupVarSet rule_ids bndr of
- Just bndr' -> setIdNoDiscard bndr'
- Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
- | otherwise -> bndr
--}
-
-addRuleToId id rule = setIdSpecialisation id (addRule (idSpecialisation id) id rule)
-
--- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that
--- it assumes that none of the rules can be attached to local Ids.
-
-prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase
-prepareOrphanRuleBase imported_rules
- = error "urk"
-{-
- = foldr add_rule emptyRuleBase imported_rules
--}
\end{code}
#include "HsVersions.h"
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
- HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+ HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassDecl, isClassOpSig, isPragSig,
getClassDeclSysNames, tyClDeclName
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
-import Class ( classTyVars, classBigSig, classSelIds, classTyCon,
- Class, ClassOpItem, DefMeth (..) )
+import Class ( classTyVars, classBigSig, classSelIds, classTyCon, classTvsFds,
+ Class, ClassOpItem, DefMeth (..), FunDep )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
import Outputable
-import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred,
+import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
splitTyConApp_maybe, isTyVarTy
)
import Var ( TyVar )
tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig rec_env tyvar_names clas tyvars fds dm_info)
+ mapTc (tcClassSig rec_env clas tyvars fds dm_info)
op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
tcClassSig :: TcEnv -- Knot tying only!
- -> [HsTyVarBndr Name] -- From the declaration, for error messages
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> [FunDep TyVar]
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure.
-tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info
+tcClassSig rec_env clas clas_tyvars fds dm_info
(ClassOpSig op_name maybe_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
tcHsSigType op_ty `thenTc` \ local_ty ->
let
- theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
- global_ty = mkSigmaTy clas_tyvars theta local_ty
+ theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
+ in
+ -- Check for ambiguous class op types
+ checkAmbiguity True clas_tyvars theta local_ty `thenTc` \ global_ty ->
+ let
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id)
where
dm_id = mkDefaultMethodId dm_name clas global_ty
-
- full_hs_ty = HsForAllTy (Just tyvar_names) op_ty
in
- -- Check for ambiguous class op types
- checkAmbiguity full_ty clas_tyvars theta local_ty `thenRn_`
-
-- Check that for a generic method, the type of
-- the method is sufficiently simple
checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty)
import CmdLineOpts ( DynFlag(..), DynFlags )
import TcMonad
-import TcEnv ( TcEnv, tcSetInstEnv, newDFunName )
+import TcEnv ( TcEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo )
import TcGenDeriv -- Deriv stuff
-import InstEnv ( InstInfo(..), InstEnv,
- pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
+import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars,
getTcGST, getTcGEnv,
- -- Instance environment
+ -- Instance environment, and InstInfo type
tcGetInstEnv, tcSetInstEnv,
+ InstInfo(..), pprInstInfo,
+ simpleInstInfoTy, simpleInstInfoTyCon, isLocalInst,
-- Global environment
tcExtendGlobalEnv, tcExtendGlobalValEnv,
#include "HsVersions.h"
+import RnHsSyn ( RenamedMonoBinds, RenamedSig )
import TcMonad
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType,
tcInstTyVars, zonkTcTyVars,
)
-import Id ( mkUserLocal, isDataConWrapId_maybe )
+import Id ( idName, mkUserLocal, isDataConWrapId_maybe )
import IdInfo ( vanillaIdInfo )
import MkId ( mkSpecPragmaId )
import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import VarSet
-import Type ( Type,
+import Type ( Type, ThetaType,
tyVarsOfTypes,
splitForAllTys, splitRhoTy,
- getDFunTyKey
+ getDFunTyKey, splitTyConApp_maybe
)
import DataCon ( DataCon )
import TyCon ( TyCon )
import Subst ( substTy )
import Name ( Name, OccName, NamedThing(..),
nameOccName, nameModule, getSrcLoc, mkGlobalName,
- isLocallyDefined,
+ isLocallyDefined, nameModule,
NameEnv, lookupNameEnv, nameEnvElts,
extendNameEnvList, emptyNameEnv
)
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
+import HscTypes ( DFunId )
import Module ( Module )
-import HscTypes ( InstEnv, lookupTypeEnv, TyThing(..),
- GlobalSymbolTable )
+import InstEnv ( InstEnv, emptyInstEnv )
+import HscTypes ( lookupTypeEnv, TyThing(..), GlobalSymbolTable )
import Util ( zipEqual )
import SrcLoc ( SrcLoc )
import Outputable
-import InstEnv ( emptyInstEnv )
import IOExts ( newIORef )
\end{code}
%************************************************************************
%* *
+\subsection{The InstInfo type}
+%* *
+%************************************************************************
+
+The InstInfo type summarises the information in an instance declaration
+
+ instance c => k (t tvs) where b
+
+\begin{code}
+data InstInfo
+ = InstInfo {
+ iClass :: Class, -- Class, k
+ iTyVars :: [TyVar], -- Type variables, tvs
+ iTys :: [Type], -- The types at which the class is being instantiated
+ iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
+ -- instance declaration. It constrains (some of)
+ -- the TyVars above
+ iLocal :: Bool, -- True <=> it's defined in this module
+ iDFunId :: DFunId, -- The dfun id
+ iBinds :: RenamedMonoBinds, -- Bindings, b
+ iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn
+ iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
+ }
+
+pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
+ nest 4 (ppr (iBinds info))]
+
+simpleInstInfoTy :: InstInfo -> Type
+simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
+
+simpleInstInfoTyCon :: InstInfo -> TyCon
+ -- Gets the type constructor for a simple instance declaration,
+ -- i.e. one of the form instance (...) => C (T a b c) where ...
+simpleInstInfoTyCon inst
+ = case splitTyConApp_maybe (simpleInstInfoTy inst) of
+ Just (tycon, _) -> tycon
+
+isLocalInst :: Module -> InstInfo -> Bool
+isLocalInst mod info = mod == nameModule (idName (iDFunId info))
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Errors}
%* *
%************************************************************************
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
+ InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
newDFunName, tcExtendTyVarEnv
)
-import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
- simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
- extendInstEnv )
+import InstEnv ( InstEnv, classDataCon, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
-- The result of (b) replaces the cached InstEnv in the PCS
let
(local_inst_info, imported_inst_info)
- = partition isLocalInst (concat inst_infos)
+ = partition (isLocalInst mod) (concat inst_infos)
imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId)
imported_inst_info
methodCtxt = ptext SLIT("When checking the methods of an instance declaration")
superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")
\end{code}
+
+
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
-import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcLookupGlobal_maybe,
+import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookupGlobal_maybe,
tcEnvTyCons, tcEnvClasses,
tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import InstEnv ( InstInfo(..) )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
import Bag ( isEmptyBag )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable,
- PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..),
+ PackageSymbolTable, DFunId, ModIface(..),
TypeEnv, extendTypeEnv, lookupTable,
TyThing(..), groupTyThings )
import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM )
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
- tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
- tcRules (pcs_rules pcs) decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
+ tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+ tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
+ tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) ->
-- Deal with constant or ambiguous InstIds. How could
-- there be ambiguous ones? They can only arise if a
tc_binds = all_binds',
tc_insts = map iDFunId local_inst_info,
tc_fords = foi_decls ++ foe_decls',
- tc_rules = rules'
+ tc_rules = local_rules'
})
get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
tcHsTyVars tv_names kind_check $ \ tyvars ->
tcContext ctxt `thenTc` \ theta ->
tcHsType ty `thenTc` \ tau ->
- checkAmbiguity full_ty tyvars theta tau `thenTc_`
- returnTc (mkSigmaTy tyvars theta tau)
+ checkAmbiguity is_source tyvars theta tau
+ where
+ is_source = case tv_names of
+ (UserTyVar _ : _) -> True
+ other -> False
-checkAmbiguity :: RenamedHsType -> [TyVar] -> ThetaType -> Type -> TcM ()
+checkAmbiguity :: Bool -> [TyVar] -> ThetaType -> Type -> TcM Type
-- Check for ambiguity
-- forall V. P => tau
-- is ambiguous if P contains generic variables
-- even in a scope where b is in scope.
-- This is the is_free test below.
-checkAmbiguity full_ty forall_tyvars theta tau
- = mapTc_ check_pred theta
- where
- tau_vars = tyVarsOfType tau
- fds = instFunDepsOfTheta theta
- tvFundep = tyVarFunDep fds
- extended_tau_vars = oclose tvFundep tau_vars
-
- is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
- not (ct_var `elemUFM` extended_tau_vars)
- is_free ct_var = not (ct_var `elem` forall_tyvars)
-
- check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_`
- checkTc (not all_free) (freeErr pred full_ty)
- where
- ct_vars = varSetElems (tyVarsOfPred pred)
- all_free = all is_free ct_vars
- any_ambig = is_source_polytype && any is_ambig ct_vars
-
-- Notes on the 'is_source_polytype' test above
-- Check ambiguity only for source-program types, not
-- for types coming from inteface files. The latter can
-- If the list of tv_names is empty, we have a monotype,
-- and then we don't need to check for ambiguity either,
-- because the test can't fail (see is_ambig).
- is_source_polytype
- = case full_ty of
- HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True
- other -> False
+
+checkAmbiguity is_source_polytype forall_tyvars theta tau
+ = mapTc_ check_pred theta `thenTc_`
+ returnTc sigma_ty
+ where
+ sigma_ty = mkSigmaTy forall_tyvars theta tau
+ tau_vars = tyVarsOfType tau
+ fds = instFunDepsOfTheta theta
+ tvFundep = tyVarFunDep fds
+ extended_tau_vars = oclose tvFundep tau_vars
+
+ is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemUFM` extended_tau_vars)
+ is_free ct_var = not (ct_var `elem` forall_tyvars)
+
+ check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_`
+ checkTc (not all_free) (freeErr pred sigma_ty)
+ where
+ ct_vars = varSetElems (tyVarsOfPred pred)
+ all_free = all is_free ct_vars
+ any_ambig = is_source_polytype && any is_ambig ct_vars
\end{code}
Help functions for type applications
#include "HsVersions.h"
-import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), isIfaceRuleDecl )
+import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) )
import CoreSyn ( CoreRule(..) )
import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl )
-import HscTypes ( PackageRuleEnv )
+import HscTypes ( PackageRuleBase )
import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
import TcMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
import TcExpr ( tcExpr )
import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv )
import Rules ( extendRuleBase )
-import Inst ( LIE, plusLIEs, instToId )
+import Inst ( LIE, emptyLIE, plusLIEs, instToId )
import Id ( idType, idName, mkVanillaId )
-import Name ( Name, extendNameEnvList )
+import Name ( nameModule )
+import Module ( Module )
import VarSet
import Type ( tyVarsOfTypes, openTypeKind )
import Bag ( bagToList )
\end{code}
\begin{code}
-tcRules :: PackageRuleEnv -> [RenamedHsDecl] -> TcM (PackageRuleEnv, LIE, [TypecheckedRuleDecl])
-tcRules pkg_rule_env decls
- = mapAndUnzipTc tcLocalRule local_rules `thenTc` \ (lies, new_local_rules) ->
- mapTc tcIfaceRule imported_rules `thenTc` \ new_imported_rules ->
- returnTc (extendRuleBaseList pkg_rule_env new_imported_rules,
- plusLIEs lies, new_local_rules)
+tcRules :: PackageRuleBase -> Module -> [RenamedHsDecl]
+ -> TcM (PackageRuleBase, LIE, [TypecheckedRuleDecl])
+tcRules pkg_rule_base mod decls
+ = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, new_rules) ->
+ let
+ (local_rules, imported_rules) = partition is_local new_rules
+ new_rule_base = foldl add pkg_rule_base imported_rules
+ in
+ returnTc (new_rule_base, plusLIEs lies, local_rules)
where
- rule_decls = [rule | RuleD rule <- decls]
- (imported_rules, local_rules) = partition isIfaceRuleDecl rule_decls
+ add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
+
+ -- When relinking this module from its interface-file decls
+ -- we'll have IfaceRules that are in fact local to this module
+ is_local (IfaceRuleOut n _) = mod == nameModule (idName n)
+ is_local other = True
-tcIfaceRule :: RenamedRuleDecl -> TcM (Id, CoreRule)
+tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl)
-- No zonking necessary!
-tcIfaceRule (IfaceRule name vars fun args rhs src_loc)
+tcRule (IfaceRule name vars fun args rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
tcVar fun `thenTc` \ fun' ->
tcCoreLamBndrs vars $ \ vars' ->
mapTc tcCoreExpr args `thenTc` \ args' ->
tcCoreExpr rhs `thenTc` \ rhs' ->
- returnTc (fun', Rule name vars' args' rhs')
+ returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs'))
-tcLocalRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl)
-tcLocalRule (HsRule name sig_tvs vars lhs rhs src_loc)
+tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
#include "HsVersions.h"
import HsSyn ( HsDecl(..), TyClDecl(..),
- HsType(..), HsTyVarBndr,
- ConDecl(..), ConDetails(..),
- Sig(..), HsPred(..), HsTupCon(..),
- tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
+ HsTyVarBndr,
+ ConDecl(..),
+ Sig(..), HsPred(..),
+ tyClDeclName, hsTyVarNames,
+ isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
)
-import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
+import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs )
import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonad
import Var ( varName )
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
-import Name ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
- mkNameEnv, lookupNameEnv_NF
+import Name ( Name, NamedThing(..), NameEnv, getSrcLoc,
+ mkNameEnv, lookupNameEnv_NF, isTyVarName
)
+import NameSet
import Outputable
-import Maybes ( mapMaybe, catMaybes )
-import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets,
- unionManyUniqSets, uniqSetToList )
+import Maybes ( mapMaybe )
import ErrUtils ( Message )
-import Unique ( Unique, Uniquable(..) )
import HsDecls ( getClassDeclSysNames )
import Generics ( mkTyConGenInfo )
import CmdLineOpts ( DynFlags )
sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
sortByDependency decls
= let -- CHECK FOR CLASS CYCLES
- cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
+ cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls)
cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
in
checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
in
returnTc decl_sccs
where
- tycl_decls = [d | TyClD d <- decls]
- edges = map mk_edges tycl_decls
+ tycl_decls = [d | TyClD d <- decls, not (isIfaceSigDecl d)]
+ edges = map mkEdges tycl_decls
is_syn_decl (d, _, _) = isSynDecl d
\end{code}
~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
+tyClDeclFTVs :: RenamedTyClDecl -> [Name]
+tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d)
+ where
+ add n fvs | isTyVarName n = fvs
+ | otherwise = n : fvs
+
----------------------------------------------------
-- mk_cls_edges looks only at the context of class decls
-- Its used when we are figuring out if there's a cycle in the
-- superclass hierarchy
-mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
-
-mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _)
- = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
-mk_cls_edges other_decl
- = Nothing
-
-----------------------------------------------------
-mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
-
-mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _)
- = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
- get_cons condecls `unionUniqSets`
- get_deriv derivs))
-
-mk_edges decl@(TySynonym name _ rhs _)
- = (decl, getUnique name, uniqSetToList (get_ty rhs))
-
-mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _)
- = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
- get_sigs sigs))
+mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
+mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt])
+mkClassEdges other_decl = Nothing
----------------------------------------------------
-get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
-get_clas (HsPClass clas _) = Just clas
-get_clas _ = Nothing
-
-----------------------------------------------------
-get_deriv Nothing = emptyUniqSet
-get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
-
-----------------------------------------------------
-get_cons cons = unionManyUniqSets (map get_con cons)
-
-----------------------------------------------------
-get_con (ConDecl _ _ _ ctxt details _)
- = get_ctxt ctxt `unionUniqSets` get_con_details details
-
-----------------------------------------------------
-get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys)
-get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys)
-
-----------------------------------------------------
-get_bty bty = get_ty (getBangType bty)
-
-----------------------------------------------------
-get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet
- | otherwise = set_name name
-get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty
-get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
-get_ty (HsUsgTy _ ty) = get_ty ty
-get_ty (HsUsgForAllTy _ ty) = get_ty ty
-get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty
-get_ty (HsPredTy (HsPClass name _)) = set_name name
-get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think
-
-----------------------------------------------------
-get_tys tys = unionManyUniqSets (map get_ty tys)
-
-----------------------------------------------------
-get_sigs sigs
- = unionManyUniqSets (map get_sig sigs)
- where
- get_sig (ClassOpSig _ _ ty _) = get_ty ty
- get_sig (FixSig _) = emptyUniqSet
- get_sig other = panic "TcTyClsDecls:get_sig"
-
-----------------------------------------------------
-set_name name = unitUniqSet (getUnique name)
+mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
+mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl)
\end{code}
\begin{code}
module InstEnv (
- InstInfo(..), pprInstInfo,
- simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon,
-
-- Instance environment
InstEnv, emptyInstEnv, extendInstEnv,
lookupInstEnv, InstLookupResult(..),
- classInstEnv, classDataCon,
-
- isLocalInst
+ classInstEnv, classDataCon, simpleDFunClassTyCon
) where
#include "HsVersions.h"
-import RnHsSyn ( RenamedMonoBinds, RenamedSig )
-
import HscTypes ( InstEnv, ClsInstEnv, DFunId )
import Class ( Class )
-import Var ( TyVar, Id )
+import Var ( Id )
import VarSet ( unionVarSet, mkVarSet )
import VarEnv ( TyVarSubstEnv )
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
import Name ( getSrcLoc )
-import SrcLoc ( SrcLoc )
-import Type ( Type, ThetaType, splitTyConApp_maybe,
+import Type ( Type, splitTyConApp_maybe,
splitSigmaTy, splitDFunTy, tyVarsOfTypes
)
import PprType ( )
-%************************************************************************
-%* *
-\subsection{The InstInfo type}
-%* *
-%************************************************************************
-
-The InstInfo type summarises the information in an instance declaration
-
- instance c => k (t tvs) where b
-
-\begin{code}
-data InstInfo
- = InstInfo {
- iClass :: Class, -- Class, k
- iTyVars :: [TyVar], -- Type variables, tvs
- iTys :: [Type], -- The types at which the class is being instantiated
- iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
- -- instance declaration. It constrains (some of)
- -- the TyVars above
- iLocal :: Bool, -- True <=> it's defined in this module
- iDFunId :: DFunId, -- The dfun id
- iBinds :: RenamedMonoBinds, -- Bindings, b
- iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn
- iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
- }
-
-pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
- nest 4 (ppr (iBinds info))]
-
-simpleInstInfoTy :: InstInfo -> Type
-simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
-
-simpleInstInfoTyCon :: InstInfo -> TyCon
- -- Gets the type constructor for a simple instance declaration,
- -- i.e. one of the form instance (...) => C (T a b c) where ...
-simpleInstInfoTyCon inst
- = case splitTyConApp_maybe (simpleInstInfoTy inst) of
- Just (tycon, _) -> tycon
-
-isLocalInst :: InstInfo -> Bool
-isLocalInst info = iLocal info
-\end{code}
-
-
A tiny function which doesn't belong anywhere else.
It makes a nasty mutual-recursion knot if you put it in Class.
doUsageSPInf :: DynFlags
-> UniqSupply
-> [CoreBind]
- -> RuleBase
-> IO [CoreBind]
-doUsageSPInf dflags us binds local_rules
+doUsageSPInf dflags us binds
| not opt_UsageSPOn
= do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ;
return binds
projects / ghc-hetmet.git / commitdiff