Commit d00cf5b8 authored by simonpj's avatar simonpj
Browse files

[project @ 2000-11-20 16:07:12 by simonpj]

Remember local decls when no recompilation is required
parent 4adc89ca
......@@ -14,7 +14,7 @@ module HsDecls (
ConDecl(..), ConDetails(..),
BangType(..), getBangType,
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys
......@@ -215,6 +215,7 @@ isClassDecl other = False
Dealing with names
\begin{code}
--------------------------------
tyClDeclName :: TyClDecl name pat -> name
tyClDeclName (IfaceSig name _ _ _) = name
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
......@@ -222,6 +223,7 @@ tyClDeclName (TySynonym name _ _ _) = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name
--------------------------------
tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
-- Returns all the binding names of the decl, along with their SrcLocs
-- The first one is guaranteed to be the name of the decl
......@@ -239,6 +241,17 @@ tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _)
tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)]
--------------------------------
tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
-- Similar to tyClDeclNames, but returns the "implicit"
-- or "system" names of the declaration
tyClDeclSysNames (ClassDecl _ _ _ _ _ _ names loc) = [(n,loc) | n <- names]
tyClDeclSysNames (TyData _ _ _ _ cons _ _ _ _ _) = [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
tyClDeclSysNames decl = []
--------------------------------
type ClassDeclSysNames name = [name]
-- [tycon, datacon wrapper, datacon worker,
-- superclass selector 1, ..., superclass selector n]
......
......@@ -22,7 +22,7 @@ import RnMonad
import RnExpr ( rnExpr )
import RnNames ( getGlobalNames, exportsFromAvail )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo,
import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
getInterfaceExports, closeDecls,
RecompileRequired, outOfDate, recompileRequired
)
......@@ -563,7 +563,10 @@ closeIfaceDecls dflags hit hst pcs
needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
unionManyNameSets (map tyClDeclFVs tycl_decls)
local_names = foldl add emptyNameSet tycl_decls
add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
in
recordLocalSlurps local_names `thenRn_`
closeDecls decls needed
\end{code}
......
......@@ -584,11 +584,6 @@ availNames :: GenAvailInfo name -> [name]
availNames (Avail n) = [n]
availNames (AvailTC n ns) = ns
-------------------------------------
addSysAvails :: AvailInfo -> [Name] -> AvailInfo
addSysAvails avail [] = avail
addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
-------------------------------------
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
......
......@@ -27,9 +27,8 @@ import HscTypes ( ModuleLocation(..),
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
)
import HsSyn ( TyClDecl(..), InstDecl(..),
HsType(..), ConDecl(..),
FixitySig(..), RuleDecl(..),
tyClDeclNames
HsType(..), FixitySig(..), RuleDecl(..),
tyClDeclNames, tyClDeclSysNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
extractHsTyRdrNames
......@@ -423,45 +422,31 @@ getIfaceDeclBinders, getTyClDeclBinders
-> RdrNameTyClDecl
-> RnM d AvailInfo
getIfaceDeclBinders mod tycl_decl
= getTyClDeclBinders mod tycl_decl `thenRn` \ avail ->
getSysTyClDeclBinders mod tycl_decl `thenRn` \ extras ->
returnRn (addSysAvails avail extras)
-- Add the sys-binders to avail. When we import the decl,
-- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
-- If we miss out sys-binders, we'll read the decl multiple times!
-----------------
getTyClDeclBinders mod (IfaceSig var ty prags src_loc)
= newTopBinder mod var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name)
getTyClDeclBinders mod tycl_decl
= mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
= new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
returnRn (AvailTC main_name (main_name : sub_names))
where
do_one (name,loc) = newTopBinder mod name loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
A the moment that's just the tycon and datacon that come with a class decl.
They aren't returned by @getDeclBinders@ because they aren't in scope;
but they {\em should} be put into the @DeclsMap@ of this module.
Note that this excludes the default-method names of a class decl,
and the dict fun of an instance decl, because both of these have
bindings of their own elsewhere.
\begin{code}
getSysTyClDeclBinders mod (ClassDecl _ cname _ _ sigs _ names src_loc)
= sequenceRn [newTopBinder mod n src_loc | n <- names]
-----------------
getIfaceDeclBinders mod (IfaceSig var ty prags src_loc)
= newTopBinder mod var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name)
getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _)
= sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getIfaceDeclBinders mod tycl_decl
= new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names ->
returnRn (AvailTC main_name (main_name : (sys_names ++ sub_names)))
getSysTyClDeclBinders mod other_decl
= returnRn []
-----------------
new_top_bndrs mod names_w_locs
= sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs]
\end{code}
%*********************************************************
%* *
\subsection{Reading an interface file}
......
......@@ -344,12 +344,9 @@ recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name)
| otherwise = (extendModuleSet imp_mods mod, imp_names)
recordLocalSlurps local_avails
recordLocalSlurps new_names
= getIfacesRn `thenRn` \ ifaces ->
let
new_slurped_names = foldl addAvailToNameSet (iSlurp ifaces) local_avails
in
setIfacesRn (ifaces { iSlurp = new_slurped_names })
setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names })
\end{code}
......@@ -603,19 +600,13 @@ data ImportDeclResult
| HereItIs (Module, RdrNameTyClDecl)
importDecl name
= -- STEP 1: Check if it was loaded before beginning this module
if isLocalName name then
traceRn (text "Already (local)" <+> ppr name) `thenRn_`
returnRn AlreadySlurped
else
-- STEP 2: Check if we've slurped it in while compiling this module
= -- STEP 1: Check if we've slurped it in while compiling this module
getIfacesRn `thenRn` \ ifaces ->
if name `elemNameSet` iSlurp ifaces then
returnRn AlreadySlurped
else
-- STEP 3: Check if it's already in the type environment
-- STEP 2: Check if it's already in the type environment
getTypeEnvRn `thenRn` \ lookup ->
case lookup name of {
Just ty_thing | name `elemNameEnv` wiredInThingEnv
......@@ -629,13 +620,13 @@ importDecl name
Nothing ->
-- STEP 4: OK, we have to slurp it in from an interface file
-- STEP 3: OK, we have to slurp it in from an interface file
-- First load the interface file
traceRn nd_doc `thenRn_`
loadHomeInterface nd_doc name `thenRn_`
getIfacesRn `thenRn` \ ifaces ->
-- STEP 5: Get the declaration out
-- STEP 4: Get the declaration out
let
(decls_map, _) = iDecls ifaces
in
......
......@@ -183,10 +183,10 @@ importsFromLocalDecls this_mod decls
(_, dups) = removeDups compare all_names
in
-- Check for duplicate definitions
mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
mapRn_ (addErrRn . dupDeclErr) dups `thenRn_`
-- Record that locally-defined things are available
recordLocalSlurps avails `thenRn_`
recordLocalSlurps (availsToNameSet avails) `thenRn_`
-- Build the environment
qualifyImports (moduleName this_mod)
......
......@@ -31,9 +31,9 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
newDFunName, tcExtendTyVarEnv
newDFunName, tcExtendTyVarEnv, tcGetInstEnv
)
import InstEnv ( InstEnv, extendInstEnv )
import InstEnv ( InstEnv, extendInstEnv, pprInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
......@@ -225,7 +225,6 @@ addInstDFuns dfuns infos
returnTc inst_env'
where
bind x f = f x
\end{code}
\begin{code}
......
......@@ -9,7 +9,7 @@ The bits common to TcInstDcls and TcDeriv.
module InstEnv (
DFunId, ClsInstEnv, InstEnv,
emptyInstEnv, extendInstEnv,
emptyInstEnv, extendInstEnv, pprInstEnv,
lookupInstEnv, InstLookupResult(..),
classInstEnv, simpleDFunClassTyCon
) where
......@@ -18,7 +18,7 @@ module InstEnv (
import Class ( Class )
import Var ( Id )
import VarSet ( TyVarSet, unionVarSet, mkVarSet )
import VarSet ( TyVarSet, unionVarSet, mkVarSet, varSetElems )
import VarEnv ( TyVarSubstEnv )
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
import Name ( getSrcLoc )
......@@ -29,7 +29,7 @@ import PprType ( )
import TyCon ( TyCon )
import Outputable
import Unify ( matchTys, unifyTyListsX )
import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM )
import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM, eltsUFM )
import Id ( idType )
import ErrUtils ( Message )
import CmdLineOpts
......@@ -55,6 +55,14 @@ simpleDFunClassTyCon dfun
where
(_,_,clas,[ty]) = splitDFunTy (idType dfun)
tycon = tyConAppTyCon ty
pprInstEnv :: InstEnv -> SDoc
pprInstEnv env
= vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+>
brackets (pprWithCommas ppr tys) <+> ppr dfun
| cls_inst_env <- eltsUFM env
, (tyvars, tys, dfun) <- cls_inst_env
]
\end{code}
%************************************************************************
......
Supports Markdown
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