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.

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index ba17c02..b6181fb 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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