X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=45b8b4260ba0c7b5aa7efe1e9b78d04e0d869b59;hb=2db30d0659c98890689d26faeac6446b515dfa72;hp=34f769daa6a49a85a5ad901ebfb89d62ccbfb614;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 34f769d..45b8b42 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -19,7 +19,7 @@ module Id ( recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails, + setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapDemandIdInfo, @@ -43,41 +43,49 @@ module Id ( -- IdInfo stuff setIdUnfolding, - setIdArityInfo, - setIdDemandInfo, - setIdStrictness, - setIdTyGenInfo, + setIdArity, + setIdNewDemandInfo, + setIdNewStrictness, zapIdNewStrictness, setIdWorkerInfo, setIdSpecialisation, setIdCgInfo, - setIdCprInfo, setIdOccInfo, - idArity, idArityInfo, - 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, 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 @@ -88,31 +96,35 @@ import Type ( Type, typePrimRep, addFreeTyVars, import IdInfo -import Demand ( Demand ) +import qualified Demand ( Demand ) +import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) import Name ( Name, OccName, - mkSysLocalName, mkLocalName, + mkSystemName, 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`, - `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} @@ -131,10 +143,8 @@ where it can easily be found. 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 @@ -147,11 +157,13 @@ 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 :: 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 (mkSystemName uniq fs) ty +mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkVanillaGlobal = mkGlobalId VanillaGlobal \end{code} @@ -162,14 +174,14 @@ 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 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] @@ -180,7 +192,7 @@ mkTemplateLocalsNum :: Int -> [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} @@ -258,11 +270,12 @@ isDataConWrapId id = case globalIdDetails id of 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 @@ -301,34 +314,37 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) \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 @@ -346,26 +362,40 @@ idUnfolding id = unfoldingInfo (idInfo 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 (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 @@ -379,21 +409,22 @@ setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_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 = cgCafInfo (idCgInfo id) - - --------------------------------- - -- CG ARITY - -idCgArity :: Id -> Arity -idCgArity id = cgArity (idCgInfo id) - +#endif --------------------------------- -- 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 @@ -474,3 +505,4 @@ zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id \end{code} +