X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=c7ce818adb64b34fe7e59fc5ca7542377fd50cd2;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=25ff7b53e4f48cab5b2a33ffa00cc2e0b8fb8a12;hpb=4e7d56fde0f44d38bbb9a6fc72cf9c603264899d;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 25ff7b5..c7ce818 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,100 +8,128 @@ module Id ( Id, DictId, -- Simple construction - mkId, mkVanillaId, mkSysLocal, mkUserLocal, - mkTemplateLocals, mkWildId, mkTemplateLocal, + 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, + zapLamIdInfo, zapDemandIdInfo, -- Predicates - omitIfaceSigForId, - exportWithOrigOccName, - externallyVisibleId, - idFreeTyVars, + 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 - 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, + isOneShotBndr, isOneShotLambda, isStateHackType, + setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, setIdArity, - setIdDemandInfo, - setIdStrictness, + setIdNewDemandInfo, + setIdNewStrictness, zapIdNewStrictness, setIdWorkerInfo, setIdSpecialisation, - setIdUpdateInfo, setIdCafInfo, + setIdOccInfo, + +#ifdef OLD_STRICTNESS + idDemandInfo, + idStrictness, + idCprInfo, + setIdStrictness, + setIdDemandInfo, setIdCprInfo, - - getIdArity, - getIdDemandInfo, - getIdStrictness, - getIdWorkerInfo, - getIdUnfolding, - getIdSpecialisation, - getIdUpdateInfo, - getIdCafInfo, - getIdCprInfo +#endif + + idArity, + idNewDemandInfo, idNewDemandInfo_maybe, + idNewStrictness, idNewStrictness_maybe, + idWorkerInfo, + idUnfolding, + idSpecialisation, idCoreRules, + idCafInfo, + idLBVarInfo, + idOccInfo, + +#ifdef OLD_STRICTNESS + newStrictnessFromOld -- Temporary +#endif ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreUnfold ( Unfolding ) -import {-# SOURCE #-} CoreSyn ( CoreRules ) +import CoreSyn ( Unfolding, CoreRule ) +import BasicTypes ( Arity ) import Var ( Id, DictId, - isId, mkIdVar, - idName, idType, idUnique, idInfo, - setIdName, setVarType, setIdUnique, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - externallyVisibleId + isId, isExportedId, isLocalId, + idName, idType, idUnique, idInfo, isGlobalId, + setIdName, setIdType, setIdUnique, + setIdExported, setIdNotExported, + setIdInfo, lazySetIdInfo, modifyIdInfo, + maybeModifyIdInfo, + globalIdDetails ) -import VarSet -import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType ) -import IdInfo -import Demand ( Demand, isStrict, wwLazy ) -import Name ( Name, OccName, - mkSysLocalName, mkLocalName, - isWiredInName, isUserExportedName - ) -import Const ( Con(..) ) -import PrimRep ( PrimRep ) -import PrimOp ( PrimOp ) -import TysPrim ( realWorldStatePrimTy ) -import FieldLabel ( FieldLabel(..) ) +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 + +#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 ) 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`, `setIdArity`, - `setIdDemandInfo`, - `setIdStrictness`, + `setIdNewDemandInfo`, + `setIdNewStrictness`, `setIdWorkerInfo`, `setIdSpecialisation`, - `setIdUpdateInfo`, `setInlinePragma`, - `getIdCafInfo`, - `getIdCprInfo` - - -- infixl so you can say (id `set` a `set` b) + `idCafInfo` +#ifdef OLD_STRICTNESS + ,`idCprInfo` + ,`setIdStrictness` + ,`setIdDemandInfo` +#endif \end{code} @@ -112,49 +140,63 @@ infixl 1 `setIdUnfolding`, %* * %************************************************************************ -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' - where - info' | isUserExportedName name = setNoDiscardInfo info - | otherwise = 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 :: FAST_STRING -> Unique -> Type -> Id +mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> 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] +-- 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} @@ -165,12 +207,9 @@ mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty %************************************************************************ \begin{code} -idFreeTyVars :: Id -> TyVarSet -idFreeTyVars id = tyVarsOfType (idType id) - 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) @@ -184,79 +223,106 @@ idPrimRep id = typePrimRep (idType id) %************************************************************************ \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 +recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) +recordSelectorFieldLabel id = case globalIdDetails id of + RecordSelId tycon lbl _ -> (tycon,lbl) + other -> panic "recordSelectorFieldLabel" -isRecordSelector id = case idFlavour id of - RecordSelId lbl -> True +isRecordSelector id = case globalIdDetails id of + RecordSelId {} -> True other -> False -isPrimitiveId_maybe id = case idFlavour id of - ConstantId (PrimOp op) -> Just op - other -> Nothing +isNaughtyRecordSelector id = case globalIdDetails id of + RecordSelId { sel_naughty = n } -> n + other -> False -isDataConId_maybe id = case idFlavour id of - ConstantId (DataCon con) -> Just con - other -> Nothing +isClassOpId_maybe id = case globalIdDetails id of + ClassOpId cls -> Just cls + _other -> Nothing -isConstantId id = case idFlavour id of - ConstantId _ -> True - other -> False - -isSpecPragmaId id = case idFlavour id of - SpecPragmaId -> True - other -> False - --- 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} +isPrimOpId id = case globalIdDetails id of + PrimOpId op -> True + other -> False +isPrimOpId_maybe id = case globalIdDetails id of + PrimOpId op -> Just op + other -> Nothing -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 +isFCallId id = case globalIdDetails id of + FCallId call -> True + other -> False - | otherwise - = case idFlavour id of - RecordSelId _ -> True -- Includes dictionary selectors - ConstantId _ -> True - -- ConstantIds are implied by their type or class decl; +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 :: 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 globalIdDetails id of + RecordSelId {} -> True + FCallId _ -> True + PrimOpId _ -> 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 - - other -> False -- Don't omit! + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + other -> False --- 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 +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 +\end{code} %************************************************************************ @@ -268,82 +334,115 @@ exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id \begin{code} --------------------------------- -- ARITY -getIdArity :: Id -> ArityInfo -getIdArity id = arityInfo (idInfo id) +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) -setIdArity :: Id -> ArityInfo -> Id +setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +#ifdef OLD_STRICTNESS --------------------------------- - -- STRICTNESS -getIdStrictness :: Id -> StrictnessInfo -getIdStrictness id = strictnessInfo (idInfo id) + -- (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 (strictnessInfo (idInfo id)) +isBottomingId id = isBottomingSig (idNewStrictness id) + +idNewStrictness_maybe :: Id -> Maybe StrictSig +idNewStrictness :: Id -> StrictSig -idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n +idNewStrictness_maybe id = newStrictnessInfo (idInfo id) +idNewStrictness id = idNewStrictness_maybe id `orElse` topSig + +setIdNewStrictness :: Id -> StrictSig -> Id +setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id + +zapIdNewStrictness :: Id -> Id +zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) 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 +#ifdef OLD_STRICTNESS --------------------------------- - -- DEMAND -getIdDemandInfo :: Id -> Demand -getIdDemandInfo id = demandInfo (idInfo id) + -- (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 - --------------------------------- - -- UPDATE INFO -getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo id = updateInfo (idInfo id) +idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand +idNewDemandInfo :: Id -> NewDemand.Demand -setIdUpdateInfo :: Id -> UpdateInfo -> Id -setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) 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` Just dmd) id --------------------------------- -- SPECIALISATION -getIdSpecialisation :: Id -> CoreRules -getIdSpecialisation id = specInfo (idInfo id) +idSpecialisation :: Id -> SpecInfo +idSpecialisation id = specInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = specInfoRules (idSpecialisation id) -setIdSpecialisation :: Id -> CoreRules -> Id +setIdSpecialisation :: Id -> SpecInfo -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- -- CAF INFO -getIdCafInfo :: Id -> CafInfo -getIdCafInfo id = cafInfo (idInfo id) +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 -getIdCprInfo :: Id -> CprInfo -getIdCprInfo id = cprInfo (idInfo id) +#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 +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id \end{code} @@ -353,34 +452,37 @@ The inline pragma tells us to be very keen to inline this Id, but it's still 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} -isOneShotLambda :: Id -> Bool -isOneShotLambda id = case lbvarInfo (idInfo id) of - IsOneShotLambda -> True - NoLBVarInfo -> idType id == realWorldStatePrimTy - -- The last clause is a gross hack. It claims that +idLBVarInfo :: Id -> LBVarInfo +idLBVarInfo id = lbvarInfo (idInfo id) + +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 @@ -391,10 +493,37 @@ isOneShotLambda id = case lbvarInfo (idInfo id) of -- 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. + + +-- 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` 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} +zapLamIdInfo :: Id -> Id +zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id + +zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id +\end{code} +