X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=1a2cb50b7de6b1e4ba876bb8bd081670fead4860;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=5c9f6e8a754493b360d8c96147f382f0b1d4d111;hpb=150e0a93f0187c4982644ac5bce776cc96b0d65d;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 5c9f6e8..1a2cb50 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,30 +8,30 @@ module Id ( Id, DictId, -- Simple construction - mkId, mkVanillaId, mkSysLocal, mkUserLocal, + mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, + mkWorkerId, mkExportedLocalId, -- Taking an Id apart idName, idType, idUnique, idInfo, - idPrimRep, isId, + idPrimRep, isId, globalIdDetails, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdNoDiscard, + setIdName, setIdUnique, Id.setIdType, setIdLocalExported, setGlobalIdDetails, 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, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isBottomingId, idIsFrom, + hasNoBinding, -- Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, @@ -42,76 +42,89 @@ module Id ( -- 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, CoreRules, IdCoreRule, rulesRules ) import BasicTypes ( Arity ) import Var ( Id, DictId, - isId, mkIdVar, - idName, idType, idUnique, idInfo, - setIdName, setVarType, setIdUnique, + isId, isExportedId, isSpecPragmaId, isLocalId, + idName, idType, idUnique, idInfo, isGlobalId, + setIdName, setIdType, setIdUnique, setIdLocalExported, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - externallyVisibleId + globalIdDetails, setGlobalIdDetails ) -import Type ( Type, typePrimRep, addFreeTyVars, - usOnce, seqType, splitTyConApp_maybe ) +import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType) import IdInfo -import Demand ( Demand ) -import Name ( Name, OccName, - mkSysLocalName, mkLocalName, - nameIsLocallyDefined, - getOccName, isIPOcc +#ifdef OLD_STRICTNESS +import qualified Demand ( Demand ) +#endif +import DataCon ( isUnboxedTupleCon ) +import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) +import Name ( Name, OccName, nameIsLocalOrFrom, + mkSystemName, mkSystemNameEncoded, mkInternalName, + getOccName, getSrcLoc ) -import OccName ( UserFS ) +import Module ( Module ) +import OccName ( EncodedFS, mkWorkerOcc ) import PrimRep ( PrimRep ) -import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) +import Maybes ( orElse ) import SrcLoc ( SrcLoc ) -import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, - getNumBuiltinUniques ) 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} @@ -122,51 +135,71 @@ 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 +mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info + +mkSpecPragmaId :: Name -> Type -> Id +mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo + +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 :: EncodedFS -> Unique -> Type -> Id +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 (mkSystemNameEncoded uniq fs) ty + +-- version to use when the faststring needs to be encoded +mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName 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} @@ -179,7 +212,7 @@ mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty \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) @@ -192,112 +225,89 @@ idPrimRep id = typePrimRep (idType id) %* * %************************************************************************ -\begin{code} -idFlavour :: Id -> IdFlavour -idFlavour id = flavourInfo (idInfo id) +The @SpecPragmaId@ exists only to make Ids that are +on the *LHS* of bindings created by SPECIALISE pragmas; +eg: s = f Int d +The SpecPragmaId is never itself mentioned; it +exists solely so that the specialiser will find +the call to f, and make specialised version of it. +The SpecPragmaId binding is discarded by the specialiser +when it gathers up overloaded calls. +Meanwhile, it is not discarded as dead code. -setIdNoDiscard :: Id -> Id -setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already - = modifyIdInfo setNoDiscardInfo id +\begin{code} recordSelectorFieldLabel :: Id -> FieldLabel -recordSelectorFieldLabel id = case idFlavour id of - RecordSelId lbl -> lbl +recordSelectorFieldLabel id = case globalIdDetails id of + RecordSelId lbl -> lbl + other -> panic "recordSelectorFieldLabel" -isRecordSelector id = case idFlavour id of +isRecordSelector id = case globalIdDetails id of RecordSelId lbl -> True other -> False -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} - - -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. +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 + +-- 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 -\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 - = 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 + -- 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} @@ -310,34 +320,37 @@ isIP id = isIPOcc (getOccName id) \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 @@ -355,37 +368,59 @@ 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 --------------------------------- -- 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 @@ -421,34 +456,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 == 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 @@ -461,10 +474,9 @@ 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}