-- Simple construction
mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
- mkSysLocal, mkUserLocal, mkVanillaGlobal,
+ mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
mkWorkerId,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails,
+ setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo,
-- IdInfo stuff
setIdUnfolding,
- setIdArityInfo,
- setIdDemandInfo, setIdNewDemandInfo,
- setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
- setIdTyGenInfo,
+ setIdArity,
+ setIdNewDemandInfo,
+ setIdNewStrictness, zapIdNewStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdCgInfo,
- setIdCprInfo,
setIdOccInfo,
- idArity, idArityInfo,
- idDemandInfo, idNewDemandInfo,
- idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness,
- idTyGenInfo,
+#ifdef OLD_STRICTNESS
+ idDemandInfo,
+ idStrictness,
+ idCprInfo,
+ setIdStrictness,
+ setIdDemandInfo,
+ setIdCprInfo,
+#endif
+
+ idArity,
+ idNewDemandInfo, idNewDemandInfo_maybe,
+ idNewStrictness, idNewStrictness_maybe,
idWorkerInfo,
idUnfolding,
- idSpecialisation,
+ idSpecialisation, idCoreRules,
idCgInfo,
idCafInfo,
- idCgArity,
- idCprInfo,
idLBVarInfo,
idOccInfo,
+#ifdef OLD_STRICTNESS
newStrictnessFromOld -- Temporary
+#endif
) where
#include "HsVersions.h"
-import CoreSyn ( Unfolding, CoreRules )
+import CoreSyn ( Unfolding, CoreRules, IdCoreRule, rulesRules )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
idName, idType, idUnique, idInfo, isGlobalId,
- setIdName, setVarType, setIdUnique, setIdNoDiscard,
+ setIdName, setVarType, setIdUnique, setIdLocalExported,
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
globalIdDetails, setGlobalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import Type ( Type, typePrimRep, addFreeTyVars,
- usOnce, eqUsage, seqType, splitTyConApp_maybe )
+ seqType, splitTyConApp_maybe )
import IdInfo
import qualified Demand ( Demand )
-import NewDemand ( Demand, DmdResult(..), StrictSig, topSig, isBotRes,
- isBottomingSig, splitStrictSig, strictSigResInfo
- )
+import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
import Name ( Name, OccName,
- mkSysLocalName, mkLocalName,
+ mkSystemName, mkSystemNameEncoded, mkInternalName,
getOccName, getSrcLoc
)
-import OccName ( UserFS, mkWorkerOcc )
+import OccName ( EncodedFS, mkWorkerOcc )
import PrimRep ( PrimRep )
-import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
import Maybes ( orElse )
import SrcLoc ( SrcLoc )
import Outputable
import Unique ( Unique, mkBuiltinUnique )
+-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
- `setIdArityInfo`,
- `setIdDemandInfo`,
- `setIdStrictness`,
+ `setIdArity`,
`setIdNewDemandInfo`,
`setIdNewStrictness`,
- `setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
- `idCafInfo`,
- `idCprInfo`
-
- -- infixl so you can say (id `set` a `set` b)
+ `idCafInfo`
+#ifdef OLD_STRICTNESS
+ ,`idCprInfo`
+ ,`setIdStrictness`
+ ,`setIdDemandInfo`
+#endif
\end{code}
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
+mkSpecPragmaId :: Name -> Type -> Id
+mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
-- 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
+mkSysLocal :: EncodedFS -> Unique -> Type -> Id
mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
-mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty
-mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName uniq occ loc) ty
+-- for SysLocal, we assume the base name is already encoded, to avoid
+-- re-encoding the same string over and over again.
+mkSysLocal fs uniq ty = mkLocalId (mkSystemNameEncoded uniq fs) ty
+
+-- version to use when the faststring needs to be encoded
+mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName uniq fs) ty
+
+mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
mkVanillaGlobal = mkGlobalId VanillaGlobal
\end{code}
\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
+mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty
mkWorkerId :: Unique -> Id -> Type -> Id
--- A worker gets a local name. CoreTidy will globalise it if necessary.
+-- A worker gets a local name. CoreTidy will externalise it if necessary.
mkWorkerId uniq unwrkr ty
= mkLocalId wkr_name ty
where
- wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
+ wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys
mkTemplateLocal :: Int -> Type -> Id
-mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
+mkTemplateLocal i ty = mkSysLocal FSLIT("tpl") (mkBuiltinUnique i) ty
\end{code}
DataConWrapId con -> 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 returns True of an Id which may not have a
+-- binding, even though it is defined in this module.
+-- Data constructor workers used to be things of this kind, but
+-- they aren't any more. Instead, we inject a binding for
+-- them at the CorePrep stage.
hasNoBinding id = case globalIdDetails id of
- DataConId _ -> True
PrimOpId _ -> True
FCallId _ -> True
other -> False
\begin{code}
---------------------------------
-- ARITY
-idArityInfo :: Id -> ArityInfo
-idArityInfo id = arityInfo (idInfo id)
-
idArity :: Id -> Arity
-idArity id = arityLowerBound (idArityInfo id)
+idArity id = arityInfo (idInfo id)
-setIdArityInfo :: Id -> Arity -> Id
-setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id
+setIdArity :: Id -> Arity -> Id
+setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
+#ifdef OLD_STRICTNESS
---------------------------------
- -- STRICTNESS
+ -- (OLD) STRICTNESS
idStrictness :: Id -> StrictnessInfo
-idStrictness id = case strictnessInfo (idInfo id) of
- NoStrictnessInfo -> case idNewStrictness_maybe id of
- Just sig -> oldStrictnessFromNew sig
- Nothing -> NoStrictnessInfo
- strictness -> strictness
+idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
+#endif
-- isBottomingId returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
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 = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
---------------------------------
- -- TYPE GENERALISATION
-idTyGenInfo :: Id -> TyGenInfo
-idTyGenInfo id = tyGenInfo (idInfo id)
-
-setIdTyGenInfo :: Id -> TyGenInfo -> Id
-setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
-
- ---------------------------------
-- WORKER ID
idWorkerInfo :: Id -> WorkerInfo
idWorkerInfo id = workerInfo (idInfo id)
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
+#ifdef OLD_STRICTNESS
---------------------------------
- -- DEMAND
+ -- (OLD) DEMAND
idDemandInfo :: Id -> Demand.Demand
idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand.Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
+#endif
+
+idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand
+idNewDemandInfo :: Id -> NewDemand.Demand
-idNewDemandInfo :: Id -> NewDemand.Demand
-idNewDemandInfo id = newDemandInfo (idInfo id)
+idNewDemandInfo_maybe id = newDemandInfo (idInfo id)
+idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd
setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
-setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
---------------------------------
-- SPECIALISATION
idSpecialisation :: Id -> CoreRules
idSpecialisation id = specInfo (idInfo id)
+idCoreRules :: Id -> [IdCoreRule]
+idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
+
setIdSpecialisation :: Id -> CoreRules -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
-- CG INFO
idCgInfo :: Id -> CgInfo
-#ifdef DEBUG
+#ifdef OLD_STRICTNESS
idCgInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCgInfo" (ppr id)
info -> info
---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
+#ifdef OLD_STRICTNESS
+idCafInfo id = case cgInfo (idInfo id) of
+ NoCgInfo -> pprPanic "idCafInfo" (ppr id)
+ info -> cgCafInfo info
+#else
idCafInfo id = cgCafInfo (idCgInfo id)
-
- ---------------------------------
- -- CG ARITY
-idCgArity :: Id -> Arity
-idCgArity id = cgArity (idCgInfo id)
-
+#endif
---------------------------------
-- CPR INFO
+#ifdef OLD_STRICTNESS
idCprInfo :: Id -> CprInfo
-idCprInfo id = case cprInfo (idInfo id) of
- NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of
- RetCPR -> ReturnsCPR
- other -> NoCPRInfo
- ReturnsCPR -> ReturnsCPR
+idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
+#endif
---------------------------------
-- Occcurrence INFO
idLBVarInfo id = lbvarInfo (idInfo id)
isOneShotLambda :: Id -> Bool
-isOneShotLambda id = analysis || hack
- where analysis = case idLBVarInfo id of
- LBVarInfo u | u `eqUsage` 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
- -- 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.
+isOneShotLambda id = case idLBVarInfo id of
+ IsOneShotLambda -> True
+ NoLBVarInfo -> False
setOneShotLambda :: Id -> Id
-setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id
+setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id
clearOneShotLambda :: Id -> Id
clearOneShotLambda id
zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
\end{code}
+