From 6af6951bef8ba4826103a7170a82d3c70bb16805 Mon Sep 17 00:00:00 2001 From: sof Date: Wed, 25 Feb 1998 19:29:58 +0000 Subject: [PATCH] [project @ 1998-02-25 19:29:52 by sof] Dictionaries are now named as follows: $d 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.) --- ghc/compiler/rename/RnEnv.lhs | 40 ++++++++++++++++++++----- ghc/compiler/rename/RnIfaces.lhs | 20 ++++++++----- ghc/compiler/rename/RnMonad.lhs | 57 ++++++++++++++++++++++++------------ ghc/compiler/rename/RnSource.lhs | 35 +++++++++++++++++++--- ghc/compiler/typecheck/TcDeriv.lhs | 44 ++++++++++++++++------------ 5 files changed, 140 insertions(+), 56 deletions(-) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 2260f56..68b2609 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -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 + + 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] diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d52d886..8912a65 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -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: diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 26a5753..a6e08ae 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -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 ===================== diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index cb5abf3..97798b7 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 631833b..17c48cf 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -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 -- 1.7.10.4