Commit 4102e5ce authored by simonpj's avatar simonpj
Browse files

[project @ 2000-10-25 07:09:52 by simonpj]

More renamer stuff; still in flight
parent b55a5d5d
...@@ -570,7 +570,7 @@ mkPrimOpId prim_op ...@@ -570,7 +570,7 @@ mkPrimOpId prim_op
`setArityInfo` exactArity arity `setArityInfo` exactArity arity
`setStrictnessInfo` strict_info `setStrictnessInfo` strict_info
rules = addRule id emptyCoreRules (primOpRule prim_op) rules = addRule emptyCoreRules id (primOpRule prim_op)
-- For each ccall we manufacture a separate CCallOpId, giving it -- For each ccall we manufacture a separate CCallOpId, giving it
......
...@@ -9,7 +9,11 @@ module NameSet ( ...@@ -9,7 +9,11 @@ module NameSet (
NameSet, NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
-- Free variables
FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV,
mkFVs, addOneFV, unitFV, delFV, delFVs
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -62,3 +66,34 @@ delListFromNameSet set ns = foldl delFromNameSet set ns ...@@ -62,3 +66,34 @@ delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code} \end{code}
%************************************************************************
%* *
\subsection{Free variables}
%* *
%************************************************************************
These synonyms are useful when we are thinking of free variables
\begin{code}
type FreeVars = NameSet
plusFV :: FreeVars -> FreeVars -> FreeVars
addOneFV :: FreeVars -> Name -> FreeVars
unitFV :: Name -> FreeVars
emptyFVs :: FreeVars
plusFVs :: [FreeVars] -> FreeVars
mkFVs :: [Name] -> FreeVars
delFV :: Name -> FreeVars -> FreeVars
delFVs :: [Name] -> FreeVars -> FreeVars
isEmptyFVs = isEmptyNameSet
emptyFVs = emptyNameSet
plusFVs = unionManyNameSets
plusFV = unionNameSets
mkFVs = mkNameSet
addOneFV = addOneToNameSet
unitFV = unitNameSet
delFV n s = delFromNameSet s n
delFVs ns s = delListFromNameSet s ns
\end{code}
...@@ -22,7 +22,7 @@ module RdrName ( ...@@ -22,7 +22,7 @@ module RdrName (
-- Environment -- Environment
RdrNameEnv, RdrNameEnv,
emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
extendRdrEnv, rdrEnvToList, extendRdrEnv, rdrEnvToList, elemRdrEnv,
-- Printing; instance Outputable RdrName -- Printing; instance Outputable RdrName
pprUnqualRdrName pprUnqualRdrName
...@@ -185,6 +185,7 @@ addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a ...@@ -185,6 +185,7 @@ addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
rdrEnvElts :: RdrNameEnv a -> [a] rdrEnvElts :: RdrNameEnv a -> [a]
elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool
emptyRdrEnv = emptyFM emptyRdrEnv = emptyFM
lookupRdrEnv = lookupFM lookupRdrEnv = lookupFM
...@@ -192,4 +193,5 @@ addListToRdrEnv = addListToFM ...@@ -192,4 +193,5 @@ addListToRdrEnv = addListToFM
rdrEnvElts = eltsFM rdrEnvElts = eltsFM
extendRdrEnv = addToFM extendRdrEnv = addToFM
rdrEnvToList = fmToList rdrEnvToList = fmToList
elemRdrEnv = elemFM
\end{code} \end{code}
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
module VarSet ( module VarSet (
VarSet, IdSet, TyVarSet, UVarSet, VarSet, IdSet, TyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet, emptyVarSet, unitVarSet, mkVarSet,
extendVarSet, extendVarSet, extendVarSet_C,
elemVarSet, varSetElems, subVarSet, elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets, unionVarSet, unionVarSets,
intersectVarSet, intersectsVarSet, intersectVarSet, intersectsVarSet,
...@@ -18,12 +18,10 @@ module VarSet ( ...@@ -18,12 +18,10 @@ module VarSet (
#include "HsVersions.h" #include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug ) import Var ( Var, Id, TyVar, UVar )
import Var ( Var, Id, TyVar, UVar, setVarUnique ) import Unique ( Unique )
import Unique ( Unique, Uniquable(..) )
import UniqSet import UniqSet
import UniqFM ( delFromUFM_Directly ) import UniqFM ( delFromUFM_Directly, addToUFM_C )
import Outputable
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -59,6 +57,7 @@ mapVarSet :: (Var -> Var) -> VarSet -> VarSet ...@@ -59,6 +57,7 @@ mapVarSet :: (Var -> Var) -> VarSet -> VarSet
sizeVarSet :: VarSet -> Int sizeVarSet :: VarSet -> Int
filterVarSet :: (Var -> Bool) -> VarSet -> VarSet filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
subVarSet :: VarSet -> VarSet -> Bool subVarSet :: VarSet -> VarSet -> Bool
extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet delVarSetByKey :: VarSet -> Unique -> VarSet
...@@ -80,6 +79,7 @@ lookupVarSet = lookupUniqSet ...@@ -80,6 +79,7 @@ lookupVarSet = lookupUniqSet
mapVarSet = mapUniqSet mapVarSet = mapUniqSet
sizeVarSet = sizeUniqSet sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet filterVarSet = filterUniqSet
extendVarSet_C combine s x = addToUFM_C combine s x x
a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b) a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b)
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
\end{code} \end{code}
......
...@@ -18,7 +18,7 @@ module HsCore ( ...@@ -18,7 +18,7 @@ module HsCore (
eq_ufExpr, eq_ufBinders, pprUfExpr, eq_ufExpr, eq_ufBinders, pprUfExpr,
toUfExpr, toUfBndr toUfExpr, toUfBndr, ufBinderName
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -47,7 +47,6 @@ import DataCon ( dataConTyCon ) ...@@ -47,7 +47,6 @@ import DataCon ( dataConTyCon )
import TyCon ( isTupleTyCon, tupleTyConBoxity ) import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind ) import Type ( Kind )
import CostCentre import CostCentre
import SrcLoc ( SrcLoc )
import Outputable import Outputable
\end{code} \end{code}
...@@ -92,6 +91,10 @@ data UfBinding name ...@@ -92,6 +91,10 @@ data UfBinding name
data UfBinder name data UfBinder name
= UfValBinder name (HsType name) = UfValBinder name (HsType name)
| UfTyBinder name Kind | UfTyBinder name Kind
ufBinderName :: UfBinder name -> name
ufBinderName (UfValBinder n _) = n
ufBinderName (UfTyBinder n _) = n
\end{code} \end{code}
......
...@@ -16,7 +16,7 @@ module HsDecls ( ...@@ -16,7 +16,7 @@ module HsDecls (
DeprecDecl(..), DeprecTxt, DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
mkClassDeclSysNames, mkClassDeclSysNames, isIfaceRuleDecl,
getClassDeclSysNames getClassDeclSysNames
) where ) where
...@@ -237,7 +237,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds ...@@ -237,7 +237,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code} \end{code}
\begin{code} \begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
...@@ -632,6 +631,8 @@ data RuleDecl name pat ...@@ -632,6 +631,8 @@ data RuleDecl name pat
name -- Head of LHS name -- Head of LHS
CoreRule CoreRule
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
data RuleBndr name data RuleBndr name
= RuleBndr name = RuleBndr name
......
...@@ -52,6 +52,7 @@ import OccName ( OccName ) ...@@ -52,6 +52,7 @@ import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv, import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName lookupModuleEnv, lookupModuleEnvByName
) )
import Rules ( RuleBase )
import VarSet ( TyVarSet ) import VarSet ( TyVarSet )
import VarEnv ( emptyVarEnv ) import VarEnv ( emptyVarEnv )
import Id ( Id ) import Id ( Id )
...@@ -149,7 +150,7 @@ data ModDetails ...@@ -149,7 +150,7 @@ data ModDetails
-- The next three fields are created by the typechecker -- The next three fields are created by the typechecker
md_types :: TypeEnv, md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module md_insts :: [DFunId], -- Dfun-ids for the instances in this module
md_rules :: RuleBase -- Domain may include Ids from other modules md_rules :: [(Id,CoreRule)] -- Domain may include Ids from other modules
} }
\end{code} \end{code}
...@@ -158,7 +159,7 @@ emptyModDetails :: ModDetails ...@@ -158,7 +159,7 @@ emptyModDetails :: ModDetails
emptyModDetails emptyModDetails
= ModDetails { md_types = emptyTypeEnv, = ModDetails { md_types = emptyTypeEnv,
md_insts = [], md_insts = [],
md_rules = emptyRuleBase md_rules = []
} }
emptyModIface :: Module -> ModIface emptyModIface :: Module -> ModIface
...@@ -386,7 +387,7 @@ data PersistentCompilerState ...@@ -386,7 +387,7 @@ data PersistentCompilerState
pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
-- the non-home-package modules -- the non-home-package modules
pcs_rules :: PackageRuleEnv, -- Ditto RuleEnv pcs_rules :: PackageRuleBase, -- Ditto RuleEnv
pcs_PRS :: PersistentRenamerState pcs_PRS :: PersistentRenamerState
} }
......
...@@ -13,17 +13,16 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, ...@@ -13,17 +13,16 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation,
RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl
) )
import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl,
extractHsTyNames, extractHsCtxtTyNames extractHsTyNames, extractHsCtxtTyNames,
instDeclFVs, tyClDeclFVs, ruleDeclFVs
) )
import CmdLineOpts ( DynFlags, DynFlag(..) ) import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad import RnMonad
import RnNames ( getGlobalNames ) import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl ) import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl )
import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo, import RnIfaces ( slurpImpDecls, mkImportInfo,
getInterfaceExports, getInterfaceExports,
getImportedRules, getSlurped,
ImportDeclResult(..),
RecompileRequired, recompileRequired RecompileRequired, recompileRequired
) )
import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs )
...@@ -91,12 +90,9 @@ renameModule :: DynFlags -> Finder ...@@ -91,12 +90,9 @@ renameModule :: DynFlags -> Finder
renameModule dflags finder hit hst old_pcs this_module rdr_module renameModule dflags finder hit hst old_pcs this_module rdr_module
= -- Initialise the renamer monad = -- Initialise the renamer monad
do { do {
(new_pcs, errors_found, (maybe_rn_stuff, dump_action)) (new_pcs, errors_found, maybe_rn_stuff)
<- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ; <- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ;
-- Dump any debugging output
dump_action ;
-- Return results. No harm in updating the PCS -- Return results. No harm in updating the PCS
if errors_found then if errors_found then
return (new_pcs, Nothing) return (new_pcs, Nothing)
...@@ -106,7 +102,7 @@ renameModule dflags finder hit hst old_pcs this_module rdr_module ...@@ -106,7 +102,7 @@ renameModule dflags finder hit hst old_pcs this_module rdr_module
\end{code} \end{code}
\begin{code} \begin{code}
rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ()) rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]))
rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc)
= -- FIND THE GLOBAL NAME ENVIRONMENT = -- FIND THE GLOBAL NAME ENVIRONMENT
getGlobalNames this_mod `thenRn` \ maybe_stuff -> getGlobalNames this_mod `thenRn` \ maybe_stuff ->
...@@ -114,8 +110,8 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls ...@@ -114,8 +110,8 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
-- CHECK FOR EARLY EXIT -- CHECK FOR EARLY EXIT
case maybe_stuff of { case maybe_stuff of {
Nothing -> -- Everything is up to date; no need to recompile further Nothing -> -- Everything is up to date; no need to recompile further
rnDump [] [] `thenRn` \ dump_action -> rnDump [] [] `thenRn_`
returnRn (Nothing, dump_action) ; returnRn Nothing ;
Just (gbl_env, local_gbl_env, export_avails, global_avail_env) -> Just (gbl_env, local_gbl_env, export_avails, global_avail_env) ->
...@@ -150,11 +146,11 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls ...@@ -150,11 +146,11 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
-- EXIT IF ERRORS FOUND -- EXIT IF ERRORS FOUND
rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action -> rnDump rn_imp_decls rn_local_decls `thenRn_`
checkErrsRn `thenRn` \ no_errs_so_far -> checkErrsRn `thenRn` \ no_errs_so_far ->
if not no_errs_so_far then if not no_errs_so_far then
-- Found errors already, so exit now -- Found errors already, so exit now
returnRn (Nothing, dump_action) returnRn Nothing
else else
-- GENERATE THE VERSION/USAGE INFO -- GENERATE THE VERSION/USAGE INFO
...@@ -197,7 +193,8 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls ...@@ -197,7 +193,8 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
export_avails source_fvs export_avails source_fvs
rn_imp_decls `thenRn_` rn_imp_decls `thenRn_`
returnRn (Just (mod_iface, final_decls), dump_action) } returnRn (Just (mod_iface, final_decls))
}
\end{code} \end{code}
@implicitFVs@ forces the renamer to slurp in some things which aren't @implicitFVs@ forces the renamer to slurp in some things which aren't
...@@ -272,296 +269,6 @@ isOrphanDecl other = False ...@@ -272,296 +269,6 @@ isOrphanDecl other = False
\end{code} \end{code}
%*********************************************************
%* *
\subsection{Slurping declarations}
%* *
%*********************************************************
\begin{code}
-------------------------------------------------------
slurpImpDecls source_fvs
= traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
-- The current slurped-set records all local things
getSlurped `thenRn` \ source_binders ->
slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) ->
-- Then get everything else
closeDecls decls needed `thenRn` \ decls1 ->
-- Finally, get any deferred data type decls
slurpDeferredDecls decls1 `thenRn` \ final_decls ->
returnRn final_decls
-------------------------------------------------------
slurpSourceRefs :: NameSet -- Variables defined in source
-> FreeVars -- Variables referenced in source
-> RnMG ([RenamedHsDecl],
FreeVars) -- Un-satisfied needs
-- The declaration (and hence home module) of each gate has
-- already been loaded
slurpSourceRefs source_binders source_fvs
= go_outer [] -- Accumulating decls
emptyFVs -- Unsatisfied needs
emptyFVs -- Accumulating gates
(nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet
where
-- The outer loop repeatedly slurps the decls for the current gates
-- and the instance decls
-- The outer loop is needed because consider
-- instance Foo a => Baz (Maybe a) where ...
-- It may be that @Baz@ and @Maybe@ are used in the source module,
-- but not @Foo@; so we need to chase @Foo@ too.
--
-- We also need to follow superclass refs. In particular, 'chasing @Foo@' must
-- include actually getting in Foo's class decl
-- class Wib a => Foo a where ..
-- so that its superclasses are discovered. The point is that Wib is a gate too.
-- We do this for tycons too, so that we look through type synonyms.
go_outer decls fvs all_gates []
= returnRn (decls, fvs)
go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet
= traceRn (text "go_outer" <+> ppr refs) `thenRn_`
foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) ->
getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls ->
rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) ->
go_outer decls2 fvs2 (all_gates `plusFV` gates2)
(nameSetToList (gates2 `minusNameSet` all_gates))
-- Knock out the all_gates because even if we don't slurp any new
-- decls we can get some apparently-new gates from wired-in names
go_inner (decls, fvs, gates) wanted_name
= importDecl wanted_name `thenRn` \ import_result ->
case import_result of
AlreadySlurped -> returnRn (decls, fvs, gates)
WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name)
Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor
HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (TyClD new_decl : decls,
fvs1 `plusFV` fvs,
gates `plusFV` getGates source_fvs new_decl)
rnInstDecls decls fvs gates []
= returnRn (decls, fvs, gates)
rnInstDecls decls fvs gates (d:ds)
= rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
rnInstDecls (new_decl:decls)
(fvs1 `plusFV` fvs)
(gates `plusFV` getInstDeclGates new_decl)
ds
\end{code}
\begin{code}
-------------------------------------------------------
-- closeDecls keeps going until the free-var set is empty
closeDecls decls needed
| not (isEmptyFVs needed)
= slurpDecls decls needed `thenRn` \ (decls1, needed1) ->
closeDecls decls1 needed1
| otherwise
= getImportedRules `thenRn` \ rule_decls ->
case rule_decls of
[] -> returnRn decls -- No new rules, so we are done
other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) ->
closeDecls decls1 needed1
-------------------------------------------------------
-- Augment decls with any decls needed by needed.
-- Return also free vars of the new decls (only)
slurpDecls decls needed
= go decls emptyFVs (nameSetToList needed)
where
go decls fvs [] = returnRn (decls, fvs)
go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) ->
go decls1 fvs1 refs
-------------------------------------------------------
slurpDecl decls fvs wanted_name
= importDecl wanted_name `thenRn` \ import_result ->
case import_result of
-- Found a declaration... rename it
HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) ->
returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs)
-- No declaration... (wired in thing, or deferred, or already slurped)
other -> returnRn (decls, fvs)
-------------------------------------------------------
rnIfaceDecls :: [RenamedHsDecl] -> FreeVars
-> [(Module, RdrNameHsDecl)]
-> RnM d ([RenamedHsDecl], FreeVars)
rnIfaceDecls decls fvs [] = returnRn (decls, fvs)
rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds
rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl)
rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl)
\end{code}
%*********************************************************
%* *
\subsection{Deferred declarations}
%* *
%*********************************************************
The idea of deferred declarations is this. Suppose we have a function
f :: T -> Int
data T = T1 A | T2 B
data A = A1 X | A2 Y
data B = B1 P | B2 Q
Then we don't want to load T and all its constructors, and all
the types those constructors refer to, and all the types *those*
constructors refer to, and so on. That might mean loading many more
interface files than is really necessary. So we 'defer' loading T.
But f might be strict, and the calling convention for evaluating
values of type T depends on how many constructors T has, so
we do need to load T, but not the full details of the type T.
So we load the full decl for T, but only skeleton decls for A and B:
f :: T -> Int
data T = {- 2 constructors -}
Whether all this is worth it is moot.
\begin{code}
slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
slurpDeferredDecls decls = returnRn decls
{- OMIT FOR NOW
slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl]
slurpDeferredDecls decls
= getDeferredDecls `thenRn` \ def_decls ->
rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) ->
ASSERT( isEmptyFVs fvs )
returnRn decls1
stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2))
= (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc
name1 name2))
-- Nuke the context and constructors
-- But retain the *number* of constructors!
-- Also the tvs will have kinds on them.
-}
\end{code}
%*********************************************************
%* *
\subsection{Extracting the `gates'}
%* *
%*********************************************************
When we import a declaration like
\begin{verbatim}
data T = T1 Wibble | T2 Wobble
\end{verbatim}
we don't want to treat @Wibble@ and @Wobble@ as gates
{\em unless} @T1@, @T2@ respectively are mentioned by the user program.
If only @T@ is mentioned
we want only @T@ to be a gate;
that way we don't suck in useless instance
decls for (say) @Eq Wibble@, when they can't possibly be useful.
@getGates@ takes a newly imported (and renamed) decl, and the free
vars of the source program, and extracts from the decl the gate names.
\begin{code}
getGates source_fvs (IfaceSig _ ty _ _)
= extractHsTyNames ty
getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ )
= (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs)
(hsTyVarNames tvs)
`addOneToNameSet` cls)
`plusFV` maybe_double
where
get (ClassOpSig n _ ty _)
| n `elemNameSet` source_fvs = extractHsTyNames ty
| otherwise = emptyFVs
-- If we load any numeric class that doesn't have
-- Int as an instance, add Double to the gates.
-- This takes account of the fact that Double might be needed for
-- defaulting, but we don't want to load Double (and all its baggage)
-- if the more exotic classes aren't used at all.