X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FId.lhs;h=65ab644fb1dfbc3e3d2cfc41dbfa0d622e2db189;hb=aae915d6743e4c0986625f142df1fbc1384ff8df;hp=b72d8c2fa4b6e6a97c582987618c1c8ece32c439;hpb=6a944ae7fe1e8e2e456c68717188463263f8978f;p=ghc-hetmet.git diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index b72d8c2..65ab644 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -30,7 +30,7 @@ module Id ( mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, + mkWorkerId, mkWiredInIdName, -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, @@ -67,34 +67,24 @@ module Id ( -- ** Reading 'IdInfo' fields idArity, - idNewDemandInfo, idNewDemandInfo_maybe, - idNewStrictness, idNewStrictness_maybe, + idDemandInfo, idDemandInfo_maybe, + idStrictness, idStrictness_maybe, idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLBVarInfo, idOccInfo, -#ifdef OLD_STRICTNESS - idDemandInfo, - idStrictness, - idCprInfo, -#endif - -- ** Writing 'IdInfo' fields + setIdUnfoldingLazily, setIdUnfolding, setIdArity, - setIdNewDemandInfo, - setIdNewStrictness, zapIdNewStrictness, + setIdDemandInfo, + setIdStrictness, zapIdStrictness, setIdSpecialisation, setIdCafInfo, setIdOccInfo, zapIdOccInfo, -#ifdef OLD_STRICTNESS - setIdStrictness, - setIdDemandInfo, - setIdCprInfo, -#endif ) where #include "HsVersions.h" @@ -112,13 +102,9 @@ import qualified Var import TyCon import Type -import TcType import TysPrim -#ifdef OLD_STRICTNESS -import qualified Demand -#endif import DataCon -import NewDemand +import Demand import Name import Module import Class @@ -134,18 +120,16 @@ import Util( count ) import StaticFlags -- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfolding`, +infixl 1 `setIdUnfoldingLazily`, + `setIdUnfolding`, `setIdArity`, - `setIdNewDemandInfo`, - `setIdNewStrictness`, + `setIdOccInfo`, + `setIdDemandInfo`, + `setIdStrictness`, `setIdSpecialisation`, `setInlinePragma`, + `setInlineActivation`, `idCafInfo` -#ifdef OLD_STRICTNESS - ,`idCprInfo` - ,`setIdStrictness` - ,`setIdDemandInfo` -#endif \end{code} %************************************************************************ @@ -188,7 +172,7 @@ localiseId :: Id -> Id -- Make an with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour localiseId id - | isLocalId id && isInternalName name + | ASSERT( isId id ) isLocalId id && isInternalName name = id | otherwise = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id) @@ -276,6 +260,9 @@ mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc)) +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -469,31 +456,21 @@ idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id -#ifdef OLD_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 - -- | Returns true if an application to n args would diverge isBottomingId :: Id -> Bool -isBottomingId id = isBottomingSig (idNewStrictness id) +isBottomingId id = isBottomingSig (idStrictness id) -idNewStrictness_maybe :: Id -> Maybe StrictSig -idNewStrictness :: Id -> StrictSig +idStrictness_maybe :: Id -> Maybe StrictSig +idStrictness :: Id -> StrictSig -idNewStrictness_maybe id = newStrictnessInfo (idInfo id) -idNewStrictness id = idNewStrictness_maybe id `orElse` topSig +idStrictness_maybe id = strictnessInfo (idInfo id) +idStrictness id = idStrictness_maybe id `orElse` topSig -setIdNewStrictness :: Id -> StrictSig -> Id -setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` Just sig) id -zapIdNewStrictness :: Id -> Id -zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` Nothing) id -- | This predicate says whether the 'Id' has a strict demand placed on it or -- has a type such that it can always be evaluated strictly (e.g., an @@ -504,7 +481,7 @@ zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id isStrictId :: Id -> Bool isStrictId id = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - (isStrictDmd (idNewDemandInfo id)) || + (isStrictDmd (idDemandInfo id)) || (isStrictType (idType id)) --------------------------------- @@ -521,27 +498,20 @@ realIdUnfolding :: Id -> Unfolding -- Expose the unfolding if there is one, including for loop breakers realIdUnfolding id = unfoldingInfo (idInfo id) +setIdUnfoldingLazily :: Id -> Unfolding -> Id +setIdUnfoldingLazily id unfolding = modifyIdInfo (`setUnfoldingInfoLazily` unfolding) id + setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id -#ifdef OLD_STRICTNESS - --------------------------------- - -- (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 +idDemandInfo_maybe :: Id -> Maybe Demand +idDemandInfo :: Id -> Demand -idNewDemandInfo_maybe id = newDemandInfo (idInfo id) -idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd +idDemandInfo_maybe id = demandInfo (idInfo id) +idDemandInfo id = demandInfo (idInfo id) `orElse` topDmd -setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id -setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` Just dmd) id --------------------------------- -- SPECIALISATION @@ -563,28 +533,12 @@ 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 idOccInfo :: Id -> OccInfo idOccInfo id = occInfo (idInfo id) @@ -705,29 +659,44 @@ zapFragileIdInfo = zapInfo zapFragileInfo Note [transferPolyIdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have +This transfer is used in two places: + FloatOut (long-distance let-floating) + SimplUtils.abstractFloats (short-distance let-floating) + +Consider the short-distance let-floating: f = /\a. let g = rhs in ... -where g has interesting strictness information. Then if we float thus +Then if we float thus g' = /\a. rhs - f = /\a. ...[g' a/g] + f = /\a. ...[g' a/g].... we *do not* want to lose g's * strictness information * arity * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get -It's simple to retain strictness and arity, but not so simple to retain + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see Trac #4345. + +It's not so simple to retain * worker info * rules so we simply discard those. Sooner or later this may bite us. -This transfer is used in two places: - FloatOut (long-distance let-floating) - SimplUtils.abstractFloats (short-distance let-floating) - If we abstract wrt one or more *value* binders, we must modify the arity and strictness info before transferring it. E.g. f = \x. e @@ -750,11 +719,13 @@ transferPolyIdInfo old_id abstract_wrt new_id old_info = idInfo old_id old_arity = arityInfo old_info old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info new_arity = old_arity + arity_increase - old_strictness = newStrictnessInfo old_info + old_strictness = strictnessInfo old_info new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness - transfer new_info = new_info `setNewStrictnessInfo` new_strictness + transfer new_info = new_info `setStrictnessInfo` new_strictness `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag + `setOccInfo` old_occ_info \end{code}