From a6f29db07ac47b8a924a65c7e07ce73bc491d0e5 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 16 Jul 2009 12:56:43 +0000 Subject: [PATCH] Use names like '$fOrdInt' for dfuns (and TF instances), rather than '$f21' 2 reasons for this: - compilation is more predictable. Adding or removing an instance is less likely to force unnecessary recompilation due to renumbering other dfun names. - it makes it easier to read Core / C-- / asm The names aren't completely deterministic. To do that, we'd have to include package and module names, which would make the symbol names long and reduce readability. So the compromise is that if there's a clash, we disambiguate by adding an integer suffix. This is fairly unlikely in practice unless you're using overlapping instances. Type family instances are handled in the same way, with the same disambiguation strategy. --- compiler/basicTypes/OccName.lhs | 31 ++++++++++++++++++++----------- compiler/typecheck/TcEnv.lhs | 25 +++++++++++-------------- compiler/typecheck/TcRnMonad.lhs | 17 ++++++++++------- compiler/typecheck/TcRnTypes.lhs | 10 ++-------- compiler/typecheck/TcTyClsDecls.lhs | 4 ++-- 5 files changed, 45 insertions(+), 42 deletions(-) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 6f5267d..0736fea 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -95,7 +95,6 @@ module OccName ( import Util import Unique import BasicTypes -import StaticFlags import UniqFM import UniqSet import FastString @@ -601,31 +600,41 @@ mkLocalOcc uniq occ \begin{code} -- | Derive a name for the representation type constructor of a -- @data@\/@newtype@ instance. -mkInstTyTcOcc :: Int -- ^ DFun Index - -> OccName -- ^ Family name, e.g. @Map@ - -> OccName -- ^ Nice unique version, e.g. @:R23Map@ -mkInstTyTcOcc index occ - = mk_deriv tcName ("R" ++ show index ++ ":") (occNameString occ) +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str set = + chooseUniqueOcc tcName ('R' : ':' : str) set \end{code} \begin{code} mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. -- Only used in debug mode, for extra clarity -> Bool -- ^ Is this a hs-boot instance DFun? - -> Int -- ^ Unique index + -> OccSet -- ^ avoid these Occs -> OccName -- ^ E.g. @$f3OrdMaybe@ -- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real -- thing when we compile the mother module. Reason: we don't know exactly -- what the mother module will call it. -mkDFunOcc info_str is_boot index - = mk_deriv VarName prefix string +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set where prefix | is_boot = "$fx" | otherwise = "$f" - string | opt_PprStyle_Debug = show index ++ info_str - | otherwise = show index +\end{code} + +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. + +\begin{code} +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ \end{code} We used to add a '$m' to indicate a method, but that gives rise to bad diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 36231cd..d1a10cf 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -677,17 +677,13 @@ name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name -newDFunName clas (ty:_) loc - = do { index <- nextDFunIndex - ; is_boot <- tcIsHsBoot +newDFunName clas tys loc + = do { is_boot <- tcIsHsBoot ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - occNameString (getDFunTyKey ty) - dfun_occ = mkDFunOcc info_string is_boot index - + concatMap (occNameString.getDFunTyKey) tys + ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } - -newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} Make a name for the representation tycon of a family instance. It's an @@ -695,12 +691,13 @@ Make a name for the representation tycon of a family instance. It's an newGlobalBinder. \begin{code} -newFamInstTyConName :: Name -> SrcSpan -> TcM Name -newFamInstTyConName tc_name loc - = do { index <- nextDFunIndex - ; mod <- getModule - ; let occ = nameOccName tc_name - ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } +newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name +newFamInstTyConName tc_name tys loc + = do { mod <- getModule + ; let info_string = occNameString (getOccName tc_name) ++ + concatMap (occNameString.getDFunTyKey) tys + ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string) + ; newGlobalBinder mod occ loc } \end{code} Stable names used for foreign exports and annotations. diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 2450d7b..8a0b4f4 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -74,7 +74,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this keep_var <- newIORef emptyNameSet ; used_rdrnames_var <- newIORef Set.empty ; th_var <- newIORef False ; - dfun_n_var <- newIORef 1 ; + dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { Just (_mod, te_var) -> return te_var ; Nothing -> newIORef emptyNameEnv } ; @@ -836,12 +836,15 @@ debugTc thing %************************************************************************ \begin{code} -nextDFunIndex :: TcM Int -- Get the next dfun index -nextDFunIndex = do { env <- getGblEnv - ; let dfun_n_var = tcg_dfun_n env - ; n <- readMutVar dfun_n_var - ; writeMutVar dfun_n_var (n+1) - ; return n } +chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName +chooseUniqueOccTc fn = + do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; set <- readMutVar dfun_n_var + ; let occ = fn set + ; writeMutVar dfun_n_var (extendOccSet set occ) + ; return occ + } getLIEVar :: TcM (TcRef LIE) getLIEVar = do { env <- getLclEnv; return (tcl_lie env) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index daed79d..19432fa 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -222,14 +222,8 @@ data TcGblEnv -- reference is implicit rather than explicit, so we have to zap a -- mutable variable. - tcg_dfun_n :: TcRef Int, - -- ^ Allows us to number off the names of DFuns. - -- - -- It's convenient to allocate an External Name for a DFun, with - -- a permanently-fixed unique, just like other top-level functions - -- defined in this module. But that means we need a canonical - -- occurrence name, distinct from all other dfuns in this module, - -- and this name supply serves that purpose (df1, df2, etc). + tcg_dfun_n :: TcRef OccSet, + -- ^ Allows us to choose unique DFun names. -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fiels are collected diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 738d36f..0e59f01 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -290,7 +290,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; checkValidTypeInst t_typats t_rhs -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name loc + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) (typeKind t_rhs) (Just (family, t_typats)) }} @@ -334,7 +334,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, newtypeConError tc_name (length k_cons) -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name loc + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc ; let ex_ok = True -- Existentials ok for type families! ; fixM (\ rep_tycon -> do { let orig_res_ty = mkTyConApp fam_tycon t_typats -- 1.7.10.4