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)
committerAustin Seipp <austin@well-typed.com>
Thu, 3 Jul 2014 15:19:43 +0000 (10:19 -0500)
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.

(cherry picked from commit 7ac600d5fcd74db1f991555de6e415030970d5f3)

Conflicts:
utils/haddock

17 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

index 50b3641..605513e 100644 (file)
@@ -248,8 +248,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]
 
 
@@ -297,6 +298,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 38922fc..457e33d 100644 (file)
@@ -66,7 +66,6 @@ import PrimOp
 import ForeignCall
 import DataCon
 import Id
-import Var              ( mkExportedLocalVar )
 import IdInfo
 import Demand
 import CoreSyn
@@ -956,29 +955,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;
@@ -988,12 +971,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 b3c8501..32908f6 100644 (file)
@@ -11,16 +11,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
@@ -28,8 +30,6 @@ import Util
 import BasicTypes
 import FastString
 import Var
-import Id
-import TcType
 import HsBinds( HsPatSynDetails(..) )
 
 import qualified Data.Data as Data
@@ -114,7 +114,7 @@ expression when available.
 -- See Note [Pattern synonym representation]
 data PatSyn
   = MkPatSyn {
-        psId          :: Id,
+        psName        :: Name,
         psUnique      :: Unique,      -- Cached from Name
 
         psArgs        :: [Type],
@@ -167,7 +167,7 @@ instance Uniquable PatSyn where
     getUnique = psUnique
 
 instance NamedThing PatSyn where
-    getName = getName . psId
+    getName = patSynName
 
 instance Outputable PatSyn where
     ppr = ppr . getName
@@ -208,7 +208,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,
@@ -217,20 +217,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
@@ -244,17 +245,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
@@ -262,6 +266,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)
@@ -270,12 +284,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
@@ -284,10 +299,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 e13767f..7afd601 100644 (file)
@@ -46,8 +46,6 @@ import OrdList
 import Data.List
 import Data.IORef
 import Control.Monad( when )
-import Data.Maybe ( mapMaybe )
-import UniqFM
 \end{code}
 
 %************************************************************************
@@ -119,27 +117,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
@@ -183,7 +174,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 fb02456..2ad9e97 100644 (file)
@@ -157,7 +157,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 d40e9c8..98f49c9 100644 (file)
@@ -1160,7 +1160,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 c3f9b49..32b4387 100644 (file)
@@ -1499,9 +1499,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 58d0c58..dd122d0 100644 (file)
@@ -71,7 +71,7 @@ module HscTypes (
         TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
         typeEnvFromEntities, mkTypeEnvWithImplicits,
         extendTypeEnv, extendTypeEnvList,
-        extendTypeEnvWithIds, extendTypeEnvWithPatSyns,
+        extendTypeEnvWithIds, 
         lookupTypeEnv,
         typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,
         typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
@@ -951,7 +951,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
@@ -1563,8 +1564,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
@@ -1680,17 +1681,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 858281a..ef7661a 100644 (file)
@@ -21,6 +21,8 @@ import CorePrep
 import CoreUtils
 import Literal
 import Rules
+import PatSyn
+import ConLike
 import CoreArity        ( exprArity, exprBotStrictness_maybe )
 import VarEnv
 import VarSet
@@ -129,18 +131,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'
@@ -333,19 +337,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
@@ -354,6 +352,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
 
@@ -405,11 +413,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 f3d7546..a077f5d 100644 (file)
@@ -66,6 +66,7 @@ import TcIface
 import PrelNames
 import TysWiredIn
 import Id
+import IdInfo( IdDetails(VanillaId) )
 import Var
 import VarSet
 import RdrName
@@ -801,7 +802,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 927062e..b418670 100644 (file)
@@ -790,9 +790,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 e8ba563..ced3492 100644 (file)
@@ -22,6 +22,7 @@ import Outputable
 import FastString
 import Var
 import Id
+import IdInfo( IdDetails( VanillaId ) )
 import TcBinds
 import BasicTypes
 import TcSimplify
@@ -128,7 +129,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
@@ -222,7 +223,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 12eb96f..e6428a6 100644 (file)
@@ -62,6 +62,7 @@ import PprCore
 import CoreSyn
 import ErrUtils
 import Id
+import IdInfo( IdDetails( VanillaId ) )
 import VarEnv
 import Module
 import UniqFM
@@ -735,7 +736,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
@@ -1361,7 +1362,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 5feaa7c..70d155b 100644 (file)
@@ -92,7 +92,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
@@ -1748,7 +1748,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 62e17d4..56968c4 100644 (file)
@@ -70,7 +70,7 @@ import Class
 import Inst
 import TyCon
 import CoAxiom
-import PatSyn ( patSynId )
+import PatSyn ( patSynName )
 import ConLike
 import DataCon
 import TcEvidence( TcEvBinds(..) )
@@ -1175,7 +1175,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 51e6464..1345696 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)
@@ -1796,7 +1796,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 ]
@@ -1836,8 +1836,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.