From fcf5ff34649982a99bc1e4a4940453a181a8d899 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Tue, 13 May 2008 08:44:00 +0000 Subject: [PATCH] FIX #1641: don't add auto sccs to compiler-generated bindings I also changed con2tag_Foo and related names to follow the standard practice of prefixing $ to compiler-generated names, so now we have $con2tag_Foo. --- compiler/basicTypes/OccName.lhs | 20 +++++++++++++++++--- compiler/deSugar/Desugar.lhs | 8 ++++++-- compiler/typecheck/TcGenDeriv.lhs | 16 +++++----------- 3 files changed, 28 insertions(+), 16 deletions(-) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index ba17c02..b6181fb 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -25,8 +25,10 @@ module OccName ( setOccNameSpace, -- ** Derived OccNames + isDerivedOccName, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkDerivedTyConOcc, mkNewTyCoOcc, + mkDerivedTyConOcc, mkNewTyCoOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, @@ -428,7 +430,6 @@ Here's our convention for splitting up the interface file name space: This knowledge is encoded in the following functions. - @mk_deriv@ generates an @OccName@ from the prefix and a string. NB: The string must already be encoded! @@ -439,6 +440,13 @@ mk_deriv :: NameSpace -> OccName mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) + +isDerivedOccName :: OccName -> Bool +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True + ':':c:_ | isAlphaNum c -> True + _other -> False \end{code} \begin{code} @@ -446,7 +454,8 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPArrayTyConOcc, mkPArrayDataConOcc, mkPReprTyConOcc, mkPADFunOcc :: OccName -> OccName @@ -467,6 +476,11 @@ mkNewTyCoOcc = mk_simple_deriv tcName ":Co" mkInstTyCoOcc = mk_simple_deriv tcName ":CoF" -- derived from rep ty mkEqPredCoOcc = mk_simple_deriv tcName "$co" +-- used in derived instances +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" + -- Generic derivable classes mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc2 = mk_simple_deriv varName "$gto" diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index eeaa154..6842e9d 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -38,7 +38,9 @@ import SrcLoc import Maybes import FastString import Coverage + import Data.IORef +import Data.Char \end{code} %************************************************************************ @@ -149,13 +151,15 @@ mkAutoScc mod exports | not opt_SccProfilingOn -- No profiling = NoSccs | opt_AutoSccsOnAllToplevs -- Add auto-scc on all top-level things - = AddSccs mod (\_ -> True) + = AddSccs mod (\id -> not $ isDerivedOccName $ getOccName id) + -- See #1641. This is pretty yucky, but I can't see a better way + -- to identify compiler-generated Ids, and at least this should + -- catch them all. | opt_AutoSccsOnExportedToplevs -- Only on exported things = AddSccs mod (\id -> idName id `elemNameSet` exports) | otherwise = NoSccs - deSugarExpr :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv -> LHsExpr Id diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index ea9a33f..4627e22 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1554,18 +1554,12 @@ z_Pat = nlVarPat z_RDR con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions -con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" -tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" -maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" +con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc +tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc +maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc -mk_tc_deriv_name :: TyCon -> [Char] -> RdrName -mk_tc_deriv_name tycon str - = mkDerivedRdrName tc_name mk_occ - where - tc_name = tyConName tycon - mk_occ tc_occ = mkVarOccFS (mkFastString new_str) - where - new_str = str ++ occNameString tc_occ ++ "#" +mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName +mk_tc_deriv_name tycon fun = mkDerivedRdrName (tyConName tycon) fun \end{code} s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports -- 1.7.10.4