Make the matcher and wrapper Ids in PatSyn into LocalIds, not GlobalIds
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 6 Jun 2014 10:39:41 +0000 (11:39 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 6 Jun 2014 12:06:09 +0000 (13:06 +0100)
This was a serious bug, exposed by Trac #9175.  The matcher and wrapper
must be LocalIds, like record selectors and dictionary functions, for
the reasons now documented in Note [Exported LocalIds] in Id.lhs

In fixing this I found
 - PatSyn should have an Id inside it (apart from the wrapper and matcher)
   It should be a Name.  Hence psId --> psName, with knock-on consequences

 - Tidying of PatSyns in TidyPgm was wrong

 - The keep-alive set in Desugar.deSugar (now) doesn't need pattern synonyms
   in it

I also cleaned up the interface to PatSyn a little, so there's a tiny knock-on
effect in Haddock; hence the haddock submodule update.

It's very hard to make a test for this bug, so I haven't.

18 files changed:
compiler/basicTypes/Id.lhs
compiler/basicTypes/MkId.lhs
compiler/basicTypes/PatSyn.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/MatchCon.lhs
compiler/hsSyn/Convert.lhs
compiler/iface/MkIface.lhs
compiler/main/HscTypes.lhs
compiler/main/TidyPgm.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcPatSyn.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/vectorise/Vectorise/Monad/Naming.hs
utils/haddock

index b180dc7..85e9b30 100644 (file)
@@ -254,8 +254,9 @@ mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info
 
 -- | Create a local 'Id' that is marked as exported.
 -- This prevents things attached to it from being removed as dead code.
-mkExportedLocalId :: Name -> Type -> Id
-mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo
+-- See Note [Exported LocalIds]
+mkExportedLocalId :: IdDetails -> Name -> Type -> Id
+mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo
         -- Note [Free type variables]
 
 
@@ -307,6 +308,40 @@ mkTemplateLocalsNum :: Int -> [Type] -> [Id]
 mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
 \end{code}
 
+Note [Exported LocalIds]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We use mkExportedLocalId for things like
+ - Dictionary functions (DFunId)
+ - Wrapper and matcher Ids for pattern synonyms
+ - Default methods for classes
+ - etc
+
+They marked as "exported" in the sense that they should be kept alive
+even if apparently unused in other bindings, and not dropped as dead
+code by the occurrence analyser.  (But "exported" here does not mean
+"brought into lexical scope by an import declaration". Indeed these
+things are always internal Ids that the user never sees.)
+
+It's very important that they are *LocalIds*, not GlobalIs, for lots
+of reasons:
+
+ * We want to treat them as free variables for the purpose of
+   dependency analysis (e.g. CoreFVs.exprFreeVars).
+
+ * Look them up in the current substitution when we come across
+   occurrences of them (in Subst.lookupIdSubst)
+
+ * Ensure that for dfuns that the specialiser does not float dict uses
+   above their defns, which would prevent good simplifications happening.
+
+ * The strictness analyser treats a occurrence of a GlobalId as
+   imported and assumes it contains strictness in its IdInfo, which
+   isn't true if the thing is bound in the same module as the
+   occurrence.
+
+In CoreTidy we must make all these LocalIds into GlobalIds, so that in
+importing modules (in --make mode) we treat them as properly global.
+That is what is happening in, say tidy_insts in TidyPgm.
 
 %************************************************************************
 %*                                                                      *
index 0678f78..7816ad9 100644 (file)
@@ -67,7 +67,6 @@ import PrimOp
 import ForeignCall
 import DataCon
 import Id
-import Var              ( mkExportedLocalVar )
 import IdInfo
 import Demand
 import CoreSyn
@@ -955,29 +954,13 @@ mkFCallId dflags uniq fcall ty
 %*                                                                      *
 %************************************************************************
 
-Important notes about dict funs and default methods
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Dict funs and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Dict funs and default methods are *not* ImplicitIds.  Their definition
 involves user-written code, so we can't figure out their strictness etc
 based on fixed info, as we can for constructors and record selectors (say).
 
-We build them as LocalIds, but with External Names.  This ensures that
-they are taken to account by free-variable finding and dependency
-analysis (e.g. CoreFVs.exprFreeVars).
-
-Why shouldn't they be bound as GlobalIds?  Because, in particular, if
-they are globals, the specialiser floats dict uses above their defns,
-which prevents good simplifications happening.  Also the strictness
-analyser treats a occurrence of a GlobalId as imported and assumes it
-contains strictness in its IdInfo, which isn't true if the thing is
-bound in the same module as the occurrence.
-
-It's OK for dfuns to be LocalIds, because we form the instance-env to
-pass on to the next module (md_insts) in CoreTidy, afer tidying
-and globalising the top-level Ids.
-
-BUT make sure they are *exported* LocalIds (mkExportedLocalId) so 
-that they aren't discarded by the occurrence analyser.
+NB: See also Note [Exported LocalIds] in Id
 
 \begin{code}
 mkDictFunId :: Name      -- Name to use for the dict fun;
@@ -987,12 +970,12 @@ mkDictFunId :: Name      -- Name to use for the dict fun;
             -> [Type]
             -> Id
 -- Implements the DFun Superclass Invariant (see TcInstDcls)
+-- See Note [Dict funs and default methods]
 
 mkDictFunId dfun_name tvs theta clas tys
-  = mkExportedLocalVar (DFunId n_silent is_nt)
-                       dfun_name
-                       dfun_ty
-                       vanillaIdInfo
+  = mkExportedLocalId (DFunId n_silent is_nt)
+                      dfun_name
+                      dfun_ty
   where
     is_nt = isNewTyCon (classTyCon clas)
     (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
index fe404eb..cba8427 100644 (file)
@@ -12,16 +12,18 @@ module PatSyn (
         PatSyn, mkPatSyn,
 
         -- ** Type deconstruction
-        patSynId, patSynType, patSynArity, patSynIsInfix,
-        patSynArgs, patSynTyDetails,
+        patSynName, patSynArity, patSynIsInfix,
+        patSynArgs, patSynTyDetails, patSynType,
         patSynWrapper, patSynMatcher,
-        patSynExTyVars, patSynSig, 
-        patSynInstArgTys, patSynInstResTy
+        patSynExTyVars, patSynSig,
+        patSynInstArgTys, patSynInstResTy,
+        tidyPatSynIds, patSynIds
     ) where
 
 #include "HsVersions.h"
 
 import Type
+import TcType( mkSigmaTy )
 import Name
 import Outputable
 import Unique
@@ -29,8 +31,6 @@ import Util
 import BasicTypes
 import FastString
 import Var
-import Id
-import TcType
 import HsBinds( HsPatSynDetails(..) )
 
 import qualified Data.Data as Data
@@ -115,7 +115,7 @@ expression when available.
 -- See Note [Pattern synonym representation]
 data PatSyn
   = MkPatSyn {
-        psId          :: Id,
+        psName        :: Name,
         psUnique      :: Unique,      -- Cached from Name
 
         psArgs        :: [Type],
@@ -168,7 +168,7 @@ instance Uniquable PatSyn where
     getUnique = psUnique
 
 instance NamedThing PatSyn where
-    getName = getName . psId
+    getName = patSynName
 
 instance Outputable PatSyn where
     ppr = ppr . getName
@@ -209,7 +209,7 @@ mkPatSyn name declared_infix orig_args
          prov_theta req_theta
          orig_res_ty
          matcher wrapper
-    = MkPatSyn {psId = id, psUnique = getUnique name,
+    = MkPatSyn {psName = name, psUnique = getUnique name,
                 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
                 psProvTheta = prov_theta, psReqTheta = req_theta,
                 psInfix = declared_infix,
@@ -218,20 +218,21 @@ mkPatSyn name declared_infix orig_args
                 psOrigResTy = orig_res_ty,
                 psMatcher = matcher,
                 psWrapper = wrapper }
-  where
-    pat_ty = mkSigmaTy univ_tvs req_theta $
-             mkSigmaTy ex_tvs prov_theta $
-             mkFunTys orig_args orig_res_ty
-    id = mkLocalId name pat_ty
 \end{code}
 
 \begin{code}
 -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification
-patSynId :: PatSyn -> Id
-patSynId = psId
+patSynName :: PatSyn -> Name
+patSynName = psName
 
 patSynType :: PatSyn -> Type
-patSynType = psOrigResTy
+-- The full pattern type, used only in error messages
+patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
+                     , psExTyVars   = ex_tvs,   psProvTheta = prov_theta
+                     , psArgs = orig_args, psOrigResTy = orig_res_ty })
+  = mkSigmaTy univ_tvs req_theta $
+    mkSigmaTy ex_tvs prov_theta $
+    mkFunTys orig_args orig_res_ty
 
 -- | Should the 'PatSyn' be presented infix?
 patSynIsInfix :: PatSyn -> Bool
@@ -245,17 +246,20 @@ patSynArgs :: PatSyn -> [Type]
 patSynArgs = psArgs
 
 patSynTyDetails :: PatSyn -> HsPatSynDetails Type
-patSynTyDetails ps = case (patSynIsInfix ps, patSynArgs ps) of
-    (True, [left, right]) -> InfixPatSyn left right
-    (_, tys) -> PrefixPatSyn tys
+patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys })
+  | is_infix, [left,right] <- arg_tys
+  = InfixPatSyn left right
+  | otherwise
+  = PrefixPatSyn arg_tys
 
 patSynExTyVars :: PatSyn -> [TyVar]
 patSynExTyVars = psExTyVars
 
-patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType)
+patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
 patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
-                    , psProvTheta = prov, psReqTheta = req })
-  = (univ_tvs, ex_tvs, prov, req)
+                    , psProvTheta = prov, psReqTheta = req
+                    , psArgs = arg_tys, psOrigResTy = res_ty })
+  = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
 
 patSynWrapper :: PatSyn -> Maybe Id
 patSynWrapper = psWrapper
@@ -263,6 +267,16 @@ patSynWrapper = psWrapper
 patSynMatcher :: PatSyn -> Id
 patSynMatcher = psMatcher
 
+patSynIds :: PatSyn -> [Id]
+patSynIds (MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
+  = case mb_wrap_id of
+      Nothing      -> [match_id]
+      Just wrap_id -> [match_id, wrap_id]
+
+tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
+tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
+  = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
+
 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 -- Return the types of the argument patterns
 -- e.g.  data D a = forall b. MkD a b (b->a)
@@ -271,12 +285,13 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 --          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c
 --   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]
 -- NB: the inst_tys should be both universal and existential
-patSynInstArgTys ps inst_tys
+patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
+                           , psExTyVars = ex_tvs, psArgs = arg_tys })
+                 inst_tys
   = ASSERT2( length tyvars == length inst_tys
-          , ptext (sLit "patSynInstArgTys") <+> ppr ps $$ ppr tyvars $$ ppr inst_tys )
-    map (substTyWith tyvars inst_tys) (psArgs ps)
+          , ptext (sLit "patSynInstArgTys") <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
+    map (substTyWith tyvars inst_tys) arg_tys
   where
