-> UniqSupply
-> HomeSymbolTable
-> TcResults
- -> IO ([CoreBind], [ProtoCoreRule], SDoc, SDoc, [CoreBndr])
+ -> IO ([CoreBind], RuleEnv, SDoc, SDoc, [CoreBndr])
deSugar dflags mod_name us hst
(TcResults {tc_env = global_val_env,
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule
-dsRule in_scope (IfaceRuleOut fn rule)
- = returnDs (ProtoCoreRule False {- non-local -} fn rule)
-
dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
Deprecations(..), lookupDeprec,
InstEnv, ClsInstEnv, DFunId,
+ PackageInstEnv, PackageRuleBase,
GlobalRdrEnv, RdrAvailInfo,
-- 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 :: RuleEnv -- Domain may include Ids from other modules
+ md_rules :: RuleBase -- Domain may include Ids from other modules
}
\end{code}
emptyModDetails
= ModDetails { md_types = emptyTypeEnv,
md_insts = [],
- md_rules = emptyRuleEnv
+ md_rules = emptyRuleBase
}
emptyModIface :: Module -> ModIface
DeprecSome env -> lookupNameEnv env name
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
+
type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class
type DFunId = Id
-
-type RuleEnv = NameEnv [CoreRule]
-
-emptyRuleEnv = emptyVarEnv
\end{code}
= PCS {
pcs_PIT :: PackageIfaceTable, -- Domain = non-home-package modules
-- the mi_decls component is empty
+
pcs_PST :: PackageSymbolTable, -- Domain = non-home-package modules
-- except that the InstEnv components is empty
- pcs_insts :: InstEnv, -- The total InstEnv accumulated from all
+
+ pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
-- the non-home-package modules
- pcs_rules :: RuleEnv, -- Ditto RuleEnv
+
+ pcs_rules :: PackageRuleEnv, -- Ditto RuleEnv
pcs_PRS :: PersistentRenamerState
}
+
\end{code}
The @PersistentRenamerState@ persists across successive calls to the
interface files but not yet sucked in, renamed, and typechecked
\begin{code}
+type PackageRuleBase = RuleBase
+type PackageInstEnv = InstEnv
+
data PersistentRenamerState
= PRS { prsOrig :: OrigNameEnv,
prsDecls :: DeclsMap,
\begin{code}
completeModDetails :: ModDetails
-> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the
- -- code generator; they have authoritative arity info
- -> [ProtoCoreRule] -- Tidy orphan rules
+ -- code generator; they have authoritative arity info
+ -> [ProtoCoreRule] -- Tidy orphan rules
-> ModDetails
completeIface :: Maybe ModIface -- The old interface, if we have it
mkTupleTyCon, isUnLiftedTyCon, mkAlgTyConRep
)
-import BasicTypes ( Arity, RecFlag(..), EP(..), Boxity(..), isBoxed )
+import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed )
-import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys,
+import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys,
mkArrowKinds, boxedTypeKind, unboxedTypeKind,
splitTyConApp_maybe, repType,
TauType, ClassContext )
returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc,
(fvs1 `plusFV` fvs2) `addOneFV` fn')
-rnRuleDecl (IfaceRuleOut fn rule)
- -- This one is used for BuiltInRules
- -- The rule itself is already done, but the thing
- -- to attach it to is not.
- = lookupOccRn fn `thenRn` \ fn' ->
- returnRn (IfaceRuleOut fn' rule, unitFV fn')
-
rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc)
= ASSERT( null tvs )
pushSrcLocRn src_loc $
\begin{code}
module Rules (
- RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase,
+ RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList,
+ prepareLocalRuleBase, prepareOrphanRuleBase,
unionRuleBase, lookupRule, addRule, addIdSpecialisations,
ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase,
localRule, orphanRule
%************************************************************************
\begin{code}
-type RuleBase = (IdSet, -- Imported Ids that have rules attached
- IdSet) -- Ids (whether local or imported) mentioned on
- -- LHS of some rule; these should be black listed
+data RuleBase = RuleBase (IdEnv CoreRules) -- Maps an Id to its rules
+ IdSet -- Ids (whether local or imported) mentioned on
+ -- LHS of some rule; these should be black listed
+
+emptyRuleBase = RuleBase emptyVarEnv emptyVarSet
+
+extendRuleBaseList :: RuleBase -> [(Name,CoreRule)] -> RuleBase
+extendRuleBaseList rule_base new_guys
+ = foldr extendRuleBase rule_base new_guys
+
+extendRuleBase :: RuleBase -> (Name,CoreRule) -> RuleBase
+extendRuleBase (RuleBase rule_env rule_fvs) (id, rule)
+ = RuleBase (extendVarEnv rule_env id (addRule id rules_for_id rule))
+ (rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
+ where
+ rules_for_id = case lookupWithDefaultVarEnv rule_env emptyCoreRules id
+
+ lhs_fvs = ruleSomeLhsFreeVars isId rule
+ -- Find *all* the free Ids of the LHS, not just
+ -- locally defined ones!!
unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2)
= (plusUFM_C merge_rules rule_ids1 rule_ids2,
prepareLocalRuleBase binds local_rules
= (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs))
where
- (rule_ids, rule_lhs_fvs) = foldr add_rule (emptyVarSet, emptyVarSet) local_rules
+ (rule_ids, rule_lhs_fvs) = foldr add_rule 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
Just bndr' -> setIdNoDiscard bndr'
Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
| otherwise -> bndr
-
-add_rule (ProtoCoreRule _ id rule)
- (rule_id_set, rule_fvs)
- = (rule_id_set `extendVarSet` new_id,
- rule_fvs `unionVarSet` extendVarSet lhs_fvs id)
- where
- new_id = case lookupVarSet rule_id_set id of
- Just id' -> addRuleToId id' rule
- Nothing -> addRuleToId id rule
- lhs_fvs = ruleSomeLhsFreeVars isId rule
- -- Find *all* the free Ids of the LHS, not just
- -- locally defined ones!!
addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule)
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
- ModDetails(..) )
+ ModDetails(..), PackageInstEnv, PersistentRenamerState
+ )
import Bag ( unionManyBags )
import Class ( Class, DefMeth(..), classBigSig )
Gather up the instance declarations from their various sources
\begin{code}
-tcInstDecls1 :: PersistentCompilerState
+tcInstDecls1 :: PackageInstEnv
+ -> PersistentRenamerState
-> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
-> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
-> [TyCon]
-> [RenamedHsDecl]
- -> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds)
+ -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
imported_inst_info
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
- addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ inst_env1 ->
+ addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
addInstInfos inst_env3 generic_inst_info `thenNF_Tc` \ inst_env4 ->
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
- tcDeriving (pcs_PRS pcs) mod inst_env4 get_fixity local_tycons
- `thenTc` \ (deriv_inst_info, deriv_binds) ->
- addInstInfos inst_env4 deriv_inst_info
- `thenNF_Tc` \ final_inst_env ->
+ tcDeriving prs mod inst_env4 get_fixity local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
- returnTc (pcs { pcs_insts = inst_env1 },
+ returnTc (inst_env1,
final_inst_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
deriv_binds)
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
-import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..) )
+import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) )
import HsTypes ( toHsType )
-import RnHsSyn ( RenamedHsModule, RenamedHsDecl )
+import RnHsSyn ( RenamedHsDecl )
import TcHsSyn ( TypecheckedMonoBinds,
TypecheckedForeignDecl, TypecheckedRuleDecl,
zonkTopBinds, zonkForeignExports, zonkRules
= TcResults {
tc_pcs :: PersistentCompilerState, -- Augmented with imported information,
-- (but not stuff from this module)
- tc_env :: TypeEnv, -- The TypeEnv just for the stuff from this module
- tc_insts :: [DFunId], -- Instances, just for this module
- tc_binds :: TypecheckedMonoBinds,
+
+ -- All these fields have info *just for this module*
+ tc_env :: TypeEnv, -- The top level TypeEnv
+ tc_insts :: [DFunId], -- Instances
+ tc_binds :: TypecheckedMonoBinds, -- Bindings
tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
tc_rules :: [TypecheckedRuleDecl] -- Transformation rules
}
:: DynFlags
-> Module
-> PersistentCompilerState
- -> HomeSymbolTable
- -> HomeIfaceTable
- -> PackageIfaceTable
+ -> HomeSymbolTable -> HomeIfaceTable
-> [RenamedHsDecl]
-> IO (Maybe TcResults)
-typecheckModule dflags this_mod pcs hst hit pit decls
+typecheckModule dflags this_mod pcs hst hit decls
= do env <- initTcEnv global_symbol_table
(maybe_result, (errs,warns)) <- initTc dflags env tc_module
- let maybe_tc_result :: Maybe TcResults
- maybe_tc_result = mapMaybe snd maybe_result
+ let { maybe_tc_result :: Maybe TcResults ;
+ maybe_tc_result = case maybe_result of
+ Nothing -> Nothing
+ Just (_,r) -> Just r }
- printErrorsAndWarnings (errs,warns)
- printTcDump dflags maybe_tc_result
+ printErrorsAndWarnings (errs,warns)
+ printTcDump dflags maybe_tc_result
- if isEmptyBag errs then
- return Nothing
- else
- return maybe_tc_result
+ if isEmptyBag errs then
+ return Nothing
+ else
+ return maybe_tc_result
where
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
tc_module :: TcM (TcEnv, TcResults)
tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env)
+ pit = pcs_PIT pcs
+
get_fixity :: Name -> Maybe Fixity
get_fixity nm = lookupTable hit pit nm `thenMaybe` \ iface ->
lookupNameEnv (mi_fixities iface) nm
in
-- Typecheck the instance decls, includes deriving
- tcInstDecls1 pcs hst unf_env get_fixity this_mod
- local_tycons decls `thenTc` \ (pcs_with_insts, inst_env, inst_info, deriv_binds) ->
+ tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
+ hst unf_env get_fixity this_mod
+ local_tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
tcSetInstEnv inst_env $
-- Default declarations
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
- tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+ tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
- tcRules decls `thenNF_Tc` \ (lie_rules, rules) ->
+ tcRules (pcs_rules pcs) 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
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
- zonkRules rules `thenNF_Tc` \ rules' ->
+ zonkRules local_rules `thenNF_Tc` \ local_rules' ->
let groups :: FiniteMap Module TypeEnv
new_pst = extendTypeEnv (pcs_PST pcs) (delFromFM groups this_mod)
final_pcs :: PersistentCompilerState
- final_pcs = pcs_with_insts {pcs_PST = new_pst}
+ final_pcs = pcs { pcs_PST = new_pst,
+ pcs_insts = new_pcs_insts,
+ pcs_rules = new_pcs_rules
+ }
in
- returnTc (final_env, -- WAS: really_final_env,
+ returnTc (final_env,
TcResults { tc_pcs = final_pcs,
tc_env = local_type_env,
tc_binds = all_binds',
- tc_insts = map iDFunId inst_info,
+ tc_insts = map iDFunId local_inst_info,
tc_fords = foi_decls ++ foe_decls',
tc_rules = rules'
})
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
import UniqFM ( emptyUFM )
import Unique ( Unique )
import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) )
import CoreSyn ( CoreRule(..) )
-import RnHsSyn ( RenamedHsDecl )
+import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl )
+import HscTypes ( PackageRuleEnv )
import TcHsSyn ( TypecheckedRuleDecl, mkHsLet )
import TcMonad
import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars )
import TcExpr ( tcExpr )
import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv )
-import Inst ( LIE, emptyLIE, plusLIEs, instToId )
+import Rules ( extendRuleBase )
+import Inst ( LIE, plusLIEs, instToId )
import Id ( idType, idName, mkVanillaId )
+import Name ( Name, extendNameEnvList )
import VarSet
import Type ( tyVarsOfTypes, openTypeKind )
import Bag ( bagToList )
+import List ( partition )
import Outputable
\end{code}
\begin{code}
-tcRules :: [RenamedHsDecl] -> TcM (LIE, [TypecheckedRuleDecl])
-tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) ->
- returnTc (plusLIEs lies, rules)
+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)
+ where
+ rule_decls = [rule | RuleD rule <- decls]
+ (imported_rules, local_rules) = partition is_iface_rule rule_decls
+
+ is_iface_rule (IfaceRule _ _ _ _ _ _) = True
+ is_iface_rule other = False
-tcRule (IfaceRule name vars fun args rhs src_loc)
+tcIfaceRule :: RenamedRuleDecl -> TcM (Id, CoreRule)
+ -- No zonking necessary!
+tcIfaceRule (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 (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs'))
+ returnTc (fun', Rule name vars' args' rhs')
-tcRule (IfaceRuleOut fun rule)
- = tcVar fun `thenTc` \ fun' ->
- returnTc (emptyLIE, IfaceRuleOut fun' rule)
-
-tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
+tcLocalRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl)
+tcLocalRule (HsRule name sig_tvs vars lhs rhs src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (ruleCtxt name) $
newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty ->
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
doubleQuotes (ptext name)
\end{code}
+
+
+
+
projects / ghc-hetmet.git / commitdiff