Id, DictId,
-- Simple construction
- mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+ mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
+ mkSysLocal, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
+ mkWorkerId,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
- idPrimRep, isId,
+ idPrimRep, isId, globalIdDetails,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdNoDiscard,
+ setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
- zapFragileIdInfo, zapLamIdInfo,
+ zapLamIdInfo, zapDemandIdInfo,
-- Predicates
isImplicitId, isDeadBinder,
- externallyVisibleId,
- isSpecPragmaId, isRecordSelector,
- isPrimOpId, isPrimOpId_maybe, isDictFunId,
+ isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
+ isRecordSelector,
+ isPrimOpId, isPrimOpId_maybe,
+ isFCallId, isFCallId_maybe,
isDataConId, isDataConId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
- isExportedId, isLocalId,
hasNoBinding,
-- Inline pragma stuff
-- IdInfo stuff
setIdUnfolding,
setIdArityInfo,
- setIdDemandInfo,
- setIdStrictness,
+ setIdDemandInfo, setIdNewDemandInfo,
+ setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
- setIdCafInfo,
+ setIdCgInfo,
setIdCprInfo,
setIdOccInfo,
idArity, idArityInfo,
- idFlavour,
- idDemandInfo,
- idStrictness,
+ idDemandInfo, idNewDemandInfo,
+ idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
idSpecialisation,
+ idCgInfo,
idCafInfo,
+ idCgArity,
idCprInfo,
idLBVarInfo,
idOccInfo,
+ newStrictnessFromOld -- Temporary
+
) where
#include "HsVersions.h"
import CoreSyn ( Unfolding, CoreRules )
import BasicTypes ( Arity )
import Var ( Id, DictId,
- isId, mkIdVar,
- idName, idType, idUnique, idInfo,
- setIdName, setVarType, setIdUnique,
+ isId, isExportedId, isSpecPragmaId, isLocalId,
+ idName, idType, idUnique, idInfo, isGlobalId,
+ setIdName, setVarType, setIdUnique, setIdLocalExported,
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
- externallyVisibleId
+ globalIdDetails, setGlobalIdDetails
)
+import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import Type ( Type, typePrimRep, addFreeTyVars,
- usOnce, seqType, splitTyConApp_maybe )
+ usOnce, eqUsage, seqType, splitTyConApp_maybe )
import IdInfo
-import Demand ( Demand )
+import qualified Demand ( Demand )
+import NewDemand ( Demand, DmdResult(..), StrictSig, topSig, isBotRes,
+ isBottomingSig, splitStrictSig, strictSigResInfo
+ )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
- getOccName
+ getOccName, getSrcLoc
)
-import OccName ( UserFS )
+import OccName ( UserFS, mkWorkerOcc )
import PrimRep ( PrimRep )
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
+import Maybes ( orElse )
import SrcLoc ( SrcLoc )
-import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
- getNumBuiltinUniques )
import Outputable
+import Unique ( Unique, mkBuiltinUnique )
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
`setIdDemandInfo`,
`setIdStrictness`,
+ `setIdNewDemandInfo`,
+ `setIdNewStrictness`,
`setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
%* *
%************************************************************************
-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
+Absolutely all Ids are made by mkId. It is just like Var.mkId,
+but in addition it pins free-tyvar-info onto the Id's type,
+where it can easily be found.
\begin{code}
-mkId :: Name -> Type -> IdInfo -> Id
-mkId name ty info = mkIdVar name (addFreeTyVars ty) info
+mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
+mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
+
+mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id
+mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc)
+ (addFreeTyVars ty)
+ vanillaIdInfo
+
+mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
+mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
\end{code}
\begin{code}
-mkVanillaId :: Name -> Type -> Id
-mkVanillaId name ty = mkId name ty vanillaIdInfo
+mkLocalId :: Name -> Type -> Id
+mkLocalId name ty = mkLocalIdWithInfo 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 -> Type -> SrcLoc -> Id
mkSysLocal :: UserFS -> Unique -> Type -> Id
+mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
-mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty
-mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty
+mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty
+mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName uniq occ loc) ty
+mkVanillaGlobal = mkGlobalId VanillaGlobal
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
@Uniques@, but that's OK because the templates are supposed to be
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 SLIT("wild") (mkBuiltinUnique 1) ty
+mkWorkerId :: Unique -> Id -> Type -> Id
+-- A worker gets a local name. CoreTidy will globalise it if necessary.
+mkWorkerId uniq unwrkr ty
+ = mkLocalId wkr_name ty
+ where
+ wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
+
-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
- (getBuiltinUniques (length tys))
- tys
+mkTemplateLocals tys = zipWith mkTemplateLocal [1..] 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
+mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
%* *
%************************************************************************
-\begin{code}
-idFlavour :: Id -> IdFlavour
-idFlavour id = flavourInfo (idInfo id)
+The @SpecPragmaId@ exists only to make Ids that are
+on the *LHS* of bindings created by SPECIALISE pragmas;
+eg: s = f Int d
+The SpecPragmaId is never itself mentioned; it
+exists solely so that the specialiser will find
+the call to f, and make specialised version of it.
+The SpecPragmaId binding is discarded by the specialiser
+when it gathers up overloaded calls.
+Meanwhile, it is not discarded as dead code.
-setIdNoDiscard :: Id -> Id
-setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already
- = modifyIdInfo setNoDiscardInfo id
+\begin{code}
recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case idFlavour id of
- RecordSelId lbl -> lbl
+recordSelectorFieldLabel id = case globalIdDetails id of
+ RecordSelId lbl -> lbl
-isRecordSelector id = case idFlavour id of
+isRecordSelector id = case globalIdDetails id of
RecordSelId lbl -> True
other -> False
-isPrimOpId id = case idFlavour id of
+isPrimOpId id = case globalIdDetails id of
PrimOpId op -> True
other -> False
-isPrimOpId_maybe id = case idFlavour id of
+isPrimOpId_maybe id = case globalIdDetails id of
PrimOpId op -> Just op
other -> Nothing
-isDataConId id = case idFlavour id of
+isFCallId id = case globalIdDetails id of
+ FCallId call -> True
+ other -> False
+
+isFCallId_maybe id = case globalIdDetails id of
+ FCallId call -> Just call
+ other -> Nothing
+
+isDataConId id = case globalIdDetails id of
DataConId _ -> True
other -> False
-isDataConId_maybe id = case idFlavour id of
+isDataConId_maybe id = case globalIdDetails id of
DataConId con -> Just con
other -> Nothing
-isDataConWrapId_maybe id = case idFlavour id of
+isDataConWrapId_maybe id = case globalIdDetails id of
DataConWrapId con -> Just con
other -> Nothing
-isDataConWrapId id = case idFlavour id of
+isDataConWrapId id = case globalIdDetails 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.
+hasNoBinding id = case globalIdDetails id of
+ DataConId _ -> True
+ PrimOpId _ -> True
+ FCallId _ -> True
+ other -> False
-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
-
-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}
-
-
-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}
isImplicitId :: Id -> Bool
+ -- 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.
isImplicitId id
- = case idFlavour id of
+ = case globalIdDetails id of
RecordSelId _ -> True -- Includes dictionary selectors
+ FCallId _ -> True
PrimOpId _ -> True
DataConId _ -> True
DataConWrapId _ -> True
idArity :: Id -> Arity
idArity id = arityLowerBound (idArityInfo id)
-setIdArityInfo :: Id -> ArityInfo -> Id
+setIdArityInfo :: Id -> Arity -> Id
setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
- -- STRICTNESS
+ -- STRICTNESS
idStrictness :: Id -> StrictnessInfo
-idStrictness id = strictnessInfo (idInfo id)
+idStrictness id = case strictnessInfo (idInfo id) of
+ NoStrictnessInfo -> case idNewStrictness_maybe id of
+ Just sig -> oldStrictnessFromNew sig
+ Nothing -> NoStrictnessInfo
+ strictness -> strictness
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 (idStrictness id)
+isBottomingId id = isBottomingSig (idNewStrictness id)
+
+idNewStrictness_maybe :: Id -> Maybe StrictSig
+idNewStrictness :: Id -> StrictSig
+
+idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
+idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
+
+getNewStrictness :: Id -> StrictSig
+-- First tries the "new-strictness" field, and then
+-- reverts to the old one. This is just until we have
+-- cross-module info for new strictness
+getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id
+
+newStrictnessFromOld :: Id -> StrictSig
+newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id)
+
+oldStrictnessFromNew :: StrictSig -> StrictnessInfo
+oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
+ where
+ (dmds, res_info) = splitStrictSig sig
+
+setIdNewStrictness :: Id -> StrictSig -> Id
+setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
+
+zapIdNewStrictness :: Id -> Id
+zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
---------------------------------
-- TYPE GENERALISATION
---------------------------------
-- DEMAND
-idDemandInfo :: Id -> Demand
+idDemandInfo :: Id -> Demand.Demand
idDemandInfo id = demandInfo (idInfo id)
-setIdDemandInfo :: Id -> Demand -> Id
+setIdDemandInfo :: Id -> Demand.Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
+idNewDemandInfo :: Id -> NewDemand.Demand
+idNewDemandInfo id = newDemandInfo (idInfo id)
+
+setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
+
---------------------------------
-- SPECIALISATION
idSpecialisation :: Id -> CoreRules
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
+ -- CG INFO
+idCgInfo :: Id -> CgInfo
+#ifdef DEBUG
+idCgInfo id = case cgInfo (idInfo id) of
+ NoCgInfo -> pprPanic "idCgInfo" (ppr id)
+ info -> info
+#else
+idCgInfo id = cgInfo (idInfo id)
+#endif
+
+setIdCgInfo :: Id -> CgInfo -> Id
+setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id
+
+ ---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
-idCafInfo id = cafInfo (idInfo id)
+#ifdef DEBUG
+idCafInfo id = case cgInfo (idInfo id) of
+ NoCgInfo -> pprPanic "idCafInfo" (ppr id)
+ info -> cgCafInfo info
+#else
+idCafInfo id = cgCafInfo (idCgInfo id)
+#endif
-setIdCafInfo :: Id -> CafInfo -> Id
-setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+ ---------------------------------
+ -- CG ARITY
+idCgArity :: Id -> Arity
+#ifdef DEBUG
+idCgArity id = case cgInfo (idInfo id) of
+ NoCgInfo -> pprPanic "idCgArity" (ppr id)
+ info -> cgArity info
+#else
+idCgArity id = cgArity (idCgInfo id)
+#endif
---------------------------------
-- CPR INFO
idCprInfo :: Id -> CprInfo
-idCprInfo id = cprInfo (idInfo id)
+idCprInfo id = case cprInfo (idInfo id) of
+ NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of
+ RetCPR -> ReturnsCPR
+ other -> NoCPRInfo
+ ReturnsCPR -> ReturnsCPR
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
isOneShotLambda :: Id -> Bool
isOneShotLambda id = analysis || hack
where analysis = case idLBVarInfo id of
- LBVarInfo u | u == usOnce -> True
+ LBVarInfo u | u `eqUsage` usOnce -> True
other -> False
hack = case splitTyConApp_maybe (idType id) of
Just (tycon,_) | tycon == statePrimTyCon -> True
\end{code}
\begin{code}
-zapFragileIdInfo :: Id -> Id
-zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id
-
zapLamIdInfo :: Id -> Id
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
-\end{code}
+zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
+\end{code}
projects / ghc-hetmet.git / blobdiff