X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=bd9fffbf4993a61371116a3ae4a77799638ee23a;hb=5819de0c5d78effa16e4c59987268eadb96b8d1d;hp=1e4097d39ff0ca24e87fd94b488e6ff272044f98;hpb=1553c7788e7f663bfc55813158325d695a21a229;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 1e4097d..bd9fffb 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -9,7 +9,7 @@ module Id ( -- Simple construction mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, - mkSysLocal, mkUserLocal, mkVanillaGlobal, + mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, mkWorkerId, @@ -46,13 +46,12 @@ module Id ( setIdArity, setIdNewDemandInfo, setIdNewStrictness, zapIdNewStrictness, - setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, setIdCgInfo, setIdOccInfo, -#ifdef DEBUG +#ifdef OLD_STRICTNESS idDemandInfo, idStrictness, idCprInfo, @@ -62,18 +61,17 @@ module Id ( #endif idArity, - idNewDemandInfo, + idNewDemandInfo, idNewDemandInfo_maybe, idNewStrictness, idNewStrictness_maybe, - idTyGenInfo, idWorkerInfo, idUnfolding, - idSpecialisation, + idSpecialisation, idCoreRules, idCgInfo, idCafInfo, idLBVarInfo, idOccInfo, -#ifdef DEBUG +#ifdef OLD_STRICTNESS newStrictnessFromOld -- Temporary #endif @@ -82,7 +80,7 @@ module Id ( #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules ) +import CoreSyn ( Unfolding, CoreRules, IdCoreRule, rulesRules ) import BasicTypes ( Arity ) import Var ( Id, DictId, isId, isExportedId, isSpecPragmaId, isLocalId, @@ -94,19 +92,18 @@ import Var ( Id, DictId, ) 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, StrictSig, topSig, isBottomingSig ) +import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) import Name ( Name, OccName, - mkSystemName, mkInternalName, + mkSystemName, mkSystemNameEncoded, mkInternalName, getOccName, getSrcLoc ) -import OccName ( EncodedFS, UserFS, mkWorkerOcc ) +import OccName ( EncodedFS, mkWorkerOcc ) import PrimRep ( PrimRep ) -import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) import Maybes ( orElse ) import SrcLoc ( SrcLoc ) @@ -118,12 +115,11 @@ infixl 1 `setIdUnfolding`, `setIdArity`, `setIdNewDemandInfo`, `setIdNewStrictness`, - `setIdTyGenInfo`, `setIdWorkerInfo`, `setIdSpecialisation`, `setInlinePragma`, `idCafInfo` -#ifdef DEBUG +#ifdef OLD_STRICTNESS ,`idCprInfo` ,`setIdStrictness` ,`setIdDemandInfo` @@ -165,7 +161,11 @@ mkVanillaGlobal :: Name -> Type -> IdInfo -> Id -- 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 (mkSystemName uniq fs) ty +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} @@ -323,7 +323,7 @@ idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id -#ifdef DEBUG +#ifdef OLD_STRICTNESS --------------------------------- -- (OLD) STRICTNESS idStrictness :: Id -> StrictnessInfo @@ -350,14 +350,6 @@ zapIdNewStrictness :: Id -> 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) @@ -373,7 +365,7 @@ idUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id -#ifdef DEBUG +#ifdef OLD_STRICTNESS --------------------------------- -- (OLD) DEMAND idDemandInfo :: Id -> Demand.Demand @@ -383,24 +375,30 @@ setIdDemandInfo :: Id -> Demand.Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id #endif -idNewDemandInfo :: Id -> NewDemand.Demand -idNewDemandInfo id = newDemandInfo (idInfo id) +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` 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 @@ -414,7 +412,7 @@ setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id --------------------------------- -- CAF INFO idCafInfo :: Id -> CafInfo -#ifdef DEBUG +#ifdef OLD_STRICTNESS idCafInfo id = case cgInfo (idInfo id) of NoCgInfo -> pprPanic "idCafInfo" (ppr id) info -> cgCafInfo info @@ -423,7 +421,7 @@ idCafInfo id = cgCafInfo (idCgInfo id) #endif --------------------------------- -- CPR INFO -#ifdef DEBUG +#ifdef OLD_STRICTNESS idCprInfo :: Id -> CprInfo idCprInfo id = cprInfo (idInfo id) @@ -465,34 +463,12 @@ idLBVarInfo :: Id -> LBVarInfo 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