-    (univ_tvs, ex_tvs, _, _) = patSynSig ps
     tyvars = univ_tvs ++ ex_tvs
 
 patSynInstResTy :: PatSyn -> [Type] -> Type
@@ -285,10 +300,10 @@ patSynInstResTy :: PatSyn -> [Type] -> Type
 --         P :: a -> b -> Just (a,a,b)
 --         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)
 -- NB: unlikepatSynInstArgTys, the inst_tys should be just the *universal* tyvars
-patSynInstResTy ps inst_tys
+patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
+                          , psOrigResTy = res_ty })
+                inst_tys
   = ASSERT2( length univ_tvs == length inst_tys
-           , ptext (sLit "patSynInstResTy") <+> ppr ps $$ ppr univ_tvs $$ ppr inst_tys )
-    substTyWith univ_tvs inst_tys (psOrigResTy ps)
-  where
-    (univ_tvs, _, _, _) = patSynSig ps
+           , ptext (sLit "patSynInstResTy") <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
+    substTyWith univ_tvs inst_tys res_ty
 \end{code}
index a103e7e..3160b35 100644 (file)
@@ -52,8 +52,6 @@ import OrdList
 import Data.List
 import Data.IORef
 import Control.Monad( when )
-import Data.Maybe ( mapMaybe )
-import UniqFM
 \end{code}
 
 %************************************************************************
@@ -125,27 +123,20 @@ deSugar hsc_env
                           ; let hpc_init
                                   | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
                                   | otherwise = empty
