-- Simple construction
mkId, mkVanillaId, mkSysLocal, mkUserLocal,
- mkTemplateLocals, mkWildId, mkTemplateLocal,
+ mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
-- Modifying an Id
setIdName, setIdUnique, setIdType, setIdNoDiscard,
- setIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ zapFragileIdInfo, zapLamIdInfo,
-- Predicates
- omitIfaceSigForId,
+ isImplicitId, isDeadBinder,
externallyVisibleId,
- idFreeTyVars,
+ isSpecPragmaId, isRecordSelector,
+ isPrimOpId, isPrimOpId_maybe, isDictFunId,
+ isDataConId, isDataConId_maybe,
+ isDataConWrapId, isDataConWrapId_maybe,
+ isBottomingId,
+ isExportedId, isLocalId,
+ hasNoBinding,
-- Inline pragma stuff
- getInlinePragma, setInlinePragma, modifyInlinePragma,
- idMustBeINLINEd, idMustNotBeINLINEd,
+ idInlinePragma, setInlinePragma, modifyInlinePragma,
- isSpecPragmaId, isRecordSelector,
- isPrimitiveId_maybe, isDataConId_maybe,
- isConstantId, isBottomingId, idAppIsBottom,
- isExportedId, isUserExportedId,
-- One shot lambda stuff
- isOneShotLambda, setOneShotLambda,
+ isOneShotLambda, setOneShotLambda, clearOneShotLambda,
-- IdInfo stuff
setIdUnfolding,
- setIdArity,
+ setIdArityInfo,
setIdDemandInfo,
setIdStrictness,
+ setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
- setIdUpdateInfo,
setIdCafInfo,
setIdCprInfo,
-
- getIdArity,
- getIdDemandInfo,
- getIdStrictness,
- getIdWorkerInfo,
- getIdUnfolding,
- getIdSpecialisation,
- getIdUpdateInfo,
- getIdCafInfo,
- getIdCprInfo
+ setIdOccInfo,
+
+ idArity, idArityInfo,
+ idFlavour,
+ idDemandInfo,
+ idStrictness,
+ idTyGenInfo,
+ idWorkerInfo,
+ idUnfolding,
+ idSpecialisation,
+ idCafInfo,
+ idCprInfo,
+ idLBVarInfo,
+ idOccInfo,
) where
#include "HsVersions.h"
-import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import {-# SOURCE #-} CoreSyn ( CoreRules )
+import CoreSyn ( Unfolding, CoreRules )
+import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, mkIdVar,
idName, idType, idUnique, idInfo,
setIdName, setVarType, setIdUnique,
- setIdInfo, modifyIdInfo, maybeModifyIdInfo,
+ setIdInfo, lazySetIdInfo, modifyIdInfo,
+ maybeModifyIdInfo,
externallyVisibleId
)
-import VarSet
-import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars )
-import IdInfo
-import Demand ( Demand, isStrict, wwLazy )
+import Type ( Type, typePrimRep, addFreeTyVars,
+ usOnce, seqType, splitTyConApp_maybe )
+
+import IdInfo
+
+import Demand ( Demand )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
- isWiredInName, isUserExportedName
+ getOccName
)
-import Const ( Con(..) )
+import OccName ( UserFS )
import PrimRep ( PrimRep )
-import PrimOp ( PrimOp )
-import TysPrim ( realWorldStatePrimTy )
-import FieldLabel ( FieldLabel(..) )
+import TysPrim ( statePrimTyCon )
+import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
-import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques )
+import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
+ getNumBuiltinUniques )
import Outputable
infixl 1 `setIdUnfolding`,
- `setIdArity`,
+ `setIdArityInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
+ `setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
- `setIdUpdateInfo`,
`setInlinePragma`,
- `getIdCafInfo`,
- `getIdCprInfo`
+ `idCafInfo`,
+ `idCprInfo`
-- infixl so you can say (id `set` a `set` b)
\end{code}
\begin{code}
mkId :: Name -> Type -> IdInfo -> Id
-mkId name ty info = mkIdVar name (addFreeTyVars ty) info'
- where
- info' | isUserExportedName name = setNoDiscardInfo info
- | otherwise = info
+mkId name ty info = mkIdVar name (addFreeTyVars ty) info
\end{code}
\begin{code}
-- 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 -> Type -> SrcLoc -> Id
-mkSysLocal :: FAST_STRING -> Unique -> Type -> Id
+mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
+mkSysLocal :: UserFS -> Unique -> Type -> Id
mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty
mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty
(getBuiltinUniques (length tys))
tys
+mkTemplateLocalsNum :: Int -> [Type] -> [Id]
+-- The Int gives the starting point for unique allocation
+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 :: Id -> TyVarSet
-idFreeTyVars id = tyVarsOfType (idType id)
-
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)
RecordSelId lbl -> True
other -> False
-isPrimitiveId_maybe id = case idFlavour id of
- ConstantId (PrimOp op) -> Just op
- other -> Nothing
+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
- ConstantId (DataCon con) -> Just con
- other -> Nothing
+ DataConId con -> Just con
+ other -> Nothing
+
+isDataConWrapId_maybe id = case idFlavour id of
+ DataConWrapId con -> Just con
+ other -> Nothing
-isConstantId id = case idFlavour id of
- ConstantId _ -> True
- other -> False
+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.
+
+isDictFunId id = case idFlavour id of
+ DictFunId -> True
+ other -> False
+
-- Don't drop a binding for an exported Id,
-- if it otherwise looks dead.
+-- Perhaps a better name would be isDiscardableId
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)
+ VanillaId -> False
+ other -> True
+
+isLocalId :: Id -> Bool
+-- True of Ids that are locally defined, but are not constants
+-- like data constructors, record selectors, and the like.
+-- See comments with CoreFVs.isLocalVar
+isLocalId id
+#ifdef DEBUG
+ | not (isId id) = pprTrace "isLocalid" (ppr id) False
+ | otherwise
+#endif
+ = case idFlavour id of
+ VanillaId -> True
+ ExportedId -> True
+ SpecPragmaId -> True
+ other -> False
\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.
+isImplicitId 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
+isImplicitId :: Id -> Bool
+isImplicitId id
= case idFlavour id of
- RecordSelId _ -> True -- Includes dictionary selectors
- ConstantId _ -> True
- -- ConstantIds are implied by their type or class decl;
+ 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!
+ other -> False
\end{code}
+\begin{code}
+isDeadBinder :: Id -> Bool
+isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
+ | otherwise = False -- TyVars count as not dead
+\end{code}
%************************************************************************
\begin{code}
---------------------------------
-- ARITY
-getIdArity :: Id -> ArityInfo
-getIdArity id = arityInfo (idInfo id)
+idArityInfo :: Id -> ArityInfo
+idArityInfo id = arityInfo (idInfo id)
-setIdArity :: Id -> ArityInfo -> Id
-setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
+idArity :: Id -> Arity
+idArity id = arityLowerBound (idArityInfo id)
+
+setIdArityInfo :: Id -> ArityInfo -> Id
+setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
-- STRICTNESS
-getIdStrictness :: Id -> StrictnessInfo
-getIdStrictness id = strictnessInfo (idInfo id)
+idStrictness :: Id -> StrictnessInfo
+idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
-- isBottomingId returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
-isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id))
+isBottomingId id = isBottomingStrictness (idStrictness id)
+
+ ---------------------------------
+ -- TYPE GENERALISATION
+idTyGenInfo :: Id -> TyGenInfo
+idTyGenInfo id = tyGenInfo (idInfo id)
-idAppIsBottom :: Id -> Int -> Bool
-idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
+setIdTyGenInfo :: Id -> TyGenInfo -> Id
+setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
---------------------------------
-- WORKER ID
-getIdWorkerInfo :: Id -> WorkerInfo
-getIdWorkerInfo id = workerInfo (idInfo id)
+idWorkerInfo :: Id -> WorkerInfo
+idWorkerInfo id = workerInfo (idInfo id)
setIdWorkerInfo :: Id -> WorkerInfo -> Id
setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id
---------------------------------
-- UNFOLDING
-getIdUnfolding :: Id -> Unfolding
-getIdUnfolding id = unfoldingInfo (idInfo id)
+idUnfolding :: Id -> Unfolding
+idUnfolding id = unfoldingInfo (idInfo id)
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
---------------------------------
-- DEMAND
-getIdDemandInfo :: Id -> Demand
-getIdDemandInfo id = demandInfo (idInfo id)
+idDemandInfo :: Id -> Demand
+idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
---------------------------------
- -- UPDATE INFO
-getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo id = updateInfo (idInfo id)
-
-setIdUpdateInfo :: Id -> UpdateInfo -> Id
-setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id
-
- ---------------------------------
-- SPECIALISATION
-getIdSpecialisation :: Id -> CoreRules
-getIdSpecialisation id = specInfo (idInfo id)
+idSpecialisation :: Id -> CoreRules
+idSpecialisation id = specInfo (idInfo id)
setIdSpecialisation :: Id -> CoreRules -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
-- CAF INFO
-getIdCafInfo :: Id -> 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
-getIdCprInfo :: Id -> CprInfo
-getIdCprInfo id = cprInfo (idInfo id)
+idCprInfo :: Id -> CprInfo
+idCprInfo id = cprInfo (idInfo id)
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 :: Id -> InlinePragInfo
-getInlinePragma id = inlinePragInfo (idInfo id)
+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
-
-idMustNotBeINLINEd id = case getInlinePragma id of
- IMustNotBeINLINEd -> True
- IAmALoopBreaker -> True
- other -> False
-
-idMustBeINLINEd id = case getInlinePragma id of
- IMustBeINLINEd -> True
- other -> False
\end{code}
---------------------------------
-- ONE-SHOT LAMBDAS
\begin{code}
+idLBVarInfo :: Id -> LBVarInfo
+idLBVarInfo id = lbvarInfo (idInfo id)
+
isOneShotLambda :: Id -> Bool
-isOneShotLambda id = case lbvarInfo (idInfo id) of
- IsOneShotLambda -> True
- NoLBVarInfo -> idType id == realWorldStatePrimTy
+isOneShotLambda id = analysis || hack
+ where analysis = case idLBVarInfo id of
+ LBVarInfo u | u == usOnce -> True
+ other -> False
+ hack = case splitTyConApp_maybe (idType id) of
+ Just (tycon,_) | tycon == statePrimTyCon -> True
+ 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
-- 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
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) 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}
+