From db95d6e8d319b0c5cee1ccc23751e8190152ade3 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 14 Nov 2000 08:07:14 +0000 Subject: [PATCH] [project @ 2000-11-14 08:07:11 by simonpj] Changing the way we know whether something is exported. THIS COMMIT WON'T EVEN COMPILE (I'm doing it to transfer from my laptop.) Wait till later today before updating. --- ghc/compiler/basicTypes/DataCon.lhs | 7 +-- ghc/compiler/basicTypes/Id.lhs | 39 +++++++------ ghc/compiler/basicTypes/IdInfo.lhs | 18 ++++-- ghc/compiler/basicTypes/Name.lhs | 85 ++++++++------------------- ghc/compiler/codeGen/CgBindery.lhs | 4 +- ghc/compiler/coreSyn/CoreFVs.lhs | 23 ++------ ghc/compiler/coreSyn/CoreSyn.lhs | 26 ++++++++- ghc/compiler/coreSyn/CoreTidy.lhs | 2 +- ghc/compiler/deSugar/DsBinds.lhs | 4 +- ghc/compiler/hsSyn/HsCore.lhs | 3 +- ghc/compiler/hsSyn/HsTypes.lhs | 8 +-- ghc/compiler/main/DriverPipeline.hs | 7 ++- ghc/compiler/main/HscMain.lhs | 8 +-- ghc/compiler/main/HscTypes.lhs | 25 ++++---- ghc/compiler/main/MkIface.lhs | 12 ++-- ghc/compiler/prelude/PrelNames.lhs | 5 +- ghc/compiler/profiling/SCCfinal.lhs | 2 +- ghc/compiler/rename/Rename.lhs | 16 ++++-- ghc/compiler/rename/RnEnv.lhs | 8 +-- ghc/compiler/rename/RnNames.lhs | 73 +++++++----------------- ghc/compiler/simplCore/OccurAnal.lhs | 9 ++- ghc/compiler/simplCore/SimplCore.lhs | 98 +++++++++++++++++--------------- ghc/compiler/simplStg/StgVarInfo.lhs | 8 +-- ghc/compiler/specialise/Specialise.lhs | 2 - ghc/compiler/stgSyn/StgLint.lhs | 6 +- ghc/compiler/typecheck/TcHsSyn.lhs | 6 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 8 +-- ghc/compiler/typecheck/TcMonoType.lhs | 5 +- 28 files changed, 232 insertions(+), 285 deletions(-) diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 1789370..4ad15df 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -36,7 +36,7 @@ import Type ( Type, TauType, ClassContext, import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) import Class ( Class, classTyCon ) -import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) +import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) import BasicTypes ( Arity ) @@ -454,9 +454,8 @@ unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type unbox_strict_arg_ty tycon strict_mark ty | case strict_mark of NotMarkedStrict -> False - MarkedUnboxed _ _ -> True - MarkedStrict -> opt_UnboxStrictFields && - isLocallyDefined tycon && + MarkedUnboxed _ _ -> True -- !! From interface file + MarkedStrict -> opt_UnboxStrictFields && -- ! From source maybeToBool maybe_product && not (isRecursiveTyCon tycon) && isDataTyCon arg_tycon diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 7faafba..e1af30d 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -32,7 +32,7 @@ module Id ( isDataConId, isDataConId_maybe, isDataConWrapId, isDataConWrapId_maybe, isBottomingId, - isExportedId, isUserExportedId, + isExportedId, isLocalId, hasNoBinding, -- Inline pragma stuff @@ -91,7 +91,7 @@ import IdInfo import Demand ( Demand ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - isUserExportedName, nameIsLocallyDefined, + nameIsLocallyDefined, getOccName, isIPOcc ) import OccName ( UserFS ) @@ -132,10 +132,10 @@ Absolutely all Ids are made by mkId. It \begin{code} mkId :: Name -> Type -> IdInfo -> Id -mkId name ty info = mkIdVar name (addFreeTyVars ty) info' - where - info' | isUserExportedName name = setNoDiscardInfo info - | otherwise = info +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} @@ -255,18 +255,21 @@ hasNoBinding id = case idFlavour id of -- Don't drop a binding for an exported Id, -- if it otherwise looks dead. +-- Perhaps a better name would be isDiscardableId isExportedId :: Id -> Bool -isExportedId id = isUserExportedId id -- Try this -{- - case idFlavour id of - VanillaId -> False - other -> True -- All the others are no-discard --} - --- Say if an Id was exported by the user --- Implies isExportedId (see mkId above) -isUserExportedId :: Id -> Bool -isUserExportedId id = isUserExportedName (idName id) +isExportedId id = case idFlavour id of + VanillaId -> False + other -> True + +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 +isLocalId id = case idFlavour id of + VanillaId -> True + ExportedId -> True + SpecPragmaId -> True + other -> False \end{code} @@ -302,7 +305,7 @@ omitIfaceSigForId' id -- these names are bound by either a class declaration or a data declaration -- or an explicit user export. exportWithOrigOccName :: Id -> Bool -exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id +exportWithOrigOccName id = omitIfaceSigForId id || isExportedId id \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 1fdf18e..0a67599 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -17,7 +17,7 @@ module IdInfo ( -- Flavour IdFlavour(..), flavourInfo, - setNoDiscardInfo, + setNoDiscardInfo, setFlavourInfo, ppFlavourInfo, -- Arity @@ -164,6 +164,7 @@ megaSeqIdInfo info Setters \begin{code} +setFlavourInfo info fl = fl `seq` info { flavourInfo = wk } setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setSpecInfo info sp = PSEQ sp (info { specInfo = sp }) setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg } @@ -236,7 +237,12 @@ mkIdInfo flv = IdInfo { \begin{code} data IdFlavour - = VanillaId -- Most Ids are like this + = VanillaId -- Locally defined, not exported + | ExportedId -- Locally defined, exported + | SpecPragmaId -- Locally defined, RHS holds specialised call + + | ImportedId -- Imported from elsewhere + | DataConId DataCon -- The Id for a data constructor *worker* | DataConWrapId DataCon -- The Id for a data constructor *wrapper* -- [the only reasons we need to know is so that @@ -245,17 +251,17 @@ data IdFlavour -- Id back to the data con] | PrimOpId PrimOp -- The Id for a primitive operator | RecordSelId FieldLabel -- The Id for a record selector - | SpecPragmaId -- Don't discard these - | NoDiscardId -- Don't discard these either + ppFlavourInfo :: IdFlavour -> SDoc ppFlavourInfo VanillaId = empty +ppFlavourInfo ExportedId = ptext SLIT("[Exported]") +ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") +ppFlavourInfo ImportedId = ptext SLIT("[Imported]") ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]") ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]") ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]") ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]") -ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]") -ppFlavourInfo NoDiscardId = ptext SLIT("[NoDiscard]") seqFlavour :: IdFlavour -> () seqFlavour f = f `seq` () diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index dcf672e..b3a6138 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -10,17 +10,16 @@ module Name ( -- The Name type Name, -- Abstract - mkLocalName, mkImportedLocalName, mkSysLocalName, mkCCallName, + mkLocalName, mkSysLocalName, mkCCallName, mkTopName, mkIPName, mkDerivedName, mkGlobalName, mkKnownKeyGlobal, mkWiredInName, - nameUnique, setNameUnique, setLocalNameSort, + nameUnique, setNameUnique, tidyTopName, nameOccName, nameModule, nameModule_maybe, setNameOcc, nameRdrName, setNameModuleAndLoc, toRdrName, hashName, - isUserExportedName, nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, @@ -36,7 +35,7 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, isLocallyDefined, getOccString, toRdrName, + getSrcLoc, getOccString, toRdrName, isFrom, isLocalOrFrom ) where @@ -70,11 +69,11 @@ data Name = Name { data NameSort = Global Module -- (a) TyCon, Class, their derived Ids, dfun Id - -- (b) imported Id + -- (b) Imported Id + -- (c) Top-level Id in the original source, even if + -- locally defined - | Exported -- An exported Ids defined in the module being compiled - - | Local -- A user-defined, but non-exported Id or TyVar, + | Local -- A user-defined Id or TyVar -- defined in the module being compiled | System -- A system-defined Id or TyVar. Typically the @@ -83,17 +82,18 @@ data NameSort Notes about the NameSorts: -1. An Exported Id is changed to Global right at the - end in the tidyCore pass, so that an importer sees a Global - Similarly, Local Ids that are visible to an importer (e.g. when - optimisation is on) are changed to Globals. +1. Initially, top-level Ids (including locally-defined ones) get Global names, + and all other local Ids get Local names 2. Things with a @Global@ name are given C static labels, so they finally appear in the .o file's symbol table. They appear in the symbol table in the form M.n. If originally-local things have this property they must be made @Global@ first. -3. A System Name differs in the following ways: +3. In the tidy-core phase, a Global that is not visible to an importer + is changed to Local, and a Local that is visible is changed to Global + +4. A System Name differs in the following ways: a) has unique attached when printing dumps b) unifier eliminates sys tyvars in favour of user provs where possible @@ -124,7 +124,6 @@ nameModule_maybe name = Nothing nameIsLocallyDefined :: Name -> Bool nameIsFrom :: Module -> Name -> Bool nameIsLocalOrFrom :: Module -> Name -> Bool -isUserExportedName :: Name -> Bool isLocalName :: Name -> Bool -- Not globals isGlobalName :: Name -> Bool isSystemName :: Name -> Bool @@ -145,15 +144,9 @@ nameIsFrom from other = pprPanic "nameIsFrom" (ppr other) -- Global names are by definition those that are visible -- outside the module, *as seen by the linker*. Externally visible --- does not mean visible at the source level (that's isUserExported). +-- does not mean visible at the source level isExternallyVisibleName name = isGlobalName name --- Constructors, selectors and suchlike Globals, and are all exported --- Other Local things may or may not be exported -isUserExportedName (Name { n_sort = Exported }) = True -isUserExportedName (Name { n_sort = Global _ }) = True -isUserExportedName other = False - isSystemName (Name {n_sort = System}) = True isSystemName other = False \end{code} @@ -177,18 +170,6 @@ mkLocalName uniq occ loc = Name { n_uniq = uniq, n_sort = Local, n_occ = occ, n_ -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkImportedLocalName :: Unique -> OccName -> SrcLoc -> Name - -- Just the same as mkLocalName, except the provenance is different - -- Reason: this flags the name as one that came in from an interface - -- file. This is useful when trying to decide which of two type - -- variables should 'win' when unifying them. - -- NB: this is only for non-top-level names, so we use ImplicitImport - -- - -- Oct 00: now that Names lack Provenances, mkImportedLocalName doesn't make - -- sense any more, so it's just the same as mkLocalName -mkImportedLocalName uniq occ loc = mkLocalName uniq occ loc - - mkGlobalName :: Unique -> Module -> OccName -> SrcLoc -> Name mkGlobalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = Global mod, n_occ = occ, n_loc = loc } @@ -244,11 +225,6 @@ setNameModuleAndLoc :: Name -> Module -> SrcLoc -> Name setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc} where set (Global _) = Global mod - -setLocalNameSort :: Name -> Bool -> Name - -- Set the name's sort to Local or Exported, depending on the boolean -setLocalNameSort name is_exported = name { n_sort = if is_exported then Exported - else Local } \end{code} @@ -293,23 +269,18 @@ are exported. But also: top-level defns externally visible \begin{code} -tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) -tidyTopName mod env +tidyTopName :: Module -> TidyOccEnv -> Bool -> Name -> (TidyOccEnv, Name) +tidyTopName mod env is_exported name@(Name { n_occ = occ, n_sort = sort, n_uniq = uniq, n_loc = loc }) = case sort of - System -> localise -- System local Ids - Local -> localise -- User non-exported Ids - Exported -> globalise -- User-exported things - Global _ -> no_op -- Constructors, class selectors, default methods + Global _ | is_exported -> (env, name) + | otherwise -> (env, name { n_sort = new_sort }) + other | is_exported -> (env', name { n_sort = Global mod, n_occ = occ' }) + | otherwise -> (env', name { n_sort = new_sort, n_occ = occ' }) where - no_op = (env, name) - - globalise = (env, name { n_sort = Global mod }) -- Don't change occurrence name - - localise = (env', name') (env', occ') = tidyOccName env occ - name' = name { n_occ = occ', n_sort = mkLocalTopSort mod } + new_sort = mkLocalTopSort mod mkTopName :: Unique -> Module -> FAST_STRING -> Name -- Make a top-level name; make it Global if top-level @@ -359,7 +330,7 @@ nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && - not (nameIsLocallyDefined nm) && -- isLocallyDefinedName test needed 'cos + not (isLocalName nm) && -- isLocalName test needed 'cos not (isModuleInThisPackage (nameModule nm)) -- nameModule won't work on local names @@ -460,13 +431,12 @@ pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) case sort of Global mod -> pprGlobal sty name uniq mod occ System -> pprSysLocal sty uniq occ - Local -> pprLocal sty uniq occ empty - Exported -> pprLocal sty uniq occ (char 'x') + Local -> pprLocal sty uniq occ -pprLocal sty uniq occ pp_export +pprLocal sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = pprOccName occ <> - text "{-" <> pp_export <+> pprUnique10 uniq <> text "-}" + text "{-" <> pprUnique10 uniq <> text "-}" | otherwise = pprOccName occ pprGlobal sty name uniq mod occ @@ -500,20 +470,15 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc -isLocallyDefined :: NamedThing a => a -> Bool getOccString :: NamedThing a => a -> String toRdrName :: NamedThing a => a -> RdrName isFrom :: NamedThing a => Module -> a -> Bool isLocalOrFrom :: NamedThing a => Module -> a -> Bool getSrcLoc = nameSrcLoc . getName -isLocallyDefined = nameIsLocallyDefined . getName getOccString = occNameString . getOccName toRdrName = nameRdrName . getName isFrom mod x = nameIsFrom mod (getName x) isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x) \end{code} -\begin{code} -{-# SPECIALIZE isLocallyDefined :: Name -> Bool #-} -\end{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 5e1f11f..efb4c80 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -44,7 +44,7 @@ import VarEnv import VarSet ( varSetElems ) import Literal ( Literal ) import Maybes ( catMaybes, maybeToBool ) -import Name ( isLocallyDefined, NamedThing(..) ) +import Name ( isLocalName, NamedThing(..) ) #ifdef DEBUG import PprAbsC ( pprAmode ) #endif @@ -251,7 +251,7 @@ I {\em think} all looking-up is done through @getCAddrMode(s)@. getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id - | not (isLocallyDefined name) || isDataConWrapId id + | not (isLocalName name) || isDataConWrapId id -- Why the isDataConWrapId? Because CoreToStg changes a call to -- a nullary constructor worker fn to a call to its wrapper, -- which may not be defined until later diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 09d1ae1..c501255 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -21,26 +21,11 @@ import CoreSyn import Id ( Id, idFreeTyVars, hasNoBinding, idSpecialisation ) import VarSet import Var ( Var, isId ) -import Name ( isLocallyDefined ) import Type ( tyVarsOfType ) import Util ( mapAndUnzip ) import Outputable \end{code} -%************************************************************************ -%* * -\section{Utilities} -%* * -%************************************************************************ - -\begin{code} -mustHaveLocalBinding :: Var -> Bool --- True <=> the variable must have a binding in this module -mustHaveLocalBinding v - | isId v = isLocallyDefined v && not (hasNoBinding v) - | otherwise = True -- TyVars etc must -\end{code} - %************************************************************************ %* * @@ -58,7 +43,7 @@ but not those that are free in the type of variable occurrence. \begin{code} exprFreeVars :: CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars -exprFreeVars = exprSomeFreeVars isLocallyDefined +exprFreeVars = exprSomeFreeVars isLocalVar exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet @@ -166,7 +151,7 @@ rulesSomeFreeVars interesting (Rules rules _) ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule _) = noFVs ruleRhsFreeVars (Rule str tpl_vars tpl_args rhs) - = rule_fvs isLocallyDefined emptyVarSet + = rule_fvs isLocalVar emptyVarSet where rule_fvs = addBndrs tpl_vars (expr_fvs rhs) @@ -259,8 +244,8 @@ freeVars (Var v) -- Actually [June 98] I don't think it's necessary -- fvs = fvs_v `unionVarSet` idSpecVars v - fvs | isLocallyDefined v = aFreeVar v - | otherwise = noFVs + fvs | isLocalVar v = aFreeVar v + | otherwise = noFVs freeVars (Lit lit) = (noFVs, AnnLit lit) freeVars (Lam b body) diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 3cce2d5..6a574c4 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -15,7 +15,8 @@ module CoreSyn ( mkConApp, varToCoreExpr, - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, isTyVar, isId, + isTyVar, isId, isLocalVar, mustHaveLocalBinding, + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, collectArgs, collectBindersIgnoringNotes, coreExprCc, @@ -108,6 +109,29 @@ 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 4f08fb4..abe5c73 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -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 (idName id) + (tidy_env', name') = tidyTopName mod tidy_env (idIsExported id) (idName id) ty' = tidyTopType (idType id) idinfo' = tidyIdInfo env_idinfo (idInfo id) id' = mkId name' ty' idinfo' diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 546c80e..9cb09ed 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -26,7 +26,7 @@ import Match ( matchWrapper ) import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) import CostCentre ( mkAutoCC, IsCafCC(..) ) -import Id ( idType, idName, isUserExportedId, isSpecPragmaId, Id ) +import Id ( idType, idName, isExportedId, isSpecPragmaId, Id ) import NameSet import VarSet import Type ( mkTyVarTy ) @@ -188,7 +188,7 @@ addSccs NoSccs exports = NoSccs addSccs TopLevel exports = TopLevelAddSccs (\id -> case [ exp | (_,exp,loc) <- exports, loc == id ] of (exp:_) | opt_AutoSccsOnAllToplevs || - (isUserExportedId exp && + (isExportedId exp && opt_AutoSccsOnExportedToplevs) -> Just exp _ -> Nothing) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 67d5c24..63583b7 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -153,7 +153,8 @@ toUfApp (App f a) as = toUfApp f (a:as) toUfApp (Var v) as = case isDataConId_maybe v of -- We convert the *worker* for tuples into UfTuples - Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args + Just dc | isTupleTyCon tc && saturated + -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args where val_args = dropWhile isTypeArg as saturated = length val_args == idArity v diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index aeb4f28..c9bb0a3 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -33,7 +33,7 @@ import Type ( Type, Kind, PredType(..), ClassContext, import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, getSynTyConDefn ) import RdrName ( RdrName, mkUnqual ) -import Name ( Name, getName, setLocalNameSort ) +import Name ( Name, getName ) import OccName ( NameSpace, tvName ) import Var ( TyVar, tyVarKind ) import Subst ( mkTyVarSubst, substTy ) @@ -88,10 +88,8 @@ hsUsOnce = HsTyVar (mkUnqual tvName SLIT(".")) -- deep magic hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic hsUsOnce_Name, hsUsMany_Name :: HsType Name --- Fudge the TyConName so that it prints unqualified --- I hate it! I hate it! -hsUsOnce_Name = HsTyVar (setLocalNameSort usOnceTyConName False) -hsUsMany_Name = HsTyVar (setLocalNameSort usManyTyConName False) +hsUsOnce_Name = HsTyVar usOnceTyConName +hsUsMany_Name = HsTyVar usManyTyConName ----------------------- data HsTupCon name = HsTupCon name Boxity diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 6ebf319..1c60a8f 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.21 2000/11/13 17:12:37 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.22 2000/11/14 08:07:12 simonpj Exp $ -- -- GHC Driver -- @@ -685,8 +685,9 @@ doLink o_files = do #ifdef mingw32_TARGET_OS let extra_os = if static || no_hs_main then [] - else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o", - head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ] +-- else [ head (lib_paths (head rts_pkg)) ++ "/Main.dll_o", +-- head (lib_paths (head std_pkg)) ++ "/PrelMain.dll_o" ] + else [] #endif (md_c_flags, _) <- machdepCCOpts run_something "Linker" diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index eb10440..aeae7e1 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -175,7 +175,7 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch <- renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { Nothing -> return (HscFail pcs_rn); - Just (print_unqualified, new_iface, rn_hs_decls) -> do { + Just (print_unqualified, is_exported, new_iface, rn_hs_decls) -> do { ------------------- -- TYPECHECK @@ -196,7 +196,7 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch ------------------- -- We grab the the unfoldings at this point. ; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod - print_unqualified tc_result hst + print_unqualified is_exported tc_result hst ; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result ------------------- @@ -315,7 +315,7 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ (ppr nm) -dsThenSimplThenTidy dflags rule_base this_mod print_unqual tc_result hst +dsThenSimplThenTidy dflags rule_base this_mod print_unqual is_exported tc_result hst = do -------------------------- Desugaring ---------------- -- _scc_ "DeSugar" (desugared, rules, h_code, c_code, fe_binders) @@ -324,7 +324,7 @@ dsThenSimplThenTidy dflags rule_base this_mod print_unqual tc_result hst -------------------------- Main Core-language transformations ---------------- -- _scc_ "Core2Core" (simplified, orphan_rules) - <- core2core dflags rule_base hst desugared rules + <- core2core dflags rule_base hst is_exported desugared rules -- Do the final tidy-up (tidy_binds, tidy_orphan_rules) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 28cdcba..1b14271 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -24,7 +24,7 @@ module HscTypes ( WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, - IfaceInsts, IfaceRules, GatedDecl, + IfaceInsts, IfaceRules, GatedDecl, IsExported, OrigNameEnv(..), OrigNameNameEnv, OrigNameIParamEnv, AvailEnv, AvailInfo, GenAvailInfo(..), PersistentCompilerState(..), @@ -45,8 +45,7 @@ module HscTypes ( #include "HsVersions.h" import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) -import Name ( Name, NamedThing, isLocallyDefined, - getName, nameModule, nameSrcLoc ) +import Name ( Name, NamedThing, getName, nameModule, nameSrcLoc ) import Name -- Env import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, @@ -222,19 +221,16 @@ emptyIfaceTable = emptyModuleEnv Simple lookups in the symbol table. \begin{code} -lookupIface :: HomeIfaceTable -> PackageIfaceTable - -> Module -> Name -- The module is to use for locally-defined names - -> Maybe ModIface +lookupIface :: HomeIfaceTable -> PackageIfaceTable -> Name -> Maybe ModIface -- We often have two IfaceTables, and want to do a lookup -lookupIface hit pit this_mod name - | isLocallyDefined name = lookupModuleEnv hit this_mod - | otherwise = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod +lookupIface hit pit name + = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod where mod = nameModule name -lookupIfaceByModName :: ModuleEnv a -> ModuleEnv a -> ModuleName -> Maybe a --- We often have two Symbol- or IfaceTables, and want to do a lookup -lookupIfaceByModName ht pt mod +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 \end{code} @@ -285,8 +281,7 @@ extendTypeEnvList env things \begin{code} lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing lookupType hst pte name - = ASSERT2( not (isLocallyDefined name), ppr name ) - case lookupModuleEnv hst (nameModule name) of + = case lookupModuleEnv hst (nameModule name) of Just details -> lookupNameEnv (md_types details) name Nothing -> lookupNameEnv pte name \end{code} @@ -403,6 +398,8 @@ data WhatsImported name = NothingAtAll -- The module is below us in the -- we imported the module without saying exactly what we imported -- We need to recompile if the module exports changes, because we might -- now have a name clash in the importing module. + +type IsExported = Name -> Bool -- True for names that are exported from this module \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 6aa5127..e65f032 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -28,7 +28,7 @@ import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), ) import CmdLineOpts -import Id ( Id, idType, idInfo, omitIfaceSigForId, isUserExportedId, hasNoBinding, +import Id ( Id, idType, idInfo, omitIfaceSigForId, isExportedId, hasNoBinding, idSpecialisation, idName, setIdInfo ) import Var ( isId ) @@ -37,13 +37,11 @@ import DataCon ( StrictnessMark(..), dataConSig, dataConFieldLabels, dataConStr import IdInfo -- Lots import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule, isBuiltinRule, rulesRules, rulesRhsFreeVars, emptyCoreRules, - bindersOfBinds + bindersOfBinds, mustHaveLocalBinding ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding ) -import Name ( isLocallyDefined, getName, nameModule, - Name, NamedThing(..) - ) +import Name ( getName, nameModule, Name, NamedThing(..) ) import Name -- Env import OccName ( pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, @@ -328,7 +326,7 @@ bindsToIds needed_ids codegen_ids binds -- The 'needed' set contains the Ids that are needed by earlier -- interface file emissions. If the Id isn't in this set, and isn't -- exported, there's no need to emit anything - need_id needed_set id = id `elemVarSet` needed_set || isUserExportedId id + need_id needed_set id = id `elemVarSet` needed_set || isExportedId id go needed [] emitted | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" @@ -479,7 +477,7 @@ mkFinalId codegen_ids is_rec id rhs find_fvs expr = exprSomeFreeVars interestingId expr -interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id) +interestingId id = isId id && mustHaveLocalBinding id \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 1ad075d..ae3a223 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -582,9 +582,10 @@ 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 = mkKnownKeyGlobal (mkRdrOrig pREL_GHC_Name (mkKindOccFS tcName str)) uq +kindQual str uq = mkLocalName (mkKindOccFS tcName str) uq -- Kinds are not z-encoded in interface file, hence mkKindOccFS - -- And they all come from PrelGHC + -- And they don't come from any particular module; indeed we always + -- want to print them unqualified. Hence the LocalName varQual_RDR mod str = mkOrig varName mod str tcQual_RDR mod str = mkOrig tcName mod str diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 66d9f9a..3cda937 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -305,7 +305,7 @@ boxHigherOrderArgs almost_expr args --------------- do_arg ids bindings arg@(StgVarArg old_var) - | (not (isLocallyDefined old_var) || elemVarSet old_var ids) + | (not (isLocalVar old_var) || elemVarSet old_var ids) && isFunType var_type = -- make a trivial let-binding for the top-level function getUniqueMM `thenMM` \ uniq -> diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index ad60177..0062c7a 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -113,13 +113,12 @@ renameModule dflags hit hst old_pcs this_module rdr_module \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, ModIface, [RenamedHsDecl])) +rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, IsExported, ModIface, [RenamedHsDecl])) rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) = pushSrcLocRn loc $ -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, - export_avails, global_avail_env) -> + getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, all_avails@(_, global_avail_env)) -> -- Exit if we've found any errors checkErrsRn `thenRn` \ no_errs_so_far -> @@ -129,6 +128,9 @@ 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) + exportsFromAvail mod_name exports all_avails gbl_env `thenRn` \ export_avails -> + traceRn (text "Local top-level environment" $$ nest 4 (pprGlobalRdrEnv local_gbl_env)) `thenRn_` @@ -183,7 +185,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) mod_iface = ModIface { mi_module = this_module, mi_version = initialVersionInfo, - mi_usages = my_usages, + mi_usages = my_usages, mi_boot = False, mi_orphan = is_orphan, mi_exports = my_exports, @@ -194,6 +196,8 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) } print_unqualified = unQualInScope gbl_env + is_exported name = name `elemNameSet` exported_names + exported_names = availsToNameSet export_avails in -- REPORT UNUSED NAMES, AND DEBUG DUMP @@ -201,7 +205,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) imports global_avail_env source_fvs export_avails rn_imp_decls `thenRn_` - returnRn (Just (print_unqualified, mod_iface, final_decls)) + returnRn (Just (print_unqualified, is_exported, mod_iface, final_decls)) where mod_name = moduleName this_module \end{code} @@ -676,7 +680,7 @@ warnDeprecations this_mod export_avails my_deprecs used_names | nameIsLocalOrFrom this_mod n = lookupDeprec my_deprecs n | otherwise - = case lookupIface hit pit this_mod n of + = case lookupIface hit pit n of Just iface -> lookupDeprec (mi_deprecs iface) n Nothing -> pprPanic "warnDeprecations:" (ppr n) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 82d8993..74d6b2e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -20,7 +20,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, import RnMonad import Name ( Name, NamedThing(..), getSrcLoc, - mkLocalName, mkImportedLocalName, mkGlobalName, + mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, setNameModuleAndLoc ) @@ -265,10 +265,6 @@ calls it at all I think). \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} -For List and Tuple types it's important to get the correct -@isLocallyDefined@ flag, which is used in turn when deciding -whether there are any instance decls in this module are ``special''. -The name cache should have the correct provenance, though. \begin{code} lookupOrigNames :: [RdrName] -> RnM d NameSet @@ -361,7 +357,7 @@ bindCoreLocalRn rdr_name enclosed_scope let (us', us1) = splitUniqSupply us uniq = uniqFromSupply us1 - name = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc + name = mkLocalName uniq (rdrNameOcc rdr_name) loc in setNameSupplyRn (us', cache, ipcache) `thenRn_` let diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index cccffc3..e95e491 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -30,8 +30,7 @@ import UniqFM ( lookupUFM ) import Bag ( bagToList ) import Module ( ModuleName, moduleName, WhereFrom(..) ) import NameSet -import Name ( Name, nameSrcLoc, - setLocalNameSort, nameOccName, nameEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameEnvElts ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, AvailEnv ) import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc, mkRdrQual, mkRdrUnqual ) @@ -57,24 +56,13 @@ import List ( partition ) getGlobalNames :: Module -> RdrNameHsModule -> RnMG (GlobalRdrEnv, -- Maps all in-scope things GlobalRdrEnv, -- Maps just *local* things - Avails, -- The exported stuff - AvailEnv) -- Maps a name to its parent AvailInfo - -- Just for in-scope things only + ExportAvails) -- The exported stuff getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) - = -- These two fix-loops are to get the right - -- provenance information into a Name - fixRn ( \ ~(rec_gbl_env, _, rec_export_avails, _) -> - - let - rec_exp_fn :: Name -> Bool - rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails) - in - - -- PROCESS LOCAL DECLS + = -- PROCESS LOCAL DECLS -- Do these *first* so that the correct provenance gets -- into the global name cache. - importsFromLocalDecls this_mod rec_exp_fn decls `thenRn` \ (local_gbl_env, local_mod_avails) -> + importsFromLocalDecls this_mod decls `thenRn` \ (local_gbl_env, local_mod_avails) -> -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful @@ -101,21 +89,10 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) all_avails :: ExportAvails all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) - - (_, global_avail_env) = all_avails in - -- PROCESS EXPORT LIST (but not if we've had errors already) - checkErrsRn `thenRn` \ no_errs_so_far -> - (if no_errs_so_far then - exportsFromAvail this_mod_name exports all_avails gbl_env - else - returnRn [] - ) `thenRn` \ export_avails -> - -- ALL DONE - returnRn (gbl_env, local_gbl_env, export_avails, global_avail_env) - ) + returnRn (gbl_env, local_gbl_env, all_avails) where this_mod_name = moduleName this_mod @@ -193,8 +170,8 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m \begin{code} -importsFromLocalDecls this_mod rec_exp_fn decls - = mapRn (getLocalDeclBinders this_mod rec_exp_fn) decls `thenRn` \ avails_s -> +importsFromLocalDecls this_mod decls + = mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s -> let avails = concat avails_s @@ -221,9 +198,8 @@ importsFromLocalDecls this_mod rec_exp_fn decls --------------------------- getLocalDeclBinders :: Module - -> (Name -> Bool) -- Whether exported -> RdrNameHsDecl -> RnMG Avails -getLocalDeclBinders mod rec_exp_fn (TyClD tycl_decl) +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 @@ -231,14 +207,16 @@ getLocalDeclBinders mod rec_exp_fn (TyClD tycl_decl) getTyClDeclBinders mod tycl_decl `thenRn` \ avail -> returnRn [avail] -getLocalDeclBinders mod rec_exp_fn (ValD binds) - = mapRn (newLocalBinder mod rec_exp_fn) - (bagToList (collectTopBinders binds)) +getLocalDeclBinders mod (ValD binds) + = mapRn new (bagToList (collectTopBinders binds)) + where + new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> + returnRn (Avail name) -getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc)) +getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc)) | binds_haskell_name kind - = newLocalBinder mod rec_exp_fn (nm, loc) `thenRn` \ avail -> - returnRn [avail] + = newTopBinder mod nm loc `thenRn` \ name -> + returnRn [Avail name] | otherwise -- a foreign export = returnRn [] @@ -247,17 +225,11 @@ getLocalDeclBinders mod rec_exp_fn (ForD (ForeignDecl nm kind _ ext_nm _ loc)) binds_haskell_name FoLabel = True binds_haskell_name FoExport = isDynamicExtName ext_nm -getLocalDeclBinders mod rec_exp_fn (FixD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (DeprecD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (DefD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (InstD _) = returnRn [] -getLocalDeclBinders mod rec_exp_fn (RuleD _) = returnRn [] - ---------------------------- -newLocalBinder mod rec_exp_fn (rdr_name, loc) - = -- Generate a local name, and with a suitable export indicator - newTopBinder mod rdr_name loc `thenRn` \ name -> - returnRn (Avail (setLocalNameSort name (rec_exp_fn name))) +getLocalDeclBinders mod (FixD _) = returnRn [] +getLocalDeclBinders mod (DeprecD _) = returnRn [] +getLocalDeclBinders mod (DefD _) = returnRn [] +getLocalDeclBinders mod (InstD _) = returnRn [] +getLocalDeclBinders mod (RuleD _) = returnRn [] \end{code} @@ -589,9 +561,6 @@ check_occs ie occs avail failWithRn occs (exportClashErr name_occ ie ie') where name_occ = nameOccName name - -mk_export_fn :: NameSet -> (Name -> Bool) -- True => exported -mk_export_fn exported_names = \name -> name `elemNameSet` exported_names \end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index fbbf6b5..3dff2de 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -24,7 +24,7 @@ import CoreUtils ( exprIsTrivial ) import Id ( isDataConId, isOneShotLambda, setOneShotLambda, idOccInfo, setIdOccInfo, isExportedId, modifyIdInfo, idInfo, - idSpecialisation, + idSpecialisation, isLocalId, idType, idUnique, Id ) import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo ) @@ -32,7 +32,6 @@ import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo ) import VarSet import VarEnv -import Name ( isLocallyDefined ) import Type ( splitFunTy_maybe, splitForAllTys ) import Maybes ( maybeToBool ) import Digraph ( stronglyConnCompR, SCC(..) ) @@ -76,7 +75,7 @@ occurAnalyseRule (Rule str tpl_vars tpl_args rhs) -- Add occ info to tpl_vars, rhs = Rule str tpl_vars' tpl_args rhs' where - (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs + (rhs_uds, rhs') = occurAnalyseExpr isLocalId rhs (_, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -175,7 +174,7 @@ occurAnalyseBinds binds other -> -- Ho ho! The normal case (final_usage, ind_env, new_binds ++ binds') -initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting +initialTopEnv = OccEnv isLocalId -- Anything local is interesting emptyVarSet [] @@ -202,7 +201,7 @@ shortMeOut ind_env exported_id local_id -- how often I don't get shorting out becuase of IdInfo stuff = if isExportedId exported_id && -- Only if this is exported - isLocallyDefined local_id && -- Only if this one is defined in this + isLocalId local_id && -- Only if this one is defined in this -- module, so that we *can* change its -- binding to be the exported thing! diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 7b9ae30..4a4f38b 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -31,7 +31,7 @@ import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( Id, isDataConWrapId, setIdNoDiscard ) +import Id ( Id, isDataConWrapId, setIdNoDiscard, isLocalId ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -58,20 +58,23 @@ import List ( partition ) core2core :: DynFlags -- includes spec of what core-to-core passes to do -> PackageRuleBase -- Rule-base accumulated from imported packages -> HomeSymbolTable + -> IsExported -> [CoreBind] -- Binds in -> [IdCoreRule] -- Rules in -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out -core2core dflags pkg_rule_base hst binds rules +core2core dflags pkg_rule_base hst is_exported binds rules = do let core_todos = dopt_CoreToDo dflags us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, binds1, orphan_rules) - <- prepareRules dflags pkg_rule_base hst ru_us binds rules + (rule_base, local_rule_stuff, orphan_rules) + <- prepareRules dflags pkg_rule_base hst ru_us rules + -- PREPARE THE BINDINGS + let binds1 = updateBinders local_rule_stuff is_exported binds -- DO THE BUSINESS (stats, processed_binds) @@ -162,10 +165,10 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } \begin{code} prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable -> UniqSupply - -> [CoreBind] -> [IdCoreRule] -- Local bindings and rules - -> IO (RuleBase, -- Full rule base - [CoreBind], -- Bindings augmented with rules - [IdCoreRule]) -- Orphan rules + -> [IdCoreRule] -- Local 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 @@ -174,14 +177,16 @@ 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 ((`elemVarSet` local_ids) . fst) better_rules - (binds1, local_rule_fvs) = addRulesToBinds binds local_id_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 local_rule_fvs + 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, binds1, orphan_rules) + ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules) } where sw_chkr any = SwBool False -- A bit bogus @@ -196,42 +201,45 @@ prepareRules dflags pkg_rule_base hst us binds rules -- simpVar fails if it isn't right, and it might conceiveably matter local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds -addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], IdSet) + +updateBinders :: IdSet -- Locally defined ids with their Rules attached + -> IdSet -- Ids free in the RHS of local rules + -> [CoreBind] -> [CoreBind] -- A horrible function - -- Attach the rules for each locally-defined Id to that Id. - -- - This makes the rules easier to look up - -- - It means that transformation rules and specialisations for - -- locally defined Ids are handled uniformly - -- - It keeps alive things that are referred to only from a rule - -- (the occurrence analyser knows about rules attached to Ids) - -- - It makes sure that, when we apply a rule, the free vars - -- of the RHS are more likely to be in scope - -- - -- Both the LHS and RHS Ids are marked 'no-discard'. - -- This means that the binding won't be discarded EVEN if the binding - -- ends up being trivial (v = w) -- the simplifier would usually just - -- substitute w for v throughout, but we don't apply the substitution to - -- the rules (maybe we should?), so this substitution would make the rule - -- bogus. - -addRulesToBinds binds local_rules - = (map zap_bind binds, rule_lhs_fvs) +-- Update the binders of top-level bindings as follows +-- a) Attach the rules for each locally-defined Id to that Id. +-- b) Set the no-discard flag if either the Id is exported, +-- or it's mentoined in the RHS of a rule +-- +-- Reason for (a) +-- - It makes the rules easier to look up +-- - It means that transformation rules and specialisations for +-- locally defined Ids are handled uniformly +-- - It keeps alive things that are referred to only from a rule +-- (the occurrence analyser knows about rules attached to Ids) +-- - It makes sure that, when we apply a rule, the free vars +-- of the RHS are more likely to be in scope +-- +-- Reason for (b) +-- It means that the binding won't be discarded EVEN if the binding +-- ends up being trivial (v = w) -- the simplifier would usually just +-- substitute w for v throughout, but we don't apply the substitution to +-- the rules (maybe we should?), so this substitution would make the rule +-- bogus. + +updateBinders rule_ids rule_rhs_fvs is_exported binds + = map update_bndrs binds where - -- rule_fvs is the set of all variables mentioned in this module's rules - rule_fvs = unionVarSets [ ruleSomeFreeVars isId rule | (_,rule) <- local_rules ] - - rule_base = extendRuleBaseList emptyRuleBase local_rules - rule_lhs_fvs = ruleBaseFVs rule_base - rule_ids = ruleBaseIds rule_base - - zap_bind (NonRec b r) = NonRec (zap_bndr b) r - zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs] - - zap_bndr bndr = case lookupVarSet rule_ids bndr of - Just bndr' -> setIdNoDiscard bndr' - Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr - | otherwise -> bndr + 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) + || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr' + | otherwise = bndr' + where + bndr' = lookupVarSet rule_ids bndr `orElse` bndr \end{code} diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 2056be2..8c16ec7 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -13,7 +13,7 @@ module StgVarInfo ( setStgVarInfo ) where import StgSyn -import Id ( setIdArityInfo, idArity, setIdOccInfo, Id ) +import Id ( isLocalId, setIdArityInfo, idArity, setIdOccInfo, Id ) import VarSet import VarEnv import Var @@ -21,7 +21,7 @@ import IdInfo ( ArityInfo(..), OccInfo(..) ) import PrimOp ( PrimOp(..), ccallMayGC ) import TysWiredIn ( isForeignObjTy ) import Maybes ( maybeToBool, orElse ) -import Name ( isLocallyDefined, getOccName ) +import Name ( isLocalName, getOccName ) import OccName ( occNameUserString ) import BasicTypes ( Arity ) import Outputable @@ -766,10 +766,10 @@ lookupLiveVarsForSet fvs sw env lvs_cont sw env lvs_cont where do_one v - = if isLocallyDefined v then + = if isLocalId v then case (lookupVarEnv env v) of Just (_, LetrecBound _ lvs) -> extendVarSet lvs v - Just _ -> unitVarSet v + Just _ -> unitVarSet v Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v) else emptyVarSet diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 095b7e2..fad010b 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -1137,8 +1137,6 @@ newIdSM old_id new_ty = getUniqSM `thenSM` \ uniq -> let -- Give the new Id a similar occurrence name to the old one - -- We used to add setIdNoDiscard if the old id was exported, to - -- avoid it being dropped as dead code, but that's not necessary any more. name = idName old_id new_id = mkUserLocal (mkSpecOcc (nameOccName name)) uniq new_ty (getSrcLoc name) in diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 7818f32..59febdd 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -11,13 +11,13 @@ module StgLint ( lintStgBindings ) where import StgSyn import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) -import Id ( Id, idType ) +import Id ( Id, idType, isLocalId ) import VarSet import DataCon ( DataCon, dataConArgTys, dataConRepType ) import PrimOp ( primOpType ) import Literal ( literalType, Literal ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, getSrcLoc ) +import Name ( getSrcLoc ) import ErrUtils ( ErrMsg, Message, addErrLocHdrLine, pprBagOfErrors, dontAddErrLoc ) import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe, isUnLiftedType, isTyVarTy, splitForAllTys, Type @@ -437,7 +437,7 @@ checkFunApp fun_ty arg_tys msg loc scope errs \begin{code} checkInScope :: Id -> LintM () checkInScope id loc scope errs - = if isLocallyDefined id && not (id `elemVarSet` scope) then + = if isLocalId id && not (id `elemVarSet` scope) then ((), addErr errs (hsep [ppr id, ptext SLIT("is out of scope")]) loc) else ((), errs) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index a9a89e4..6af65b0 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -48,7 +48,6 @@ import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, import TcMonad import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) -import Name ( isLocallyDefined ) import CoreSyn ( Expr ) import CoreUnfold( unfoldingTemplate ) import BasicTypes ( RecFlag(..) ) @@ -165,9 +164,8 @@ zonkIdBndr id zonkIdOcc :: TcId -> NF_TcM Id zonkIdOcc id - | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id - -- The omitIfaceSigForId thing may look wierd but it's quite - -- sensible really. We're avoiding looking up superclass selectors + | not (isLocalId id) || isIP id + -- We're avoiding looking up superclass selectors -- and constructors; zonking them is a no-op anyway, and the -- superclass selectors aren't in the environment anyway. = returnNF_Tc id diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 727a3c2..64f77bb 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -29,13 +29,13 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) +import Id ( Id, mkId, mkImportedId, isDataConWrapId_maybe ) import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) import Type ( mkTyVarTys, splitAlgTyConApp_maybe ) import Var ( mkTyVar, tyVarKind ) -import Name ( Name, isLocallyDefined ) +import Name ( Name ) import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) import Outputable @@ -61,8 +61,6 @@ tcInterfaceSigs unf_env decls | TyClD (IfaceSig name ty id_infos src_loc) <- decls] where in_scope_vars = [] -- I think this will be OK - -- If so, don't pass it around - -- Was: filter isLocallyDefined (tcEnvIds unf_env) do_one name ty id_infos src_loc = tcAddSrcLoc src_loc $ @@ -70,7 +68,7 @@ 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 (mkId name sigma_ty id_info) + returnTc (mkImportedId name sigma_ty id_info) \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 2a05b8c..123b4b7 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -57,7 +57,7 @@ import VarSet import ErrUtils ( Message ) import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind ) import Class ( ClassContext, classArity, classTyCon ) -import Name ( Name, isLocallyDefined ) +import Name ( Name ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import UniqFM ( elemUFM ) import BasicTypes ( Boxity(..), RecFlag(..), isRec ) @@ -852,8 +852,7 @@ find_globals tv tidy_env acc [] = returnNF_Tc (tidy_env, acc) find_globals tv tidy_env acc (id:ids) - | not (isLocallyDefined id) || - isEmptyVarSet (idFreeTyVars id) + | isEmptyVarSet (idFreeTyVars id) = find_globals tv tidy_env acc ids | otherwise -- 1.7.10.4