diff options
author | simonpj <unknown> | 1998-12-18 17:42:39 +0000 |
---|---|---|
committer | simonpj <unknown> | 1998-12-18 17:42:39 +0000 |
commit | 7e602b0a11e567fcb035d1afd34015aebcf9a577 (patch) | |
tree | 54ca13c3ec0704e343b68d0d313a29f53d6c3855 /ghc/compiler/basicTypes | |
parent | 139f0fd30e19f934aa51885a52b8e5d7c24ee460 (diff) | |
download | haskell-7e602b0a11e567fcb035d1afd34015aebcf9a577.tar.gz |
[project @ 1998-12-18 17:40:31 by simonpj]
Another big commit from Simon. Actually, the last one
didn't all go into the main trunk; because of a CVS glitch it
ended up in the wrong branch.
So this commit includes:
* Scoped type variables
* Warnings for unused variables should work now (they didn't before)
* Simplifier improvements:
- Much better treatment of strict arguments
- Better treatment of bottoming Ids
- No need for w/w split for fns that are merely strict
- Fewer iterations needed, I hope
* Less gratuitous renaming in interface files and abs C
* OccName is a separate module, and is an abstract data type
I think the whole Prelude and Exts libraries compile correctly.
Something isn't quite right about typechecking existentials though.
Diffstat (limited to 'ghc/compiler/basicTypes')
-rw-r--r-- | ghc/compiler/basicTypes/BasicTypes.lhs | 17 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/DataCon.lhs | 26 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/Demand.lhs | 64 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/Id.lhs | 106 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/IdInfo.lhs | 51 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/MkId.lhs | 17 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/Name.lhs | 735 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/NameSet.lhs | 30 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/OccName.lhs | 594 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/PprEnv.lhs | 20 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/UniqSupply.lhs | 2 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/Unique.lhs | 26 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/Var.lhs | 144 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/VarEnv.lhs | 44 | ||||
-rw-r--r-- | ghc/compiler/basicTypes/VarSet.lhs | 50 |
15 files changed, 1176 insertions, 750 deletions
diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index cfd79b1f1b..5045c784e2 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -16,7 +16,6 @@ types that module BasicTypes( Version, Arity, Unused, unused, - Module, moduleString, pprModule, Fixity(..), FixityDirection(..), StrictnessMark(..), NewOrData(..), IfaceFlavour(..), TopLevelFlag(..), RecFlag(..) ) where @@ -66,22 +65,6 @@ type Version = Int %************************************************************************ %* * -\subsection[Module]{The name of a module} -%* * -%************************************************************************ - -\begin{code} -type Module = FAST_STRING - -moduleString :: Module -> String -moduleString mod = _UNPK_ mod - -pprModule :: Module -> SDoc -pprModule m = ptext m -\end{code} - -%************************************************************************ -%* * \subsection[IfaceFlavour]{IfaceFlavour} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index b99ca31a4c..3ecd9689e6 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -51,7 +51,25 @@ data DataCon dcName :: Name, dcUnique :: Unique, -- Cached from Name dcTag :: ConTag, - dcType :: Type, -- Type of the constructor (see notes below) + + -- Running example: + -- + -- data Eq a => T a = forall b. Ord b => MkT a [b] + + dcType :: Type, -- Type of the constructor + -- forall ab . Ord b => a -> [b] -> MkT a + -- (this is *not* of the constructor Id: + -- see notes after this data type declaration) + + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcTyVars = [a] + -- dcTheta = [Eq a] + -- dcExTyVars = [b] + -- dcExTheta = [Ord b] + -- dcArgTys = [a,List b] + -- dcTyCon = T dcTyVars :: [TyVar], -- Type vars and context for the data type decl dcTheta :: ThetaType, @@ -62,6 +80,7 @@ data DataCon dcArgTys :: [Type], -- Argument types dcTyCon :: TyCon, -- Result tycon + -- Now the strictness annotations and field labels of the constructor dcStricts :: [StrictnessMark], -- Strict args, in the same order as the argument types; -- length = dataConNumFields dataCon @@ -69,6 +88,11 @@ data DataCon -- same order as the argument types; -- length = 0 (if not a record) or dataConSourceArity. + -- Finally, the curried function that corresponds to the constructor + -- mkT :: forall a b. (Eq a, Ord b) => a -> [b] -> T a + -- mkT = /\ab. \deq dord p qs. Con MkT [a, b, dord, p, qs] + -- This unfolding is built in MkId.mkDataConId + dcId :: Id -- The corresponding Id } diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index 0f25717745..f0342165eb 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -78,9 +78,7 @@ isStrict (WwUnpack NewType _ ds) = isStrict (head ds) isStrict (WwUnpack other _ _) = True isStrict WwStrict = True isStrict WwEnum = True -isStrict WwPrim = False -- NB: we treat only lifted types as strict. - -- Why is this important? Mostly it doesn't matter - -- but it saves a test for lifted-ness in SimplUtils.etaCoreExpr +isStrict WwPrim = True isStrict _ = False \end{code} @@ -97,7 +95,42 @@ isLazy _ = False -- (as they imply a worker) %* * %************************************************************************ + \begin{code} +pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot + where + pp_bot | bot = ptext SLIT("B") + | otherwise = empty + + +pprDemand (WwLazy False) = char 'L' +pprDemand (WwLazy True) = char 'A' +pprDemand WwStrict = char 'S' +pprDemand WwPrim = char 'P' +pprDemand WwEnum = char 'E' +pprDemand (WwUnpack nd wu args) = char ch <> parens (hcat (map pprDemand args)) + where + ch = case nd of + DataType | wu -> 'U' + | otherwise -> 'u' + NewType | wu -> 'N' + | otherwise -> 'n' + +instance Outputable Demand where + ppr (WwLazy False) = empty + ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand + +instance Show Demand where + showsPrec p d = showsPrecSDoc p (ppr d) +\end{code} + + +\begin{code} +{- ------------------- OMITTED NOW ------------------------------- + -- Reading demands is done in Lex.lhs + -- Also note that the (old) code here doesn't take proper + -- account of the 'B' suffix for bottoming functions + #ifdef REALLY_HASKELL_1_3 instance Read Demand where @@ -113,6 +146,8 @@ instance Text Demand where showsPrec p d = showsPrecSDoc p (ppr d) #endif +readDemands :: String -> + read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs read_em acc ('S' : xs) = read_em (WwStrict : acc) xs @@ -128,25 +163,8 @@ read_em acc rest = [(reverse acc, rest)] do_unpack new_or_data wrapper_unpacks acc xs = case (read_em [] xs) of [(stuff, rest)] -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest - _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> text ("::"++xs)) - - -pprDemands demands = hcat (map pprDemand demands) - -pprDemand (WwLazy False) = char 'L' -pprDemand (WwLazy True) = char 'A' -pprDemand WwStrict = char 'S' -pprDemand WwPrim = char 'P' -pprDemand WwEnum = char 'E' -pprDemand (WwUnpack nd wu args) = char ch <> parens (pprDemands args) - where - ch = case nd of - DataType | wu -> 'U' - | otherwise -> 'u' - NewType | wu -> 'N' - | otherwise -> 'n' + _ -> pprPanic "Demand.do_unpack:" (ppr acc <+> dcolon <> text xs) -instance Outputable Demand where - ppr (WwLazy False) = empty - ppr other_demand = ptext SLIT("__D") <+> pprDemand other_demand +-------------------- END OF OMISSION ------------------------------ -} \end{code} + diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 0ae23a6816..56afa7ae6b 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -5,20 +5,19 @@ \begin{code} module Id ( - Id, DictId, GenId, + Id, DictId, -- Simple construction mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal, mkTemplateLocals, mkWildId, mkUserId, -- Taking an Id apart - idName, idType, idUnique, idInfo, + idName, idType, idUnique, idInfo, idDetails, idPrimRep, isId, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdInfo, - setIdVisibility, mkIdVisible, + setIdName, setIdUnique, setIdType, setIdInfo, mkIdVisible, -- Predicates omitIfaceSigForId, @@ -34,7 +33,7 @@ module Id ( isRecordSelector, isPrimitiveId_maybe, isDataConId_maybe, isConstantId, - isBottomingId, + isBottomingId, idAppIsBottom, -- IdInfo stuff setIdUnfolding, @@ -59,25 +58,24 @@ module Id ( import {-# SOURCE #-} CoreUnfold ( Unfolding ) -import Var ( Id, GenId, DictId, VarDetails(..), +import Var ( Id, DictId, VarDetails(..), isId, mkId, - idName, idType, idUnique, idInfo, varDetails, + idName, idType, idUnique, idInfo, idDetails, setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo, externallyVisibleId ) import VarSet -import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars ) +import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars ) import IdInfo import Demand ( Demand ) -import Name ( Name, OccName, +import Name ( Name, OccName, Module, mkSysLocalName, mkLocalName, - isWiredInName, setNameVisibility, mkNameVisible + isWiredInName, mkNameVisible ) import Const ( Con(..) ) import PrimRep ( PrimRep ) import PrimOp ( PrimOp ) import FieldLabel ( FieldLabel(..) ) -import BasicTypes ( Module ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) import Outputable @@ -100,22 +98,22 @@ infixl 1 `setIdUnfolding`, %************************************************************************ \begin{code} -mkVanillaId :: Name -> (GenType flexi) -> GenId flexi -mkVanillaId name ty = mkId name ty VanillaId noIdInfo +mkVanillaId :: Name -> Type -> Id +mkVanillaId name ty = mkId name (addFreeTyVars ty) VanillaId noIdInfo mkImportedId :: Name -> Type -> IdInfo -> Id -mkImportedId name ty info = mkId name ty VanillaId info +mkImportedId name ty info = mkId name (addFreeTyVars ty) VanillaId info -mkUserId :: Name -> GenType flexi -> GenId flexi +mkUserId :: Name -> Type -> Id mkUserId name ty = mkVanillaId name ty -- SysLocal: for an Id being created by the compiler out of thin air... -- UserLocal: an Id with a name the user might recognize... -mkUserLocal :: OccName -> Unique -> GenType flexi -> GenId flexi -mkSysLocal :: Unique -> GenType flexi -> GenId flexi +mkUserLocal :: OccName -> Unique -> Type -> Id +mkSysLocal :: FAST_STRING -> Unique -> Type -> Id -mkSysLocal uniq ty = mkVanillaId (mkSysLocalName uniq) ty -mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty +mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty +mkUserLocal occ uniq ty = mkVanillaId (mkLocalName uniq occ) ty \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -125,11 +123,11 @@ instantiated before use. \begin{code} -- "Wild Id" typically used when you need a binder that you don't expect to use mkWildId :: Type -> Id -mkWildId ty = mkSysLocal (mkBuiltinUnique 1) ty +mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty -- "Template locals" typically used in unfoldings mkTemplateLocals :: [Type] -> [Id] -mkTemplateLocals tys = zipWith mkSysLocal +mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) (getBuiltinUniques (length tys)) tys \end{code} @@ -142,10 +140,10 @@ mkTemplateLocals tys = zipWith mkSysLocal %************************************************************************ \begin{code} -idFreeTyVars :: (GenId flexi) -> (GenTyVarSet flexi) +idFreeTyVars :: Id -> TyVarSet idFreeTyVars id = tyVarsOfType (idType id) -setIdType :: GenId flexi1 -> GenType flexi2 -> GenId flexi2 +setIdType :: Id -> Type -> Id -- Add free tyvar info to the type setIdType id ty = setVarType id (addFreeTyVars ty) @@ -164,7 +162,7 @@ omitIfaceSigForId id = True | otherwise - = case varDetails id of + = case idDetails id of RecordSelId _ -> True -- Includes dictionary selectors ConstantId _ -> True -- ConstantIds are implied by their type or class decl; @@ -175,13 +173,7 @@ omitIfaceSigForId id other -> False -- Don't omit! \end{code} -See notes with setNameVisibility (Name.lhs) - \begin{code} -setIdVisibility :: Maybe Module -> Unique -> Id -> Id -setIdVisibility maybe_mod u id - = setIdName id (setNameVisibility maybe_mod u (idName id)) - mkIdVisible :: Module -> Unique -> Id -> Id mkIdVisible mod u id = setIdName id (mkNameVisible mod u (idName id)) @@ -195,22 +187,22 @@ mkIdVisible mod u id \begin{code} recordSelectorFieldLabel :: Id -> FieldLabel -recordSelectorFieldLabel id = case varDetails id of +recordSelectorFieldLabel id = case idDetails id of RecordSelId lbl -> lbl -isRecordSelector id = case varDetails id of +isRecordSelector id = case idDetails id of RecordSelId lbl -> True other -> False -isPrimitiveId_maybe id = case varDetails id of +isPrimitiveId_maybe id = case idDetails id of ConstantId (PrimOp op) -> Just op other -> Nothing -isDataConId_maybe id = case varDetails id of +isDataConId_maybe id = case idDetails id of ConstantId (DataCon con) -> Just con other -> Nothing -isConstantId id = case varDetails id of +isConstantId id = case idDetails id of ConstantId _ -> True other -> False \end{code} @@ -225,61 +217,65 @@ isConstantId id = case varDetails id of \begin{code} --------------------------------- -- ARITY -getIdArity :: GenId flexi -> ArityInfo +getIdArity :: Id -> ArityInfo getIdArity id = arityInfo (idInfo id) -setIdArity :: GenId flexi -> ArityInfo -> GenId flexi +setIdArity :: Id -> ArityInfo -> Id setIdArity id arity = modifyIdInfo id (arity `setArityInfo`) --------------------------------- -- STRICTNESS -getIdStrictness :: GenId flexi -> StrictnessInfo +getIdStrictness :: Id -> StrictnessInfo getIdStrictness id = strictnessInfo (idInfo id) -setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi +setIdStrictness :: Id -> StrictnessInfo -> Id setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`) -isBottomingId :: GenId flexi -> Bool -isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id)) +-- isBottomingId returns true if an application to n args would diverge +isBottomingId :: Id -> Bool +isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id)) + +idAppIsBottom :: Id -> Int -> Bool +idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n --------------------------------- -- UNFOLDING -getIdUnfolding :: GenId flexi -> Unfolding +getIdUnfolding :: Id -> Unfolding getIdUnfolding id = unfoldingInfo (idInfo id) -setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi +setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`) --------------------------------- -- DEMAND -getIdDemandInfo :: GenId flexi -> Demand +getIdDemandInfo :: Id -> Demand getIdDemandInfo id = demandInfo (idInfo id) -setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi +setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`) --------------------------------- -- UPDATE INFO -getIdUpdateInfo :: GenId flexi -> UpdateInfo +getIdUpdateInfo :: Id -> UpdateInfo getIdUpdateInfo id = updateInfo (idInfo id) -setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi +setIdUpdateInfo :: Id -> UpdateInfo -> Id setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`) --------------------------------- -- SPECIALISATION -getIdSpecialisation :: GenId flexi -> IdSpecEnv +getIdSpecialisation :: Id -> IdSpecEnv getIdSpecialisation id = specInfo (idInfo id) -setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi +setIdSpecialisation :: Id -> IdSpecEnv -> Id setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`) --------------------------------- -- CAF INFO -getIdCafInfo :: GenId flexi -> CafInfo +getIdCafInfo :: Id -> CafInfo getIdCafInfo id = cafInfo (idInfo id) -setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi +setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`) \end{code} @@ -290,16 +286,16 @@ The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. \begin{code} -getInlinePragma :: GenId flexi -> InlinePragInfo +getInlinePragma :: Id -> InlinePragInfo getInlinePragma id = inlinePragInfo (idInfo id) -setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi +setInlinePragma :: Id -> InlinePragInfo -> Id setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag) -modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi +modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info) -idWantsToBeINLINEd :: GenId flexi -> Bool +idWantsToBeINLINEd :: Id -> Bool idWantsToBeINLINEd id = case getInlinePragma id of IWantToBeINLINEd -> True IMustBeINLINEd -> True diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index f2084c8265..c92f94318a 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -20,9 +20,10 @@ module IdInfo ( -- Strictness StrictnessInfo(..), -- Non-abstract - workerExists, mkStrictnessInfo, mkBottomStrictnessInfo, - noStrictnessInfo, bottomIsGuaranteed, strictnessInfo, + workerExists, mkStrictnessInfo, + noStrictnessInfo, strictnessInfo, ppStrictnessInfo, setStrictnessInfo, + isBottomingStrictness, appIsBottom, -- Unfolding unfoldingInfo, setUnfoldingInfo, @@ -302,52 +303,46 @@ it exists); i.e. its calling convention. data StrictnessInfo = NoStrictnessInfo - | BottomGuaranteed -- This Id guarantees never to return; - -- it is bottom regardless of its arguments. - -- Useful for "error" and other disguised - -- variants thereof. - | StrictnessInfo [Demand] + Bool -- True <=> the function diverges regardless of its arguments + -- Useful for "error" and other disguised variants thereof. + -- BUT NB: f = \x y. error "urk" + -- will have info SI [SS] True + -- but still (f) and (f 2) are not bot; only (f 3 2) is bot + Bool -- True <=> there is a worker. There might not be, even for a -- strict function, because: -- (a) the function might be small enough to inline, -- so no need for w/w split -- (b) the strictness info might be "SSS" or something, so no w/w split. - - -- Worker's Id, if applicable, and a list of the constructors - -- mentioned by the wrapper. This is necessary so that the - -- renamer can slurp them in. Without this info, the renamer doesn't - -- know which data types to slurp in concretely. Remember, for - -- strict things we don't put the unfolding in the interface file, to save space. - -- This constructor list allows the renamer to behave much as if the - -- unfolding *was* in the interface file. \end{code} \begin{code} -mkStrictnessInfo :: [Demand] -> Bool -> StrictnessInfo +mkStrictnessInfo :: ([Demand], Bool) -> Bool -> StrictnessInfo -mkStrictnessInfo xs has_wrkr - | all isLazy xs = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs has_wrkr +mkStrictnessInfo (xs, is_bot) has_wrkr + | all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting + | otherwise = StrictnessInfo xs is_bot has_wrkr noStrictnessInfo = NoStrictnessInfo -mkBottomStrictnessInfo = BottomGuaranteed -bottomIsGuaranteed BottomGuaranteed = True -bottomIsGuaranteed other = False +isBottomingStrictness (StrictnessInfo _ bot _) = bot +isBottomingStrictness NoStrictnessInfo = False -ppStrictnessInfo NoStrictnessInfo = empty -ppStrictnessInfo BottomGuaranteed = ptext SLIT("__bot") +-- appIsBottom returns true if an application to n args would diverge +appIsBottom (StrictnessInfo ds bot _) n = bot && (n >= length ds) +appIsBottom NoStrictnessInfo n = False -ppStrictnessInfo (StrictnessInfo wrapper_args wrkr_maybe) - = hsep [ptext SLIT("__S"), pprDemands wrapper_args] +ppStrictnessInfo NoStrictnessInfo = empty +ppStrictnessInfo (StrictnessInfo wrapper_args bot wrkr_maybe) + = hsep [ptext SLIT("__S"), pprDemands wrapper_args bot] \end{code} \begin{code} workerExists :: StrictnessInfo -> Bool -workerExists (StrictnessInfo _ worker_exists) = worker_exists -workerExists other = False +workerExists (StrictnessInfo _ _ worker_exists) = worker_exists +workerExists other = False \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index bb9020c7ba..cd0ec9bcc8 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -30,7 +30,7 @@ import {-# SOURCE #-} CoreUnfold ( mkUnfolding ) import TysWiredIn ( boolTy ) import Type ( Type, ThetaType, mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, - isUnLiftedType, substFlexiTheta, + isUnLiftedType, substTopTheta, splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, splitFunTys, splitForAllTys ) @@ -39,11 +39,11 @@ import Class ( Class, classBigSig, classTyCon ) import Var ( Id, TyVar, VarDetails(..), mkId ) import VarEnv ( zipVarEnv ) import Const ( Con(..) ) -import Name ( mkCompoundName, mkWiredInIdName, - mkWorkerName, mkSuperDictSelName, +import Name ( mkDerivedName, mkWiredInIdName, + mkWorkerOcc, mkSuperDictSelOcc, Name, NamedThing(..), ) -import PrimOp ( PrimOp, primOpType, primOpStr, primOpUniq ) +import PrimOp ( PrimOp, primOpType, primOpOcc, primOpUniq ) import DataCon ( DataCon, dataConStrictMarks, dataConFieldLabels, dataConArgTys, dataConSig ) @@ -86,7 +86,7 @@ mkDefaultMethodId dm_name rec_c ty = mkVanillaId dm_name ty mkWorkerId uniq unwrkr ty - = mkVanillaId (mkCompoundName mkWorkerName uniq (getName unwrkr)) ty + = mkVanillaId (mkDerivedName mkWorkerOcc (getName unwrkr) uniq) ty \end{code} %************************************************************************ @@ -257,7 +257,7 @@ mkSuperDictSelId :: Unique -> Class -> FieldLabelTag -> Type -> Id mkSuperDictSelId uniq clas index ty = mkDictSelId name clas ty where - name = mkCompoundName (mkSuperDictSelName index) uniq (getName clas) + name = mkDerivedName (mkSuperDictSelOcc index) (getName clas) uniq -- For method selectors the clean thing to do is -- to give the method selector the same name as the class op itself. @@ -315,7 +315,7 @@ mkPrimitiveId :: PrimOp -> Id mkPrimitiveId prim_op = id where - occ_name = primOpStr prim_op + occ_name = primOpOcc prim_op key = primOpUniq prim_op ty = primOpType prim_op name = mkWiredInIdName key pREL_GHC occ_name id @@ -365,8 +365,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta = mkVanillaId dfun_name dfun_ty where (class_tyvars, sc_theta, _, _, _) = classBigSig clas - sc_theta' = substFlexiTheta (zipVarEnv class_tyvars inst_tys) sc_theta - -- Doesn't really need to be flexi + sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys) sc_theta dfun_theta = case inst_decl_theta of [] -> [] -- If inst_decl_theta is empty, then we don't diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 5fc667cfa3..a84e626f98 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -5,33 +5,20 @@ \begin{code} module Name ( - -- Re-export the Module type - Module, - pprModule, moduleString, - - -- The basic form of names - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - mkTupNameStr, mkUbxTupNameStr, isLowerISO, isUpperISO, - - -- The OccName type - OccName(..), varOcc, - pprOccName, occNameString, occNameFlavour, - isTvOcc, isTCOcc, isVarOcc, prefixOccName, + -- Re-export the OccName stuff + module OccName, -- The Name type Name, -- Abstract - mkLocalName, mkSysLocalName, - - mkCompoundName, mkGlobalName, - + mkLocalName, mkSysLocalName, mkTopName, + mkDerivedName, mkGlobalName, mkWiredInIdName, mkWiredInTyConName, maybeWiredInIdName, maybeWiredInTyConName, isWiredInName, - nameUnique, changeUnique, setNameProvenance, getNameProvenance, - setNameVisibility, mkNameVisible, - nameOccName, nameModule, + nameUnique, setNameUnique, setNameProvenance, getNameProvenance, + tidyTopName, mkNameVisible, + nameOccName, nameModule, setNameOcc, isExportedName, nameSrcLoc, isLocallyDefinedName, @@ -40,14 +27,9 @@ module Name ( pprNameProvenance, - -- Special Names - dictNamePrefix, mkSuperDictSelName, mkWorkerName, - mkDefaultMethodName, mkClassTyConStr, mkClassDataConStr, - -- Misc - Provenance(..), pprProvenance, - ExportFlag(..), - PrintUnqualified, + Provenance(..), ImportReason(..), pprProvenance, + ExportFlag(..), PrintUnqualified, -- Class NamedThing and overloaded friends NamedThing(..), @@ -60,177 +42,19 @@ module Name ( import {-# SOURCE #-} Var ( Id ) import {-# SOURCE #-} TyCon ( TyCon ) -import CStrings ( identToC ) -import PrelMods ( pREL_BASE, pREL_TUP, pREL_GHC ) +import OccName -- All of it import CmdLineOpts ( opt_PprStyle_NoPrags, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) -import BasicTypes ( Module, IfaceFlavour(..), moduleString, pprModule ) +import BasicTypes ( IfaceFlavour(..) ) import SrcLoc ( noSrcLoc, mkBuiltinSrcLoc, SrcLoc ) import Unique ( pprUnique, Unique, Uniquable(..) ) import Outputable -import Char ( isUpper, isLower, ord ) -import Util ( nOfThem ) import GlaExts \end{code} %************************************************************************ %* * -\subsection{Lexical categories} -%* * -%************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, - isLexVarId, isLexVarSym :: FAST_STRING -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- - -isLexConId cs - | _NULL_ cs = False - | cs == SLIT("[]") = True - | c == '(' = True -- (), (,), (,,), ... - | otherwise = isUpper c || isUpperISO c - where - c = _HEAD_ cs - -isLexVarId cs - | _NULL_ cs = False - | otherwise = isLower c || isLowerISO c - where - c = _HEAD_ cs - -isLexConSym cs - | _NULL_ cs = False - | otherwise = c == ':' - || cs == SLIT("->") - where - c = _HEAD_ cs - -isLexVarSym cs - | _NULL_ cs = False - | otherwise = isSymbolASCII c - || isSymbolISO c - where - c = _HEAD_ cs - -------------- -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" -isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# ---0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# ---0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c -\end{code} - -\begin{code} -mkTupNameStr 0 = (pREL_BASE, SLIT("()")) -mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" -mkTupNameStr 2 = (pREL_TUP, _PK_ "(,)") -- not strictly necessary -mkTupNameStr 3 = (pREL_TUP, _PK_ "(,,)") -- ditto -mkTupNameStr 4 = (pREL_TUP, _PK_ "(,,,)") -- ditto -mkTupNameStr n = (pREL_TUP, _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")) - -mkUbxTupNameStr 0 = panic "Name.mkUbxTupNameStr: 0 ???" -mkUbxTupNameStr 1 = (pREL_GHC, _PK_ "(# #)") -- 1 and 0 both make sense!!! -mkUbxTupNameStr 2 = (pREL_GHC, _PK_ "(#,#)") -mkUbxTupNameStr 3 = (pREL_GHC, _PK_ "(#,,#)") -mkUbxTupNameStr 4 = (pREL_GHC, _PK_ "(#,,,#)") -mkUbxTupNameStr n = (pREL_GHC, _PK_ ("(#" ++ nOfThem (n-1) ',' ++ "#)")) -\end{code} - - -%************************************************************************ -%* * -\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} -%* * -%************************************************************************ - -\begin{code} -data OccName = VarOcc FAST_STRING -- Variables and data constructors - | TvOcc FAST_STRING -- Type variables - | TCOcc FAST_STRING -- Type constructors and classes - -pprOccName :: OccName -> SDoc -pprOccName n = getPprStyle $ \ sty -> - if codeStyle sty - then identToC (occNameString n) - else ptext (occNameString n) - -varOcc :: FAST_STRING -> OccName -varOcc = VarOcc - -occNameString :: OccName -> FAST_STRING -occNameString (VarOcc s) = s -occNameString (TvOcc s) = s -occNameString (TCOcc s) = s - -mapOccName :: (FAST_STRING -> FAST_STRING) -> OccName -> OccName -mapOccName f (VarOcc s) = VarOcc (f s) -mapOccName f (TvOcc s) = TvOcc (f s) -mapOccName f (TCOcc s) = TCOcc (f s) - -prefixOccName :: FAST_STRING -> OccName -> OccName -prefixOccName prefix (VarOcc s) = VarOcc (prefix _APPEND_ s) -prefixOccName prefix (TvOcc s) = TvOcc (prefix _APPEND_ s) -prefixOccName prefix (TCOcc s) = TCOcc (prefix _APPEND_ s) - --- occNameFlavour is used only to generate good error messages, so it doesn't matter --- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for --- data constructors and values, but that makes everything else a bit more complicated. -occNameFlavour :: OccName -> String -occNameFlavour (VarOcc s) | isLexConId s = "Data constructor" - | otherwise = "Value" -occNameFlavour (TvOcc s) = "Type variable" -occNameFlavour (TCOcc s) = "Type constructor or class" - -isVarOcc, isTCOcc, isTvOcc :: OccName -> Bool -isVarOcc (VarOcc s) = True -isVarOcc other = False - -isTvOcc (TvOcc s) = True -isTvOcc other = False - -isTCOcc (TCOcc s) = True -isTCOcc other = False - -instance Eq OccName where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord OccName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare a b = cmpOcc a b - -(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `compare` s2 -(VarOcc s1) `cmpOcc` other2 = LT - -(TvOcc s1) `cmpOcc` (VarOcc s2) = GT -(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `compare` s2 -(TvOcc s1) `cmpOcc` other = LT - -(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `compare` s2 -(TCOcc s1) `cmpOcc` other = GT - -instance Outputable OccName where - ppr = pprOccName -\end{code} - - -%************************************************************************ -%* * \subsection[Name-datatype]{The @Name@ datatype, and name construction} %* * %************************************************************************ @@ -238,7 +62,10 @@ instance Outputable OccName where \begin{code} data Name = Local Unique - (Maybe OccName) -- For ones that started life with a user name + OccName -- How to print it + Bool -- True <=> this is a "sys-local" + -- see notes just below + | Global Unique Module -- The defining module @@ -246,117 +73,103 @@ data Name Provenance -- How it was defined \end{code} +Sys-locals are only used internally. When the compiler generates (say) +a fresh desguar variable it always calls it "ds", and of course it gets +a fresh unique. But when printing -ddump-xx dumps, we must print it with +its unique, because there'll be a lot of "ds" variables. That debug +printing issue is the ONLY way in which sys-locals are different. I think. + +Before anything gets printed in interface files or output code, it's +fed through a 'tidy' processor, which zaps the OccNames to have +unique names; and converts all sys-locals to ordinary locals +If any desugarer sys-locals have survived that far, they get changed to +"ds1", "ds2", etc. + 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. -\begin{code} -data Provenance - = NoProvenance - - | LocalDef -- Defined locally - SrcLoc -- Defn site - ExportFlag -- Whether it's exported - - | NonLocalDef -- Defined non-locally - SrcLoc -- Defined non-locally; src-loc gives defn site - IfaceFlavour -- Whether the defn site is an .hi-boot file - PrintUnqualified - - | WiredInTyCon TyCon -- There's a wired-in version - | WiredInId Id -- ...ditto... - -type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is - -- in scope in this module, so print it - -- unqualified in error messages -\end{code} - -Something is "Exported" if it may be mentioned by another module without -warning. The crucial thing about Exported things is that they must -never be dropped as dead code, even if they aren't used in this module. -Furthermore, being Exported means that we can't see all call sites of the thing. - -Exported things include: - - - explicitly exported Ids, including data constructors, - class method selectors - - - dfuns from instance decls - -Being Exported is *not* the same as finally appearing in the .o file's -symbol table. For example, a local Id may be mentioned in an Exported -Id's unfolding in the interface file, in which case the local Id goes -out too. - -\begin{code} -data ExportFlag = Exported | NotExported -\end{code} \begin{code} mkLocalName :: Unique -> OccName -> Name -mkLocalName uniq occ = Local uniq (Just occ) +mkLocalName uniq occ = Local uniq occ False + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which puts the uniques + -- into the print name (see setNameVisibility below) mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name mkGlobalName = Global -mkSysLocalName :: Unique -> Name -mkSysLocalName uniq = Local uniq Nothing +mkSysLocalName :: Unique -> FAST_STRING -> Name +mkSysLocalName uniq fs = Local uniq (varOcc fs) True + +mkTopName :: Unique -> Module -> FAST_STRING -> Name + -- Make a top-level name; make it Global if top-level + -- things should be externally visible; Local otherwise + -- This chap is only used *after* the tidyCore phase + -- Notably, it is used during STG lambda lifting + -- + -- We have to make sure that the name is globally unique + -- and we don't have tidyCore to help us. So we append + -- the unique. Hack! Hack! +mkTopName uniq mod fs + | all_toplev_ids_visible = Global uniq mod occ (LocalDef noSrcLoc NotExported) + | otherwise = Local uniq occ False + where + occ = varOcc (_PK_ ((_UNPK_ fs) ++ show uniq)) -mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name -mkWiredInIdName uniq mod occ id - = Global uniq mod (VarOcc occ) (WiredInId id) +mkWiredInIdName :: Unique -> Module -> OccName -> Id -> Name +mkWiredInIdName uniq mod occ id = Global uniq mod occ (WiredInId id) +-- mkWiredInTyConName takes a FAST_STRING instead of +-- an OccName, which is a bit yukky but that's what the +-- clients find easiest. mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name mkWiredInTyConName uniq mod occ tycon - = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) - - -mkCompoundName :: (OccName -> OccName) - -> Unique -- New unique - -> Name -- Base name - -> Name -- Result is always a value name - -mkCompoundName f uniq (Global _ mod occ prov) - = Global uniq mod (f occ) prov - -mkCompoundName f uniq (Local _ (Just occ)) - = Local uniq (Just (f occ)) + = Global uniq mod (tcOcc occ) (WiredInTyCon tycon) -mkCompoundName f uniq (Local _ Nothing) - = Local uniq Nothing +mkDerivedName :: (OccName -> OccName) + -> Name -- Base name + -> Unique -- New unique + -> Name -- Result is always a value name -setNameProvenance :: Name -> Provenance -> Name - -- setNameProvenance used to only change the provenance of - -- Implicit-provenance things, but that gives bad error messages - -- for names defined twice in the same module, so I changed it to - -- set the provenance of *any* global (SLPJ Jun 97) -setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov -setNameProvenance other_name prov = other_name - -getNameProvenance :: Name -> Provenance -getNameProvenance (Global uniq mod occ prov) = prov -getNameProvenance (Local uniq occ) = LocalDef noSrcLoc NotExported +mkDerivedName f (Global _ mod occ prov) uniq = Global uniq mod (f occ) prov +mkDerivedName f (Local _ occ sys) uniq = Local uniq (f occ) sys -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. -changeUnique (Local _ n ) u = Local u n -changeUnique (Global _ mod occ prov) u = Global u mod occ prov +setNameUnique (Local _ occ sys) u = Local u occ sys +setNameUnique (Global _ mod occ prov) u = Global u mod occ prov + +setNameOcc :: Name -> OccName -> Name + -- Give the thing a new OccName, *and* + -- record that it's no longer a sys-local + -- This is used by the tidy-up pass +setNameOcc (Global uniq mod _ prov) occ = Global uniq mod occ prov +setNameOcc (Local uniq _ sys) occ = Local uniq occ False \end{code} -setNameVisibility is applied to names in the final program -The Maybe Module argument is (Just mod) for top-level values, -and Nothing for all others (local values and type variables) +%************************************************************************ +%* * +\subsection{Setting provenance and visibility +%* * +%************************************************************************ + +tidyTopName is applied to top-level names in the final program For top-level things, it globalises Local names (if all top-level things should be visible) and localises non-exported Global names (if only exported things should be visible) -For nested things it localises Global names. - In all cases except an exported global, it gives it a new occurrence name. The "visibility" here concerns whether the .o file's symbol table @@ -384,41 +197,126 @@ are exported. But also: top-level defns externally visible \begin{code} -setNameVisibility :: Maybe Module -> Unique -> Name -> Name +tidyTopName :: Module -> TidyOccEnv -> Name -> (TidyOccEnv, Name) +tidyTopName mod env name + | isExported name = (env, name) -- Don't fiddle with an exported name + -- It should be in the TidyOccEnv already + | otherwise = (env', name') + where + prov = getNameProvenance name + uniq = nameUnique name + (env', occ') = tidyOccName env (nameOccName name) -setNameVisibility maybe_mod uniq name@(Global _ mod occ (LocalDef loc NotExported)) - | not all_toplev_ids_visible || not_top_level maybe_mod - = Local uniq Nothing -- Localise Global name + name' | all_toplev_ids_visible = Global uniq mod occ' prov + | otherwise = Local uniq occ' False -setNameVisibility maybe_mod uniq name@(Global _ _ _ _) - = name -- Otherwise don't fiddle with Global +all_toplev_ids_visible = + not opt_OmitInterfacePragmas || -- Pragmas can make them visible + opt_EnsureSplittableC -- Splitting requires visiblilty +\end{code} -setNameVisibility (Just mod) uniq (Local _ _) - | all_toplev_ids_visible - = Global uniq mod -- Globalise Local name - (uniqToOccName uniq) - (LocalDef noSrcLoc NotExported) +\begin{code} +setNameProvenance :: Name -> Provenance -> Name + -- setNameProvenance used to only change the provenance of + -- Implicit-provenance things, but that gives bad error messages + -- for names defined twice in the same module, so I changed it to + -- set the provenance of *any* global (SLPJ Jun 97) +setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov +setNameProvenance other_name prov = other_name -setNameVisibility maybe_mod uniq (Local _ _) - = Local uniq Nothing -- New unique for Local; zap its occ +getNameProvenance :: Name -> Provenance +getNameProvenance (Global uniq mod occ prov) = prov +getNameProvenance (Local _ _ _) = LocalDef noSrcLoc NotExported +\end{code} +\begin{code} -- make the Name globally visible regardless. mkNameVisible :: Module -> Unique -> Name -> Name mkNameVisible mod occ_uniq nm@(Global _ _ _ _) = nm -mkNameVisible mod occ_uniq nm@(Local uniq occ) - = Global uniq mod (uniqToOccName occ_uniq) (LocalDef noSrcLoc Exported) +mkNameVisible mod occ_uniq nm@(Local uniq occ _) + = Global uniq mod occ (LocalDef noSrcLoc Exported) +\end{code} -uniqToOccName uniq = VarOcc (_PK_ ('_':show uniq)) - -- The "_" is to make sure that this OccName is distinct from all user-defined ones -not_top_level (Just m) = False -not_top_level Nothing = True +%************************************************************************ +%* * +\subsection{Provenance and export info} +%* * +%************************************************************************ -all_toplev_ids_visible = - not opt_OmitInterfacePragmas || -- Pragmas can make them visible - opt_EnsureSplittableC -- Splitting requires visiblilty +\begin{code} +data Provenance + = NoProvenance + + | LocalDef -- Defined locally + SrcLoc -- Defn site + ExportFlag -- Whether it's exported + + | NonLocalDef -- Defined non-locally + ImportReason + IfaceFlavour -- Whether the defn site is an .hi-boot file + PrintUnqualified + + | WiredInTyCon TyCon -- There's a wired-in version + | WiredInId Id -- ...ditto... + +data ImportReason + = UserImport Module SrcLoc Bool -- Imported from module M on line L + -- Note the M may well not be the defining module + -- for this thing! + -- The Bool is true iff the thing was named *explicitly* in the import spec, + -- rather than being imported as part of a group; e.g. + -- import B + -- import C( T(..) ) + -- Here, everything imported by B, and the constructors of T + -- are not named explicitly; only T is named explicitly. + -- This info is used when warning of unused names. + + | ImplicitImport -- Imported implicitly for some other reason + + +type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is + -- in scope in this module, so print it + -- unqualified in error messages + +data ExportFlag = Exported | NotExported +\end{code} + +Something is "Exported" if it may be mentioned by another module without +warning. The crucial thing about Exported things is that they must +never be dropped as dead code, even if they aren't used in this module. +Furthermore, being Exported means that we can't see all call sites of the thing. + +Exported things include: + + - explicitly exported Ids, including data constructors, + class method selectors + + - dfuns from instance decls + +Being Exported is *not* the same as finally appearing in the .o file's +symbol table. For example, a local Id may be mentioned in an Exported +Id's unfolding in the interface file, in which case the local Id goes +out too. + + +\begin{code} +-- pprNameProvenance is used in error messages to say where a name came from +pprNameProvenance :: Name -> SDoc +pprNameProvenance name = pprProvenance (getNameProvenance name) + +pprProvenance :: Provenance -> SDoc +pprProvenance NoProvenance = ptext SLIT("No provenance") +pprProvenance (LocalDef loc _) = ptext SLIT("defined at") <+> ppr loc +pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") +pprProvenance (WiredInId id) = ptext SLIT("Wired-in id") +pprProvenance (NonLocalDef ImplicitImport _ _) + = ptext SLIT("implicitly imported") +pprProvenance (NonLocalDef (UserImport mod loc _) _ _) + = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc \end{code} + %************************************************************************ %* * \subsection{Predicates and selectors} @@ -440,12 +338,11 @@ isExternallyVisibleName :: Name -> Bool -nameUnique (Local u _) = u +nameUnique (Local u _ _) = u nameUnique (Global u _ _ _) = u -nameOccName (Local _ (Just occ)) = occ -nameOccName (Local uniq Nothing) = pprPanic "nameOccName" (ppr uniq) -nameOccName (Global _ _ occ _) = occ +nameOccName (Local _ occ _) = occ +nameOccName (Global _ _ occ _) = occ nameModule (Global _ mod occ _) = mod @@ -454,14 +351,13 @@ nameModAndOcc (Global _ mod occ _) = (mod,occ) isExportedName (Global _ _ _ (LocalDef _ Exported)) = True isExportedName other = False -nameSrcLoc (Local _ _) = noSrcLoc -nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc -nameSrcLoc (Global _ _ _ (NonLocalDef loc _ _)) = loc -nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc -nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc -nameSrcLoc other = noSrcLoc +nameSrcLoc (Global _ _ _ (LocalDef loc _)) = loc +nameSrcLoc (Global _ _ _ (NonLocalDef (UserImport _ loc _) _ _)) = loc +nameSrcLoc (Global _ _ _ (WiredInTyCon _)) = mkBuiltinSrcLoc +nameSrcLoc (Global _ _ _ (WiredInId _)) = mkBuiltinSrcLoc +nameSrcLoc other = noSrcLoc -isLocallyDefinedName (Local _ _) = True +isLocallyDefinedName (Local _ _ _) = True isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True isLocallyDefinedName other = False @@ -482,11 +378,11 @@ maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc)) = Just tc maybeWiredInTyConName other = Nothing -isLocalName (Local _ _) = True -isLocalName _ = False +isLocalName (Local _ _ _) = True +isLocalName _ = False -isSysLocalName (Local _ Nothing) = True -isSysLocalName other = False +isSysLocalName (Local _ _ sys) = sys +isSysLocalName other = False isGlobalName (Global _ _ _ _) = True isGlobalName other = False @@ -507,10 +403,10 @@ isExternallyVisibleName name = isGlobalName name \begin{code} cmpName n1 n2 = c n1 n2 where - c (Local u1 _) (Local u2 _) = compare u1 u2 - c (Local _ _) _ = LT + c (Local u1 _ _) (Local u2 _ _) = compare u1 u2 + c (Local _ _ _) _ = LT c (Global u1 _ _ _) (Global u2 _ _ _) = compare u1 u2 - c (Global _ _ _ _) _ = GT + c (Global _ _ _ _) _ = GT \end{code} \begin{code} @@ -535,103 +431,6 @@ instance NamedThing Name where %************************************************************************ %* * -\subsection[Special-Names]{Special Kinds of names} -%* * -%************************************************************************ - -Here's our convention for splitting up the object file name space: - - _d... dictionary identifiers - _g... externally visible (non-user visible) names - - _m... default methods - _n... default methods (encoded symbols, eg. <= becomes _nle) - - _p... superclass selectors - - _w... workers - _v... workers (encoded symbols) - - _x... local variables - - _u... user-defined names that previously began with '_' - - _[A-Z]... compiler-generated tycons/datacons (namely dictionary - constructors) - - __.... keywords (__export, __letrec etc.) - -This knowledge is encoded in the following functions. - -\begin{code} -dictNamePrefix :: FAST_STRING -dictNamePrefix = SLIT("_d") - -mkSuperDictSelName :: Int -> OccName -> OccName -mkSuperDictSelName index = prefixOccName (_PK_ ("_p" ++ show index ++ "_")) - -mkWorkerName :: OccName -> OccName -mkWorkerName nm - | isLexSym nm_str = - prefixOccName SLIT("_v") (mapOccName trName nm) - | otherwise = - prefixOccName SLIT("_w") nm - where nm_str = occNameString nm - -mkDefaultMethodName :: OccName -> OccName -mkDefaultMethodName nm - | isLexSym nm_str = - prefixOccName SLIT("_n") (mapOccName trName nm) - | otherwise = - prefixOccName SLIT("_m") nm - where nm_str = occNameString nm - --- not used yet: ---mkRecordSelectorName :: Name -> Name ---mkMethodSelectorName :: Name -> Name - -mkClassTyConStr, mkClassDataConStr :: FAST_STRING -> FAST_STRING - -mkClassTyConStr s = SLIT("_") _APPEND_ s -mkClassDataConStr s = SLIT("_") _APPEND_ s - --- translate a string such that it can occur as *part* of an identifer. This --- is used when we prefix identifiers to create new names, for example the --- name of a default method. - -trName :: FAST_STRING -> FAST_STRING -trName nm = _PK_ (foldr tran "" (_UNPK_ nm)) - where - tran c cs = case trChar c of - '\0' -> '_' : show (ord c) ++ cs - c' -> c' : cs - trChar '&' = 'a' - trChar '|' = 'b' - trChar ':' = 'c' - trChar '/' = 'd' - trChar '=' = 'e' - trChar '>' = 'g' - trChar '#' = 'h' - trChar '@' = 'i' - trChar '<' = 'l' - trChar '-' = 'm' - trChar '!' = 'n' - trChar '+' = 'p' - trChar '\'' = 'q' - trChar '$' = 'r' - trChar '?' = 's' - trChar '*' = 't' - trChar '_' = 'u' - trChar '.' = 'v' - trChar '\\' = 'w' - trChar '%' = 'x' - trChar '~' = 'y' - trChar '^' = 'z' - trChar _ = '\0' -\end{code} - -%************************************************************************ -%* * \subsection{Pretty printing} %* * %************************************************************************ @@ -641,76 +440,62 @@ instance Outputable Name where -- When printing interfaces, all Locals have been given nice print-names ppr name = pprName name -pprName name +pprName (Local uniq occ sys_local) = getPprStyle $ \ sty -> - let - -- when printing local names for interface files, prepend the '_' - -- to avoid clashes with user-defined names. In fact, these names - -- will always begin with 'g' for top-level ids and 'x' otherwise, - -- because these are the unique supplies going into the tidy phase. - ppr (Local u n) | codeStyle sty = pprUnique u - | ifaceStyle sty = char '_' <> pprUnique u - - ppr (Local u Nothing) = pprUnique u - ppr (Local u (Just occ)) | userStyle sty = ptext (occNameString occ) - | otherwise = ptext (occNameString occ) <> char '_' <> pprUnique u - - ppr name@(Global u m n prov) - | codeStyle sty - = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) - - | otherwise - = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name] - where - pp_mod_dot - = case prov of -- Omit home module qualifier if in scope - LocalDef _ _ -> pp_qual dot (user_sty || iface_sty) - NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty) - -- Hack: omit qualifers on wired in things - -- in user style only - WiredInTyCon _ -> pp_qual dot user_sty - WiredInId _ -> pp_qual dot user_sty - NoProvenance -> pp_qual dot False - - pp_qual sep omit_qual - | omit_qual = empty - | otherwise = pprModule m <> sep - - dot = text "." - pp_hif HiFile = dot -- Vanilla case - pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface - - user_sty = userStyle sty - iface_sty = ifaceStyle sty - in - ppr name - - -pp_debug sty (Global uniq m n prov) - | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p, text "-}"] - | otherwise = empty - where - prov_p | opt_PprStyle_NoPrags = empty - | otherwise = comma <> pp_prov prov - -pp_prov (LocalDef _ Exported) = char 'x' -pp_prov (LocalDef _ NotExported) = char 'l' -pp_prov (NonLocalDef _ _ _) = char 'n' -pp_prov (WiredInTyCon _) = char 'W' -pp_prov (WiredInId _) = char 'w' -pp_prov NoProvenance = char '?' + if codeStyle sty then + pprUnique uniq -- When printing in code we required all names to + -- be globally unique; for example, we use this identifier + -- for the closure name. So we just print the unique alone. + else + pprOccName occ <> pp_local_extra sty uniq + where + pp_local_extra sty uniq + | sys_local = underscore <> pprUnique uniq -- Must print uniques for sys_locals + | debugStyle sty = text "{-" <> pprUnique uniq <> text "-}" + | otherwise = empty --- pprNameProvenance is used in error messages to say where a name came from -pprNameProvenance :: Name -> SDoc -pprNameProvenance (Local _ _) = pprProvenance (LocalDef noSrcLoc NotExported) -pprNameProvenance (Global _ _ _ prov) = pprProvenance prov -pprProvenance :: Provenance -> SDoc -pprProvenance (LocalDef loc _) = ptext SLIT("Locally defined at") <+> ppr loc -pprProvenance (NonLocalDef loc _ _) = ptext SLIT("Non-locally defined at") <+> ppr loc -pprProvenance (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") -pprProvenance (WiredInId id) = ptext SLIT("Wired-in id") -pprProvenance NoProvenance = ptext SLIT("No provenance") +pprName (Global uniq mod occ prov) + = getPprStyle $ \ sty -> + if codeStyle sty then + ppr mod <> underscore <> ppr occ + else + pp_mod_dot sty <> ppr occ <> pp_global_debug sty uniq prov + where + pp_mod_dot sty + = case prov of -- Omit home module qualifier if in scope + LocalDef _ _ -> pp_qual dot (user_sty || iface_sty) + NonLocalDef _ hif omit -> pp_qual (pp_hif hif) (omit && user_sty) + -- Hack: omit qualifers on wired in things + -- in user style only + WiredInTyCon _ -> pp_qual dot user_sty + WiredInId _ -> pp_qual dot user_sty + NoProvenance -> pp_qual dot False + where + user_sty = userStyle sty + iface_sty = ifaceStyle sty + + pp_qual sep omit_qual + | omit_qual = empty + | otherwise = pprModule mod <> sep + + pp_hif HiFile = dot -- Vanilla case + pp_hif HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface + + pp_global_debug sty uniq prov + | debugStyle sty = hcat [text "{-", pprUnique uniq, prov_p prov, text "-}"] + | otherwise = empty + + prov_p prov | opt_PprStyle_NoPrags = empty + | otherwise = comma <> pp_prov prov + +pp_prov (LocalDef _ Exported) = char 'x' +pp_prov (LocalDef _ NotExported) = char 'l' +pp_prov (NonLocalDef ImplicitImport _ _) = char 'i' +pp_prov (NonLocalDef explicitimport _ _) = char 'I' +pp_prov (WiredInTyCon _) = char 'W' +pp_prov (WiredInId _) = char 'w' +pp_prov NoProvenance = char '?' \end{code} @@ -739,11 +524,9 @@ modAndOcc = nameModAndOcc . getName isExported = isExportedName . getName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName -getOccString x = _UNPK_ (occNameString (getOccName x)) +getOccString x = occNameString (getOccName x) \end{code} \begin{code} -{-# SPECIALIZE isLocallyDefined - :: Name -> Bool - #-} +{-# SPECIALIZE isLocallyDefined :: Name -> Bool #-} \end{code} diff --git a/ghc/compiler/basicTypes/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index 0e2b137546..0f857db309 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -8,7 +8,8 @@ module NameSet ( -- Sets of Names NameSet, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, - minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet, + minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, + delFromNameSet, delListFromNameSet, isEmptyNameSet, ) where #include "HsVersions.h" @@ -26,17 +27,19 @@ import UniqSet \begin{code} type NameSet = UniqSet Name -emptyNameSet :: NameSet -unitNameSet :: Name -> NameSet -addListToNameSet :: NameSet -> [Name] -> NameSet -addOneToNameSet :: NameSet -> Name -> NameSet -mkNameSet :: [Name] -> NameSet -unionNameSets :: NameSet -> NameSet -> NameSet -unionManyNameSets :: [NameSet] -> NameSet -minusNameSet :: NameSet -> NameSet -> NameSet -elemNameSet :: Name -> NameSet -> Bool -nameSetToList :: NameSet -> [Name] -isEmptyNameSet :: NameSet -> Bool +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +addListToNameSet :: NameSet -> [Name] -> NameSet +addOneToNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSets :: NameSet -> NameSet -> NameSet +unionManyNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +nameSetToList :: NameSet -> [Name] +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet isEmptyNameSet = isEmptyUniqSet emptyNameSet = emptyUniqSet @@ -49,6 +52,9 @@ unionManyNameSets = unionManyUniqSets minusNameSet = minusUniqSet elemNameSet = elementOfUniqSet nameSetToList = uniqSetToList +delFromNameSet = delOneFromUniqSet + +delListFromNameSet set ns = foldl delFromNameSet set ns \end{code} diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs new file mode 100644 index 0000000000..11244fbbf7 --- /dev/null +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -0,0 +1,594 @@ + +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +\section[OccName]{@OccName@} + +\begin{code} +module OccName ( + -- Modules + Module, -- Abstract, instance of Outputable + mkModule, mkModuleFS, moduleString, moduleCString, pprModule, + + -- The OccName type + OccName, -- Abstract, instance of Outputable + varOcc, tcOcc, tvOcc, -- Occ constructors + srcVarOcc, srcTCOcc, srcTvOcc, -- For Occs arising from source code + + mkSuperDictSelOcc, mkDFunOcc, + mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkClassTyConOcc, mkClassDataConOcc, + + isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc, + pprOccName, occNameString, occNameFlavour, + + -- The basic form of names + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + isLowerISO, isUpperISO, + + -- Tidying up + TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, + + -- Junk + identToC + + ) where + +#include "HsVersions.h" + +import Char ( isAlpha, isUpper, isLower, isAlphanum, ord ) +import Util ( thenCmp ) +import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, elemFM ) +import Outputable +import GlaExts +\end{code} + + +%************************************************************************ +%* * +\subsection[Module]{The name of a module} +%* * +%************************************************************************ + +\begin{code} +data Module = Module FAST_STRING -- User and interface files + FAST_STRING -- Print this in C files + + -- The C version has quote chars Z-encoded + +instance Outputable Module where + ppr = pprModule + +instance Eq Module where + (Module m1 _) == (Module m2 _) = m1 == m2 + +instance Ord Module where + (Module m1 _) `compare` (Module m2 _) = m1 `compare` m2 + +pprModule :: Module -> SDoc +pprModule (Module real code) + = getPprStyle $ \ sty -> + if codeStyle sty then + ptext code + else + ptext real + +mkModule :: String -> Module +mkModule s = Module (_PK_ s) (identToC s) + +mkModuleFS :: FAST_STRING -> Module +mkModuleFS s = Module s (identFsToC s) + +moduleString :: Module -> String +moduleString (Module mod _) = _UNPK_ mod + +moduleCString :: Module -> String +moduleCString (Module _ code) = _UNPK_ code +\end{code} + + +%************************************************************************ +%* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +%* * +%************************************************************************ + +\begin{code} +data OccName = OccName + OccSpace + FAST_STRING -- The 'real name' + FAST_STRING -- Print this in interface files + FAST_STRING -- Print this in C/asm code + +-- The OccSpace/real-name pair define the OccName +-- The iface and c/asm versions are simply derived from the +-- other two. They are cached here simply to avoid recomputing +-- them repeatedly when printing + +-- The latter two are irrelevant in RdrNames; on the other hand, +-- the OccSpace field is irrelevant after RdrNames. +-- So the OccName type might be refined a bit. +-- It is now abstract so that's easier than before + + +-- Why three print-names? +-- Real Iface C +-- --------------------- +-- foo foo foo +-- +-- + + Zp Operators OK in interface files; +-- 'Z' is the escape char for C names +-- +-- x# x# xZh Trailing # lexed ok by GHC -fglasgow-exts +-- +-- _foo _ufoo _ufoo Leading '_' is the escape char in interface files +-- +-- _vfoo _vfoo _vfoo Worker for foo +-- +-- _wp _wp _wp Worker for + + + +data OccSpace = VarOcc -- Variables and data constructors + | TvOcc -- Type variables + | TCOcc -- Type constructors and classes + deriving( Eq, Ord ) +\end{code} + + +%************************************************************************ +%* * +\subsection{Printing} +%* * +%************************************************************************ + +\begin{code} +instance Outputable OccName where + ppr = pprOccName + +pprOccName :: OccName -> SDoc +pprOccName (OccName space real iface code) + = getPprStyle $ \ sty -> + if codeStyle sty then + ptext code + else if ifaceStyle sty then + ptext iface + else + ptext real +\end{code} + + +%************************************************************************ +%* * +\subsection{Construction} +%* * +%************************************************************************ + +*Source-code* things beginning with '_' are zapped to begin with '_u' + +\begin{code} +mkSrcOcc :: OccSpace -> FAST_STRING -> OccName +mkSrcOcc occ_sp real + = case _UNPK_ real of + + '_' : rest -> OccName occ_sp real (_PK_ zapped_str) (identToC zapped_str) + where + zapped_str = '_' : 'u' : rest + + other -> OccName occ_sp real real (identFsToC real) + +srcVarOcc, srcTCOcc, srcTvOcc :: FAST_STRING -> OccName +srcVarOcc = mkSrcOcc VarOcc +srcTCOcc = mkSrcOcc TCOcc +srcTvOcc = mkSrcOcc TvOcc +\end{code} + +However, things that don't come from Haskell source code aren't +treated specially. + +\begin{code} +mkOcc :: OccSpace -> String -> OccName +mkOcc occ_sp str = OccName occ_sp fs fs (identToC str) + where + fs = _PK_ str + +mkFsOcc :: OccSpace -> FAST_STRING -> OccName +mkFsOcc occ_sp real = OccName occ_sp real real (identFsToC real) + +varOcc, tcOcc, tvOcc :: FAST_STRING -> OccName +varOcc = mkFsOcc VarOcc +tcOcc = mkFsOcc TCOcc +tvOcc = mkFsOcc TvOcc +\end{code} + + +%************************************************************************ +%* * +\subsection{Making system names} +%* * +%************************************************************************ + +Here's our convention for splitting up the interface file name space: + + _d... dictionary identifiers + + _f... dict-fun identifiers (from inst decls) + _g... ditto, when the tycon has symbols + + _t... externally visible (non-user visible) names + + _m... default methods + _n... default methods (encoded symbols, eg. <= becomes _nle) + + _p... superclass selectors + + _v... workers + _w... workers (encoded symbols) + + _x... local variables + + _u... user-defined names that previously began with '_' + + _T... compiler-generated tycons for dictionaries + _D.. ...ditto data cons + + __.... keywords (__export, __letrec etc.) + +This knowledge is encoded in the following functions. + + + + +@mkDerivedOcc@ generates an @OccName@ from an existing @OccName@; + eg: workers, derived methods + +We pass a character to use as the prefix. So, for example, + "f" gets derived to "_vf", if the prefix char is 'v' + +\begin{code} +mk_deriv :: OccSpace -> Char -> String -> OccName +mk_deriv occ_sp sys_ch str = mkOcc occ_sp ('_' : sys_ch : str) +\end{code} + +Things are a bit more complicated if the thing is an operator; then +we must encode it into a normal identifier first. We do this in +a simple way, and use a different character prefix (one after the one +suggested). For example + "<" gets derived to "_wl", if the prefix char is 'v' + +\begin{code} +mk_enc_deriv :: OccSpace + -> Char -- The system-name-space character (see list above) + -> OccName -- The OccName from which we are deriving + -> OccName + +mk_enc_deriv occ_sp sys_ch occ + | needs_encoding real_str = mk_deriv occ_sp sys_op_ch (encode_operator real_str) + | otherwise = mk_deriv occ_sp sys_ch real_str + where + real_str = occNameString occ + sys_op_ch = succ sys_ch + + +mkDictOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkClassTyConOcc, mkClassDataConOcc + :: OccName -> OccName + +mkWorkerOcc = mk_enc_deriv VarOcc 'v' -- v,w +mkDefaultMethodOcc = mk_enc_deriv VarOcc 'm' -- m,n +mkClassTyConOcc = mk_enc_deriv TCOcc 'T' -- not U +mkClassDataConOcc = mk_enc_deriv VarOcc 'D' -- not E +mkDictOcc = mk_enc_deriv VarOcc 'd' -- not e +\end{code} + +\begin{code} +mkSuperDictSelOcc :: Int -- Index of superclass, eg 3 + -> OccName -- Class, eg "Ord" + -> OccName -- eg "p3Ord" +mkSuperDictSelOcc index cls_occ + = mk_deriv VarOcc 'p' (show index ++ occNameString cls_occ) +\end{code} + + +\begin{code} +mkDFunOcc :: OccName -- class, eg "Ord" + -> OccName -- tycon (or something convenient from the instance type) + -- eg "Maybe" + -> Int -- Unique to distinguish dfuns which share the previous two + -- eg 3 + -> OccName -- "dOrdMaybe3" + +mkDFunOcc cls_occ tycon_occ index + | needs_encoding tycon_str -- Drat! Have to encode the tycon + = mk_deriv VarOcc 'g' (show_index ++ cls_str ++ encode_operator tycon_str) + | otherwise -- Normal case + = mk_deriv VarOcc 'f' (show_index ++ cls_str ++ tycon_str) + where + cls_str = occNameString cls_occ + tycon_str = occNameString tycon_occ + -- NB: if a non-operator the tycon has a trailing # we don't encode. + show_index | index == 0 = "" + | otherwise = show index +\end{code} + + +%************************************************************************ +%* * +\subsection{Lexical categories} +%* * +%************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +\begin{code} +isLexCon, isLexVar, isLexId, isLexSym :: FAST_STRING -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- + +isLexConId cs -- Prefix type or data constructors + | _NULL_ cs = False -- e.g. "Foo", "[]", "(,)" + | cs == SLIT("[]") = True + | c == '(' = True -- (), (,), (,,), ... + | otherwise = isUpper c || isUpperISO c + where + c = _HEAD_ cs + +isLexVarId cs -- Ordinary prefix identifiers + | _NULL_ cs = False -- e.g. "x", "_x" + | otherwise = isLower c || isLowerISO c || c == '_' + where + c = _HEAD_ cs + +isLexConSym cs -- Infix type or data constructors + | _NULL_ cs = False -- e.g. ":-:", ":", "->" + | otherwise = c == ':' + || cs == SLIT("->") + where + c = _HEAD_ cs + +isLexVarSym cs -- Infix identifiers + | _NULL_ cs = False -- e.g. "+" + | otherwise = isSymbolASCII c + || isSymbolISO c + where + c = _HEAD_ cs + +------------- +isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" +isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) +isUpperISO (C# c#) = c# `geChar#` '\xc0'# && c# `leChar#` '\xde'# && c# `neChar#` '\xd7'# + --0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c +isLowerISO (C# c#) = c# `geChar#` '\xdf'# && c# `leChar#` '\xff'# && c# `neChar#` '\xf7'# + --0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +\end{code} + +%************************************************************************ +%* * +\subsection{Predicates and taking them apart} +%* * +%************************************************************************ + +\begin{code} +occNameString :: OccName -> String +occNameString (OccName _ s _ _) = _UNPK_ s + +-- occNameFlavour is used only to generate good error messages, so it doesn't matter +-- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for +-- data constructors and values, but that makes everything else a bit more complicated. +occNameFlavour :: OccName -> String +occNameFlavour (OccName VarOcc s _ _) | isLexConId s = "Data constructor" + | otherwise = "Value" +occNameFlavour (OccName TvOcc _ _ _) = "Type variable" +occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class" + +isVarOcc, isTCOcc, isTvOcc, + isConSymOcc, isSymOcc :: OccName -> Bool + +isVarOcc (OccName VarOcc _ _ _) = True +isVarOcc other = False + +isTvOcc (OccName TvOcc _ _ _) = True +isTvOcc other = False + +isTCOcc (OccName TCOcc _ _ _) = True +isTCOcc other = False + +isConSymOcc (OccName _ s _ _) = isLexConSym s + +isSymOcc (OccName _ s _ _) = isLexSym s + +isConOcc (OccName _ s _ _) = isLexCon s +\end{code} + + +%************************************************************************ +%* * +\subsection{Comparison} +%* * +%************************************************************************ + +Comparison is done by space and 'real' name + +\begin{code} +instance Eq OccName where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord OccName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + compare (OccName sp1 r1 _ _) (OccName sp2 r2 _ _) + = (sp1 `compare` sp2) `thenCmp` (r1 `compare` r2) +\end{code} + + +%************************************************************************ +%* * +\subsection{Tidying them up} +%* * +%************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +\begin{code} +type TidyOccEnv = FiniteMap FAST_STRING Int -- The in-scope OccNames +emptyTidyOccEnv = emptyFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOccEnv + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) + +tidyOccName in_scope occ@(OccName occ_sp real _ _) + | not (real `elemFM` in_scope) + = (addToFM in_scope real 1, occ) -- First occurrence + + | otherwise -- Already occurs + = -- First encode, to deal with + -- a) operators, and + -- b) trailing # signs + -- so that we can then append '1', '2', etc + go in_scope (encode_operator (_UNPK_ real)) + where + + go in_scope str = case lookupFM in_scope pk_str of + Just n -> go (addToFM in_scope pk_str (n+1)) (str ++ show n) + -- Need to go round again, just in case "t3" (say) + -- clashes with a "t3" that's already in scope + + Nothing -> (addToFM in_scope pk_str 1, mkFsOcc occ_sp pk_str) + -- str is now unique + where + pk_str = _PK_ str +\end{code} + + +%************************************************************************ +%* * +\subsection{Encoding for operators in derived names} +%* * +%************************************************************************ + +See comments with mk_enc_deriv + +\begin{code} +needs_encoding :: String -> Bool -- Needs encoding when embedded in a derived name + -- Just look at the first character +needs_encoding (c:cs) = not (isAlpha c || c == '_') + +encode_operator :: String -> String +encode_operator nm = foldr tran "" nm + where + tran c cs = case trChar c of + '\0' -> '_' : show (ord c) ++ cs -- No translation + tr_c -> tr_c : cs + + trChar '&' = 'a' + trChar '|' = 'b' + trChar ':' = 'c' + trChar '/' = 'd' + trChar '=' = 'e' + trChar '>' = 'g' + trChar '#' = 'h' + trChar '@' = 'i' + trChar '<' = 'l' + trChar '-' = 'm' + trChar '!' = 'n' + trChar '+' = 'p' + trChar '\'' = 'q' + trChar '$' = 'r' + trChar '?' = 's' + trChar '*' = 't' + trChar '_' = 'u' + trChar '.' = 'v' + trChar '\\' = 'w' + trChar '%' = 'x' + trChar '~' = 'y' + trChar '^' = 'z' + trChar _ = '\0' -- No translation +\end{code} + + +%************************************************************************ +%* * +\subsection{The 'Z' encoding} +%* * +%************************************************************************ + +We provide two interfaces for efficiency. + +\begin{code} +identToC :: String -> FAST_STRING +identToC str + | all isAlphanum str && not std = _PK_ str + | std = _PK_ ("Zs" ++ encode str) + | otherwise = _PK_ (encode str) + where + std = has_std_prefix str + +identFsToC :: FAST_STRING -> FAST_STRING +identFsToC fast_str + | all isAlphanum str && not std = fast_str + | std = _PK_ ("Zs" ++ encode str) + | otherwise = _PK_ (encode str) + where + std = has_std_prefix str + str = _UNPK_ fast_str + +-- avoid "stdin", "stdout", and "stderr"... +has_std_prefix ('s':'t':'d':_) = True +has_std_prefix _ = False + +encode :: String -> String +encode [] = [] +encode (c:cs) = encode_ch c ++ encode cs + +encode_ch :: Char -> String +encode_ch c | isAlphanum c = [c] + -- Common case first +encode_ch 'Z' = "ZZ" +encode_ch '&' = "Za" +encode_ch '|' = "Zb" +encode_ch ':' = "Zc" +encode_ch '/' = "Zd" +encode_ch '=' = "Ze" +encode_ch '>' = "Zg" +encode_ch '#' = "Zh" +encode_ch '<' = "Zl" +encode_ch '-' = "Zm" +encode_ch '!' = "Zn" +encode_ch '.' = "Zd" +encode_ch '\'' = "Zq" +encode_ch '*' = "Zt" +encode_ch '+' = "Zp" +encode_ch '_' = "_" +encode_ch c = 'Z':show (ord c) +\end{code} + +For \tr{modnameToC}, we really only have to worry about \tr{'}s +(quote chars) in the name. Rare. + +\begin{code} +modnameToC :: FAST_STRING -> FAST_STRING +modnameToC fast_str = identFsToC fast_str +\end{code} diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index 4e502e05cc..ed06d2ce15 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -18,9 +18,9 @@ module PprEnv ( import {-# SOURCE #-} Const ( Con ) -import Var ( GenId, GenTyVar ) +import Var ( Id, TyVar ) import CostCentre ( CostCentre ) -import Type ( GenType ) +import Type ( Type ) import Outputable \end{code} @@ -31,16 +31,16 @@ import Outputable %************************************************************************ \begin{code} -data PprEnv bndr flexi +data PprEnv bndr = PE { pCon :: Con -> SDoc, pSCC :: CostCentre -> SDoc, - pTyVarO :: GenTyVar flexi -> SDoc, -- to print tyvar occurrences - pTy :: GenType flexi -> SDoc, -- to print types + pTyVarO :: TyVar -> SDoc, -- to print tyvar occurrences + pTy :: Type -> SDoc, -- to print types pBndr :: BindingSite -> bndr -> SDoc, -- to print value binders - pOcc :: GenId flexi -> SDoc -- to print value occurrences + pOcc :: Id -> SDoc -- to print value occurrences } \end{code} @@ -55,11 +55,11 @@ data BindingSite = LambdaBind | CaseBind | LetBind initPprEnv :: Maybe (Con -> SDoc) -> Maybe (CostCentre -> SDoc) - -> Maybe (GenTyVar flexi -> SDoc) - -> Maybe (GenType flexi -> SDoc) + -> Maybe (TyVar -> SDoc) + -> Maybe (Type -> SDoc) -> Maybe (BindingSite -> bndr -> SDoc) - -> Maybe (GenId flexi -> SDoc) - -> PprEnv bndr flexi + -> Maybe (Id -> SDoc) + -> PprEnv bndr -- you can specify all the printers individually; if -- you don't specify one, you get bottom diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 1ae2133430..4b8a7564f7 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -23,7 +23,7 @@ module UniqSupply ( #include "HsVersions.h" import Unique -import Util +import Panic ( panic ) import GlaExts diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 1c0dda9bd4..d91bf45e56 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -51,7 +51,7 @@ module Unique ( augmentIdKey, boolTyConKey, boundedClassKey, - boxedKindConKey, + boxedConKey, buildIdKey, byteArrayPrimTyConKey, cCallableClassKey, @@ -129,7 +129,7 @@ module Unique ( noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, numClassKey, - openKindConKey, + anyBoxConKey, ordClassKey, orderingTyConKey, otherwiseIdKey, @@ -160,14 +160,16 @@ module Unique ( stateTyConKey, statePrimTyConKey, - superKindConKey, + typeConKey, + kindConKey, + boxityConKey, mVarPrimTyConKey, thenMClassOpKey, threadIdPrimTyConKey, toEnumClassOpKey, traceIdKey, trueDataConKey, - unboxedKindConKey, + unboxedConKey, unpackCString2IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, @@ -200,13 +202,12 @@ module Unique ( #include "HsVersions.h" -import FastString ( uniqueOfFS ) +import FastString ( FastString, uniqueOfFS ) import GlaExts import ST import PrelBase ( Char(..), chr, ord ) import Outputable -import Util \end{code} %************************************************************************ @@ -534,12 +535,13 @@ word32TyConKey = mkPreludeTyConUnique 61 word64PrimTyConKey = mkPreludeTyConUnique 62 word64TyConKey = mkPreludeTyConUnique 63 voidTyConKey = mkPreludeTyConUnique 64 -boxedKindConKey = mkPreludeTyConUnique 65 -unboxedKindConKey = mkPreludeTyConUnique 66 -openKindConKey = mkPreludeTyConUnique 67 -superKindConKey = mkPreludeTyConUnique 68 -threadIdPrimTyConKey = mkPreludeTyConUnique 69 - +boxedConKey = mkPreludeTyConUnique 65 +unboxedConKey = mkPreludeTyConUnique 66 +anyBoxConKey = mkPreludeTyConUnique 67 +kindConKey = mkPreludeTyConUnique 68 +boxityConKey = mkPreludeTyConUnique 69 +typeConKey = mkPreludeTyConUnique 70 +threadIdPrimTyConKey = mkPreludeTyConUnique 71 \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index fb760e6fca..6bf3a88b00 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -8,36 +8,39 @@ module Var ( Var, IdOrTyVar, -- Abstract VarDetails(..), -- Concrete varName, varUnique, varDetails, varInfo, varType, - setVarName, setVarUnique, setVarType, + setVarName, setVarUnique, setVarType, setVarOcc, -- TyVars - TyVar, GenTyVar, + TyVar, tyVarName, tyVarKind, - tyVarFlexi, setTyVarFlexi, removeTyVarFlexi, setTyVarName, setTyVarUnique, - mkFlexiTyVar, mkTyVar, mkSysTyVar, isTyVar, isFlexiTyVar, + setTyVarName, setTyVarUnique, + mkTyVar, mkSysTyVar, isTyVar, + newMutTyVar, readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable, -- Ids - Id, DictId, GenId, - idName, idType, idUnique, idInfo, modifyIdInfo, + Id, DictId, + idDetails, idName, idType, idUnique, idInfo, modifyIdInfo, setIdName, setIdUnique, setIdInfo, mkId, isId, externallyVisibleId ) where #include "HsVersions.h" -import {-# SOURCE #-} Type( GenType, Kind ) +import {-# SOURCE #-} Type( Type, Kind ) import {-# SOURCE #-} IdInfo( IdInfo ) import {-# SOURCE #-} Const( Con ) import FieldLabel ( FieldLabel ) import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) -import Name ( Name, NamedThing(..), - changeUnique, nameUnique, +import Name ( Name, OccName, NamedThing(..), + setNameUnique, setNameOcc, nameUnique, mkSysLocalName, isExternallyVisibleName ) import BasicTypes ( Unused ) import Outputable + +import IOExts ( IORef, newIORef, readIORef, writeIORef ) \end{code} @@ -55,46 +58,49 @@ strictness). The essential info about different kinds of @Vars@ is in its @VarDetails@. \begin{code} -type IdOrTyVar = Var Unused Unused +type IdOrTyVar = Var -data Var flex_self flex_ty +data Var = Var { varName :: Name, realUnique :: Int#, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed - varType :: GenType flex_ty, - varDetails :: VarDetails flex_self, + varType :: Type, + varDetails :: VarDetails, varInfo :: IdInfo -- Only used for Ids at the moment } -varUnique Var{realUnique = uniq} = mkUniqueGrimily uniq - -data VarDetails flex_self - = TyVar - | FlexiTyVar flex_self -- Used during unification - | VanillaId -- Most Ids are like this - | ConstantId Con -- The Id for a constant (data constructor or primop) - | RecordSelId FieldLabel -- The Id for a record selector +data VarDetails + = VanillaId -- Most Ids are like this + | ConstantId Con -- The Id for a constant (data constructor or primop) + | RecordSelId FieldLabel -- The Id for a record selector + | TyVar + | MutTyVar (IORef (Maybe Type)) -- Used during unification + +-- For a long time I tried to keep mutable Vars statically type-distinct +-- from immutable Vars, but I've finally given up. It's just too painful. +-- After type checking there are no MutTyVars left, but there's no static check +-- of that fact. \end{code} \begin{code} -instance Outputable (Var fs ft) where +instance Outputable Var where ppr var = ppr (varName var) -instance Show (Var fs ft) where +instance Show Var where showsPrec p var = showsPrecSDoc p (ppr var) -instance NamedThing (Var fs ft) where +instance NamedThing Var where getName = varName -instance Uniquable (Var fs ft) where +instance Uniquable Var where getUnique = varUnique -instance Eq (Var fs ft) where +instance Eq Var where a == b = realUnique a ==# realUnique b -instance Ord (Var fs ft) where +instance Ord Var where a <= b = realUnique a <=# realUnique b a < b = realUnique a <# realUnique b a >= b = realUnique a >=# realUnique b @@ -104,15 +110,22 @@ instance Ord (Var fs ft) where \begin{code} -setVarUnique :: Var fs ft -> Unique -> Var fs ft +varUnique :: Var -> Unique +varUnique (Var {realUnique = uniq}) = mkUniqueGrimily uniq + +setVarUnique :: Var -> Unique -> Var setVarUnique var uniq = var {realUnique = getKey uniq, - varName = changeUnique (varName var) uniq} + varName = setNameUnique (varName var) uniq} -setVarName :: Var fs ft -> Name -> Var fs ft +setVarName :: Var -> Name -> Var setVarName var new_name = var { realUnique = getKey (getUnique new_name), varName = new_name } -setVarType :: Var flex_self flex_ty1 -> GenType flex_ty2 -> Var flex_self flex_ty2 +setVarOcc :: Var -> OccName -> Var +setVarOcc var new_occ + = var { varName = setNameOcc (varName var) new_occ } + +setVarType :: Var -> Type -> Var setVarType var ty = var {varType = ty} \end{code} @@ -124,10 +137,7 @@ setVarType var ty = var {varType = ty} %************************************************************************ \begin{code} -type GenTyVar flex_self = Var flex_self Unused -- Perhaps a mutable tyvar, but - -- with a fixed Kind - -type TyVar = GenTyVar Unused -- NOt even mutable +type TyVar = Var \end{code} \begin{code} @@ -136,46 +146,47 @@ tyVarKind = varType setTyVarUnique = setVarUnique setTyVarName = setVarName - -tyVarFlexi :: GenTyVar flexi -> flexi -tyVarFlexi (Var {varDetails = FlexiTyVar flex}) = flex -tyVarFlexi other_var = pprPanic "tyVarFlexi" (ppr other_var) - -setTyVarFlexi :: GenTyVar flexi1 -> flexi2 -> GenTyVar flexi2 -setTyVarFlexi var flex = var {varDetails = FlexiTyVar flex} - -removeTyVarFlexi :: GenTyVar flexi1 -> GenTyVar flexi2 -removeTyVarFlexi var = var {varDetails = TyVar} \end{code} \begin{code} -mkTyVar :: Name -> Kind -> GenTyVar flexi +mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = Var { varName = name, realUnique = getKey (nameUnique name), varType = kind, varDetails = TyVar } -mkSysTyVar :: Unique -> Kind -> GenTyVar flexi +mkSysTyVar :: Unique -> Kind -> TyVar mkSysTyVar uniq kind = Var { varName = name, realUnique = getKey uniq, varType = kind, varDetails = TyVar } where - name = mkSysLocalName uniq + name = mkSysLocalName uniq SLIT("t") + +newMutTyVar :: Name -> Kind -> IO TyVar +newMutTyVar name kind = + do loc <- newIORef Nothing + return (Var { varName = name, + realUnique = getKey (nameUnique name), + varType = kind, + varDetails = MutTyVar loc }) + +readMutTyVar :: TyVar -> IO (Maybe Type) +readMutTyVar (Var {varDetails = MutTyVar loc}) = readIORef loc + +writeMutTyVar :: TyVar -> Maybe Type -> IO () +writeMutTyVar (Var {varDetails = MutTyVar loc}) val = writeIORef loc val -mkFlexiTyVar :: Name -> Kind -> flexi -> GenTyVar flexi -mkFlexiTyVar name kind flex = Var { varName = name, - realUnique = getKey (nameUnique name), - varType = kind, - varDetails = FlexiTyVar flex } +makeTyVarImmutable :: TyVar -> TyVar +makeTyVarImmutable tyvar = tyvar { varDetails = TyVar} \end{code} \begin{code} -isTyVar :: Var fs ft -> Bool +isTyVar :: Var -> Bool isTyVar (Var {varDetails = details}) = case details of - TyVar -> True - FlexiTyVar _ -> True - other -> False + TyVar -> True + MutTyVar _ -> True + other -> False -isFlexiTyVar :: Var fs ft -> Bool -isFlexiTyVar (Var {varDetails = FlexiTyVar _}) = True -isFlexiTyVar other = False +isMutTyVar :: Var -> Bool +isMutTyVar (Var {varDetails = MutTyVar _}) = True +isMutTyVar other = False \end{code} @@ -188,9 +199,8 @@ isFlexiTyVar other = False Most Id-related functions are in Id.lhs and MkId.lhs \begin{code} -type GenId flex_ty = Var Unused flex_ty -type Id = GenId Unused -type DictId = Id +type Id = Var +type DictId = Id \end{code} \begin{code} @@ -206,22 +216,22 @@ setIdUnique = setVarUnique setIdName :: Id -> Name -> Id setIdName = setVarName -setIdInfo :: GenId flexi -> IdInfo -> GenId flexi +setIdInfo :: Id -> IdInfo -> Id setIdInfo var info = var {varInfo = info} -modifyIdInfo :: GenId flexi -> (IdInfo -> IdInfo) -> GenId flexi +modifyIdInfo :: Id -> (IdInfo -> IdInfo) -> Id modifyIdInfo var@(Var {varInfo = info}) fn = var {varInfo = fn info} \end{code} \begin{code} -mkId :: Name -> GenType flex_ty -> VarDetails Unused -> IdInfo -> GenId flex_ty +mkId :: Name -> Type -> VarDetails -> IdInfo -> Id mkId name ty details info = Var {varName = name, realUnique = getKey (nameUnique name), varType = ty, varDetails = details, varInfo = info} \end{code} \begin{code} -isId :: Var fs ft -> Bool +isId :: Var -> Bool isId (Var {varDetails = details}) = case details of VanillaId -> True ConstantId _ -> True diff --git a/ghc/compiler/basicTypes/VarEnv.lhs b/ghc/compiler/basicTypes/VarEnv.lhs index ed0986345a..515025b3ed 100644 --- a/ghc/compiler/basicTypes/VarEnv.lhs +++ b/ghc/compiler/basicTypes/VarEnv.lhs @@ -14,12 +14,15 @@ module VarEnv ( lookupVarEnv, lookupVarEnv_NF, mapVarEnv, zipVarEnv, modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, foldVarEnv + isEmptyVarEnv, foldVarEnv, + + TidyEnv, emptyTidyEnv ) where #include "HsVersions.h" -import Var ( Var, Id ) +import OccName ( TidyOccEnv, emptyTidyOccEnv ) +import Var ( Var, Id, IdOrTyVar ) import UniqFM import Util ( zipEqual ) \end{code} @@ -27,6 +30,21 @@ import Util ( zipEqual ) %************************************************************************ %* * +\subsection{Tidying} +%* * +%************************************************************************ + +When tidying up print names, we keep a mapping of in-scope occ-names +(the TidyOccEnv) and a Var-to-Var of the current renamings. + +\begin{code} +type TidyEnv = (TidyOccEnv, VarEnv IdOrTyVar) +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) +\end{code} + + +%************************************************************************ +%* * \subsection{@VarEnv@s} %* * %************************************************************************ @@ -37,24 +55,24 @@ type IdEnv elt = VarEnv elt type TyVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a -mkVarEnv :: [(Var fs ft, a)] -> VarEnv a -zipVarEnv :: [Var fs ft] -> [a] -> VarEnv a -unitVarEnv :: Var fs ft -> a -> VarEnv a -extendVarEnv :: VarEnv a -> Var fs ft -> a -> VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -extendVarEnvList :: VarEnv a -> [(Var fs ft, a)] -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a -delVarEnvList :: VarEnv a -> [Var fs ft] -> VarEnv a -delVarEnv :: VarEnv a -> Var fs ft -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -modifyVarEnv :: (a -> a) -> VarEnv a -> Var fs ft -> VarEnv a +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a rngVarEnv :: VarEnv a -> [a] isEmptyVarEnv :: VarEnv a -> Bool -lookupVarEnv :: VarEnv a -> Var fs ft -> Maybe a -lookupVarEnv_NF :: VarEnv a -> Var fs ft -> a -elemVarEnv :: Var fs ft -> VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +lookupVarEnv_NF :: VarEnv a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b \end{code} diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 217e3a16fa..9091dfe2b7 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -5,7 +5,7 @@ \begin{code} module VarSet ( - VarSet, IdSet, GenIdSet, TyVarSet, GenTyVarSet, IdOrTyVarSet, + VarSet, IdSet, TyVarSet, IdOrTyVarSet, emptyVarSet, unitVarSet, mkVarSet, extendVarSet, elemVarSet, varSetElems, @@ -20,7 +20,7 @@ module VarSet ( #include "HsVersions.h" -import Var ( Var, Id, GenId, TyVar, GenTyVar, IdOrTyVar, setVarUnique ) +import Var ( Var, Id, TyVar, IdOrTyVar, setVarUnique ) import Unique ( Uniquable(..), incrUnique ) import UniqSet import Outputable @@ -33,32 +33,30 @@ import Outputable %************************************************************************ \begin{code} -type VarSet fs ft = UniqSet (Var fs ft) -type IdSet = UniqSet Id -type GenIdSet flexi = UniqSet (GenId flexi) -type TyVarSet = UniqSet TyVar -type GenTyVarSet flexi = UniqSet (GenTyVar flexi) -type IdOrTyVarSet = UniqSet IdOrTyVar +type VarSet = UniqSet Var +type IdSet = UniqSet Id +type TyVarSet = UniqSet TyVar +type IdOrTyVarSet = UniqSet IdOrTyVar -emptyVarSet :: VarSet fs ft -intersectVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft -intersectsVarSet:: VarSet fs ft -> VarSet fs ft -> Bool -- True if non-empty intersection -unionVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft -unionVarSets :: [VarSet fs ft] -> VarSet fs ft -varSetElems :: VarSet fs ft -> [Var fs ft] -unitVarSet :: Var fs ft -> VarSet fs ft -extendVarSet :: VarSet fs ft -> Var fs ft -> VarSet fs ft -elemVarSet :: Var fs ft -> VarSet fs ft -> Bool -delVarSet :: VarSet fs ft -> Var fs ft -> VarSet fs ft -minusVarSet :: VarSet fs ft -> VarSet fs ft -> VarSet fs ft -isEmptyVarSet :: VarSet fs ft -> Bool -mkVarSet :: [Var fs ft] -> VarSet fs ft -foldVarSet :: (Var fs ft -> a -> a) -> a -> VarSet fs ft -> a -lookupVarSet :: VarSet fs ft -> Var fs ft -> Maybe (Var fs ft) +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet +varSetElems :: VarSet -> [Var] +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a +lookupVarSet :: VarSet -> Var -> Maybe Var -- Returns the set element, which may be -- (==) to the argument, but not the same as -mapVarSet :: (Var fs ft -> Var fs ft) -> VarSet fs ft -> VarSet fs ft -filterVarSet :: (Var fs ft -> Bool) -> VarSet fs ft -> VarSet fs ft +mapVarSet :: (Var -> Var) -> VarSet -> VarSet +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet emptyVarSet = emptyUniqSet unitVarSet = unitUniqSet @@ -80,7 +78,7 @@ filterVarSet = filterUniqSet \end{code} \begin{code} -uniqAway :: VarSet fs ft -> Var fs ft -> Var fs ft +uniqAway :: VarSet -> Var -> Var -- Give the Var a new unique, different to any in the VarSet uniqAway set var = try 1 (incrUnique (getUnique var)) |