Commit 6af6951b authored by sof's avatar sof
Browse files

[project @ 1998-02-25 19:29:52 by sof]

Dictionaries are now named as follows:

  $d<class><tycon><n>

where "n" is a positive int, "tycon" is the name of the tyvar/tycon
of the first argument to the "class" that the dict represent an
instance of.

The change should improve the behaviour of the recompilation
checker, preventing the recompilation of all the dependents
of a module whenever a data type of instance is added to it.
(The common behaviour should be no recompilations, but there
are cases where the naming scheme fails to prevent a recompile.)
parent edfe9359
......@@ -19,7 +19,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) )
import RnMonad
import ErrUtils ( ErrMsg )
import Name ( Name, OccName(..), Provenance(..), ExportFlag(..), NamedThing(..),
occNameFlavour, getSrcLoc,
occNameFlavour, getSrcLoc, occNameString,
NameSet, emptyNameSet, addListToNameSet, nameSetToList,
mkLocalName, mkGlobalName, modAndOcc,
nameOccName, setNameProvenance, isVarOcc, getNameProvenance,
......@@ -35,6 +35,7 @@ import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
import Util ( removeDups )
import List ( nub )
import Char ( isAlphanum )
\end{code}
......@@ -136,19 +137,42 @@ newLocallyDefinedGlobalName mod occ rec_exp_fn loc
-- When renaming derived definitions we are in *interface* mode (because we can trip
-- over original names), but we still want to make the Dfun locally-defined.
-- So we can't use whether or not we're in source mode to decide the locally-defined question.
newDfunName :: Maybe RdrName -> SrcLoc -> RnMS s Name
newDfunName Nothing src_loc -- Local instance decls have a "Nothing"
newDfunName :: OccName -> OccName -> Maybe RdrName -> SrcLoc -> RnMS s Name
newDfunName _ _ (Just n) src_loc -- Imported ones have "Just n"
= getModuleRn `thenRn` \ mod_name ->
newInstUniq `thenRn` \ inst_uniq ->
newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
newDfunName cl_nm tycon_nm Nothing src_loc -- Local instance decls have a "Nothing"
= getModuleRn `thenRn` \ mod_name ->
newInstUniq name `thenRn` \ inst_uniq ->
let
dfun_occ = VarOcc (_PK_ ("$d" ++ show inst_uniq))
dfun_occ = VarOcc (_PK_ ("$d" ++ (_UNPK_ name) ++ show inst_uniq))
in
newLocallyDefinedGlobalName mod_name dfun_occ
(\_ -> Exported) src_loc
where
{-
Dictionary names have the following form
newDfunName (Just n) src_loc -- Imported ones have "Just n"
= getModuleRn `thenRn` \ mod_name ->
newImportedGlobalName mod_name (rdrNameOcc n) HiFile {- Correct? -}
$d<class><tycon><n>
where "n" is a positive number, and "tycon" is the
name of the type constructor for which a "class"
instance is derived.
Prefixing dictionary names with their class and instance
types improves the behaviour of the recompilation checker.
(fewer recompilations required should an instance or type
declaration be added to a module.)
-}
-- We're dropping the modids on purpose.
tycon_nm_str = occNameString tycon_nm
cl_nm_str = occNameString cl_nm
-- give up on any type constructor that starts with a
-- non-alphanumeric char (e.g., [] (,*)
name
| (_NULL_ tycon_nm_str) || not (isAlphanum (_HEAD_ (tycon_nm_str))) = cl_nm_str
| otherwise = cl_nm_str _APPEND_ tycon_nm_str
newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
......
......@@ -157,22 +157,22 @@ count_decls decls
\begin{code}
loadInterface :: SDoc -> Module -> IfaceFlavour -> RnMG Ifaces
loadInterface doc_str load_mod as_source
= getIfacesRn `thenRn` \ ifaces ->
let
= getIfacesRn `thenRn` \ ifaces ->
let
Ifaces this_mod mod_map decls
all_names imp_names (insts, tycls_names)
deferred_data_decls inst_mods = ifaces
in
in
-- CHECK WHETHER WE HAVE IT ALREADY
case lookupFM mod_map load_mod of {
case lookupFM mod_map load_mod of {
Just (hif, _, _, _) | hif `as_good_as` as_source
-> -- Already in the cache; don't re-read it
returnRn ifaces ;
other ->
-- READ THE MODULE IN
findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
case read_result of {
findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
case read_result of {
-- Check for not found
Nothing -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
......@@ -1003,7 +1003,13 @@ readIface file_path
failWithRn Nothing (cannaeReadFile file_path err)
\end{code}
mkSearchPath takes a string consisting of a colon-separated list
%*********************************************************
%* *
\subsection{Utils}
%* *
%*********************************************************
@mkSearchPath@ takes a string consisting of a colon-separated list
of directories and corresponding suffixes, and turns it into a list
of (directory, suffix) pairs. For example:
......
......@@ -40,7 +40,7 @@ import TysWiredIn ( boolTyCon )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSet
import UniqSupply
......@@ -93,7 +93,7 @@ type SSTRWRef a = SSTRef RealWorld a -- ToDo: there ought to be a standard defn
-- Common part
data RnDown s = RnDown
SrcLoc
(SSTRef s RnNameSupply)
(SSTRef s (GenRnNameSupply s))
(SSTRef s (Bag WarnMsg, Bag ErrMsg))
(SSTRef s ([Occurrence],[Occurrence])) -- Occurrences: compulsory and optional resp
......@@ -138,10 +138,16 @@ type FreeVars = NameSet
===================================================
\begin{code}
type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
type RnNameSupply = GenRnNameSupply RealWorld
type GenRnNameSupply s
= ( UniqSupply
, FiniteMap FAST_STRING (SSTRef s Int)
, FiniteMap (Module,OccName) Name
)
-- Ensures that one (m,n) pair gets one unique
-- The Int is used to give a number to each instance declaration;
-- it's really a separate name supply.
-- The finite map on FAST_STRINGS is used to give a per-class unique to each
-- instance declaration; it's really a separate name supply.
data RnEnv = RnEnv GlobalNameEnv FixityEnv
emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
......@@ -279,10 +285,10 @@ initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
initRn mod us dirs loc do_rn
= sstToIO $
newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
newMutVarSST initOccs `thenSST` \ occs_var ->
newMutVarSST (us, emptyFM, builtins) `thenSST` \ names_var ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
newMutVarSST initOccs `thenSST` \ occs_var ->
let
rn_down = RnDown loc names_var errs_var occs_var
g_down = GDown dirs iface_var
......@@ -331,7 +337,7 @@ once you must either split it, or install a fresh unique supply.
\begin{code}
renameSourceCode :: Module
-> RnNameSupply
-> RnNameSupply
-> RnMS RealWorld r
-> r
......@@ -482,21 +488,34 @@ getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
================ Name supply =====================
\begin{code}
getNameSupplyRn :: RnM s d RnNameSupply
getNameSupplyRn :: RnM s d (GenRnNameSupply s)
getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST names_var
setNameSupplyRn :: RnNameSupply -> RnM s d ()
setNameSupplyRn :: GenRnNameSupply s -> RnM s d ()
setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
= writeMutVarSST names_var names'
-- The "instance-decl unique supply", inst, is just an integer that's used to
-- give a unique number for each instance declaration.
newInstUniq :: RnM s d Int
newInstUniq (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST names_var `thenSST` \ (us, inst, cache) ->
writeMutVarSST names_var (us, inst+1, cache) `thenSST_`
returnSST inst
-- The "instance-decl unique supply", inst, is really a map from class names
-- to unique supplies. Having per-class unique numbers for instance decls helps
-- the recompilation checker.
newInstUniq :: FAST_STRING -> RnM s d Int
newInstUniq cname (RnDown loc names_var errs_var occs_var) l_down
= readMutVarSST names_var `thenSST` \ (us, mapInst, cache) ->
case lookupFM mapInst cname of
Just class_us ->
readMutVarSST class_us `thenSST` \ v ->
writeMutVarSST class_us (v+1) `thenSST_`
returnSST v
Nothing -> -- first time caller gets to add a unique supply
-- to the finite map for that class.
newMutVarSST 1 `thenSST` \ class_us ->
let
mapInst' = addToFM mapInst cname class_us
in
writeMutVarSST names_var (us, mapInst', cache) `thenSST_`
returnSST 0
\end{code}
================ Occurrences =====================
......
......@@ -27,7 +27,7 @@ import RnMonad
import Name ( Name, OccName(..), occNameString, prefixOccName,
ExportFlag(..), Provenance(..), NameSet,
elemNameSet
elemNameSet, nameOccName, NamedThing(..)
)
import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
......@@ -240,9 +240,36 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
checkDupNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
mapRn rn_uprag uprags `thenRn` \ new_uprags ->
newDfunName maybe_dfun src_loc `thenRn` \ dfun_name ->
addOccurrenceName dfun_name `thenRn_`
let
-- We use the class name and the name of the first
-- type constructor the class is applied to.
(cl_nm, tycon_nm) = mkDictPrefix inst_ty'
mkDictPrefix (MonoDictTy cl tys) =
case tys of
[] -> (c_nm, nilOccName )
(ty:_) -> (c_nm, getInstHeadTy ty)
where
c_nm = nameOccName (getName cl)
mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty
mkDictPrefix (HsForAllTy _ _ ty) = mkDictPrefix ty -- can this
mkDictPrefix _ = (nilOccName, nilOccName)
getInstHeadTy t
= case t of
MonoTyVar tv -> nameOccName (getName tv)
MonoTyApp t _ -> getInstHeadTy t
_ -> nilOccName
-- I cannot see how the rest of HsType constructors
-- can occur, but this isn't really a failure condition,
-- so we return silently.
nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
in
newDfunName cl_nm tycon_nm maybe_dfun src_loc `thenRn` \ dfun_name ->
addOccurrenceName dfun_name `thenRn_`
-- The dfun is not optional, because we use its version number
-- to identify the version of the instance declaration
......
......@@ -34,7 +34,8 @@ import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined, getSrcLoc, Provenance,
Name{--O only-}, Module, NamedThing(..)
Name{--O only-}, Module, NamedThing(..),
OccName, nameOccName
)
import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings,
......@@ -228,9 +229,11 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
returnRn (dfun_names_w_method_binds, rn_extra_binds)
)
rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
returnRn (dfun_name, rn_meth_binds)
rn_one (cl_nm, tycon_nm, meth_binds)
= newDfunName cl_nm tycon_nm
Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
returnRn (dfun_name, rn_meth_binds)
really_new_inst_infos = map (gen_inst_info modname)
(new_inst_infos `zip` dfun_names_w_method_binds)
......@@ -570,24 +573,29 @@ the renamer. What a great hack!
\begin{code}
-- Generate the method bindings for the required instance
gen_bind :: InstInfo -> RdrNameMonoBinds
-- (paired with class name, as we need that when generating dict
-- names.)
gen_bind :: InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
gen_bind (InstInfo clas _ [ty] _ _ _ _ _ _)
| not from_here
= EmptyMonoBinds
= (clas_nm, tycon_nm, EmptyMonoBinds)
| otherwise
= assoc "gen_inst_info:bad derived class"
[(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(evalClassKey, gen_Eval_binds)
,(boundedClassKey, gen_Bounded_binds)
,(showClassKey, gen_Show_binds)
,(readClassKey, gen_Read_binds)
,(ixClassKey, gen_Ix_binds)
]
(classKey clas)
tycon
= (clas_nm, tycon_nm,
assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds)
,(evalClassKey, gen_Eval_binds)
,(boundedClassKey, gen_Bounded_binds)
,(showClassKey, gen_Show_binds)
,(readClassKey, gen_Read_binds)
,(ixClassKey, gen_Ix_binds)
]
(classKey clas)
tycon)
where
clas_nm = nameOccName (getName clas)
tycon_nm = nameOccName (getName tycon)
from_here = isLocallyDefined tycon
(tycon,_,_) = splitAlgTyConApp ty
......
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