From 4161ba13916463f8e67259498eacf22744160e1f Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 14 Nov 2000 10:46:41 +0000 Subject: [PATCH] [project @ 2000-11-14 10:46:39 by simonpj] Compiles now --- ghc/compiler/basicTypes/Id.lhs | 12 +-- ghc/compiler/basicTypes/IdInfo.lhs | 14 +-- ghc/compiler/basicTypes/MkId.lhs | 13 ++- ghc/compiler/coreSyn/CoreFVs.lhs | 44 ++++++++-- ghc/compiler/coreSyn/CoreSyn.lhs | 25 +----- ghc/compiler/coreSyn/CoreTidy.lhs | 4 +- ghc/compiler/main/HscTypes.lhs | 2 +- ghc/compiler/main/MkIface.lhs | 4 +- ghc/compiler/prelude/PrelNames.lhs | 8 +- ghc/compiler/rename/Rename.lhs | 17 ++-- ghc/compiler/rename/RnMonad.lhs | 2 +- ghc/compiler/rename/RnNames.lhs | 4 +- ghc/compiler/simplCore/SetLevels.lhs | 2 +- ghc/compiler/simplCore/SimplCore.lhs | 40 +++++---- ghc/compiler/simplCore/SimplUtils.lhs | 4 +- ghc/compiler/typecheck/Inst.lhs | 5 +- ghc/compiler/typecheck/TcBinds.lhs | 3 +- ghc/compiler/typecheck/TcHsSyn.lhs | 4 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 6 +- ghc/compiler/typecheck/TcModule.lhs | 153 +++++++++++++++++---------------- ghc/compiler/typecheck/TcMonoType.lhs | 3 +- ghc/compiler/typecheck/TcSimplify.lhs | 9 -- ghc/compiler/types/Generics.lhs | 6 +- 23 files changed, 193 insertions(+), 191 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index e1af30d..57edb62 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -25,7 +25,6 @@ module Id ( omitIfaceSigForId, isDeadBinder, exportWithOrigOccName, externallyVisibleId, - idFreeTyVars, isIP, isSpecPragmaId, isRecordSelector, isPrimOpId, isPrimOpId_maybe, @@ -82,8 +81,7 @@ import Var ( Id, DictId, maybeModifyIdInfo, externallyVisibleId ) -import VarSet -import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, +import Type ( Type, typePrimRep, addFreeTyVars, usOnce, seqType, splitTyConApp_maybe ) import IdInfo @@ -133,9 +131,6 @@ Absolutely all Ids are made by mkId. It \begin{code} mkId :: Name -> Type -> IdInfo -> Id mkId name ty info = mkIdVar name (addFreeTyVars ty) info - -mkImportedId :: Name -> Type -> IdInfo -> Id -mkImportedId name ty info = mkId name ty (info `setFlavourInfo` ImportedId) \end{code} \begin{code} @@ -183,9 +178,6 @@ mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty %************************************************************************ \begin{code} -idFreeTyVars :: Id -> TyVarSet -idFreeTyVars id = tyVarsOfType (idType id) - setIdType :: Id -> Type -> Id -- Add free tyvar info to the type setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty) @@ -264,7 +256,7 @@ isExportedId id = case idFlavour id of isLocalId :: Id -> Bool -- True of Ids that are locally defined, but are not constants -- like data constructors, record selectors, and the like. --- See comments with CoreSyn.isLocalVar +-- See comments with CoreFVs.isLocalVar isLocalId id = case idFlavour id of VanillaId -> True ExportedId -> True diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 0a67599..a8f16ae 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -10,7 +10,7 @@ Haskell. [WDP 94/11]) module IdInfo ( IdInfo, -- Abstract - vanillaIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo, + vanillaIdInfo, constantIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo, -- Zapping zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo, @@ -164,7 +164,7 @@ megaSeqIdInfo info Setters \begin{code} -setFlavourInfo info fl = fl `seq` info { flavourInfo = wk } +setFlavourInfo info fl = fl `seq` info { flavourInfo = fl } setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setSpecInfo info sp = PSEQ sp (info { specInfo = sp }) setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg } @@ -198,7 +198,7 @@ setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } setNoDiscardInfo info = case flavourInfo info of - VanillaId -> info { flavourInfo = NoDiscardId } + VanillaId -> info { flavourInfo = ExportedId } other -> info zapSpecPragInfo info = case flavourInfo info of SpecPragmaId -> info { flavourInfo = VanillaId } @@ -210,6 +210,9 @@ zapSpecPragInfo info = case flavourInfo info of vanillaIdInfo :: IdInfo vanillaIdInfo = mkIdInfo VanillaId +constantIdInfo :: IdInfo +constantIdInfo = mkIdInfo ConstantId + mkIdInfo :: IdFlavour -> IdInfo mkIdInfo flv = IdInfo { flavourInfo = flv, @@ -241,7 +244,8 @@ data IdFlavour | ExportedId -- Locally defined, exported | SpecPragmaId -- Locally defined, RHS holds specialised call - | ImportedId -- Imported from elsewhere + | ConstantId -- Imported from elsewhere, or a dictionary function, + -- default method Id. | DataConId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* @@ -257,7 +261,7 @@ ppFlavourInfo :: IdFlavour -> SDoc ppFlavourInfo VanillaId = empty ppFlavourInfo ExportedId = ptext SLIT("[Exported]") ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") -ppFlavourInfo ImportedId = ptext SLIT("[Imported]") +ppFlavourInfo ConstantId = ptext SLIT("[Constant]") 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 1f29b86..47818a3 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -76,7 +76,7 @@ import Id ( idType, mkId, mkVanillaId, mkTemplateLocals, mkTemplateLocal, idCprInfo ) -import IdInfo ( IdInfo, vanillaIdInfo, mkIdInfo, +import IdInfo ( IdInfo, constantIdInfo, mkIdInfo, exactArity, setUnfoldingInfo, setCafInfo, setCprInfo, setArityInfo, setSpecInfo, setTyGenInfo, mkStrictnessInfo, setStrictnessInfo, @@ -144,7 +144,7 @@ mkSpecPragmaId occ uniq ty loc mkDefaultMethodId dm_name rec_c ty = mkId dm_name ty info where - info = vanillaIdInfo `setTyGenInfo` TyGenNever + info = constantIdInfo `setTyGenInfo` TyGenNever -- type is wired-in (see comment at TcClassDcl.tcClassSig), so -- do not generalise it @@ -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 = vanillaIdInfo `setTyGenInfo` TyGenNever + info = constantIdInfo `setTyGenInfo` TyGenNever -- type is wired-in (see comment at TcClassDcl.tcClassSig), so -- do not generalise it @@ -686,8 +686,7 @@ another gun with which to shoot yourself in the foot. unsafeCoerceId = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info where - info = vanillaIdInfo - `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = constantIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] @@ -705,7 +704,7 @@ evaluate its argument and call the dataToTag# primitive. getTagId = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info where - info = vanillaIdInfo + info = constantIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs -- We don't provide a defn for this; you must inline it @@ -813,7 +812,7 @@ pc_bottoming_Id key mod name ty generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy -- Very useful... -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs +noCafIdInfo = constantIdInfo `setCafInfo` NoCafRefs (openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars openAlphaTy = mkTyVarTy openAlphaTyVar diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index c501255..fc0d7bd 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -5,20 +5,20 @@ Taken quite directly from the Peyton Jones/Lester paper. \begin{code} module CoreFVs ( + isLocalVar, mustHaveLocalBinding, + exprFreeVars, exprsFreeVars, exprSomeFreeVars, exprsSomeFreeVars, - idRuleVars, idFreeVars, + idRuleVars, idFreeVars, idFreeTyVars, ruleSomeFreeVars, ruleSomeLhsFreeVars, ruleRhsFreeVars, - mustHaveLocalBinding, - CoreExprWithFVs, CoreBindWithFVs, freeVars, freeVarsOf, ) where #include "HsVersions.h" import CoreSyn -import Id ( Id, idFreeTyVars, hasNoBinding, idSpecialisation ) +import Id ( Id, idName, idType, isLocalId, hasNoBinding, idSpecialisation ) import VarSet import Var ( Var, isId ) import Type ( tyVarsOfType ) @@ -29,6 +29,29 @@ import Outputable %************************************************************************ %* * +\subsection{isLocalVar} +%* * +%************************************************************************ + +@isLocalVar@ returns True of all TyVars, and of Ids that are defined in +this module and are not constants like data constructors and record selectors. +These are the variables that we need to pay attention to when finding free +variables, or doing dependency analysis. + +\begin{code} +isLocalVar :: Var -> Bool +isLocalVar v = isTyVar v || isLocalId v +\end{code} + +\begin{code} +mustHaveLocalBinding :: Var -> Bool +-- True <=> the variable must have a binding in this module +mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v)) +\end{code} + + +%************************************************************************ +%* * \section{Finding the free variables of an expression} %* * %************************************************************************ @@ -138,12 +161,19 @@ expr_fvs (Let (Rec pairs) body) \begin{code} -idRuleVars ::Id -> VarSet -idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) - idFreeVars :: Id -> VarSet idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` idFreeTyVars id +idFreeTyVars :: Id -> TyVarSet +-- Only local Ids conjured up locally, can have free type variables. +-- (During type checking top-level Ids can have free tyvars) +idFreeTyVars id = tyVarsOfType (idType id) +-- | isLocalId id = tyVarsOfType (idType id) +-- | otherwise = emptyVarSet + +idRuleVars ::Id -> VarSet +idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) + rulesSomeFreeVars :: InterestingVarFun -> CoreRules -> VarSet rulesSomeFreeVars interesting (Rules rules _) = foldr (unionVarSet . ruleSomeFreeVars interesting) emptyVarSet rules diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 6a574c4..f53a56f 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -15,7 +15,7 @@ module CoreSyn ( mkConApp, varToCoreExpr, - isTyVar, isId, isLocalVar, mustHaveLocalBinding, + isTyVar, isId, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, collectArgs, collectBindersIgnoringNotes, @@ -109,29 +109,6 @@ data Note %************************************************************************ %* * -\subsection{isLocalVar} -%* * -%************************************************************************ - -@isLocalVar@ returns True of all TyVars, and of Ids that are defined in -this module and are not constants like data constructors and record selectors. -These are the variables that we need to pay attention to when finding free -variables, or doing dependency analysis. - -\begin{code} -isLocalVar :: Var -> Bool -isLocalVar v = isTyVar v || isLocalId v -\end{code} - -\begin{code} -mustHaveLocalBinding :: Var -> Bool --- True <=> the variable must have a binding in this module -mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v)) -\end{code} - - -%************************************************************************ -%* * \subsection{Transformation rules} %* * %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index abe5c73..892cb26 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -19,7 +19,7 @@ import UsageSPInf ( doUsageSPInf ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, +import Id ( idType, idInfo, idName, isExportedId, mkVanillaId, mkId, exportWithOrigOccName, idStrictness, setIdStrictness, idDemandInfo, setIdDemandInfo, @@ -216,7 +216,7 @@ tidyTopId :: Module -> TidyEnv -> TidyEnv -> Id -> (TidyEnv, Id) tidyTopId mod env@(tidy_env, var_env) env_idinfo id = -- Top level variables let - (tidy_env', name') = tidyTopName mod tidy_env (idIsExported id) (idName id) + (tidy_env', name') = tidyTopName mod tidy_env (isExportedId id) (idName id) ty' = tidyTopType (idType id) idinfo' = tidyIdInfo env_idinfo (idInfo id) id' = mkId name' ty' idinfo' diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 1b14271..c630078 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -231,7 +231,7 @@ lookupIface hit pit name lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface -- We often have two IfaceTables, and want to do a lookup lookupIfaceByModName hit pit mod - = lookupModuleEnvByName ht mod `seqMaybe` lookupModuleEnvByName pt mod + = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index e65f032..68b6ff7 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -37,9 +37,9 @@ import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStr import IdInfo -- Lots import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule, isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules, - bindersOfBinds, mustHaveLocalBinding + bindersOfBinds ) -import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) +import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars, mustHaveLocalBinding ) import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding ) import Name ( getName, nameModule, Name, NamedThing(..) ) import Name -- Env diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index ae3a223..d339e5d 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -38,7 +38,7 @@ module PrelNames ( import Module ( ModuleName, mkPrelModule, mkModuleName ) import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, mkKindOccFS ) -import RdrName ( RdrName, mkOrig, mkRdrOrig, mkUnqual ) +import RdrName ( RdrName, mkOrig, mkUnqual ) import UniqFM import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, @@ -48,7 +48,7 @@ import BasicTypes ( Boxity(..), Arity ) import UniqFM ( UniqFM, listToUFM ) import Name ( Name, mkLocalName, mkKnownKeyGlobal, nameRdrName ) import RdrName ( rdrNameOcc ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( builtinSrcLoc ) import Util ( nOfThem ) import Panic ( panic ) \end{code} @@ -582,7 +582,7 @@ dataQual mod str uq = mkKnownKeyGlobal (dataQual_RDR mod str) uq tcQual mod str uq = mkKnownKeyGlobal (tcQual_RDR mod str) uq clsQual mod str uq = mkKnownKeyGlobal (clsQual_RDR mod str) uq -kindQual str uq = mkLocalName (mkKindOccFS tcName str) uq +kindQual str uq = mkLocalName uq (mkKindOccFS tcName str) builtinSrcLoc -- Kinds are not z-encoded in interface file, hence mkKindOccFS -- And they don't come from any particular module; indeed we always -- want to print them unqualified. Hence the LocalName @@ -960,7 +960,7 @@ noDictClassKeys -- These classes are used only for type annotations; -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) builtinSrcLoc isUnboundName :: Name -> Bool isUnboundName name = name `hasKey` unboundKey diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 0062c7a..5affac9 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -19,7 +19,7 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDe import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad -import RnNames ( getGlobalNames ) +import RnNames ( getGlobalNames, exportsFromAvail ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) import RnIfaces ( slurpImpDecls, mkImportInfo, getInterfaceExports, closeDecls, @@ -62,7 +62,7 @@ import Outputable import IO ( openFile, IOMode(..) ) import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, ModIface(..), WhatsImported(..), - VersionInfo(..), ImportVersion, + VersionInfo(..), ImportVersion, IsExported, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, GlobalRdrEnv, pprGlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Avails, @@ -85,7 +85,7 @@ renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe (PrintUnqualified, ModIface, [RenamedHsDecl])) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl])) -- Nothing => some error occurred in the renamer renameModule dflags hit hst old_pcs this_module rdr_module @@ -95,10 +95,9 @@ renameModule dflags hit hst old_pcs this_module rdr_module ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module (rename this_module rdr_module) - ; let print_unqualified :: Name -> Bool -- Is this chap in scope unqualified? - print_unqualified = case maybe_rn_stuff of - Just (unqual, _, _) -> unqual - Nothing -> alwaysQualify + ; let print_unqualified = case maybe_rn_stuff of + Just (unqual, _, _, _) -> unqual + Nothing -> alwaysQualify -- Print errors from renaming @@ -114,7 +113,7 @@ renameModule dflags hit hst old_pcs this_module rdr_module \begin{code} rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl])) -rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) +rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ -- FIND THE GLOBAL NAME ENVIRONMENT @@ -128,7 +127,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) returnRn Nothing else - -- PROCESS EXPORT LIST (but not if we've had errors already) + -- PROCESS EXPORT LIST exportsFromAvail mod_name exports all_avails gbl_env `thenRn` \ export_avails -> traceRn (text "Local top-level environment" $$ diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 6b2fa19..c1c7495 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -102,7 +102,7 @@ traceHiDiffsRn msg if b then putDocRn msg else returnRn () putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printDump msg) `thenRn_` +putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_` returnRn () \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index e95e491..a739648 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -5,7 +5,7 @@ \begin{code} module RnNames ( - getGlobalNames + getGlobalNames, exportsFromAvail ) where #include "HsVersions.h" @@ -58,7 +58,7 @@ getGlobalNames :: Module -> RdrNameHsModule GlobalRdrEnv, -- Maps just *local* things ExportAvails) -- The exported stuff -getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) +getGlobalNames this_mod (HsModule _ _ _ imports decls _ mod_loc) = -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 806d9df..4127f52 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -57,7 +57,7 @@ import CoreSyn import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType ) import CoreFVs -- all of it import Subst -import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo, +import Id ( Id, idType, mkSysLocal, isOneShotLambda, modifyIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo ) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 4a4f38b..b744da9 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -10,13 +10,12 @@ module SimplCore ( core2core ) where import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SwitchResult(..), intSwitchSet, - opt_UsageSPOn, DynFlags, DynFlag(..), dopt, dopt_CoreToDo ) import CoreLint ( showPass, endPass ) import CoreSyn -import CoreFVs ( ruleSomeFreeVars ) -import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) ) +import CoreFVs ( ruleRhsFreeVars ) +import HscTypes ( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) ) import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs ) @@ -31,7 +30,7 @@ import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( Id, isDataConWrapId, setIdNoDiscard, isLocalId ) +import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -45,6 +44,7 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) import Outputable +import Maybes ( orElse ) import List ( partition ) \end{code} @@ -71,7 +71,7 @@ core2core dflags pkg_rule_base hst is_exported binds rules -- COMPUTE THE RULE BASE TO USE (rule_base, local_rule_stuff, orphan_rules) - <- prepareRules dflags pkg_rule_base hst ru_us rules + <- prepareRules dflags pkg_rule_base hst ru_us binds rules -- PREPARE THE BINDINGS let binds1 = updateBinders local_rule_stuff is_exported binds @@ -165,10 +165,11 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } \begin{code} prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable -> UniqSupply + -> [CoreBind] -> [IdCoreRule] -- Local rules - -> IO (RuleBase, -- Full rule base - (IdSet,IdSet), -- Local rule Ids, and RHS fvs - [IdCoreRule]) -- Orphan rules + -> IO (RuleBase, -- Full rule base + (IdSet,IdSet), -- Local rule Ids, and RHS fvs + [IdCoreRule]) -- Orphan rules prepareRules dflags pkg_rule_base hst us binds rules = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all @@ -177,13 +178,13 @@ prepareRules dflags pkg_rule_base hst us binds rules ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (vcat (map pprIdCoreRule better_rules)) - ; let (local_id_rules, orphan_rules) = partition (isLocalId . fst) better_rules - local_rule_rhs_fvs = unionVarSets (map ruleRhsFreeVars local_id_rules) - local_rule_base = extendRuleBaseList emptyRuleBase local_id_rules - local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst) - rule_base = extendRuleBaseList imp_rule_base orphan_rules - final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base) + ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules + local_rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) local_rules) + local_rule_base = extendRuleBaseList emptyRuleBase local_rules + local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached + imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst) + rule_base = extendRuleBaseList imp_rule_base orphan_rules + final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base) -- The last step black-lists the free vars of local rules too ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules) @@ -202,8 +203,9 @@ prepareRules dflags pkg_rule_base hst us binds rules local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds -updateBinders :: IdSet -- Locally defined ids with their Rules attached - -> IdSet -- Ids free in the RHS of local rules +updateBinders :: (IdSet, -- Locally defined ids with their Rules attached + IdSet) -- Ids free in the RHS of local rules + -> IsExported -> [CoreBind] -> [CoreBind] -- A horrible function @@ -228,14 +230,14 @@ updateBinders :: IdSet -- Locally defined ids with their Rules attached -- the rules (maybe we should?), so this substitution would make the rule -- bogus. -updateBinders rule_ids rule_rhs_fvs is_exported binds +updateBinders (rule_ids, rule_rhs_fvs) is_exported binds = map update_bndrs binds where update_bndrs (NonRec b r) = NonRec (update_bndr b) r update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] update_bndr bndr - | is_exported (getName bndr) + | is_exported (idName bndr) || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr' | otherwise = bndr' where diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 5c7d33d..cf022c2 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -27,7 +27,7 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExp import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr ) import Id ( idType, idName, idUnfolding, idStrictness, - mkId, idInfo + mkVanillaId, idInfo ) import IdInfo ( StrictnessInfo(..), ArityInfo, atLeastArity, vanillaIdInfo ) import Maybes ( maybeToBool, catMaybes ) @@ -621,7 +621,7 @@ tryRhsTyLam rhs thing_inside -- Only does something if there's a let let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course - poly_id = mkId poly_name poly_ty vanillaIdInfo + poly_id = mkVanillaId poly_name poly_ty -- In the olden days, it was crucial to copy the occInfo of the original var, -- because we were looking at occurrence-analysed but as yet unsimplified code! diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 8d6c869..96bc7c1 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -50,10 +50,10 @@ import TcType ( TcThetaType, zonkTcTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType ) -import Bag +import CoreFVs ( idFreeTyVars ) import Class ( Class, FunDep ) import FunDeps ( instantiateFdClassTys ) -import Id ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal ) +import Id ( Id, idType, mkUserLocal, mkSysLocal ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique ) import PprType ( pprPred ) @@ -77,6 +77,7 @@ import TysWiredIn ( isIntTy, import PrelNames( Unique, hasKey, fromIntName, fromIntegerClassOpKey ) import Maybe ( catMaybes ) import Util ( thenCmp, zipWithEqual, mapAccumL ) +import Bag import Outputable \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 0b9bc20..533058f 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -40,7 +40,8 @@ import TcType ( TcThetaType, newTyVarTy, newTyVar, ) import TcUnify ( unifyTauTy, unifyTauTyLists ) -import Id ( mkVanillaId, setInlinePragma, idFreeTyVars ) +import CoreFVs ( idFreeTyVars ) +import Id ( mkVanillaId, setInlinePragma ) import Var ( idType, idName ) import IdInfo ( InlinePragInfo(..) ) import Name ( Name, getOccName, getSrcLoc ) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 6af65b0..6acef37 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -39,7 +39,7 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id ) +import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id ) import DataCon ( dataConWrapId ) import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId, tcInstId @@ -174,7 +174,7 @@ zonkIdOcc id let new_id = case maybe_id' of Just (AnId id') -> id' - other -> pprTrace "zonkIdOcc: " (ppr id) id + other -> pprTrace "zonkIdOcc:" (ppr id) id in returnNF_Tc new_id \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 64f77bb..c947fab 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -29,7 +29,7 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkImportedId, isDataConWrapId_maybe ) +import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) @@ -68,12 +68,12 @@ tcInterfaceSigs unf_env decls tcHsType ty `thenTc` \ sigma_ty -> tcIdInfo unf_env in_scope_vars name sigma_ty vanillaIdInfo id_infos `thenTc` \ id_info -> - returnTc (mkImportedId name sigma_ty id_info) + returnTc (mkId name sigma_ty id_info) \end{code} \begin{code} tcIdInfo unf_env in_scope_vars name ty info info_ins - = foldlTc tcPrag vanillaIdInfo info_ins + = foldlTc tcPrag constantIdInfo info_ins where tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity) tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 6ecaff1..ff885c7 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -27,7 +27,7 @@ import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcEnvTyCons, tcEnvClasses, isLocalThing, - RecTcEnv, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv + tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) @@ -89,12 +89,7 @@ typecheckModule dflags this_mod pcs hst mod_iface unqual decls = do { showPass dflags "Typechecker"; ; env <- initTcEnv hst (pcs_PTE pcs) - ; (maybe_result, (warns,errs)) <- initTc dflags env tc_module - - ; let { maybe_tc_result :: Maybe TcResults ; - maybe_tc_result = case maybe_result of - Nothing -> Nothing - Just (_,r) -> Just r } + ; (maybe_tc_result, (warns,errs)) <- initTc dflags env (tcModule pcs hst get_fixity this_mod decls) ; printErrorsAndWarnings unqual (errs,warns) ; printTcDump dflags maybe_tc_result @@ -105,9 +100,6 @@ typecheckModule dflags this_mod pcs hst mod_iface unqual decls return Nothing } where - tc_module :: TcM (RecTcEnv, TcResults) - tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env) - fixity_env = mi_fixities mod_iface get_fixity :: Name -> Maybe Fixity @@ -121,81 +113,94 @@ tcModule :: PersistentCompilerState -> (Name -> Maybe Fixity) -> Module -> [RenamedHsDecl] - -> RecTcEnv -- The knot-tied environment - -> TcM (TcEnv, TcResults) + -> TcM TcResults - -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas - -- which is done lazily [ie failure just drops the pragma - -- without having any global-failure effect]. - -- - -- unf_env is also used to get the pragama info - -- for imported dfuns and default methods - -tcModule pcs hst get_fixity this_mod decls unf_env +tcModule pcs hst get_fixity this_mod decls = -- Type-check the type and class decls - tcTyAndClassDecls unf_env decls `thenTc` \ env -> - tcSetEnv env $ - let - classes = tcEnvClasses env - tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes - in - - -- Typecheck the instance decls, includes deriving - tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) - hst unf_env get_fixity this_mod - tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> - tcSetInstEnv inst_env $ - - -- Default declarations - tcDefaults decls `thenTc` \ defaulting_tys -> - tcSetDefaultTys defaulting_tys $ - - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - -- We must do this before mkImplicitDataBinds (which comes next), since - -- the latter looks up unpackCStringId, for example, which is usually - -- imported - tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - - -- Create any necessary record selector Ids and their bindings - -- "Necessary" includes data and newtype declarations - -- We don't create bindings for dictionary constructors; - -- they are always fully applied, and the bindings are just there - -- to support partial applications - mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) -> - mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> - - -- Extend the global value environment with - -- (a) constructors - -- (b) record selectors - -- (c) class op selectors - -- (d) default-method ids... where? I can't see where these are - -- put into the envt, and I'm worried that the zonking phase - -- will find they aren't there and complain. - tcExtendGlobalValEnv data_ids $ - tcExtendGlobalValEnv cls_ids $ - tcGetEnv `thenTc` \ unf_env -> + fixTc (\ ~(unf_env, _, _, _, _) -> + -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas + -- which is done lazily [ie failure just drops the pragma + -- without having any global-failure effect]. + -- + -- unf_env is also used to get the pragama info + -- for imported dfuns and default methods + +-- traceTc (text "Tc1") `thenNF_Tc_` + tcTyAndClassDecls unf_env decls `thenTc` \ env -> + tcSetEnv env $ + let + classes = tcEnvClasses env + tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes + in + + -- Typecheck the instance decls, includes deriving +-- traceTc (text "Tc2") `thenNF_Tc_` + tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) + hst unf_env get_fixity this_mod + tycons decls `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) -> + tcSetInstEnv inst_env $ + + -- Interface type signatures + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + -- We must do this before mkImplicitDataBinds (which comes next), since + -- the latter looks up unpackCStringId, for example, which is usually + -- imported +-- traceTc (text "Tc3") `thenNF_Tc_` + tcInterfaceSigs unf_env decls `thenTc` \ sig_ids -> + tcExtendGlobalValEnv sig_ids $ + + -- Create any necessary record selector Ids and their bindings + -- "Necessary" includes data and newtype declarations + -- We don't create bindings for dictionary constructors; + -- they are always fully applied, and the bindings are just there + -- to support partial applications + mkImplicitDataBinds this_mod tycons `thenTc` \ (data_ids, imp_data_binds) -> + mkImplicitClassBinds this_mod classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) -> + + -- Extend the global value environment with + -- (a) constructors + -- (b) record selectors + -- (c) class op selectors + -- (d) default-method ids... where? I can't see where these are + -- put into the envt, and I'm worried that the zonking phase + -- will find they aren't there and complain. + tcExtendGlobalValEnv data_ids $ + tcExtendGlobalValEnv cls_ids $ + tcGetEnv `thenTc` \ unf_env -> + returnTc (unf_env, new_pcs_insts, local_inst_info, deriv_binds, + imp_data_binds `AndMonoBinds` imp_cls_binds) + ) `thenTc` \ (env, new_pcs_insts, local_inst_info, deriv_binds, data_cls_binds) -> + tcSetEnv env $ + -- Foreign import declarations next +-- traceTc (text "Tc4") `thenNF_Tc_` tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) -> tcExtendGlobalValEnv fo_ids $ - -- Value declarations next. - -- We also typecheck any extra binds that came out of the "deriving" process + -- Default declarations + tcDefaults decls `thenTc` \ defaulting_tys -> + tcSetDefaultTys defaulting_tys $ + + -- Value declarations next. + -- We also typecheck any extra binds that came out of the "deriving" process +-- traceTc (text "Tc5") `thenNF_Tc_` tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) -> tcSetEnv env $ - -- Foreign export declarations next + -- Foreign export declarations next +-- traceTc (text "Tc6") `thenNF_Tc_` tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> -- Second pass over class and instance declarations, -- to compile the bindings themselves. +-- traceTc (text "Tc7") `thenNF_Tc_` tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> +-- traceTc (text "Tc8") `thenNF_Tc_` tcClassDecls2 this_mod decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) -> @@ -217,14 +222,14 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. let - all_binds = imp_data_binds `AndMonoBinds` - imp_cls_binds `AndMonoBinds` + all_binds = data_cls_binds `AndMonoBinds` val_binds `AndMonoBinds` inst_binds `AndMonoBinds` cls_dm_binds `AndMonoBinds` const_inst_binds `AndMonoBinds` foe_binds in +-- traceTc (text "Tc9") `thenNF_Tc_` zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) -> tcSetEnv final_env $ -- zonkTopBinds puts all the top-level Ids into the tcGEnv @@ -247,8 +252,8 @@ tcModule pcs hst get_fixity this_mod decls unf_env pcs_rules = new_pcs_rules } in - returnTc (unf_env, - TcResults { tc_pcs = final_pcs, +-- traceTc (text "Tc10") `thenNF_Tc_` + returnTc (TcResults { tc_pcs = final_pcs, tc_env = local_type_env, tc_binds = all_binds', tc_insts = map iDFunId local_inst_info, diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 123b4b7..2176456 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -50,7 +50,8 @@ import Type ( Type, Kind, PredType(..), ThetaType, ) import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) -import Id ( mkVanillaId, idName, idType, idFreeTyVars ) +import CoreFVs ( idFreeTyVars ) +import Id ( mkVanillaId, idName, idType ) import Var ( Id, Var, TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 7098929..4976f41 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1073,7 +1073,6 @@ tcSimplifyTop wanted_lie -- Collect together all the bad guys bad_guys = non_stds ++ concat std_bads in - -- Disambiguate the ones that look feasible mapTc disambigGroup std_oks `thenTc` \ binds_ambig -> @@ -1248,14 +1247,6 @@ warnDefault dicts default_ty warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty), pprInstsInFull dicts]) -addRuleLhsErr dict - = addInstErrTcM (instLoc dict) - (tidy_env, - vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict), - nest 4 (ptext SLIT("LHS of a rule must have no overloading"))]) - where - (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict - addTopIPErr dict = addInstErrTcM (instLoc dict) (tidy_env, diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 7b65447..40b223e 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -31,7 +31,7 @@ import TysWiredIn ( genericTyCons, genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, inlDataCon, crossTyCon, crossDataCon ) -import IdInfo ( vanillaIdInfo, setUnfoldingInfo ) +import IdInfo ( constantIdInfo, setUnfoldingInfo ) import CoreUnfold ( mkTopUnfolding ) import Unique ( mkBuiltinUnique ) @@ -258,8 +258,8 @@ mkTyConGenInfo tycon from_name to_name tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c tyvar_tys = mkTyVarTys tyvars - from_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn - to_id_info = vanillaIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn + from_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn + to_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty) to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty) -- 1.7.10.4