-                          ; let patsyn_defs = [(patSynId ps, ps) | ps <- patsyns]
                           ; return ( ds_ev_binds
                                    , foreign_prs `appOL` core_prs `appOL` spec_prs
                                    , spec_rules ++ ds_rules, ds_vects
-                                   , ds_fords `appendStubC` hpc_init
-                                   , patsyn_defs) }
+                                   , ds_fords `appendStubC` hpc_init) }
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, patsyn_defs) -> do
+           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do
 
      do {       -- Add export flags to bindings
           keep_alive <- readIORef keep_var
-        ; let (rules_for_locals, rules_for_imps)
-                   = partition isLocalRule all_rules
-              final_patsyns = addExportFlagsAndRules target export_set keep_alive [] patsyn_defs
-              exp_patsyn_wrappers = mapMaybe (patSynWrapper . snd) final_patsyns
-              exp_patsyn_matchers = map (patSynMatcher . snd) final_patsyns
-              keep_alive' = addListToUFM keep_alive (map (\x -> (x, getName x)) (exp_patsyn_wrappers ++ exp_patsyn_matchers))
-              final_prs = addExportFlagsAndRules target
-                              export_set keep_alive' rules_for_locals (fromOL all_prs)
+        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+              final_prs = addExportFlagsAndRules target export_set keep_alive
+                                                 rules_for_locals (fromOL all_prs)
 
               final_pgm = combineEvBinds ds_ev_binds final_prs
         -- Notice that we put the whole lot in a big Rec, even the foreign binds
@@ -189,7 +180,7 @@ deSugar hsc_env
                 mg_fam_insts    = fam_insts,
                 mg_inst_env     = inst_env,
                 mg_fam_inst_env = fam_inst_env,
-                mg_patsyns      = map snd . filter (isExportedId . fst) $ final_patsyns,
+                mg_patsyns      = filter ((`elemNameSet` export_set) . patSynName) patsyns,
                 mg_rules        = ds_rules_for_imps,
                 mg_binds        = ds_binds,
                 mg_foreign      = ds_fords,
index 4eec0d2..8e581f6 100644 (file)
@@ -158,7 +158,7 @@ matchOneConLike vars ty (eqn1 : eqns)       -- All eqns for a single constructor
 
     ex_tvs = case con1 of
                RealDataCon dcon1 -> dataConExTyVars dcon1
-               PatSynCon psyn1 -> patSynExTyVars psyn1
+               PatSynCon psyn1   -> patSynExTyVars psyn1
 
     match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
     -- All members of the group have compatible ConArgPats
index 04ca09e..6862901 100644 (file)
@@ -1158,7 +1158,7 @@ Consider this TH term construction:
      ; x3 <- TH.newName "x"
 
      ; let x = mkName "x"     -- mkName :: String -> TH.Name
-                              -- Builds a NameL
+                              -- Builds a NameS
 
      ; return (LamE (..pattern [x1,x2]..) $
                LamE (VarPat x3) $
index 21a8047..e3c0ac3 100644 (file)
@@ -1510,9 +1510,7 @@ patSynToIfaceDecl ps
                 , ifPatTy         = tidyToIfaceType env2 rhs_ty
                 }
   where
-    (univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig ps
-    args = patSynArgs ps
-    rhs_ty = patSynType ps
+    (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps
     (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
     (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
 
index 1e40d42..9738f59 100644 (file)
@@ -72,7 +72,7 @@ module HscTypes (
         TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
         typeEnvFromEntities, mkTypeEnvWithImplicits,
         extendTypeEnv, extendTypeEnvList,
-        extendTypeEnvWithIds, extendTypeEnvWithPatSyns,
+        extendTypeEnvWithIds, 
         lookupTypeEnv,
         typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,
         typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
@@ -952,7 +952,8 @@ data ModDetails
         -- The next two fields are created by the typechecker
         md_exports   :: [AvailInfo],
         md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module
-        md_insts     :: ![ClsInst],    -- ^ 'DFunId's for the instances in this module
+                                        -- Includes Ids, TyCons, PatSyns
+        md_insts     :: ![ClsInst],     -- ^ 'DFunId's for the instances in this module
         md_fam_insts :: ![FamInst],
         md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules
         md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently
@@ -1564,8 +1565,8 @@ implicitCoTyCon tc
 -- other declaration.
 isImplicitTyThing :: TyThing -> Bool
 isImplicitTyThing (AConLike cl) = case cl of
-    RealDataCon{}  -> True
-    PatSynCon ps   -> isImplicitId (patSynId ps)
+                                    RealDataCon {} -> True
+                                    PatSynCon {}   -> False
 isImplicitTyThing (AnId id)     = isImplicitId id
 isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
 isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
@@ -1681,17 +1682,6 @@ extendTypeEnvList env things = foldl extendTypeEnv env things
 extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
 extendTypeEnvWithIds env ids
   = extendNameEnvList env [(getName id, AnId id) | id <- ids]
-
-extendTypeEnvWithPatSyns :: TypeEnv -> [PatSyn] -> TypeEnv
-extendTypeEnvWithPatSyns env patsyns
-  = extendNameEnvList env $ concatMap pat_syn_things patsyns
-  where
-    pat_syn_things :: PatSyn -> [(Name, TyThing)]
-    pat_syn_things ps = (getName ps, AConLike (PatSynCon ps)):
-                        case patSynWrapper ps of
-                            Just wrap_id -> [(getName wrap_id, AnId wrap_id)]
-                            Nothing -> []
-
 \end{code}
 
 \begin{code}
index 9904bb0..7d47330 100644 (file)
@@ -23,6 +23,8 @@ import CorePrep
 import CoreUtils
 import Literal
 import Rules
+import PatSyn
+import ConLike
 import CoreArity        ( exprArity, exprBotStrictness_maybe )
 import VarEnv
 import VarSet
@@ -132,18 +134,20 @@ mkBootModDetailsTc hsc_env
         TcGblEnv{ tcg_exports   = exports,
                   tcg_type_env  = type_env, -- just for the Ids
                   tcg_tcs       = tcs,
+                  tcg_patsyns   = pat_syns,
                   tcg_insts     = insts,
                   tcg_fam_insts = fam_insts
                 }
   = do  { let dflags = hsc_dflags hsc_env
         ; showPass dflags CoreTidy
 
-        ; let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
-              ; dfun_ids   = map instanceDFunId insts'
+        ; let { insts'      = map (tidyClsInstDFun globaliseAndTidyId) insts
+              ; pat_syns'   = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
+              ; dfun_ids    = map instanceDFunId insts'
+              ; pat_syn_ids = concatMap patSynIds pat_syns'
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
-                                (typeEnvIds type_env) tcs fam_insts
-              ; type_env2  = extendTypeEnvWithPatSyns type_env1 (typeEnvPatSyns type_env)
-              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
+                                           (typeEnvIds type_env) tcs fam_insts
+              ; type_env'  = extendTypeEnvWithIds type_env1 (pat_syn_ids ++ dfun_ids)
               }
         ; return (ModDetails { md_types     = type_env'
                              , md_insts     = insts'
@@ -336,19 +340,13 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
         ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
                                     isExternalName (idName id)]
-              ; final_patsyns = filter (isExternalName . getName) patsyns
+              ; type_env1  = extendTypeEnvWithIds type_env final_ids
 
-              ; type_env' = extendTypeEnvWithIds type_env final_ids
-              ; type_env'' = extendTypeEnvWithPatSyns type_env' final_patsyns
-
-              ; tidy_type_env = tidyTypeEnv omit_prags type_env''
-
-              ; tidy_insts    = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts
-                -- A DFunId will have a binding in tidy_binds, and so
-                -- will now be in final_env, replete with IdInfo
-                -- Its name will be unchanged since it was born, but
-                -- we want Global, IdInfo-rich (or not) DFunId in the
-                -- tidy_insts
+              ; tidy_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) insts
+                -- A DFunId will have a binding in tidy_binds, and so will now be in
+                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since
+                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
+                -- tidy_insts.  Similarly the Ids inside a PatSyn.
 
               ; tidy_rules = tidyRules tidy_env ext_rules
                 -- You might worry that the tidy_env contains IdInfo-rich stuff
@@ -357,6 +355,16 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
               ; tidy_vect_info = tidyVectInfo tidy_env vect_info
 
+                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
+                -- and then override the PatSyns in the type_env with the new tidy ones
+                -- This is really the only reason we keep mg_patsyns at all; otherwise
+                -- they could just stay in type_env
+              ; tidy_patsyns = map (tidyPatSynIds (lookup_aux_id tidy_type_env)) patsyns
+              ; type_env2    = extendTypeEnvList type_env1
+                                    [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
+
+              ; tidy_type_env = tidyTypeEnv omit_prags type_env2
+
               -- See Note [Injecting implicit bindings]
               ; all_tidy_binds = implicit_binds ++ tidy_binds
 
@@ -408,11 +416,11 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               })
         }
 
-lookup_dfun :: TypeEnv -> Var -> Id
-lookup_dfun type_env dfun_id
-  = case lookupTypeEnv type_env (idName dfun_id) of
-        Just (AnId dfun_id') -> dfun_id'
-        _other -> pprPanic "lookup_dfun" (ppr dfun_id)
+lookup_aux_id :: TypeEnv -> Var -> Id
+lookup_aux_id type_env id
+  = case lookupTypeEnv type_env (idName id) of
+        Just (AnId id') -> id'
+        _other          -> pprPanic "lookup_axu_id" (ppr id)
 
 --------------------------
 tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
index 44df7e1..28cd7a6 100644 (file)
@@ -68,6 +68,7 @@ import TcIface
 import PrelNames
 import TysWiredIn
 import Id
+import IdInfo( IdDetails(VanillaId) )
 import Var
 import VarSet
 import RdrName
@@ -803,7 +804,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do
     name <- mkWrapperName "stable" str
     let occ = mkVarOccFS name :: OccName
         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
-        id  = mkExportedLocalId gnm sig_ty :: Id
+        id  = mkExportedLocalId VanillaId gnm sig_ty :: Id
     return id
 
 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
index cf95f03..cfc76d6 100644 (file)
@@ -791,9 +791,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn
            -> HsConPatDetails Name -> TcM a
            -> TcM (Pat TcId, a)
 tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
-  = do { let (univ_tvs, ex_tvs, prov_theta, req_theta) = patSynSig pat_syn
-              arg_tys = patSynArgs pat_syn
-              ty = patSynType pat_syn
+  = do { let (univ_tvs, ex_tvs, prov_theta, req_theta, arg_tys, ty) = patSynSig pat_syn
 
         ; (univ_tvs', inst_tys, subst) <- tcInstTyVars univ_tvs
 
index 894dfb2..82fa999 100644 (file)
@@ -24,6 +24,7 @@ import Outputable
 import FastString
 import Var
 import Id
+import IdInfo( IdDetails( VanillaId ) )
 import TcBinds
 import BasicTypes
 import TcSimplify
@@ -130,7 +131,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
 
        ; let matcher_tau = mkFunTys [pat_ty, cont_ty, res_ty] res_ty
              matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id = mkVanillaGlobal matcher_name matcher_sigma
+             matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma
 
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; let matcher_lid = L loc matcher_id
@@ -224,7 +225,7 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t
 
        ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
        ; let wrapper_lname = L loc wrapper_name
-             wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
+             wrapper_id = mkExportedLocalId VanillaId wrapper_name wrapper_sigma
 
        ; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
              wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
index 475158f..67fa39e 100644 (file)
@@ -61,6 +61,7 @@ import RnEnv
 import RnSource
 import ErrUtils
 import Id
+import IdInfo( IdDetails( VanillaId ) )
 import VarEnv
 import Module
 import UniqFM
@@ -632,7 +633,7 @@ checkHiBootIface
         where
           boot_dfun = instanceDFunId boot_inst
           boot_inst_ty = idType boot_dfun
-          local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
+          local_boot_dfun = Id.mkExportedLocalId VanillaId (idName boot_dfun) boot_inst_ty
 
 
 -- This has to compare the TyThing from the .hi-boot file to the TyThing
@@ -1045,7 +1046,7 @@ check_main dflags tcg_env
         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
                                    (mkVarOccFS (fsLit "main"))
                                    (getSrcSpan main_name)
-              ; root_main_id = Id.mkExportedLocalId root_main_name
+              ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name
                                                     (mkTyConApp ioTyCon [res_ty])
               ; co  = mkWpTyApps [res_ty]
               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
index 01aece7..d054bc2 100644 (file)
@@ -94,7 +94,7 @@ import Class    ( Class )
 import TyCon    ( TyCon )
 import ConLike  ( ConLike(..) )
 import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
-import PatSyn   ( PatSyn, patSynId )
+import PatSyn   ( PatSyn, patSynType )
 import TcType
 import Annotations
 import InstEnv
@@ -1752,7 +1752,7 @@ pprSkolInfo (PatSkol cl mc) = case cl of
                           , ptext (sLit "in") <+> pprMatchContext mc ]
     PatSynCon ps -> sep [ ptext (sLit "a pattern with pattern synonym")
                         , nest 2 $ ppr ps <+> dcolon
-                          <+> pprType (varType (patSynId ps)) <> comma
+                          <+> pprType (patSynType ps) <> comma
                         , ptext (sLit "in") <+> pprMatchContext mc ]
 pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
                                   , vcat [ ppr name <+> dcolon <+> ppr ty
index b3991b2..de3fbdb 100644 (file)
@@ -71,7 +71,7 @@ import Class
 import Inst
 import TyCon
 import CoAxiom
-import PatSyn ( patSynId )
+import PatSyn ( patSynName )
 import ConLike
 import DataCon
 import TcEvidence( TcEvBinds(..) )
@@ -1184,7 +1184,7 @@ reifyThing (AGlobal (AConLike (RealDataCon dc)))
                               (reifyName (dataConOrigTyCon dc)) fix)
         }
 reifyThing (AGlobal (AConLike (PatSynCon ps)))
-  = noTH (sLit "pattern synonyms") (ppr $ patSynId ps)
+  = noTH (sLit "pattern synonyms") (ppr $ patSynName ps)
 
 reifyThing (ATcId {tct_id = id})
   = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
index f771caf..94fefbb 100644 (file)
@@ -644,7 +644,7 @@ tcTyClDecl1 _parent rec_info
                ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
                ; return (clas, tvs', gen_dm_env) }
 
-       ; let { gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+       ; let { gen_dm_ids = [ AnId (mkExportedLocalId VanillaId gen_dm_name gen_dm_ty)
                             | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
                             , let gen_dm_tau = expectJust "tcTyClDecl1" $
                                                lookupNameEnv gen_dm_env (idName sel_id)
@@ -1797,7 +1797,7 @@ checkValidRoles tc
 mkDefaultMethodIds :: [TyThing] -> [Id]
 -- See Note [Default method Ids and Template Haskell]
 mkDefaultMethodIds things
-  = [ mkExportedLocalId dm_name (idType sel_id)
+  = [ mkExportedLocalId VanillaId dm_name (idType sel_id)
     | ATyCon tc <- things
     , Just cls <- [tyConClass_maybe tc]
     , (sel_id, DefMeth dm_name) <- classOpItems cls ]
@@ -1837,8 +1837,7 @@ mkRecSelBind (tycon, sel_name)
   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
   where
     loc    = getSrcSpan sel_name
-    sel_id = Var.mkExportedLocalVar rec_details sel_name
-                                    sel_ty vanillaIdInfo
+    sel_id = mkExportedLocalId rec_details sel_name sel_ty
     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1
index def1ffa..b533240 100644 (file)
@@ -24,6 +24,7 @@ import Name
 import SrcLoc
 import MkId
 import Id
+import IdInfo( IdDetails(VanillaId) )
 import FastString
 
 import Control.Monad
@@ -67,7 +68,7 @@ mkVectId :: Id -> Type -> VM Id
 mkVectId id ty
   = do { name <- mkLocalisedName mkVectOcc (getName id)
        ; let id' | isDFunId id     = MkId.mkDictFunId name tvs theta cls tys
-                 | isExportedId id = Id.mkExportedLocalId name ty
+                 | isExportedId id = Id.mkExportedLocalId VanillaId name ty
                  | otherwise       = Id.mkLocalId         name ty
        ; return id'
        }
@@ -91,8 +92,8 @@ newExportedVar occ_name ty
       u   <- liftDs newUnique
 
       let name = mkExternalName u mod occ_name noSrcSpan
-      
-      return $ Id.mkExportedLocalId name ty
+
+      return $ Id.mkExportedLocalId VanillaId name ty
 
 -- |Make a fresh local variable with the given type.
 -- The variable's name is formed using the given string as the prefix.
index c4f6201..276f201 160000 (submodule)
@@ -1 +1 @@
-Subproject commit c4f6201356b29023ecbd2f7bf1c91e5318586765
+Subproject commit 276f201de589999690e49491089c7e7ec9cfbf3f