Id, DictId,
-- Simple construction
- mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+ mkGlobalId, mkLocalId, mkLocalIdWithInfo,
+ mkSysLocal, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
+ mkWorkerId, mkExportedLocalId,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
- idPrimRep, isId,
+ isId, globalIdDetails, idPrimRep,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdNoDiscard,
+ setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
- zapFragileIdInfo, zapLamIdInfo,
+ zapLamIdInfo, zapDemandIdInfo,
-- Predicates
- isImplicitId, isDeadBinder,
- externallyVisibleId,
- isIP,
- isSpecPragmaId, isRecordSelector,
- isPrimOpId, isPrimOpId_maybe, isDictFunId,
- isDataConId, isDataConId_maybe,
- isDataConWrapId, isDataConWrapId_maybe,
- isBottomingId,
- isExportedId, isLocalId,
- hasNoBinding,
+ isImplicitId, isDeadBinder, isDictId,
+ isExportedId, isLocalId, isGlobalId,
+ isRecordSelector, isNaughtyRecordSelector,
+ isClassOpId_maybe,
+ isPrimOpId, isPrimOpId_maybe,
+ isFCallId, isFCallId_maybe,
+ isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon,
+ isBottomingId, idIsFrom,
+ hasNoBinding,
-- Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
-- One shot lambda stuff
- isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+ isOneShotBndr, isOneShotLambda, isStateHackType,
+ setOneShotLambda, clearOneShotLambda,
-- IdInfo stuff
setIdUnfolding,
- setIdArityInfo,
- setIdDemandInfo,
- setIdStrictness,
- setIdTyGenInfo,
+ setIdArity,
+ setIdNewDemandInfo,
+ setIdNewStrictness, zapIdNewStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdCafInfo,
- setIdCprInfo,
setIdOccInfo,
- idArity, idArityInfo,
- idFlavour,
- idDemandInfo,
- idStrictness,
- idTyGenInfo,
+#ifdef OLD_STRICTNESS
+ idDemandInfo,
+ idStrictness,
+ idCprInfo,
+ setIdStrictness,
+ setIdDemandInfo,
+ setIdCprInfo,
+#endif
+
+ idArity,
+ idNewDemandInfo, idNewDemandInfo_maybe,
+ idNewStrictness, idNewStrictness_maybe,
idWorkerInfo,
idUnfolding,
- idSpecialisation,
+ idSpecialisation, idCoreRules,
idCafInfo,
- idCprInfo,
idLBVarInfo,
idOccInfo,
+#ifdef OLD_STRICTNESS
+ newStrictnessFromOld -- Temporary
+#endif
+
) where
#include "HsVersions.h"
-import CoreSyn ( Unfolding, CoreRules )
+import CoreSyn ( Unfolding, CoreRule )
import BasicTypes ( Arity )
import Var ( Id, DictId,
- isId, mkIdVar,
- idName, idType, idUnique, idInfo,
- setIdName, setVarType, setIdUnique,
+ isId, isExportedId, isLocalId,
+ idName, idType, idUnique, idInfo, isGlobalId,
+ setIdName, setIdType, setIdUnique,
+ setIdExported, setIdNotExported,
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
- externallyVisibleId
+ globalIdDetails
)
-import Type ( Type, typePrimRep, addFreeTyVars,
- usOnce, seqType, splitTyConApp_maybe )
-
+import qualified Var ( mkLocalId, mkGlobalId, mkExportedLocalId )
+import TyCon ( FieldLabel, TyCon )
+import Type ( Type, typePrimRep, addFreeTyVars, seqType,
+ splitTyConApp_maybe, PrimRep )
+import TcType ( isDictTy )
+import TysPrim ( statePrimTyCon )
import IdInfo
-import Demand ( Demand )
-import Name ( Name, OccName,
- mkSysLocalName, mkLocalName,
- nameIsLocallyDefined,
- getOccName, isIPOcc
- )
-import OccName ( UserFS )
-import PrimRep ( PrimRep )
-import TysPrim ( statePrimTyCon )
-import FieldLabel ( FieldLabel )
+#ifdef OLD_STRICTNESS
+import qualified Demand ( Demand )
+#endif
+import DataCon ( DataCon, isUnboxedTupleCon )
+import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
+import Name ( Name, OccName, nameIsLocalOrFrom,
+ mkSystemVarName, mkInternalName, getOccName,
+ getSrcLoc )
+import Module ( Module )
+import OccName ( mkWorkerOcc )
+import Maybes ( orElse )
import SrcLoc ( SrcLoc )
-import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
- getNumBuiltinUniques )
import Outputable
+import Unique ( Unique, mkBuiltinUnique )
+import FastString ( FastString )
+import StaticFlags ( opt_NoStateHack )
+-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
- `setIdArityInfo`,
- `setIdDemandInfo`,
- `setIdStrictness`,
- `setIdTyGenInfo`,
+ `setIdArity`,
+ `setIdNewDemandInfo`,
+ `setIdNewStrictness`,
`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}
%* *
%************************************************************************
-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
+
+mkExportedLocalId :: Name -> Type -> Id
+mkExportedLocalId name ty = Var.mkExportedLocalId name (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
+mkSysLocal :: FastString -> Unique -> Type -> Id
+mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
+
+mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
-mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty
-mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty
+mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName 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
+mkWildId ty = mkSysLocal FSLIT("wild") (mkBuiltinUnique 1) ty
+
+mkWorkerId :: Unique -> Id -> Type -> Id
+-- A worker gets a local name. CoreTidy will externalise it if necessary.
+mkWorkerId uniq unwrkr ty
+ = mkLocalId wkr_name ty
+ where
+ wkr_name = mkInternalName 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]
-mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
- (getNumBuiltinUniques n (length tys))
- tys
+-- The Int gives the starting point for unique allocation
+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}
\begin{code}
setIdType :: Id -> Type -> Id
-- Add free tyvar info to the type
-setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty)
+setIdType id ty = seqType ty `seq` Var.setIdType id (addFreeTyVars ty)
idPrimRep :: Id -> PrimRep
idPrimRep id = typePrimRep (idType id)
%************************************************************************
\begin{code}
-idFlavour :: Id -> IdFlavour
-idFlavour id = flavourInfo (idInfo id)
+recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
+recordSelectorFieldLabel id = case globalIdDetails id of
+ RecordSelId tycon lbl _ -> (tycon,lbl)
+ other -> panic "recordSelectorFieldLabel"
-setIdNoDiscard :: Id -> Id
-setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already
- = modifyIdInfo setNoDiscardInfo id
+isRecordSelector id = case globalIdDetails id of
+ RecordSelId {} -> True
+ other -> False
-recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case idFlavour id of
- RecordSelId lbl -> lbl
+isNaughtyRecordSelector id = case globalIdDetails id of
+ RecordSelId { sel_naughty = n } -> n
+ other -> False
-isRecordSelector id = case idFlavour id of
- RecordSelId lbl -> True
- other -> False
+isClassOpId_maybe id = case globalIdDetails id of
+ ClassOpId cls -> Just cls
+ _other -> Nothing
-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
- 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.
-
-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}
-
+isFCallId id = case globalIdDetails id of
+ FCallId call -> True
+ other -> False
+
+isFCallId_maybe id = case globalIdDetails id of
+ FCallId call -> Just call
+ other -> Nothing
+
+isDataConWorkId id = case globalIdDetails id of
+ DataConWorkId _ -> True
+ other -> False
+
+isDataConWorkId_maybe id = case globalIdDetails id of
+ DataConWorkId con -> Just con
+ other -> Nothing
+
+isDataConId_maybe :: Id -> Maybe DataCon
+isDataConId_maybe id = case globalIdDetails id of
+ DataConWorkId con -> Just con
+ DataConWrapId con -> Just con
+ other -> Nothing
+
+idDataCon :: Id -> DataCon
+-- Get from either the worker or the wrapper to the DataCon
+-- Currently used only in the desugarer
+-- INVARIANT: idDataCon (dataConWrapId d) = d
+-- (Remember, dataConWrapId can return either the wrapper or the worker.)
+idDataCon id = case globalIdDetails id of
+ DataConWorkId con -> con
+ DataConWrapId con -> con
+ other -> pprPanic "idDataCon" (ppr id)
+
+
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
+-- 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.
+-- EXCEPT: unboxed tuples, which definitely have no binding
+hasNoBinding id = case globalIdDetails id of
+ PrimOpId _ -> True
+ FCallId _ -> True
+ DataConWorkId dc -> isUnboxedTupleCon dc
+ other -> False
-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
- = ASSERT2( not (omit && nameIsLocallyDefined (idName id)
- && idTyGenInfo id /= TyGenNever),
- ppr id )
- -- mustn't omit type signature for a name whose type might change!
- omit
- where
- omit = isImplicitId' id
-
-isImplicitId' id
- = case idFlavour id of
- RecordSelId _ -> True -- Includes dictionary selectors
+ = case globalIdDetails id of
+ RecordSelId {} -> True
+ FCallId _ -> True
PrimOpId _ -> True
- DataConId _ -> True
+ ClassOpId _ -> True
+ DataConWorkId _ -> 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
-
- ConstantId -> False -- Ordinary Ids
- DictFunId -> False
-
- ExportedId -> False -- I don't think these happen
- VanillaId -> False -- ditto
- SpecPragmaId -> False -- ditto
+ -- The dfun id is not an implicit Id; it must *not* be omitted, because
+ -- it carries version info for the instance decl
+ other -> False
+
+idIsFrom :: Module -> Id -> Bool
+idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
\end{code}
\begin{code}
isDeadBinder :: Id -> Bool
isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr)
| otherwise = False -- TyVars count as not dead
-
-isIP id = isIPOcc (getOccName id)
\end{code}
\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 -> ArityInfo -> 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 = 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
-isBottomingId id = isBottomingStrictness (idStrictness id)
+isBottomingId id = isBottomingSig (idNewStrictness id)
- ---------------------------------
- -- TYPE GENERALISATION
-idTyGenInfo :: Id -> TyGenInfo
-idTyGenInfo id = tyGenInfo (idInfo id)
+idNewStrictness_maybe :: Id -> Maybe StrictSig
+idNewStrictness :: Id -> StrictSig
+
+idNewStrictness_maybe id = newStrictnessInfo (idInfo id)
+idNewStrictness id = idNewStrictness_maybe id `orElse` topSig
-setIdTyGenInfo :: Id -> TyGenInfo -> Id
-setIdTyGenInfo id tygen_info = modifyIdInfo (`setTyGenInfo` tygen_info) id
+setIdNewStrictness :: Id -> StrictSig -> Id
+setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
+
+zapIdNewStrictness :: Id -> Id
+zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
---------------------------------
-- WORKER ID
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
+#ifdef OLD_STRICTNESS
---------------------------------
- -- DEMAND
-idDemandInfo :: Id -> Demand
+ -- (OLD) 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
+#endif
+
+idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand
+idNewDemandInfo :: Id -> NewDemand.Demand
+
+idNewDemandInfo_maybe id = newDemandInfo (idInfo id)
+idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd
+
+setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id
+setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id
---------------------------------
-- SPECIALISATION
-idSpecialisation :: Id -> CoreRules
+idSpecialisation :: Id -> SpecInfo
idSpecialisation id = specInfo (idInfo id)
-setIdSpecialisation :: Id -> CoreRules -> Id
+idCoreRules :: Id -> [CoreRule]
+idCoreRules id = specInfoRules (idSpecialisation id)
+
+setIdSpecialisation :: Id -> SpecInfo -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
-- 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 = cafInfo (idInfo id)
+#endif
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
---------------------------------
-- CPR INFO
+#ifdef OLD_STRICTNESS
idCprInfo :: Id -> CprInfo
idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
+#endif
---------------------------------
-- Occcurrence INFO
idLBVarInfo :: Id -> LBVarInfo
idLBVarInfo id = lbvarInfo (idInfo id)
-isOneShotLambda :: Id -> Bool
-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
+isOneShotBndr :: Id -> Bool
+-- This one is the "business end", called externally.
+-- Its main purpose is to encapsulate the Horrible State Hack
+isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id))
+
+isStateHackType :: Type -> Bool
+isStateHackType ty
+ | opt_NoStateHack
+ = False
+ | otherwise
+ = case splitTyConApp_maybe ty of
+ Just (tycon,_) -> tycon == statePrimTyCon
+ other -> False
+ -- This 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
-- 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.
+
+-- The OneShotLambda functions simply fiddle with the IdInfo flag
+isOneShotLambda :: Id -> Bool
+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
\end{code}
\begin{code}
-zapFragileIdInfo :: Id -> Id
-zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id
-
zapLamIdInfo :: Id -> Id
zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
+
+zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
\end{code}
projects / ghc-hetmet.git / blobdiff