From 83eef621e4a4fbb6c1343304ec638cafd6c9dc09 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 24 Nov 2000 17:02:06 +0000 Subject: [PATCH] [project @ 2000-11-24 17:02:01 by simonpj] 1. Make the new version machinery work. I think it does now! 2. Consequence of (1): Move the generation of default method names to one place (namely in RdrHsSyn.mkClassOpSigDM 3. Major clean up on HsDecls.TyClDecl These big constructors should have been records ages ago, and they are now. At last. --- ghc/compiler/basicTypes/Id.lhs | 17 ++- ghc/compiler/basicTypes/IdInfo.lhs | 8 +- ghc/compiler/basicTypes/MkId.lhs | 2 +- ghc/compiler/basicTypes/Name.lhs | 2 +- ghc/compiler/basicTypes/OccName.lhs | 12 +- ghc/compiler/coreSyn/CoreTidy.lhs | 9 +- ghc/compiler/count_lines | 4 +- ghc/compiler/hsSyn/HsBinds.lhs | 21 ++-- ghc/compiler/hsSyn/HsDecls.lhs | 209 ++++++++++++++++--------------- ghc/compiler/main/HscMain.lhs | 21 ++-- ghc/compiler/main/HscStats.lhs | 11 +- ghc/compiler/main/Main.hs | 9 +- ghc/compiler/main/MkIface.lhs | 91 ++++++++------ ghc/compiler/parser/Parser.y | 4 +- ghc/compiler/parser/RdrHsSyn.lhs | 19 +-- ghc/compiler/prelude/TysWiredIn.lhs | 2 +- ghc/compiler/rename/ParseIface.y | 9 +- ghc/compiler/rename/Rename.lhs | 7 +- ghc/compiler/rename/RnEnv.lhs | 4 +- ghc/compiler/rename/RnHiFiles.lhs | 26 ++-- ghc/compiler/rename/RnHsSyn.lhs | 12 +- ghc/compiler/rename/RnIfaces.lhs | 9 +- ghc/compiler/rename/RnNames.lhs | 15 ++- ghc/compiler/rename/RnSource.lhs | 57 +++++---- ghc/compiler/simplStg/SimplStg.lhs | 3 +- ghc/compiler/stgSyn/CoreToStg.lhs | 113 ++++++++++------- ghc/compiler/typecheck/TcClassDcl.lhs | 100 ++++++++------- ghc/compiler/typecheck/TcDeriv.lhs | 10 +- ghc/compiler/typecheck/TcEnv.lhs | 30 ++--- ghc/compiler/typecheck/TcIfaceSig.lhs | 2 +- ghc/compiler/typecheck/TcInstDcls.lhs | 50 ++++---- ghc/compiler/typecheck/TcModule.lhs | 6 +- ghc/compiler/typecheck/TcMonad.lhs | 47 +------ ghc/compiler/typecheck/TcTyClsDecls.lhs | 73 +++++------ ghc/compiler/typecheck/TcTyDecls.lhs | 5 +- ghc/compiler/types/Generics.hi-boot-5 | 2 +- ghc/compiler/types/Generics.lhs | 4 +- 37 files changed, 518 insertions(+), 507 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 0864777..b907563 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -26,9 +26,9 @@ module Id ( externallyVisibleId, isIP, isSpecPragmaId, isRecordSelector, - isPrimOpId, isPrimOpId_maybe, - isDataConId, isDataConId_maybe, isDataConWrapId, - isDataConWrapId_maybe, + isPrimOpId, isPrimOpId_maybe, isDictFunId, + isDataConId, isDataConId_maybe, + isDataConWrapId, isDataConWrapId_maybe, isBottomingId, isExportedId, isLocalId, hasNoBinding, @@ -244,6 +244,10 @@ hasNoBinding id = case idFlavour id of -- binding, even though it is defined in this module. Notably, -- the constructors of a dictionary are in this situation. +isDictFunId id = case idFlavour id of + DictFunId -> True + other -> False + -- Don't drop a binding for an exported Id, -- if it otherwise looks dead. -- Perhaps a better name would be isDiscardableId @@ -295,7 +299,12 @@ omitIfaceSigForId' id -- The dfun id must *not* be omitted, because it carries version info for -- the instance decl - other -> False -- Don't omit! + ConstantId -> False -- Ordinary Ids + DictFunId -> False + + ExportedId -> False -- I don't think these happen + VanillaId -> False -- ditto + SpecPragmaId -> False -- ditto \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index a8f16ae..cb77d6b 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -244,8 +244,11 @@ data IdFlavour | ExportedId -- Locally defined, exported | SpecPragmaId -- Locally defined, RHS holds specialised call - | ConstantId -- Imported from elsewhere, or a dictionary function, - -- default method Id. + | ConstantId -- Imported from elsewhere, or a default method Id. + + | DictFunId -- We flag dictionary functions so that we can + -- conveniently extract the DictFuns from a set of + -- bindings when building a module's interface | DataConId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* @@ -262,6 +265,7 @@ ppFlavourInfo VanillaId = empty ppFlavourInfo ExportedId = ptext SLIT("[Exported]") ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") ppFlavourInfo ConstantId = ptext SLIT("[Constant]") +ppFlavourInfo DictFunId = ptext SLIT("[DictFun]") ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]") ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]") diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 47818a3..ccc56cc 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -632,7 +632,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta = mkId dfun_name dfun_ty info where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - info = constantIdInfo `setTyGenInfo` TyGenNever + info = mkIdInfo DictFunId `setTyGenInfo` TyGenNever -- type is wired-in (see comment at TcClassDcl.tcClassSig), so -- do not generalise it diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 38aec1c..8d8f56c 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -44,7 +44,7 @@ module Name ( import OccName -- All of it import Module ( Module, moduleName, mkVanillaModule, isHomeModule ) import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) -import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) +import CmdLineOpts ( opt_Static ) import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 ) import FastTypes diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index a794b75..f914535 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -326,17 +326,9 @@ mkSuperDictSelOcc index cls_occ \begin{code} mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" - -> Int -- Unique to distinguish dfuns which share the previous two - -- eg 3 - -- The requirement is that the (string,index) pair be unique in this module + -> OccName -- "$fOrdMaybe" - -> OccName -- "$fOrdMaybe3" - -mkDFunOcc string index - = mk_deriv VarName "$f" (show_index ++ string) - where - show_index | index == 0 = "" - | otherwise = show index +mkDFunOcc string = mk_deriv VarName "$f" string \end{code} We used to add a '$m' to indicate a method, but that gives rise to bad diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index e959574..f1f3142 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -20,7 +20,7 @@ import VarEnv import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, isExportedId, - mkVanillaId, mkId, isLocalId, + mkVanillaId, mkId, isLocalId, omitIfaceSigForId, setIdStrictness, setIdDemandInfo, ) import IdInfo ( constantIdInfo, @@ -293,7 +293,11 @@ tidyTopRhs (_, occ_env, subst_env) rhs = tidyExpr (occ_env, subst_env) rhs tidyTopBinder :: Module -> IdEnv Bool -> TopTidyEnv -> CoreExpr -> TopTidyEnv -> Id -> (TopTidyEnv, Id) -tidyTopBinder mod ext_ids env_idinfo rhs (orig_env, occ_env, subst_env) id +tidyTopBinder mod ext_ids env_idinfo rhs env@(orig_env, occ_env, subst_env) id + | omitIfaceSigForId id -- Don't mess with constructors, + = (env, id) -- record selectors, and the like + + | otherwise -- This function is the heart of Step 2 -- The second env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive @@ -321,7 +325,6 @@ tidyTopBinder mod ext_ids env_idinfo rhs (orig_env, occ_env, subst_env) id | otherwise = noUnfolding tidyIdInfo (_, occ_env, subst_env) is_external unfold_info id - | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't = constantIdInfo diff --git a/ghc/compiler/count_lines b/ghc/compiler/count_lines index cbf6503..9fb7b19 100644 --- a/ghc/compiler/count_lines +++ b/ghc/compiler/count_lines @@ -1,4 +1,4 @@ -#! /usr/local/bin/perl +#! /usr/bin/perl # %DirCount = (); %ModCount = (); @@ -8,7 +8,7 @@ foreach $f ( @ARGV ) { if ( $f =~ /\.lhs$/ ) { - open(INF, "unlit $f - |") || die "Couldn't unlit $f!\n"; + open(INF, "/home/simonpj/builds/slpj/ghc/utils/unlit/unlit $f - |") || die "Couldn't unlit $f!\n"; } else { open(INF, "< $f") || die "Couldn't open $f!\n"; } diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index f1e9191..2cea4d2 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -240,9 +240,12 @@ data Sig name (HsType name) SrcLoc - | ClassOpSig name -- Selector name - (Maybe (DefMeth name)) -- Nothing for source-file class signatures - -- Gives DefMeth info for interface files sigs + | ClassOpSig name -- Selector name + (DefMeth name) -- (Just dm_name) for source-file class signatures + -- The name may not be used, if there isn't a + -- generic default method, but it's there if we + -- need it + -- Gives DefMeth info for interface files sigs (HsType name) SrcLoc @@ -340,15 +343,9 @@ ppr_sig (ClassOpSig var dm ty _) = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)] where pp_dm = case dm of - Just (DefMeth _) -> equals -- Default method indicator - Just GenDefMeth -> semi -- Generic method indicator - Just NoDefMeth -> empty -- No Method at all - -- Not convinced this is right... - -- Not used in interface file output hopefully - -- but needed for ddump-rn ?? - other -> dot - -- empty -- No method at all - + DefMeth _ -> equals -- Default method indicator + GenDefMeth -> semi -- Generic method indicator + NoDefMeth -> empty -- No Method at all ppr_sig (SpecSig var ty _) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index c464de5..64f6725 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -160,38 +160,43 @@ Plan of attack: \begin{code} data TyClDecl name pat - = IfaceSig name -- It may seem odd to classify an interface-file signature - (HsType name) -- as a 'TyClDecl', but it's very convenient. These three - [HsIdInfo name] -- are the kind that appear in interface files. - SrcLoc - - | TyData NewOrData - (HsContext name) -- context - name -- type constructor - [HsTyVarBndr name] -- type variables - [ConDecl name] -- data constructors (empty if abstract) - Int -- Number of data constructors (valid even if type is abstract) - (Maybe [name]) -- derivings; Nothing => not specified + = IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature + tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. These three + tcdIdInfo :: [HsIdInfo name], -- are the kind that appear in interface files. + tcdLoc :: SrcLoc + } + + | TyData { tcdND :: NewOrData, + tcdCtxt :: HsContext name, -- context + tcdName :: name, -- type constructor + tcdTyVars :: [HsTyVarBndr name], -- type variables + tcdCons :: [ConDecl name], -- data constructors (empty if abstract) + tcdNCons :: Int, -- Number of data constructors (valid even if type is abstract) + tcdDerivs :: Maybe [name], -- derivings; Nothing => not specified -- (i.e., derive default); Just [] => derive -- *nothing*; Just => as you would -- expect... - SrcLoc - name -- generic converter functions - name -- generic converter functions - - | TySynonym name -- type constructor - [HsTyVarBndr name] -- type variables - (HsType name) -- synonym expansion - SrcLoc - - | ClassDecl (HsContext name) -- context... - name -- name of the class - [HsTyVarBndr name] -- the class type variables - [FunDep name] -- functional dependencies - [Sig name] -- methods' signatures - (MonoBinds name pat) -- default methods - (ClassDeclSysNames name) - SrcLoc + tcdSysNames :: DataSysNames name, -- Generic converter functions + tcdLoc :: SrcLoc + } + + | TySynonym { tcdName :: name, -- type constructor + tcdTyVars :: [HsTyVarBndr name], -- type variables + tcdSynRhs :: HsType name, -- synonym expansion + tcdLoc :: SrcLoc + } + + | ClassDecl { tcdCtxt :: HsContext name, -- Context... + tcdName :: name, -- Name of the class + tcdTyVars :: [HsTyVarBndr name], -- The class type variables + tcdFDs :: [FunDep name], -- Functional dependencies + tcdSigs :: [Sig name], -- Methods' signatures + tcdMeths :: Maybe (MonoBinds name pat), -- Default methods + -- Nothing for imported class decls + -- Just bs for source class decls + tcdSysNames :: ClassSysNames name, + tcdLoc :: SrcLoc + } \end{code} Simple classifiers @@ -199,17 +204,17 @@ Simple classifiers \begin{code} isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool -isIfaceSigDecl (IfaceSig _ _ _ _) = True -isIfaceSigDecl other = False +isIfaceSigDecl (IfaceSig {}) = True +isIfaceSigDecl other = False -isSynDecl (TySynonym _ _ _ _) = True -isSynDecl other = False +isSynDecl (TySynonym {}) = True +isSynDecl other = False -isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True -isDataDecl other = False +isDataDecl (TyData {}) = True +isDataDecl other = False -isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True -isClassDecl other = False +isClassDecl (ClassDecl {}) = True +isClassDecl other = False \end{code} Dealing with names @@ -217,11 +222,7 @@ Dealing with names \begin{code} -------------------------------- tyClDeclName :: TyClDecl name pat -> name -tyClDeclName (IfaceSig name _ _ _) = name -tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name -tyClDeclName (TySynonym name _ _ _) = name -tyClDeclName (ClassDecl _ name _ _ _ _ _ _) = name - +tyClDeclName tycl_decl = tcdName tycl_decl -------------------------------- tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] @@ -230,33 +231,43 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] -- For record fields, the first one counts as the SrcLoc -- We use the equality to filter out duplicate field names -tyClDeclNames (TySynonym name _ _ loc) - = [(name,loc)] +tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)] +tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)] -tyClDeclNames (ClassDecl _ cls_name _ _ sigs _ _ loc) +tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc}) = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs] -tyClDeclNames (TyData _ _ tc_name _ cons _ _ loc _ _) +tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc}) = (tc_name,loc) : conDeclsNames cons -tyClDeclNames (IfaceSig name _ _ loc) = [(name,loc)] -------------------------------- +-- The "system names" are extra implicit names. +-- They are kept in a list rather than a tuple +-- to make the renamer easier. + +type ClassSysNames name = [name] +-- For class decls they are: +-- [tycon, datacon wrapper, datacon worker, +-- superclass selector 1, ..., superclass selector n] + +type DataSysNames name = [name] +-- For data decls they are +-- [from, to] +-- where from :: T -> Tring +-- to :: Tring -> T + tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)] -- Similar to tyClDeclNames, but returns the "implicit" -- or "system" names of the declaration -tyClDeclSysNames (ClassDecl _ _ _ _ _ _ names loc) = [(n,loc) | n <- names] -tyClDeclSysNames (TyData _ _ _ _ cons _ _ _ _ _) = [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons] -tyClDeclSysNames decl = [] - +tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc}) + = [(n,loc) | n <- names] +tyClDeclSysNames (TyData {tcdCons = cons, tcdSysNames = names, tcdLoc = loc}) + = [(n,loc) | n <- names] ++ + [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons] +tyClDeclSysNames decl = [] --------------------------------- -type ClassDeclSysNames name = [name] - -- [tycon, datacon wrapper, datacon worker, - -- superclass selector 1, ..., superclass selector n] - -- They are kept in a list rather than a tuple to make the - -- renamer easier. mkClassDeclSysNames :: (name, name, name, [name]) -> [name] getClassDeclSysNames :: [name] -> (name, name, name, [name]) @@ -267,30 +278,31 @@ getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) \begin{code} instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where -- Used only when building interface files - (==) (IfaceSig n1 t1 i1 _) - (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2 - - (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _) - (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _) - = n1 == n2 && - nd1 == nd2 && - eqWithHsTyVars tvs1 tvs2 (\ env -> - eq_hsContext env cxt1 cxt2 && - eqListBy (eq_ConDecl env) cons1 cons2 - ) - - (==) (TySynonym n1 tvs1 ty1 _) - (TySynonym n2 tvs2 ty2 _) - = n1 == n2 && - eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2) - - (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ ) - (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ ) - = n1 == n2 && - eqWithHsTyVars tvs1 tvs2 (\ env -> - eq_hsContext env cxt1 cxt2 && - eqListBy (eq_hsFD env) fds1 fds2 && - eqListBy (eq_cls_sig env) sigs1 sigs2 + (==) d1@(IfaceSig {}) d2@(IfaceSig {}) + = tcdName d1 == tcdName d2 && + tcdType d1 == tcdType d2 && + tcdIdInfo d1 == tcdIdInfo d2 + + (==) d1@(TyData {}) d2@(TyData {}) + = tcdName d1 == tcdName d2 && + tcdND d1 == tcdND d2 && + eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> + eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) && + eqListBy (eq_ConDecl env) (tcdCons d1) (tcdCons d2) + ) + + (==) d1@(TySynonym {}) d2@(TySynonym {}) + = tcdName d1 == tcdName d2 && + eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> + eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2) + ) + + (==) d1@(ClassDecl {}) d2@(ClassDecl {}) + = tcdName d1 == tcdName d2 && + eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> + eq_hsContext env (tcdCtxt d1) (tcdCtxt d2) && + eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) && + eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2) ) (==) _ _ = False -- default case @@ -305,11 +317,10 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) -- This is used for comparing declarations before putting -- them into interface files, and the name of the default -- method isn't relevant - Nothing `eq_dm` Nothing = True - (Just NoDefMeth) `eq_dm` (Just NoDefMeth) = True - (Just GenDefMeth) `eq_dm` (Just GenDefMeth) = True - (Just (DefMeth _)) `eq_dm` (Just (DefMeth _)) = True - dm1 `eq_dm` dm2 = False + NoDefMeth `eq_dm` NoDefMeth = True + GenDefMeth `eq_dm` GenDefMeth = True + DefMeth _ `eq_dm` DefMeth _ = True + dm1 `eq_dm` dm2 = False \end{code} @@ -318,27 +329,28 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls - = (length [() | ClassDecl _ _ _ _ _ _ _ _ <- decls], - length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls], - length [() | TyData NewType _ _ _ _ _ _ _ _ _ <- decls], - length [() | TySynonym _ _ _ _ <- decls], - length [() | IfaceSig _ _ _ _ <- decls]) + = (length [() | ClassDecl {} <- decls], + length [() | TySynonym {} <- decls], + length [() | IfaceSig {} <- decls], + length [() | TyData {tcdND = DataType} <- decls], + length [() | TyData {tcdND = NewType} <- decls]) \end{code} \begin{code} instance (NamedThing name, Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where - ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] + ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) + = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] - ppr (TySynonym tycon tyvars mono_ty src_loc) + ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals) 4 (ppr mono_ty) - ppr (TyData new_or_data context tycon tyvars condecls ncons - derivings src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM - = pp_tydecl - (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals) + ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, + tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons, + tcdDerivs = derivings}) + = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals) (pp_condecls condecls ncons) derivings where @@ -346,7 +358,8 @@ instance (NamedThing name, Outputable name, Outputable pat) NewType -> SLIT("newtype") DataType -> SLIT("data") - ppr (ClassDecl context clas tyvars fds sigs methods _ src_loc) + ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods}) | null sigs -- No "where" part = top_matter diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index e3d5a46..a9b0223 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -16,6 +16,9 @@ module HscMain ( HscResult(..), hscMain, import RdrHsSyn ( RdrNameHsExpr ) import CoreToStg ( coreToStgExpr ) import StringBuffer ( stringToStringBuffer, freeStringBuffer ) +import Unique ( Uniquable(..) ) +import Type ( splitTyConApp_maybe ) +import PrelNames ( ioTyConKey ) #endif import HsSyn @@ -32,7 +35,6 @@ import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails, writeIface, pprIface ) import TcModule import Type -import TcHsSyn import InstEnv ( emptyInstEnv ) import Desugar import SimplCore @@ -48,8 +50,6 @@ import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn, showPass ) import Util ( unJust ) -import Unique ( Uniquable(..) ) -import PrelNames ( ioTyConKey ) import UniqSupply ( mkSplitUniqSupply ) import Bag ( emptyBag ) @@ -62,7 +62,6 @@ import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), HomeSymbolTable, OrigNameEnv(..), PackageRuleBase, HomeIfaceTable, typeEnvClasses, typeEnvTyCons, emptyIfaceTable ) -import Type ( splitTyConApp_maybe ) import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) import Name ( Name, nameModule, nameOccName, getName ) @@ -160,11 +159,10 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch Just (pcs_tc, tc_result) -> do { let env_tc = tc_env tc_result - local_insts = tc_insts tc_result local_rules = tc_rules tc_result ; -- create a new details from the closed, typechecked, old iface - let new_details = mkModDetailsFromIface env_tc local_insts local_rules + let new_details = mkModDetailsFromIface env_tc local_rules ; return (HscNoRecomp pcs_tc new_details old_iface) }}}} @@ -206,8 +204,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch Nothing -> return (HscFail pcs_rn); Just (pcs_tc, tc_result) -> do { - ; let env_tc = tc_env tc_result - local_insts = tc_insts tc_result + ; let env_tc = tc_env tc_result ------------------- -- DESUGAR, SIMPLIFY, TIDY-CORE @@ -227,7 +224,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ------------------- -- BUILD THE NEW ModDetails AND ModIface ------------------- - ; let new_details = mkModDetails env_tc local_insts tidy_binds + ; let new_details = mkModDetails env_tc tidy_binds top_level_ids orphan_rules ; final_iface <- mkFinalIface ghci_mode dflags location maybe_checked_iface new_iface new_details @@ -359,16 +356,16 @@ dsThenSimplThenTidy dflags pcs hst this_mod print_unqual is_exported tc_result myCoreToStg dflags this_mod tidy_binds = do - () <- coreBindsSize occ_anal_tidy_binds `seq` return () + () <- coreBindsSize tidy_binds `seq` return () -- TEMP: the above call zaps some space usage allocated by the -- simplifier, which for reasons I don't understand, persists -- thoroughout code generation -- _scc_ "Core2Stg" - stg_binds <- topCoreBindsToStg dflags occ_anal_tidy_binds + stg_binds <- topCoreBindsToStg dflags this_mod tidy_binds -- _scc_ "Stg2Stg" - (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds + (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod stg_binds let final_ids = collectFinalStgBinders (map fst stg_binds2) return (stg_binds2, cost_centre_info, final_ids) diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 12c261d..8338b01 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -104,6 +104,9 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) count_monobinds (PatMonoBind p r _) = (0,1) count_monobinds (FunMonoBind f _ m _) = (0,1) + count_mb_monobinds (Just mbs) = count_monobinds mbs + count_mb_monobinds Nothing = (0,0) + count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) sig_info (Sig _ _ _) = (1,0,0,0) @@ -123,14 +126,14 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) spec_info (Just (False, _)) = (0,0,0,0,1,0) spec_info (Just (True, _)) = (0,0,0,0,0,1) - data_info (TyData _ _ _ _ _ nconstrs derivs _ _ _) + data_info (TyData {tcdNCons = nconstrs, tcdDerivs = derivs}) = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) - class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ ) - = case count_sigs meth_sigs of + class_info decl@(ClassDecl {}) + = case count_sigs (tcdSigs decl) of (_,classops,_,_) -> - (classops, addpr (count_monobinds def_meths)) + (classops, addpr (count_mb_monobinds (tcdMeths decl))) class_info other = (0,0) inst_info (InstDecl _ inst_meths inst_sigs _ _) diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 13aa963..6f7be2f 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.33 2000/11/24 09:51:39 simonpj Exp $ +-- $Id: Main.hs,v 1.34 2000/11/24 17:02:02 simonpj Exp $ -- -- GHC Driver program -- @@ -19,7 +19,11 @@ module Main (main) where #ifdef GHCI import Interpreter import InteractiveUI +#endif + +#ifndef mingw32_TARGET_OS import Dynamic +import Posix #endif import CompManager @@ -40,9 +44,6 @@ import Util import Concurrent -#ifndef mingw32_TARGET_OS -import Posix -#endif import Directory import IOExts import Exception diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index b6c1606..70748aa 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -22,15 +22,15 @@ import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) import TcHsSyn ( TypecheckedRuleDecl ) import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, TypeEnv, isTyClThing, Avails, + TyThing(..), DFunId, TypeEnv, Avails, WhatsImported(..), GenAvailInfo(..), ImportVersion, AvailInfo, Deprecations(..), extendTypeEnvList ) import CmdLineOpts -import Id ( Id, idType, idInfo, omitIfaceSigForId, - idSpecialisation, setIdInfo, isLocalId +import Id ( Id, idType, idInfo, omitIfaceSigForId, isDictFunId, + idSpecialisation, setIdInfo, isLocalId, idName, hasNoBinding ) import Var ( isId ) import VarSet @@ -40,7 +40,7 @@ import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule, isBuiltinRule, rulesRules, bindersOf, bindersOfBinds ) -import CoreFVs ( ruleSomeLhsFreeVars, ruleSomeFreeVars ) +import CoreFVs ( ruleSomeLhsFreeVars ) import CoreUnfold ( neverUnfold, unfoldingTemplate ) import Name ( getName, nameModule, Name, NamedThing(..) ) import Name -- Env @@ -66,38 +66,44 @@ import IO ( IOMode(..), openFile, hClose ) %************************************************************************ \begin{code} -mkModDetails :: TypeEnv -> [DFunId] -- From typechecker - -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the - -- code generator; they have authoritative arity info - -> [IdCoreRule] -- Tidy orphan rules +mkModDetails :: TypeEnv -- From typechecker + -> [CoreBind] -- Final bindings + -> [Id] -- Top-level Ids from the code generator; + -- they have authoritative arity info + -> [IdCoreRule] -- Tidy orphan rules -> ModDetails -mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules +mkModDetails type_env tidy_binds stg_ids orphan_rules = ModDetails { md_types = new_type_env, md_rules = rule_dcls, - md_insts = dfun_ids } + md_insts = filter isDictFunId final_ids } where -- The competed type environment is gotten from -- a) keeping the types and classes -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings - -- From (c) we keep only those Ids with Global names, plus Ids - -- accessible from them (notably via unfoldings) + -- From (c) we keep only those Ids with Global names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -- -- However, we do keep things like constructors, which should not appear -- in interface files, because they are needed by importing modules when -- using the compilation manager - new_type_env = extendTypeEnvList (filterNameEnv isTyClThing type_env) + new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env) (map AnId final_ids) + -- We keep constructor workers, because they won't appear + -- in the bindings from which final_ids are derived! + keep_it (AnId id) = hasNoBinding id + keep_it other = True + stg_id_set = mkVarSet stg_ids final_ids = [addStgInfo stg_id_set id | bind <- tidy_binds , id <- bindersOf bind , isGlobalName (idName id)] - -- The complete rules are gotten by combining -- a) the orphan rules -- b) rules embedded in the top-level Ids @@ -106,14 +112,15 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules -- This version is used when we are re-linking a module -- so we've only run the type checker on its previous interface -mkModDetailsFromIface :: TypeEnv -> [DFunId] -- From typechecker +mkModDetailsFromIface :: TypeEnv -> [TypecheckedRuleDecl] -> ModDetails -mkModDetailsFromIface type_env dfun_ids rules +mkModDetailsFromIface type_env rules = ModDetails { md_types = type_env, md_rules = rule_dcls, md_insts = dfun_ids } where + dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id] rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules] -- All the rules from an interface are of the IfaceRuleOut form \end{code} @@ -231,19 +238,20 @@ ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] ifaceTyCls (AClass clas) so_far = cls_decl : so_far where - cls_decl = ClassDecl (toHsContext sc_theta) - (getName clas) - (toHsTyVars clas_tyvars) - (toHsFDs clas_fds) - (map toClassOpSig op_stuff) - EmptyMonoBinds - [] noSrcLoc + cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, + tcdName = getName clas, + tcdTyVars = toHsTyVars clas_tyvars, + tcdFDs = toHsFDs clas_fds, + tcdSigs = map toClassOpSig op_stuff, + tcdMeths = Nothing, + tcdSysNames = bogus_sysnames, + tcdLoc = noSrcLoc } (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas toClassOpSig (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) - ClassOpSig (getName sel_id) (Just def_meth') (toHsType op_ty) noSrcLoc + ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc where (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) def_meth' = case def_meth of @@ -256,16 +264,21 @@ ifaceTyCls (ATyCon tycon) so_far | otherwise = ty_decl : so_far where ty_decl | isSynTyCon tycon - = TySynonym (getName tycon)(toHsTyVars tyvars) - (toHsType syn_ty) noSrcLoc + = TySynonym { tcdName = getName tycon, + tcdTyVars = toHsTyVars tyvars, + tcdSynRhs = toHsType syn_ty, + tcdLoc = noSrcLoc } | isAlgTyCon tycon - = TyData new_or_data (toHsContext (tyConTheta tycon)) - (getName tycon) - (toHsTyVars tyvars) - (map ifaceConDecl (tyConDataCons tycon)) - (tyConFamilySize tycon) - Nothing noSrcLoc (panic "gen1") (panic "gen2") + = TyData { tcdND = new_or_data, + tcdCtxt = toHsContext (tyConTheta tycon), + tcdName = getName tycon, + tcdTyVars = toHsTyVars tyvars, + tcdCons = map ifaceConDecl (tyConDataCons tycon), + tcdNCons = tyConFamilySize tycon, + tcdDerivs = Nothing, + tcdSysNames = bogus_sysnames, + tcdLoc = noSrcLoc } | otherwise = pprPanic "ifaceTyCls" (ppr tycon) @@ -301,7 +314,10 @@ ifaceTyCls (AnId id) so_far | omitIfaceSigForId id = so_far | otherwise = iface_sig : so_far where - iface_sig = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc + iface_sig = IfaceSig { tcdName = getName id, + tcdType = toHsType id_type, + tcdIdInfo = hs_idinfo, + tcdLoc = noSrcLoc } id_type = idType id id_info = idInfo id @@ -371,6 +387,8 @@ ifaceRule (id, Rule name bndrs args rhs) = IfaceRule name (map toUfBndr bndrs) (getName id) (map toUfExpr args) (toUfExpr rhs) noSrcLoc +bogus_sysnames = panic "Bogus sys names" + bogusIfaceRule id = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc \end{code} @@ -409,7 +427,8 @@ addVersionInfo (Just old_iface@(ModIface { mi_version = old_version, -- mi_globals field set to anything reasonable. | otherwise -- Add updated version numbers - = (final_iface, Just pp_tc_diffs) + = pprTrace "completeIface" (ppr (dcl_tycl old_decls)) + (final_iface, Just pp_tc_diffs) where final_iface = new_iface { mi_version = new_version } @@ -449,7 +468,7 @@ diffDecls old_vers old_fixities new_fixities old new same_fixity n = lookupNameEnv old_fixities n == lookupNameEnv new_fixities n diff ok_so_far pp new_vers [] [] = (ok_so_far, pp, new_vers) - diff ok_so_far pp new_vers old [] = (False, pp, new_vers) + diff ok_so_far pp new_vers (od:ods) [] = diff False (pp $$ only_old od) new_vers ods [] diff ok_so_far pp new_vers [] (nd:nds) = diff False (pp $$ only_new nd) new_vers [] nds diff ok_so_far pp new_vers (od:ods) (nd:nds) = case od_name `compare` nd_name of @@ -461,7 +480,7 @@ diffDecls old_vers old_fixities new_fixities old new od_name = tyClDeclName od nd_name = tyClDeclName nd new_vers' = extendNameEnv new_vers nd_name - (bumpVersion True (lookupNameEnv_NF old_vers od_name)) + (bumpVersion False (lookupNameEnv_NF old_vers od_name)) only_old d = ptext SLIT("Only in old iface:") <+> ppr d only_new d = ptext SLIT("Only in new iface:") <+> ppr d diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 9dc85a2..dbc68a2 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.48 2000/11/16 11:39:37 simonmar Exp $ +$Id: Parser.y,v 1.49 2000/11/24 17:02:03 simonpj Exp $ Haskell grammar. @@ -353,7 +353,7 @@ topdecl :: { RdrBinding } (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5) in returnP (RdrHsDecl (TyClD - (mkClassDecl cs c ts $4 sigs binds $1))) } + (mkClassDecl cs c ts $4 sigs (Just binds) $1))) } | srcloc 'instance' inst_type where { let (binds,sigs) diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 8870c14..d7ad728 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -49,7 +49,7 @@ module RdrHsSyn ( extractRuleBndrsTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl, + mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, mkHsNegApp, cvBinds, @@ -211,7 +211,9 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. \begin{code} mkClassDecl cxt cname tyvars fds sigs mbinds loc - = ClassDecl cxt cname tyvars fds sigs mbinds new_names loc + = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, + tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, + tcdSysNames = new_names, tcdLoc = loc } where cls_occ = rdrNameOcc cname data_occ = mkClassDataConOcc cls_occ @@ -234,15 +236,14 @@ mkTyData new_or_data context tname list_var list_con i maybe src = let t_occ = rdrNameOcc tname name1 = mkRdrUnqual (mkGenOcc1 t_occ) name2 = mkRdrUnqual (mkGenOcc2 t_occ) - in TyData new_or_data context - tname list_var list_con i maybe src name1 name2 + in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, + tcdTyVars = list_var, tcdCons = list_con, tcdNCons = i, + tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] } -mkClassOpSig (DefMeth x) op ty loc - = ClassOpSig op (Just (DefMeth dm_rn)) ty loc +mkClassOpSigDM op ty loc + = ClassOpSig op (DefMeth dm_rn) ty loc where dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) -mkClassOpSig x op ty loc = - ClassOpSig op (Just x) ty loc mkConDecl cname ex_vars cxt details loc = ConDecl cname wkr_name ex_vars cxt details loc @@ -331,7 +332,7 @@ cvValSig sig = sig cvInstDeclSig sig = sig -cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc +cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc cvClassOpSig sig = sig \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 15f3451..49aef1d 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -182,7 +182,7 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons -- the TyCon unique. So each Prelude tycon needs 3 slots, one -- for itself and two more for the generic Ids. mk_tc_gen_info mod tc_uniq tc_name tycon - = mkTyConGenInfo tycon name1 name2 + = mkTyConGenInfo tycon [name1, name2] where tc_occ_name = nameOccName tc_name occ_name1 = mkGenOcc1 tc_occ_name diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 1bf43a2..c5d3d55 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -326,10 +326,9 @@ csigs1 : { [] } | csig ';' csigs1 { $1 : $3 } csig :: { RdrNameSig } -csig : src_loc qvar_name '::' type { mkClassOpSig NoDefMeth $2 $4 $1 } - | src_loc qvar_name '=' '::' type { mkClassOpSig (DefMeth (error "DefMeth") ) - $2 $5 $1 } - | src_loc qvar_name ';' '::' type { mkClassOpSig GenDefMeth $2 $5 $1 } +csig : src_loc qvar_name '::' type { ClassOpSig $2 NoDefMeth $4 $1 } + | src_loc qvar_name ';' '::' type { ClassOpSig $2 GenDefMeth $5 $1 } + | src_loc qvar_name '=' '::' type { mkClassOpSigDM $2 $5 $1 } -------------------------------------------------------------------------- @@ -363,7 +362,7 @@ decl : src_loc qvar_name '::' type maybe_idinfo | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr { mkTyData NewType $3 $4 $5 $6 1 Nothing $1 } | src_loc 'class' opt_decl_context qtc_name tv_bndrs fds csigs - { mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds $1 } + { mkClassDecl $3 $4 $5 $6 $7 Nothing $1 } maybe_idinfo :: { RdrName -> [HsIdInfo RdrName] } maybe_idinfo : {- empty -} { \_ -> [] } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 9e28cd9..298d0b7 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -334,9 +334,8 @@ implicitFVs mod_name decls implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls - get (TyClD (TyData _ _ _ _ _ _ (Just deriv_classes) _ _ _)) - = concat (map get_deriv deriv_classes) - get other = [] + get (TyClD (TyData {tcdDerivs = Just deriv_classes})) = concat (map get_deriv deriv_classes) + get other = [] get_deriv cls = case lookupUFM derivingOccurrences cls of Nothing -> [] @@ -395,7 +394,7 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix - getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ )) + getFixities acc (TyClD (ClassDecl { tcdSigs = sigs})) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. getFixities acc other_decl diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index e4621a0..40dc61a 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -86,7 +86,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (us, new_cache, ipcache) `thenRn_` - -- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` + traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! @@ -100,7 +100,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (us', new_cache, ipcache) `thenRn_` - -- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` + traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 9e6a926..42240c1 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -294,8 +294,11 @@ loadDecls mod (decls_map, n_slurped) decls returnRn (vers, (decls_map', n_slurped)) loadDecl mod (version_map, decls_map) (version, decl) - = getIfaceDeclBinders mod decl `thenRn` \ full_avail -> + = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) -> let + full_avail = case avail of + Avail n -> avail + AvailTC n ns -> AvailTC n (sys_names ++ ns) main_name = availName full_avail new_decls_map = extendNameEnvList decls_map stuff stuff = [ (name, (full_avail, name==main_name, (mod, decl))) @@ -417,29 +420,20 @@ It doesn't deal with source-code specific things: @ValD@, @DefD@. They are handled by the sourc-code specific stuff in @RnNames@. \begin{code} -getIfaceDeclBinders, getTyClDeclBinders +getTyClDeclBinders :: Module -> RdrNameTyClDecl - -> RnM d AvailInfo + -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names ----------------- -getTyClDeclBinders mod (IfaceSig var ty prags src_loc) +getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name) + returnRn (Avail var_name, []) getTyClDeclBinders mod tycl_decl - = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> - returnRn (AvailTC main_name (main_name : sub_names)) - ------------------ -getIfaceDeclBinders mod (IfaceSig var ty prags src_loc) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name) - -getIfaceDeclBinders mod tycl_decl - = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) -> + = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) -> new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names -> - returnRn (AvailTC main_name (main_name : (sys_names ++ sub_names))) + returnRn (AvailTC main_name names, sys_names) ----------------- new_top_bndrs mod names_w_locs diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index d883716..3085cd1 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -120,20 +120,20 @@ In all cases this is set up for interface-file declarations: \begin{code} tyClDeclFVs :: RenamedTyClDecl -> NameSet -tyClDeclFVs (IfaceSig name ty id_infos loc) +tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) = extractHsTyNames ty `plusFV` plusFVs (map hsIdInfoFVs id_infos) -tyClDeclFVs (TyData _ context _ tyvars condecls _ derivings _ _ _) +tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` plusFVs (map conDeclFVs condecls) `plusFV` mkNameSet (derivings `orElse` []) -tyClDeclFVs (TySynonym _ tyvars ty _) +tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty}) = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty) -tyClDeclFVs (ClassDecl context _ tyvars fds sigs _ _ src_loc) +tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs}) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` plusFVs (map extractFunDepNames fds) `plusFV` @@ -150,8 +150,8 @@ hsSigFVs (InlineSig v p _) = unitFV v hsSigFVs (NoInlineSig v p _) = unitFV v hsSigFVs (ClassOpSig v dm ty _) = dmFVs dm `plusFV` extractHsTyNames ty `addOneFV` v -dmFVs (Just (DefMeth v)) = unitFV v -dmFVs other = emptyFVs +dmFVs (DefMeth v) = unitFV v +dmFVs other = emptyFVs ---------------- instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index a9334eb..54ec9e6 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -418,10 +418,9 @@ getGates :: FreeVars -- Things mentioned in the source program getGates source_fvs decl = get_gates (\n -> n `elemNameSet` source_fvs) decl -get_gates is_used (IfaceSig _ ty _ _) - = extractHsTyNames ty +get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty -get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ ) +get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs}) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (hsTyVarNames tvs) `addOneToNameSet` cls) @@ -441,11 +440,11 @@ get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ ) | otherwise = emptyFVs -get_gates is_used (TySynonym tycon tvs ty _) +get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty}) = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _) +get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons}) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (hsTyVarNames tvs) `addOneToNameSet` tycon diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 5dc3100..4cc04df 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -174,7 +174,7 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m \begin{code} importsFromLocalDecls this_mod decls = mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s -> - + -- The avails that are returned don't include the "system" names let avails = concat avails_s @@ -187,9 +187,9 @@ importsFromLocalDecls this_mod decls -- Check for duplicate definitions mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` + -- Record that locally-defined things are available recordLocalSlurps (availsToNameSet avails) `thenRn_` - let mod_name = moduleName this_mod unqual_imp = True -- Want unqualified names @@ -201,18 +201,21 @@ importsFromLocalDecls this_mod decls returnRn (gbl_env, exports) --------------------------- -getLocalDeclBinders :: Module - -> RdrNameHsDecl -> RnMG Avails +getLocalDeclBinders :: Module -> RdrNameHsDecl -> RnMG [AvailInfo] getLocalDeclBinders mod (TyClD tycl_decl) = -- For type and class decls, we generate Global names, with -- no export indicator. They need to be global because they get -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - getTyClDeclBinders mod tycl_decl `thenRn` \ avail -> + getTyClDeclBinders mod tycl_decl `thenRn` \ (avail, sys_names) -> + + -- Record that the system names are available + recordLocalSlurps (mkNameSet sys_names) `thenRn_` returnRn [avail] getLocalDeclBinders mod (ValD binds) - = mapRn new (bagToList (collectTopBinders binds)) + = mapRn new (bagToList (collectTopBinders binds)) `thenRn` \ avails -> + returnRn avails where new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> returnRn (Avail name) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index c60d850..fff5f92 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -282,38 +282,40 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyClDecl (IfaceSig name ty id_infos loc) +rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc}) = pushSrcLocRn loc $ lookupTopBndrRn name `thenRn` \ name' -> rnHsType doc_str ty `thenRn` \ ty' -> mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> - returnRn (IfaceSig name' ty' id_infos' loc) + returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc}) where doc_str = text "the interface signature for" <+> quotes (ppr name) -rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2) +rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, + tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, + tcdDerivs = derivings, tcdLoc = src_loc, tcdSysNames = sys_names}) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ context' -> checkDupOrQualNames data_doc con_names `thenRn_` mapRn rnConDecl condecls `thenRn` \ condecls' -> - lookupSysBinder gen_name1 `thenRn` \ name1' -> - lookupSysBinder gen_name2 `thenRn` \ name2' -> + mapRn lookupSysBinder sys_names `thenRn` \ sys_names' -> rnDerivs derivings `thenRn` \ derivings' -> - returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs - derivings' src_loc name1' name2') + returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs, + tcdDerivs = derivings', tcdLoc = src_loc, tcdSysNames = sys_names'}) where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls -rnTyClDecl (TySynonym name tyvars ty src_loc) +rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) = pushSrcLocRn src_loc $ doptRn Opt_GlasgowExts `thenRn` \ glaExts -> lookupTopBndrRn name `thenRn` \ name' -> bindTyVarsRn syn_doc tyvars $ \ tyvars' -> rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' -> - returnRn (TySynonym name' tyvars' ty' src_loc) + returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc}) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) @@ -322,7 +324,9 @@ rnTyClDecl (TySynonym name tyvars ty src_loc) unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty unquantify glaExys ty = ty -rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) +rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdSysNames = names, tcdLoc = src_loc}) = pushSrcLocRn src_loc $ lookupTopBndrRn cname `thenRn` \ cname' -> @@ -360,12 +364,14 @@ rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) -- The renamer *could* check this for class decls, but can't -- for instance decls. - returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds names' src_loc) + returnRn (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', + tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing, + tcdSysNames = names', tcdLoc = src_loc}) where cls_doc = text "the declaration for class" <+> ppr cname sig_doc = text "the signatures for class" <+> ppr cname -rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn) +rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn) = pushSrcLocRn locn $ lookupTopBndrRn op `thenRn` \ op_name -> @@ -373,28 +379,29 @@ rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn) rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> -- Make the default-method name - (case maybe_dm_stuff of - Nothing -> returnRn Nothing -- Source-file class decl - - Just (DefMeth dm_rdr_name) + (case dm_stuff of + DefMeth dm_rdr_name -> -- Imported class that has a default method decl -- See comments with tname, snames, above lookupSysBinder dm_rdr_name `thenRn` \ dm_name -> - returnRn (Just (DefMeth dm_name)) + returnRn (DefMeth dm_name) -- An imported class decl for a class decl that had an explicit default -- method, mentions, rather than defines, -- the default method, so we must arrange to pull it in - Just GenDefMeth -> returnRn (Just GenDefMeth) - Just NoDefMeth -> returnRn (Just NoDefMeth) - ) `thenRn` \ maybe_dm_stuff' -> + GenDefMeth -> returnRn GenDefMeth + NoDefMeth -> returnRn NoDefMeth + ) `thenRn` \ dm_stuff' -> - returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn) + returnRn (ClassOpSig op_name dm_stuff' new_ty locn) rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) -- Rename the mbinds only; the rest is done already -rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here - (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here +rnClassBinds (ClassDecl {tcdMeths = Nothing}) rn_cls_decl + = returnRn (rn_cls_decl, emptyFVs) -- No meth binds; decl came from interface file + +rnClassBinds (ClassDecl {tcdMeths = Just mbinds}) -- Get mbinds from here + rn_cls_decl@(ClassDecl {tcdTyVars = tyvars, tcdLoc = src_loc}) -- Everything else is here = -- The newLocals call is tiresome: given a generic class decl -- class C a where -- op :: a -> a @@ -414,9 +421,9 @@ rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- G checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> - returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs) + returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs) where - meth_doc = text "the default-methods for class" <+> ppr cname + meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl) rnClassBinds _ tycl_decl = returnRn (tycl_decl, emptyFVs) -- Not a class declaration diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index d4c558d..e8ee16e 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -33,7 +33,6 @@ import Outputable \begin{code} stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module name (profiling only) - -> UniqSupply -- a name supply -> [StgBinding] -- input... -> IO ([(StgBinding,[Id])], -- output program... @@ -41,7 +40,7 @@ stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do [CostCentre], -- "extern" cost-centres [CostCentreStack])) -- pre-defined "singleton" cost centre stacks -stg2stg dflags module_name us binds +stg2stg dflags module_name binds = do { showPass dflags "Stg2Stg" ; us <- mkSplitUniqSupply 'g' diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 99e8c13..74767ae 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -24,11 +24,12 @@ import Id ( Id, mkSysLocal, idType, idStrictness, isExportedId, mkVanillaId, idName, idDemandInfo, idArity, setIdType, idFlavour ) +import Module ( Module ) import IdInfo ( StrictnessInfo(..), IdFlavour(..) ) import DataCon ( dataConWrapId, dataConTyCon ) import TyCon ( isAlgTyCon ) import Demand ( Demand, isStrict, wwLazy ) -import Name ( setNameUnique ) +import Name ( setNameUnique, globaliseName, isLocalName ) import VarEnv import PrimOp ( PrimOp(..), setCCallUnique ) import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, @@ -37,7 +38,6 @@ import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe, uaUTy, usOnce, usMany, isTyVarTy ) import UniqSupply -- all of it, really -import BasicTypes ( TopLevelFlag(..), isNotTopLevel ) import UniqSet ( emptyUniqSet ) import ErrUtils ( showPass, dumpIfSet_dyn ) import CmdLineOpts ( DynFlags, DynFlag(..) ) @@ -89,15 +89,15 @@ does some important transformations: in. (Pulling in a piece you don't need can be v bad, because it may mention other pieces you don't need either, and so on.) - Sadly, splitting up .hc files means that local names (like s234) are - now globally visible, which can lead to clashes between two .hc - files. So we make them all Global, so they are printed complete - with their module name. - - We don't want to do this in CoreTidy, because at that stage we use - Global to mean "external" and hence "should appear in interface files". - This object-file splitting thing is a code generator matter that we - don't want to pollute earlier phases. + Sadly, splitting up .hc files means that local names (like s234) are + now globally visible, which can lead to clashes between two .hc + files. So we make them all Global, so they are printed complete + with their module name. + + We don't want to do this in CoreTidy, because at that stage we use + Global to mean "external" and hence "should appear in interface files". + This object-file splitting thing is a code generator matter that we + don't want to pollute earlier phases. NOTE THAT: @@ -198,17 +198,19 @@ bOGUS_FVs = [] \end{code} \begin{code} -topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] -topCoreBindsToStg dflags core_binds +topCoreBindsToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding] +topCoreBindsToStg dflags mod core_binds = do showPass dflags "Core2Stg" us <- mkSplitUniqSupply 'c' return (initUs_ us (coreBindsToStg emptyVarEnv core_binds)) where + top_flag = Top mod + coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding] coreBindsToStg env [] = returnUs [] coreBindsToStg env (b:bs) - = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) -> + = coreBindToStg top_flag env b `thenUs` \ (bind_spec, new_env) -> coreBindsToStg new_env bs `thenUs` \ new_bs -> case bind_spec of NonRecF bndr rhs dem floats @@ -217,7 +219,7 @@ topCoreBindsToStg dflags core_binds ppr b ) -- No top-level cases! mkStgBinds floats rhs `thenUs` \ new_rhs -> - returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs) + returnUs (StgNonRec bndr (exprToRhs dem top_flag new_rhs) : new_bs) -- Keep all the floats inside... -- Some might be cases etc @@ -251,7 +253,7 @@ coreToStgExpr dflags core_expr %************************************************************************ \begin{code} -coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv) +coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv) coreBindToStg top_lev env (NonRec binder rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) -> @@ -264,14 +266,14 @@ coreBindToStg top_lev env (NonRec binder rhs) -- But we don't want to discard exported things. They can -- occur; e.g. an exported user binding f = g - other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) -> + other -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) -> returnUs (NonRecF new_binder stg_rhs dem floats, new_env) where dem = bdrDem binder coreBindToStg top_lev env (Rec pairs) - = newLocalIds top_lev env binders `thenUs` \ (env', binders') -> + = newBinders top_lev env binders `thenUs` \ (env', binders') -> mapUs (do_rhs env') pairs `thenUs` \ stg_rhss -> returnUs (RecF (binders' `zip` stg_rhss), env') where @@ -290,7 +292,7 @@ coreBindToStg top_lev env (Rec pairs) %************************************************************************ \begin{code} -exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs +exprToRhs :: RhsDemand -> TopLvl -> StgExpr -> StgRhs exprToRhs dem _ (StgLam _ bndrs body) = ASSERT( not (null bndrs) ) StgRhsClosure noCCS @@ -332,7 +334,7 @@ exprToRhs dem _ (StgLam _ bndrs body) then be run at load time to fix up static closures. -} exprToRhs dem toplev (StgConApp con args) - | isNotTopLevel toplev || not (isDllConApp con args) + | isNotTop toplev || not (isDllConApp con args) -- isDllConApp checks for LitLit args too = StgRhsCon noCCS con args @@ -347,7 +349,7 @@ exprToRhs dem toplev expr expr where upd = if isOnceDem dem - then (if isNotTopLevel toplev + then (if isNotTop toplev then SingleEntry -- HA! Paydirt for "dem" else #ifdef DEBUG @@ -442,7 +444,7 @@ coreExprToStgFloat env (Lit lit) = returnUs ([], StgLit lit) coreExprToStgFloat env (Let bind body) - = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) -> + = coreBindToStg NotTop env bind `thenUs` \ (new_bind, new_env) -> coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) -> returnUs (new_bind:floats, stg_body) \end{code} @@ -481,9 +483,9 @@ coreExprToStgFloat env expr@(Lam _ _) coreExprToStgFloat env body else -- At least some value binders - newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') -> - coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) -> - mkStgBinds floats stg_body `thenUs` \ stg_body' -> + newLocalBinders env id_binders `thenUs` \ (env', binders') -> + coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) -> + mkStgBinds floats stg_body `thenUs` \ stg_body' -> case stg_body' of StgLam ty lam_bndrs lam_body -> @@ -584,7 +586,7 @@ coreExprToStgFloat env expr@(App _ _) \begin{code} coreExprToStgFloat env (Case scrut bndr alts) = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') -> - newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') -> + newLocalBinder env bndr `thenUs` \ (env', bndr') -> alts_to_stg env' (findDefault alts) `thenUs` \ alts' -> mkStgCase scrut' bndr' alts' `thenUs` \ expr' -> returnUs (binds, expr') @@ -604,8 +606,8 @@ coreExprToStgFloat env (Case scrut bndr alts) returnUs (mkStgAlgAlts scrut_ty alts' deflt') alg_alt_to_stg env (DataAlt con, bs, rhs) - = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) -> - coreExprToStg env' rhs `thenUs` \ stg_rhs -> + = newLocalBinders env (filter isId bs) `thenUs` \ (env', stg_bs) -> + coreExprToStg env' rhs `thenUs` \ stg_rhs -> returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs) -- NB the filter isId. Some of the binders may be -- existential type variables, which STG doesn't care about @@ -643,20 +645,38 @@ newStgVar ty \end{code} \begin{code} -newLocalId TopLevel env id +---------------------------- +data TopLvl = Top Module | NotTop + +isNotTop NotTop = True +isNotTop (Top _) = False + +---------------------------- +newBinder :: TopLvl -> StgEnv -> Id -> UniqSM (StgEnv, Id) +newBinder (Top mod) env id = returnUs (env, newTopBinder mod id) +newBinder NotTop env id = newLocalBinder env id + +newBinders (Top mod) env ids = returnUs (env, map (newTopBinder mod) ids) +newBinders NotTop env ids = newLocalBinders env ids + + +---------------------------- +newTopBinder mod id -- Don't clone top-level binders. MkIface relies on their -- uniques staying the same, so it can snaffle IdInfo off the -- STG ids to put in interface files. - = let - name = idName id - ty = idType id - in - name `seq` + = name' `seq` seqType ty `seq` - returnUs (env, mkVanillaId name ty) - - -newLocalId NotTopLevel env id + mkVanillaId name' ty + where + name = idName id + name' | isLocalName name = globaliseName name mod + | otherwise = name + ty = idType id + +---------------------------- +newLocalBinder :: StgEnv -> Id -> UniqSM (StgEnv, Id) +newLocalBinder env id = -- Local binder, give it a new unique Id. getUniqueUs `thenUs` \ uniq -> let @@ -669,13 +689,14 @@ newLocalId NotTopLevel env id seqType ty `seq` returnUs (new_env, new_id) -newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id]) -newLocalIds top_lev env [] +---------------------------- +newLocalBinders :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id]) +newLocalBinders env [] = returnUs (env, []) -newLocalIds top_lev env (b:bs) - = newLocalId top_lev env b `thenUs` \ (env', b') -> - newLocalIds top_lev env' bs `thenUs` \ (env'', bs') -> +newLocalBinders env (b:bs) + = newLocalBinder env b `thenUs` \ (env', b') -> + newLocalBinders env' bs `thenUs` \ (env'', bs') -> returnUs (env'', b':bs') \end{code} @@ -859,7 +880,7 @@ mk_stg_let bndr rhs dem floats body = if is_strict then -- Strict let with WHNF rhs mkStgBinds floats $ - StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body + StgLet (StgNonRec bndr (exprToRhs dem NotTop rhs)) body else -- Lazy let with WHNF rhs; float until we find a strict binding let @@ -867,7 +888,7 @@ mk_stg_let bndr rhs dem floats body in mkStgBinds floats_in rhs `thenUs` \ new_rhs -> mkStgBinds floats_out $ - StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body + StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body | otherwise -- Not WHNF = if is_strict then @@ -877,7 +898,7 @@ mk_stg_let bndr rhs dem floats body else -- Lazy let with non-WHNF rhs, so keep the floats in the RHS mkStgBinds floats rhs `thenUs` \ new_rhs -> - returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body) + returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body) where bndr_rep_ty = repType (idType bndr) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index dcc4882..0114a03 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -13,8 +13,8 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsExpr(..), HsLit(..), HsType(..), HsPred(..), mkSimpleMatch, andMonoBinds, andMonoBindList, - isClassDecl, isClassOpSig, isPragSig, - getClassDeclSysNames, tyClDeclName + isClassOpSig, isPragSig, + getClassDeclSysNames, ) import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import RnHsSyn ( RenamedTyClDecl, @@ -28,7 +28,7 @@ import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod ) import TcEnv ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, - tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName + tcExtendLocalValEnv, tcExtendTyVarEnv ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) @@ -43,7 +43,7 @@ import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) import Module ( Module ) -import Name ( Name, NamedThing(..), isFrom ) +import Name ( Name, NamedThing(..) ) import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts ) import NameSet ( emptyNameSet ) import Outputable @@ -55,7 +55,7 @@ import VarSet ( mkVarSet, emptyVarSet ) import CmdLineOpts import ErrUtils ( dumpIfSet ) import Util ( count ) -import Maybes ( seqMaybe, maybeToBool, orElse ) +import Maybes ( seqMaybe, maybeToBool ) \end{code} @@ -103,9 +103,10 @@ Death to "ExpandingDicts". tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) tcClassDecl1 is_rec rec_env - (ClassDecl context class_name - tyvar_names fundeps class_sigs def_methods - sys_names src_loc) + (ClassDecl {tcdCtxt = context, tcdName = class_name, + tcdTyVars = tyvar_names, tcdFDs = fundeps, + tcdSigs = class_sigs, tcdMeths = def_methods, + tcdSysNames = sys_names, tcdLoc = src_loc}) = -- CHECK ARITY 1 FOR HASKELL 1.4 doptsTc Opt_GlasgowExts `thenTc` \ glaExts -> checkTc (glaExts || length tyvar_names == 1) @@ -121,15 +122,19 @@ tcClassDecl1 is_rec rec_env in tcExtendTyVarEnv tyvars $ - -- CHECK THAT THE DEFAULT BINDINGS ARE LEGAL - checkDefaultBinds clas op_names def_methods `thenTc` \ dm_info -> - checkGenericClassIsUnary clas dm_info `thenTc_` + -- SOURCE-CODE CONSISTENCY CHECKS + (case def_methods of + Nothing -> returnTc Nothing -- Not source + Just dms -> checkDefaultBinds clas op_names dms `thenTc` \ dm_env -> + checkGenericClassIsUnary clas dm_env `thenTc_` + returnTc (Just dm_env) + ) `thenTc` \ mb_dm_env -> -- CHECK THE CONTEXT tcSuperClasses is_rec clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, - mapTc (tcClassSig is_rec rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff -> + mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff -> -- MAKE THE CLASS DETAILS let @@ -154,12 +159,20 @@ tcClassDecl1 is_rec rec_env \end{code} \begin{code} -checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds -> TcM (NameEnv (DefMeth Name)) +checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds + -> TcM (NameEnv Bool) + -- The returned environment says + -- x not in env => no default method + -- x -> True => generic default method + -- x -> False => polymorphic default method + -- Check default bindings -- a) must be for a class op for this class -- b) must be all generic or all non-generic -- and return a mapping from class-op to DefMeth info + -- But do all this only for source binds + checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv checkDefaultBinds clas ops (AndMonoBinds b1 b2) @@ -176,27 +189,20 @@ checkDefaultBinds clas ops (FunMonoBind op _ matches loc) -- Check that all the defns ar generic, or none are checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_` - -- Make up the right dm_info - if all_generic then - returnTc (unitNameEnv op GenDefMeth) - else - -- An explicit non-generic default method - newDefaultMethodName op loc `thenNF_Tc` \ dm_name -> - returnTc (unitNameEnv op (DefMeth dm_name)) - + returnTc (unitNameEnv op all_generic) where n_generic = count (maybeToBool . maybeGenericMatch) matches none_generic = n_generic == 0 all_generic = n_generic == length matches -checkGenericClassIsUnary clas dm_info +checkGenericClassIsUnary clas dm_env = -- Check that if the class has generic methods, then the -- class has only one parameter. We can't do generic -- multi-parameter type classes! checkTc (unary || no_generics) (genericMultiParamErr clas) where unary = length (classTyVars clas) == 1 - no_generics = null [() | GenDefMeth <- nameEnvElts dm_info] + no_generics = not (or (nameEnvElts dm_env)) \end{code} @@ -239,7 +245,7 @@ tcSuperClasses is_rec clas context sc_sel_names tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only! -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only - -> NameEnv (DefMeth Name) -- Info about default methods + -> Maybe (NameEnv Bool) -- Info about default methods -> RenamedClassOpSig -> TcM (Type, -- Type of the method ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding @@ -249,8 +255,8 @@ tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only! -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the -- Class.DefMeth data structure. -tcClassSig is_rec unf_env clas clas_tyvars dm_info - (ClassOpSig op_name maybe_dm op_ty src_loc) +tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env + (ClassOpSig op_name sig_dm op_ty src_loc) = tcAddSrcLoc src_loc $ -- Check the type signature. NB that the envt *already has* @@ -272,23 +278,30 @@ tcClassSig is_rec unf_env clas clas_tyvars dm_info let -- Build the selector id and default method id - sel_id = mkDictSelId op_name clas - - dm_info_name = maybe_dm `orElse` lookupNameEnv dm_info op_name `orElse` NoDefMeth - - dm_info_id = case dm_info_name of - NoDefMeth -> NoDefMeth - GenDefMeth -> GenDefMeth - DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id) - where - dm_id = mkDefaultMethodId dm_name clas global_ty + sel_id = mkDictSelId op_name clas + dm_id = mkDefaultMethodId dm_name clas global_ty + DefMeth dm_name = sig_dm + + dm_info = case maybe_dm_env of + Nothing -> iface_dm_info + Just dm_env -> mk_src_dm_info dm_env + + iface_dm_info = case sig_dm of + NoDefMeth -> NoDefMeth + GenDefMeth -> GenDefMeth + DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id) + + mk_src_dm_info dm_env = case lookupNameEnv dm_env op_name of + Nothing -> NoDefMeth + Just True -> GenDefMeth + Just False -> DefMeth dm_id in -- Check that for a generic method, the type of -- the method is sufficiently simple - checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty) + checkTc (dm_info /= GenDefMeth || validGenericMethodType local_ty) (badGenericMethodType op_name op_ty) `thenTc_` - returnTc (local_ty, (sel_id, dm_info_id)) + returnTc (local_ty, (sel_id, dm_info)) \end{code} @@ -362,9 +375,8 @@ tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds) tcClassDecls2 this_mod decls = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds)) - [tcClassDecl2 cls_decl | cls_decl <- decls, - isClassDecl cls_decl, - isFrom this_mod (tyClDeclName cls_decl)] + [tcClassDecl2 cls_decl | cls_decl@(ClassDecl {tcdMeths = Just _}) <- decls] + -- The 'Just' picks out source ClassDecls where combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) -> tc2 `thenNF_Tc` \ (lie2, binds2) -> @@ -379,9 +391,9 @@ tcClassDecls2 this_mod decls tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> NF_TcM (LIE, TcMonoBinds) -tcClassDecl2 (ClassDecl context class_name - tyvar_names _ sigs default_binds _ src_loc) - = -- A locally defined class +tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, + tcdMeths = Just default_binds, tcdLoc = src_loc}) + = -- The 'Just' picks out source ClassDecls recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc src_loc $ tcLookupClass class_name `thenNF_Tc` \ clas -> diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 259dd94..db21e8e 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -193,7 +193,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns mod tycl_decls `thenTc` \ eqns -> + makeDerivEqns tycl_decls `thenTc` \ eqns -> if null eqns then returnTc ([], EmptyBinds) else @@ -276,9 +276,9 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: Module -> [RenamedTyClDecl] -> TcM [DerivEqn] +makeDerivEqns :: [RenamedTyClDecl] -> TcM [DerivEqn] -makeDerivEqns this_mod tycl_decls +makeDerivEqns tycl_decls = mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> returnTc (catMaybes maybe_eqns) where @@ -287,7 +287,7 @@ makeDerivEqns this_mod tycl_decls -- Find the (Class,TyCon) pairs that must be `derived' -- NB: only source-language decls have deriving, no imported ones do derive_these = [ (clas,tycon) - | TyData _ _ tycon _ _ _ (Just classes) _ _ _ <- tycl_decls, + | TyData {tcdName = tycon, tcdDerivs = Just classes} <- tycl_decls, clas <- nub classes ] ------------------------------------------------------------------ @@ -323,7 +323,7 @@ makeDerivEqns this_mod tycl_decls case chk_out clas tycon of Just err -> addErrTc err `thenNF_Tc_` returnNF_Tc Nothing - Nothing -> newDFunName this_mod clas [ty] locn `thenNF_Tc` \ dfun_name -> + Nothing -> newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name -> returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints)) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index ae1f4e6..f38d126 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -31,7 +31,7 @@ module TcEnv( -- New Ids newLocalId, newSpecPragmaId, - newDefaultMethodName, newDFunName, + newDFunName, -- Misc isLocalThing, tcSetEnv @@ -59,11 +59,11 @@ import TyCon ( TyCon ) import Class ( Class, ClassOpItem, ClassContext ) import Subst ( substTy ) import Name ( Name, OccName, NamedThing(..), - nameOccName, nameModule, getSrcLoc, mkGlobalName, + nameOccName, getSrcLoc, mkLocalName, isLocalName, nameModule_maybe ) import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) -import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) +import OccName ( mkDFunOcc, occNameString ) import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv ) import Module ( Module ) import InstEnv ( InstEnv, emptyInstEnv ) @@ -268,28 +268,20 @@ newSpecPragmaId name ty returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) \end{code} -Make a name for the dict fun for an instance decl +Make a name for the dict fun for an instance decl. +It's a *local* name for the moment. The CoreTidy pass +will globalise it. \begin{code} -newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name -newDFunName mod clas (ty:_) loc - = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> - tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq mod - (mkDFunOcc dfun_string inst_uniq) - loc) +newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name +newDFunName clas (ty:_) loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc) where -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) -newDFunName mod clas [] loc = pprPanic "newDFunName" (ppr mod <+> ppr clas <+> ppr loc) - -newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name -newDefaultMethodName op_name loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq (nameModule op_name) - (mkDefaultMethodOcc (getOccName op_name)) - loc) +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 6a8e32f..cb9a4cf 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -58,7 +58,7 @@ tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings tcInterfaceSigs unf_env decls = listTc [ do_one name ty id_infos src_loc - | IfaceSig name ty id_infos src_loc <- decls] + | IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc =src_loc} <- decls] where in_scope_vars = [] -- I think this will be OK diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 2a95703..df6bfa5 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -177,10 +177,10 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls clas_decls = filter isClassDecl tycl_decls in -- (1) Do the ordinary instance declarations - mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls `thenNF_Tc` \ inst_infos -> + mapNF_Tc (tcInstDecl1 unf_env) inst_decls `thenNF_Tc` \ inst_infos -> -- (2) Instances from generic class declarations - getGenericInstances mod clas_decls `thenTc` \ generic_inst_info -> + getGenericInstances clas_decls `thenTc` \ generic_inst_info -> -- Next, construct the instance environment so far, consisting of -- a) cached non-home-package InstEnv (gotten from pcs) pcs_insts pcs @@ -228,9 +228,9 @@ addInstDFuns dfuns infos \end{code} \begin{code} -tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo] +tcInstDecl1 :: TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo] -- Deal with a single instance declaration -tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) +tcInstDecl1 unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) = -- Prime error recovery, set source location recoverNF_Tc (returnNF_Tc []) $ tcAddSrcLoc src_loc $ @@ -253,7 +253,7 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) mapNF_Tc scrutiniseInstanceConstraint theta `thenNF_Tc_` -- Make the dfun id and return it - newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> + newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> returnNF_Tc (True, dfun_name) Just dfun_name -> -- An interface-file instance declaration @@ -300,9 +300,9 @@ gives rise to the instance declarations \begin{code} -getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo] -getGenericInstances mod class_decls - = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos -> +getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] +getGenericInstances class_decls + = mapTc get_generics class_decls `thenTc` \ gen_inst_infos -> let gen_inst_info = concat gen_inst_infos in @@ -312,13 +312,12 @@ getGenericInstances mod class_decls `thenNF_Tc_` returnTc gen_inst_info -get_generics mod decl@(ClassDecl context class_name tyvar_names - fundeps class_sigs def_methods - name_list loc) +get_generics decl@(ClassDecl {tcdMeths = Nothing}) + = returnTc [] -- Imported class decls + +get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, tcdLoc = loc}) | null groups - = returnTc [] -- The comon case: - -- no generic default methods, or - -- its an imported class decl (=> has no methods at all) + = returnTc [] -- The comon case: no generic default methods | otherwise -- A local class decl with generic default methods = recoverNF_Tc (returnNF_Tc []) $ @@ -326,7 +325,7 @@ get_generics mod decl@(ClassDecl context class_name tyvar_names tcLookupClass class_name `thenTc` \ clas -> -- Make an InstInfo out of each group - mapTc (mkGenericInstance mod clas loc) groups `thenTc` \ inst_infos -> + mapTc (mkGenericInstance clas loc) groups `thenTc` \ inst_infos -> -- Check that there is only one InstInfo for each type constructor -- The main way this can fail is if you write @@ -378,11 +377,11 @@ getGenericBinds (FunMonoBind id infixop matches loc) wrap ms = FunMonoBind id infixop ms loc --------------------------------- -mkGenericInstance :: Module -> Class -> SrcLoc +mkGenericInstance :: Class -> SrcLoc -> (RenamedHsType, RenamedMonoBinds) -> TcM InstInfo -mkGenericInstance mod clas loc (hs_ty, binds) +mkGenericInstance clas loc (hs_ty, binds) -- Make a generic instance declaration -- For example: instance (C a, C b) => C (a+b) where { binds } @@ -397,7 +396,7 @@ mkGenericInstance mod clas loc (hs_ty, binds) (badGenericInstanceType binds) `thenTc_` -- Make the dictionary function. - newDFunName mod clas [inst_ty] loc `thenNF_Tc` \ dfun_name -> + newDFunName clas [inst_ty] loc `thenNF_Tc` \ dfun_name -> let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] inst_tys = [inst_ty] @@ -734,19 +733,18 @@ scrutiniseInstanceHead clas inst_taus \begin{code} tcAddDeclCtxt decl thing_inside - = tcAddSrcLoc loc $ + = tcAddSrcLoc (tcdLoc decl) $ tcAddErrCtxt ctxt $ thing_inside where - (name, loc, thing) - = case decl of - (ClassDecl _ name _ _ _ _ _ loc) -> (name, loc, "class") - (TySynonym name _ _ loc) -> (name, loc, "type synonym") - (TyData NewType _ name _ _ _ _ loc _ _) -> (name, loc, "newtype") - (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type") + thing = case decl of + ClassDecl {} -> "class" + TySynonym {} -> "type synonym" + TyData {tcdND = NewType} -> "newtype" + TyData {tcdND = DataType} -> "data type" ctxt = hsep [ptext SLIT("In the"), text thing, - ptext SLIT("declaration for"), quotes (ppr name)] + ptext SLIT("declaration for"), quotes (ppr (tcdName decl))] \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 9a747c1..3bd6902 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -30,7 +30,7 @@ import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults, defaultDefaultTys ) import TcExpr ( tcMonoExpr ) -import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, +import TcEnv ( TcEnv, InstInfo, tcExtendGlobalValEnv, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv ) import TcRules ( tcIfaceRules, tcSourceRules ) @@ -54,7 +54,7 @@ import BasicTypes ( EP(..), Fixity ) import Bag ( isEmptyBag ) import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, - PackageTypeEnv, DFunId, ModIface(..), + PackageTypeEnv, ModIface(..), TypeEnv, extendTypeEnvList, TyThing(..), implicitTyThingIds, mkTypeEnv @@ -69,7 +69,6 @@ data TcResults = TcResults { -- All these fields have info *just for this module* tc_env :: TypeEnv, -- The top level TypeEnv - tc_insts :: [DFunId], -- Instances tc_binds :: TypecheckedMonoBinds, -- Bindings tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. tc_rules :: [TypecheckedRuleDecl] -- Transformation rules @@ -246,7 +245,6 @@ tcModule pcs hst get_fixity this_mod decls returnTc (new_pcs, TcResults { tc_env = local_type_env, tc_binds = implicit_binds `AndMonoBinds` all_binds', - tc_insts = map iDFunId local_inst_info, tc_fords = foi_decls ++ foe_decls', tc_rules = all_local_rules } diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index c50e6fe..b13a511 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -27,7 +27,7 @@ module TcMonad( tcGetEnv, tcSetEnv, tcGetDefaultTys, tcSetDefaultTys, - tcGetUnique, tcGetUniques, tcGetDFunUniq, + tcGetUnique, tcGetUniques, doptsTc, getDOptsTc, tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc, @@ -63,7 +63,6 @@ import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply, mkSplitUniqSupply, UniqSM, initUs_ ) import SrcLoc ( SrcLoc, noSrcLoc ) -import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM ) import UniqFM ( emptyUFM ) import Unique ( Unique ) import CmdLineOpts @@ -131,14 +130,13 @@ initTc dflags tc_env do_this = do { us <- mkSplitUniqSupply 'a' ; us_var <- newIORef us ; - dfun_var <- newIORef emptyFM ; errs_var <- newIORef (emptyBag,emptyBag) ; tvs_var <- newIORef emptyUFM ; let - init_down = TcDown dflags [] us_var dfun_var - noSrcLoc - [] errs_var + init_down = TcDown { tc_dflags = dflags, tc_def = [], + tc_us = us_var, tc_loc = noSrcLoc, + tc_ctxt = [], tc_errs = errs_var } ; maybe_res <- catch (do { res <- do_this init_down tc_env ; @@ -251,7 +249,7 @@ We throw away any error messages! \begin{code} forkNF_Tc :: NF_TcM r -> NF_TcM r -forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env +forkNF_Tc m down@(TcDown { tc_us = u_var }) env = do -- Get a fresh unique supply us <- readIORef u_var @@ -261,8 +259,7 @@ forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env unsafeInterleaveIO (do { us_var' <- newIORef us2 ; err_var' <- newIORef (emptyBag,emptyBag) ; - tv_var' <- newIORef emptyUFM ; - let { down' = TcDown dflags deflts us_var' df_var src_loc err_cxt err_var' } ; + let { down' = down { tc_us = us_var', tc_errs = err_var' } }; m down' env -- ToDo: optionally dump any error messages }) @@ -559,20 +556,6 @@ uniqSMToTcM m down env \end{code} -\begin{code} -tcGetDFunUniq :: String -> NF_TcM Int -tcGetDFunUniq key down env - = do dfun_supply <- readIORef d_var - let uniq = case lookupFM dfun_supply key of - Just x -> x+1 - Nothing -> 0 - let dfun_supply' = addToFM dfun_supply key uniq - writeIORef d_var dfun_supply' - return uniq - where - d_var = getDFunSupplyVar down -\end{code} - %************************************************************************ %* * @@ -585,11 +568,7 @@ data TcDown = TcDown { tc_dflags :: DynFlags, tc_def :: [Type], -- Types used for defaulting - tc_us :: (TcRef UniqSupply), -- Unique supply - tc_ds :: (TcRef DFunNameSupply), -- Name supply for - -- dictionary function names - tc_loc :: SrcLoc, -- Source location tc_ctxt :: ErrCtxt, -- Error context tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg)) @@ -599,19 +578,6 @@ type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)] -- Innermost first. Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction - -type DFunNameSupply = FiniteMap String Int - -- This is used as a name supply for dictionary functions - -- From the inst decl we derive a string, usually by glomming together - -- the class and tycon name -- but it doesn't matter exactly how; - -- this map then gives a unique int for each inst decl with that - -- string. (In Haskell 98 there can only be one, - -- but not so in more extended versions; also class CC type T - -- and class C type TT might both give the string CCT - -- - -- We could just use one Int for all the instance decls, but this - -- way the uniques change less when you add an instance decl, - -- hence less recompilation \end{code} -- These selectors are *local* to TcMonad.lhs @@ -627,7 +593,6 @@ getLoc (TcDown{tc_loc=loc}) = loc setLoc down loc = down{tc_loc=loc} getUniqSupplyVar (TcDown{tc_us=us}) = us -getDFunSupplyVar (TcDown{tc_ds=ds}) = ds getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt setErrCtxt down msg = down{tc_ctxt=[msg]} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 8d575da..1bd7312 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,7 +11,7 @@ module TcTyClsDecls ( #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import HsSyn ( TyClDecl(..), HsTyVarBndr, +import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..), HsPred(..), tyClDeclName, hsTyVarNames, isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig @@ -30,7 +30,7 @@ import TcType ( TcKind, newKindVar, zonkKindEnv ) import TcUnify ( unifyKind ) import TcInstDcls ( tcAddDeclCtxt ) -import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys ) +import Type ( Kind, mkArrowKind, zipFunTys ) import Variance ( calcTyConArgVrcs ) import Class ( Class, mkClass, classTyCon ) import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), @@ -201,18 +201,10 @@ tcTyClDecl1 is_rec unf_env decl \begin{code} getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind) -getInitialKind (TySynonym name tyvars _ _) - = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds -> - newKindVar `thenNF_Tc` \ result_kind -> - returnNF_Tc (name, mk_kind arg_kinds result_kind) - -getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _) - = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds -> - returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind) - -getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ ) - = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds -> - returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind) +getInitialKind decl + = kcHsTyVars (tcdTyVars decl) `thenNF_Tc` \ arg_kinds -> + newKindVar `thenNF_Tc` \ result_kind -> + returnNF_Tc (tcdName decl, mk_kind arg_kinds result_kind) mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds \end{code} @@ -240,42 +232,35 @@ Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} kcTyClDecl :: RenamedTyClDecl -> TcM () -kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc) - = tcAddDeclCtxt decl $ - kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind -> - kcHsType rhs `thenTc` \ rhs_kind -> +kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) + = kcTyClDeclBody decl $ \ result_kind -> + kcHsType rhs `thenTc` \ rhs_kind -> unifyKind result_kind rhs_kind -kcTyClDecl decl@(TyData new_or_data context tycon_name hs_tyvars con_decls _ _ loc _ _) - = tcAddDeclCtxt decl $ - kcTyClDeclBody tycon_name hs_tyvars $ \ result_kind -> +kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls}) + = kcTyClDeclBody decl $ \ result_kind -> kcHsContext context `thenTc_` mapTc_ kc_con_decl con_decls where kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc) - = tcAddSrcLoc loc $ - kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env -> + = kcHsTyVars ex_tvs `thenNF_Tc` \ kind_env -> tcExtendKindEnv kind_env $ kcConDetails new_or_data ex_ctxt details -kcTyClDecl decl@(ClassDecl context class_name - hs_tyvars fundeps class_sigs - _ _ loc) - = tcAddDeclCtxt decl $ - kcTyClDeclBody class_name hs_tyvars $ \ result_kind -> - kcHsContext context `thenTc_` +kcTyClDecl decl@(ClassDecl {tcdCtxt = context, tcdSigs = class_sigs}) + = kcTyClDeclBody decl $ \ result_kind -> + kcHsContext context `thenTc_` mapTc_ kc_sig (filter isClassOpSig class_sigs) where - kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty) + kc_sig (ClassOpSig _ _ op_ty loc) = kcHsBoxedSigType op_ty -kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars - -> (Kind -> TcM a) -- Thing inside - -> TcM a +kcTyClDeclBody :: RenamedTyClDecl -> (Kind -> TcM a) -> TcM a -- Extend the env with bindings for the tyvars, taken from -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches -kcTyClDeclBody tc_name hs_tyvars thing_inside - = tcLookup tc_name `thenNF_Tc` \ thing -> +kcTyClDeclBody decl thing_inside + = tcAddDeclCtxt decl $ + tcLookup (tcdName decl) `thenNF_Tc` \ thing -> let kind = case thing of AGlobal (ATyCon tc) -> tyConKind tc @@ -283,7 +268,7 @@ kcTyClDeclBody tc_name hs_tyvars thing_inside AThing kind -> kind -- For some odd reason, a class doesn't include its kind - (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind + (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames (tcdTyVars decl)) kind in tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind) \end{code} @@ -303,7 +288,7 @@ buildTyConOrClass -> RenamedTyClDecl -> TyThing buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details - (TySynonym tycon_name tyvar_names rhs src_loc) + (TySynonym {tcdName = tycon_name, tcdTyVars = tyvar_names}) = ATyCon tycon where tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs @@ -314,7 +299,8 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details argvrcs = lookupWithDefaultFM rec_vrcs bogusVrcs tycon buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details - (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2) + (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names, + tcdNCons = nconstrs, tcdSysNames = sys_names}) = ATyCon tycon where tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs @@ -322,7 +308,7 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details flavour is_rec gen_info gen_info | not (dopt Opt_Generics dflags) = Nothing - | otherwise = mkTyConGenInfo tycon name1 name2 + | otherwise = mkTyConGenInfo tycon sys_names DataTyDetails ctxt data_cons sel_ids = lookupNameEnv_NF rec_details tycon_name @@ -336,9 +322,8 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details | otherwise -> DataTyCon buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details - (ClassDecl context class_name - tyvar_names fundeps class_sigs def_methods - name_list src_loc) + (ClassDecl {tcdName = class_name, tcdTyVars = tyvar_names, + tcdFDs = fundeps, tcdSysNames = name_list} ) = AClass clas where (tycon_name, _, _, _) = getClassDeclSysNames name_list @@ -427,8 +412,8 @@ tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d) mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name]) -mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt]) -mkClassEdges other_decl = Nothing +mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt]) +mkClassEdges other_decl = Nothing mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name]) mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 16e30e1..9eb3fc7 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -53,7 +53,7 @@ import ListSetOps ( equivClasses ) \begin{code} tcTyDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) -tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc) +tcTyDecl1 is_rec unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs}) = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> tcExtendTyVarEnv (tyConTyVars tycon) $ tcHsRecType is_rec rhs `thenTc` \ rhs_ty -> @@ -71,7 +71,8 @@ tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc) returnTc (tycon_name, SynTyDetails rhs_ty) -tcTyDecl1 is_rec unf_env (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2) +tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context, + tcdName = tycon_name, tcdCons = con_decls}) = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> let tyvars = tyConTyVars tycon diff --git a/ghc/compiler/types/Generics.hi-boot-5 b/ghc/compiler/types/Generics.hi-boot-5 index f57436d..6325080 100644 --- a/ghc/compiler/types/Generics.hi-boot-5 +++ b/ghc/compiler/types/Generics.hi-boot-5 @@ -1,4 +1,4 @@ __interface Generics 1 0 where __export Generics mkTyConGenInfo ; -2 mkTyConGenInfo :: TyCon.TyCon -> Name.Name -> Name.Name -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ; +2 mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] -> PrelMaybe.Maybe (BasicTypes.EP Var.Id) ; diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 40b223e..4af9f41 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -225,7 +225,7 @@ validGenericMethodType ty %************************************************************************ \begin{code} -mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id) +mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id) -- mkTyConGenInfo is called twice -- once from TysWiredIn for Tuples -- once the typechecker TcTyDecls @@ -236,7 +236,7 @@ mkTyConGenInfo :: TyCon -> Name -> Name -> Maybe (EP Id) -- The two names are the names constructed by the renamer -- for the fromT and toT conversion functions. -mkTyConGenInfo tycon from_name to_name +mkTyConGenInfo tycon [from_name, to_name] | null datacons -- Abstractly imported types don't have = Nothing -- to/from operations, (and should not need them) -- 1.7.10.4