\begin{code}
module Id (
- Id, DictId, GenId,
+ Id, DictId,
-- Simple construction
- mkVanillaId, mkImportedId, mkSysLocal, mkUserLocal,
- mkTemplateLocals, mkWildId, mkUserId,
+ mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+ mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdInfo,
- setIdVisibility, mkIdVisible,
+ setIdName, setIdUnique, setIdType, setIdNoDiscard,
+ setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ zapFragileIdInfo, zapLamIdInfo,
-- Predicates
- omitIfaceSigForId,
+ omitIfaceSigForId, isDeadBinder,
+ exportWithOrigOccName,
externallyVisibleId,
- idFreeTyVars,
+ idFreeTyVars,
+ isIP,
+ isSpecPragmaId, isRecordSelector,
+ isPrimOpId, isPrimOpId_maybe,
+ isDataConId, isDataConId_maybe, isDataConWrapId,
+ isDataConWrapId_maybe,
+ isBottomingId,
+ isExportedId, isUserExportedId,
+ hasNoBinding,
-- Inline pragma stuff
- getInlinePragma, setInlinePragma, modifyInlinePragma,
- idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
- isSpecPragmaId,
-
+ idInlinePragma, setInlinePragma, modifyInlinePragma,
- isRecordSelector,
- isPrimitiveId_maybe, isDataConId_maybe,
- isConstantId,
- isBottomingId,
+
+ -- One shot lambda stuff
+ isOneShotLambda, setOneShotLambda, clearOneShotLambda,
-- IdInfo stuff
setIdUnfolding,
- setIdArity,
+ setIdArityInfo,
setIdDemandInfo,
setIdStrictness,
+ setIdWorkerInfo,
setIdSpecialisation,
- setIdUpdateInfo,
setIdCafInfo,
-
- getIdArity,
- getIdDemandInfo,
- getIdStrictness,
- getIdUnfolding,
- getIdSpecialisation,
- getIdUpdateInfo,
- getIdCafInfo
+ setIdCprInfo,
+ setIdOccInfo,
+
+ idArity, idArityInfo,
+ idFlavour,
+ idDemandInfo,
+ idStrictness,
+ idWorkerInfo,
+ idUnfolding,
+ idSpecialisation,
+ idCafInfo,
+ idCprInfo,
+ idLBVarInfo,
+ idOccInfo,
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import Var ( Id, GenId, DictId, VarDetails(..),
- isId, mkId,
- idName, idType, idUnique, idInfo, varDetails,
- setIdName, setVarType, setIdUnique, setIdInfo, modifyIdInfo,
+import CoreSyn ( Unfolding, CoreRules )
+import BasicTypes ( Arity )
+import Var ( Id, DictId,
+ isId, mkIdVar,
+ idName, idType, idUnique, idInfo,
+ setIdName, setVarType, setIdUnique,
+ setIdInfo, lazySetIdInfo, modifyIdInfo,
+ maybeModifyIdInfo,
externallyVisibleId
)
import VarSet
-import Type ( GenType, Type, tyVarsOfType, typePrimRep, addFreeTyVars )
-import IdInfo
+import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars,
+ seqType, splitTyConApp_maybe )
+
+import IdInfo
+
import Demand ( Demand )
-import Name ( Name, OccName,
+import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
- isWiredInName, setNameVisibility, mkNameVisible
+ isUserExportedName, getOccName, isIPOcc
)
-import Const ( Con(..) )
+import OccName ( UserFS )
import PrimRep ( PrimRep )
-import PrimOp ( PrimOp )
-import FieldLabel ( FieldLabel(..) )
-import BasicTypes ( Module )
-import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
-import Outputable
+import TysPrim ( statePrimTyCon )
+import FieldLabel ( FieldLabel )
+import SrcLoc ( SrcLoc )
+import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
+ getNumBuiltinUniques )
infixl 1 `setIdUnfolding`,
- `setIdArity`,
+ `setIdArityInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
+ `setIdWorkerInfo`,
`setIdSpecialisation`,
- `setIdUpdateInfo`,
- `setInlinePragma`
+ `setInlinePragma`,
+ `idCafInfo`,
+ `idCprInfo`
+
-- infixl so you can say (id `set` a `set` b)
\end{code}
%* *
%************************************************************************
-\begin{code}
-mkVanillaId :: Name -> (GenType flexi) -> GenId flexi
-mkVanillaId name ty = mkId name ty VanillaId noIdInfo
+Absolutely all Ids are made by mkId. It
+ a) Pins free-tyvar-info onto the Id's type,
+ where it can easily be found.
+ b) Ensures that exported Ids are
-mkImportedId :: Name -> Type -> IdInfo -> Id
-mkImportedId name ty info = mkId name ty VanillaId info
+\begin{code}
+mkId :: Name -> Type -> IdInfo -> Id
+mkId name ty info = mkIdVar name (addFreeTyVars ty) info'
+ where
+ info' | isUserExportedName name = setNoDiscardInfo info
+ | otherwise = info
+\end{code}
-mkUserId :: Name -> GenType flexi -> GenId flexi
-mkUserId name ty = mkVanillaId name ty
+\begin{code}
+mkVanillaId :: Name -> Type -> Id
+mkVanillaId name ty = mkId name ty vanillaIdInfo
-- 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 -> SrcLoc -> Id
+mkSysLocal :: UserFS -> 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 loc = mkVanillaId (mkLocalName uniq occ loc) ty
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
\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
+
+mkTemplateLocalsNum :: Int -> [Type] -> [Id]
+mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
+ (getNumBuiltinUniques n (length tys))
+ tys
+
+mkTemplateLocal :: Int -> Type -> Id
+mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
\end{code}
%************************************************************************
\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)
+setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Special Ids}
+%* *
+%************************************************************************
+
+\begin{code}
+idFlavour :: Id -> IdFlavour
+idFlavour id = flavourInfo (idInfo id)
+
+setIdNoDiscard :: Id -> Id
+setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already
+ = modifyIdInfo setNoDiscardInfo id
+
+recordSelectorFieldLabel :: Id -> FieldLabel
+recordSelectorFieldLabel id = case idFlavour id of
+ RecordSelId lbl -> lbl
+
+isRecordSelector id = case idFlavour id of
+ RecordSelId lbl -> True
+ other -> False
+
+isPrimOpId id = case idFlavour id of
+ PrimOpId op -> True
+ other -> False
+
+isPrimOpId_maybe id = case idFlavour id of
+ PrimOpId op -> Just op
+ other -> Nothing
+
+isDataConId id = case idFlavour id of
+ DataConId _ -> True
+ other -> False
+
+isDataConId_maybe id = case idFlavour id of
+ DataConId con -> Just con
+ other -> Nothing
+
+isDataConWrapId_maybe id = case idFlavour id of
+ DataConWrapId con -> Just con
+ other -> Nothing
+
+isDataConWrapId id = case idFlavour id of
+ DataConWrapId con -> True
+ other -> False
+
+isSpecPragmaId id = case idFlavour id of
+ SpecPragmaId -> True
+ other -> False
+
+hasNoBinding id = case idFlavour id of
+ DataConId _ -> True
+ PrimOpId _ -> True
+ other -> False
+ -- hasNoBinding returns True of an Id which may not have a
+ -- binding, even though it is defined in this module. Notably,
+ -- the constructors of a dictionary are in this situation.
+
+-- Don't drop a binding for an exported Id,
+-- if it otherwise looks dead.
+isExportedId :: Id -> Bool
+isExportedId id = 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)
+\end{code}
+
+
omitIfaceSigForId tells whether an Id's info is implied by other declarations,
so we don't need to put its signature in an interface file, even if it's mentioned
in some other interface unfolding.
\begin{code}
omitIfaceSigForId :: Id -> Bool
omitIfaceSigForId id
- | isWiredInName (idName id)
- = True
-
| otherwise
- = case varDetails id of
- RecordSelId _ -> True -- Includes dictionary selectors
- ConstantId _ -> True
- -- ConstantIds are implied by their type or class decl;
+ = case idFlavour id of
+ RecordSelId _ -> True -- Includes dictionary selectors
+ PrimOpId _ -> True
+ DataConId _ -> True
+ DataConWrapId _ -> True
+ -- These are are implied by their type or class decl;
-- remember that all type and class decls appear in the interface file.
-- The dfun id must *not* be omitted, because it carries version info for
-- the instance decl
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))
+-- Certain names must be exported with their original occ names, because
+-- 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
\end{code}
-%************************************************************************
-%* *
-\subsection{Special Ids}
-%* *
-%************************************************************************
-
\begin{code}
-recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case varDetails id of
- RecordSelId lbl -> lbl
-
-isRecordSelector id = case varDetails id of
- RecordSelId lbl -> True
- other -> False
+isDeadBinder :: Id -> Bool
+isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
+ | otherwise = False -- TyVars count as not dead
-isPrimitiveId_maybe id = case varDetails id of
- ConstantId (PrimOp op) -> Just op
- other -> Nothing
-
-isDataConId_maybe id = case varDetails id of
- ConstantId (DataCon con) -> Just con
- other -> Nothing
-
-isConstantId id = case varDetails id of
- ConstantId _ -> True
- other -> False
+isIP id = isIPOcc (getOccName id)
\end{code}
\begin{code}
---------------------------------
-- ARITY
-getIdArity :: GenId flexi -> ArityInfo
-getIdArity id = arityInfo (idInfo id)
+idArityInfo :: Id -> ArityInfo
+idArityInfo id = arityInfo (idInfo id)
+
+idArity :: Id -> Arity
+idArity id = arityLowerBound (idArityInfo id)
-setIdArity :: GenId flexi -> ArityInfo -> GenId flexi
-setIdArity id arity = modifyIdInfo id (arity `setArityInfo`)
+setIdArityInfo :: Id -> ArityInfo -> Id
+setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
-- STRICTNESS
-getIdStrictness :: GenId flexi -> StrictnessInfo
-getIdStrictness id = strictnessInfo (idInfo id)
+idStrictness :: Id -> StrictnessInfo
+idStrictness id = strictnessInfo (idInfo id)
-setIdStrictness :: GenId flexi -> StrictnessInfo -> GenId flexi
-setIdStrictness id strict_info = modifyIdInfo id (strict_info `setStrictnessInfo`)
+setIdStrictness :: Id -> StrictnessInfo -> Id
+setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
-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 (idStrictness id)
---------------------------------
- -- UNFOLDING
-getIdUnfolding :: GenId flexi -> Unfolding
-getIdUnfolding id = unfoldingInfo (idInfo id)
+ -- WORKER ID
+idWorkerInfo :: Id -> WorkerInfo
+idWorkerInfo id = workerInfo (idInfo id)
-setIdUnfolding :: GenId flexi -> Unfolding -> GenId flexi
-setIdUnfolding id unfolding = modifyIdInfo id (unfolding `setUnfoldingInfo`)
+setIdWorkerInfo :: Id -> WorkerInfo -> Id
+setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
---------------------------------
- -- DEMAND
-getIdDemandInfo :: GenId flexi -> Demand
-getIdDemandInfo id = demandInfo (idInfo id)
+ -- UNFOLDING
+idUnfolding :: Id -> Unfolding
+idUnfolding id = unfoldingInfo (idInfo id)
-setIdDemandInfo :: GenId flexi -> Demand -> GenId flexi
-setIdDemandInfo id demand_info = modifyIdInfo id (demand_info `setDemandInfo`)
+setIdUnfolding :: Id -> Unfolding -> Id
+setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
---------------------------------
- -- UPDATE INFO
-getIdUpdateInfo :: GenId flexi -> UpdateInfo
-getIdUpdateInfo id = updateInfo (idInfo id)
+ -- DEMAND
+idDemandInfo :: Id -> Demand
+idDemandInfo id = demandInfo (idInfo id)
-setIdUpdateInfo :: GenId flexi -> UpdateInfo -> GenId flexi
-setIdUpdateInfo id upd_info = modifyIdInfo id (upd_info `setUpdateInfo`)
+setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
---------------------------------
-- SPECIALISATION
-getIdSpecialisation :: GenId flexi -> IdSpecEnv
-getIdSpecialisation id = specInfo (idInfo id)
+idSpecialisation :: Id -> CoreRules
+idSpecialisation id = specInfo (idInfo id)
-setIdSpecialisation :: GenId flexi -> IdSpecEnv -> GenId flexi
-setIdSpecialisation id spec_info = modifyIdInfo id (spec_info `setSpecInfo`)
+setIdSpecialisation :: Id -> CoreRules -> Id
+setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
-- CAF INFO
-getIdCafInfo :: GenId flexi -> CafInfo
-getIdCafInfo id = cafInfo (idInfo id)
+idCafInfo :: Id -> CafInfo
+idCafInfo id = cafInfo (idInfo id)
+
+setIdCafInfo :: Id -> CafInfo -> Id
+setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+
+ ---------------------------------
+ -- CPR INFO
+idCprInfo :: Id -> CprInfo
+idCprInfo id = cprInfo (idInfo id)
-setIdCafInfo :: GenId flexi -> CafInfo -> GenId flexi
-setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
+setIdCprInfo :: Id -> CprInfo -> Id
+setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
+
+ ---------------------------------
+ -- Occcurrence INFO
+idOccInfo :: Id -> OccInfo
+idOccInfo id = occInfo (idInfo id)
+
+setIdOccInfo :: Id -> OccInfo -> Id
+setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
\end{code}
OK not to if optimisation is switched off.
\begin{code}
-getInlinePragma :: GenId flexi -> InlinePragInfo
-getInlinePragma id = inlinePragInfo (idInfo id)
-
-setInlinePragma :: GenId flexi -> InlinePragInfo -> GenId flexi
-setInlinePragma id prag = modifyIdInfo id (setInlinePragInfo prag)
-
-modifyInlinePragma :: GenId flexi -> (InlinePragInfo -> InlinePragInfo) -> GenId flexi
-modifyInlinePragma id fn = modifyIdInfo id (\info -> setInlinePragInfo (fn (inlinePragInfo info)) info)
-
-idWantsToBeINLINEd :: GenId flexi -> Bool
-idWantsToBeINLINEd id = case getInlinePragma id of
- IWantToBeINLINEd -> True
- IMustBeINLINEd -> True
- other -> False
-
-idMustNotBeINLINEd id = case getInlinePragma id of
- IMustNotBeINLINEd -> True
- IAmASpecPragmaId -> True
- IAmALoopBreaker -> True
- other -> False
-
-idMustBeINLINEd id = case getInlinePragma id of
- IMustBeINLINEd -> True
- other -> False
-
-isSpecPragmaId id = case getInlinePragma id of
- IAmASpecPragmaId -> True
- other -> False
+idInlinePragma :: Id -> InlinePragInfo
+idInlinePragma id = inlinePragInfo (idInfo id)
+
+setInlinePragma :: Id -> InlinePragInfo -> Id
+setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id
+
+modifyInlinePragma :: Id -> (InlinePragInfo -> InlinePragInfo) -> Id
+modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id
\end{code}
+
+
+ ---------------------------------
+ -- ONE-SHOT LAMBDAS
+\begin{code}
+idLBVarInfo :: Id -> LBVarInfo
+idLBVarInfo id = lbvarInfo (idInfo id)
+
+isOneShotLambda :: Id -> Bool
+isOneShotLambda id = case idLBVarInfo id of
+ IsOneShotLambda -> True
+ NoLBVarInfo -> case splitTyConApp_maybe (idType id) of
+ Just (tycon,_) -> tycon == statePrimTyCon
+ other -> False
+ -- The last clause is a gross hack. It claims that
+ -- every function over realWorldStatePrimTy is a one-shot
+ -- function. This is pretty true in practice, and makes a big
+ -- difference. For example, consider
+ -- a `thenST` \ r -> ...E...
+ -- The early full laziness pass, if it doesn't know that r is one-shot
+ -- will pull out E (let's say it doesn't mention r) to give
+ -- let lvl = E in a `thenST` \ r -> ...lvl...
+ -- When `thenST` gets inlined, we end up with
+ -- let lvl = E in \s -> case a s of (r, s') -> ...lvl...
+ -- and we don't re-inline E.
+ --
+ -- It would be better to spot that r was one-shot to start with, but
+ -- I don't want to rely on that.
+ --
+ -- Another good example is in fill_in in PrelPack.lhs. We should be able to
+ -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
+
+setOneShotLambda :: Id -> Id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
+
+clearOneShotLambda :: Id -> Id
+clearOneShotLambda id
+ | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id
+ | otherwise = id
+
+-- But watch out: this may change the type of something else
+-- f = \x -> e
+-- If we change the one-shot-ness of x, f's type changes
+\end{code}
+
+\begin{code}
+zapFragileIdInfo :: Id -> Id
+zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id
+
+zapLamIdInfo :: Id -> Id
+zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
+\end{code}
+
+
+
+
+
+
+
+
+
+
+
projects / ghc-hetmet.git / blobdiff