Commit b55a5d5d authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-24 17:09:44 by simonpj]

Stuff to do with Rules; may not compile
parent ae547177
......@@ -48,7 +48,7 @@ deSugar :: DynFlags
-> 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,
......@@ -110,9 +110,6 @@ ppr_ds_rules rules
\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) ->
......
......@@ -30,6 +30,7 @@ module HscTypes (
Deprecations(..), lookupDeprec,
InstEnv, ClsInstEnv, DFunId,
PackageInstEnv, PackageRuleBase,
GlobalRdrEnv, RdrAvailInfo,
......@@ -148,7 +149,7 @@ data ModDetails
-- 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}
......@@ -157,7 +158,7 @@ emptyModDetails :: ModDetails
emptyModDetails
= ModDetails { md_types = emptyTypeEnv,
md_insts = [],
md_rules = emptyRuleEnv
md_rules = emptyRuleBase
}
emptyModIface :: Module -> ModIface
......@@ -299,12 +300,9 @@ lookupDeprec iface name
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}
......@@ -381,14 +379,18 @@ data PersistentCompilerState
= 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
......@@ -411,6 +413,9 @@ It contains:
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,
......
......@@ -69,8 +69,8 @@ import List ( partition )
\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
......
......@@ -102,9 +102,9 @@ import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons,
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 )
......
......@@ -221,13 +221,6 @@ rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc)
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 $
......
......@@ -5,7 +5,8 @@
\begin{code}
module Rules (
RuleBase, prepareLocalRuleBase, prepareOrphanRuleBase,
RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList,
prepareLocalRuleBase, prepareOrphanRuleBase,
unionRuleBase, lookupRule, addRule, addIdSpecialisations,
ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase,
localRule, orphanRule
......@@ -476,9 +477,26 @@ orphanRule (ProtoCoreRule local fn _)
%************************************************************************
\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,
......@@ -507,7 +525,7 @@ prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase)
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
......@@ -535,18 +553,6 @@ prepareLocalRuleBase binds local_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)
......
......@@ -39,7 +39,8 @@ import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
ModDetails(..) )
ModDetails(..), PackageInstEnv, PersistentRenamerState
)
import Bag ( unionManyBags )
import Class ( Class, DefMeth(..), classBigSig )
......@@ -160,16 +161,17 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
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]
......@@ -195,7 +197,7 @@ tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls
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 ->
......@@ -205,12 +207,10 @@ tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls
-- 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)
......
......@@ -12,9 +12,9 @@ module TcModule (
#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
......@@ -70,9 +70,11 @@ data TcResults
= 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
}
......@@ -82,33 +84,35 @@ typecheckModule
:: 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
......@@ -147,8 +151,9 @@ tcModule pcs hst get_fixity this_mod decls unf_env
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
......@@ -199,9 +204,9 @@ tcModule pcs hst get_fixity this_mod decls unf_env
-- 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
......@@ -236,7 +241,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env
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
......@@ -249,13 +254,16 @@ tcModule pcs hst get_fixity this_mod decls unf_env
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'
})
......
......@@ -62,7 +62,7 @@ import VarSet ( TyVarSet )
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 )
......
......@@ -10,7 +10,8 @@ module TcRules ( tcRules ) where
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 )
......@@ -19,33 +20,44 @@ import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
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 ->
......@@ -111,3 +123,7 @@ tcRule (HsRule name sig_tvs vars lhs rhs src_loc)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
doubleQuotes (ptext name)
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment