X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=ae1b79903385f6782ce9720c17beedf3501e9ff2;hb=b732f90c9e6b1c0177e04a5f84abac7f50cca4e4;hp=d562a4d45589af6e1578158b2036c14e627f3573;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index d562a4d..ae1b799 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -9,7 +9,7 @@ module Id ( -- Simple construction mkId, mkVanillaId, mkSysLocal, mkUserLocal, - mkTemplateLocals, mkWildId, mkTemplateLocal, + mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, -- Taking an Id apart idName, idType, idUnique, idInfo, @@ -22,90 +22,100 @@ module Id ( zapFragileIdInfo, zapLamIdInfo, -- Predicates - omitIfaceSigForId, + omitIfaceSigForId, isDeadBinder, exportWithOrigOccName, externallyVisibleId, - idFreeTyVars, + idFreeTyVars, + isIP, + isSpecPragmaId, isRecordSelector, + isPrimOpId, isPrimOpId_maybe, + isDataConId, isDataConId_maybe, isDataConWrapId, + isDataConWrapId_maybe, + isBottomingId, + isExportedId, isUserExportedId, + hasNoBinding, -- Inline pragma stuff - getInlinePragma, setInlinePragma, modifyInlinePragma, + idInlinePragma, setInlinePragma, modifyInlinePragma, - isSpecPragmaId, isRecordSelector, - isPrimitiveId_maybe, isDataConId_maybe, - isConstantId, isBottomingId, idAppIsBottom, - isExportedId, isUserExportedId, - mayHaveNoBinding, -- One shot lambda stuff isOneShotLambda, setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, - setIdArity, + setIdArityInfo, setIdDemandInfo, setIdStrictness, setIdWorkerInfo, setIdSpecialisation, - setIdUpdateInfo, setIdCafInfo, setIdCprInfo, setIdOccInfo, - getIdArity, - getIdDemandInfo, - getIdStrictness, - getIdWorkerInfo, - getIdUnfolding, - getIdSpecialisation, - getIdUpdateInfo, - getIdCafInfo, - getIdCprInfo, - getIdOccInfo + idArity, idArityInfo, + idFlavour, + idDemandInfo, + idStrictness, + idWorkerInfo, + idUnfolding, + idSpecialisation, + idCafInfo, + idCprInfo, + idLBVarInfo, + idOccInfo, ) where #include "HsVersions.h" -import {-# SOURCE #-} CoreUnfold ( Unfolding ) -import {-# SOURCE #-} CoreSyn ( CoreRules ) +import CoreSyn ( Unfolding, CoreRules, CoreExpr, Expr(..), + AltCon (..), Alt, mkApps, Arg ) +import BasicTypes ( Arity ) import Var ( Id, DictId, isId, mkIdVar, idName, idType, idUnique, idInfo, setIdName, setVarType, setIdUnique, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + setIdInfo, lazySetIdInfo, modifyIdInfo, + maybeModifyIdInfo, externallyVisibleId ) import VarSet -import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, seqType, splitTyConApp_maybe ) +import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, + seqType, splitAlgTyConApp_maybe, mkTyVarTy, + mkTyConApp, splitTyConApp_maybe) import IdInfo import Demand ( Demand, isStrict, wwLazy ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - isWiredInName, isUserExportedName + isUserExportedName, getOccName, isIPOcc ) import OccName ( UserFS ) -import Const ( Con(..) ) import PrimRep ( PrimRep ) -import PrimOp ( PrimOp ) +import PrimOp ( PrimOp, primOpIsCheap ) import TysPrim ( statePrimTyCon ) -import FieldLabel ( FieldLabel(..) ) +import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) -import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques ) +import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, + getNumBuiltinUniques ) import Outputable - +import TyCon ( TyCon, AlgTyConFlavour(..), ArgVrcs, mkSynTyCon, + mkAlgTyConRep, tyConName, + tyConTyVars, tyConDataCons ) +import DataCon ( DataCon, dataConWrapId, dataConOrigArgTys ) +import Var ( Var ) infixl 1 `setIdUnfolding`, - `setIdArity`, + `setIdArityInfo`, `setIdDemandInfo`, `setIdStrictness`, `setIdWorkerInfo`, `setIdSpecialisation`, - `setIdUpdateInfo`, `setInlinePragma`, - `getIdCafInfo`, - `getIdCprInfo` + `idCafInfo`, + `idCprInfo` -- infixl so you can say (id `set` a `set` b) \end{code} @@ -159,6 +169,11 @@ mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) (getBuiltinUniques (length tys)) tys +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl")) + (getNumBuiltinUniques n (length tys)) + tys + mkTemplateLocal :: Int -> Type -> Id mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty \end{code} @@ -205,29 +220,41 @@ isRecordSelector id = case idFlavour id of RecordSelId lbl -> True other -> False -isPrimitiveId_maybe id = case idFlavour id of - ConstantId (PrimOp op) -> Just op - other -> Nothing +isPrimOpId id = case idFlavour id of + PrimOpId op -> True + other -> False + +isPrimOpId_maybe id = case idFlavour 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 - ConstantId (DataCon con) -> Just con - other -> Nothing + DataConId con -> Just con + other -> Nothing + +isDataConWrapId_maybe id = case idFlavour id of + DataConWrapId con -> Just con + other -> Nothing -isConstantId id = case idFlavour id of - ConstantId _ -> True - other -> False +isDataConWrapId id = case idFlavour id of + DataConWrapId con -> True + other -> False isSpecPragmaId id = case idFlavour id of SpecPragmaId -> True other -> False -mayHaveNoBinding id = isConstantId id - -- mayHaveNoBinding returns True of an Id which may not have a +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. - -- - -- mayHaveNoBinding returns True of some things that *do* have a local binding, - -- so it's only an approximation. That's ok... it's only use for assertions. -- Don't drop a binding for an exported Id, -- if it otherwise looks dead. @@ -250,14 +277,13 @@ in some other interface unfolding. \begin{code} omitIfaceSigForId :: Id -> Bool omitIfaceSigForId id - | isWiredInName (idName id) - = True - | otherwise = case idFlavour id of - RecordSelId _ -> True -- Includes dictionary selectors - ConstantId _ -> True - -- ConstantIds are implied by their type or class decl; + RecordSelId _ -> True -- Includes dictionary selectors + PrimOpId _ -> True + DataConId _ -> 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 @@ -271,6 +297,13 @@ exportWithOrigOccName :: Id -> Bool exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId 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} %************************************************************************ @@ -282,87 +315,79 @@ exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id \begin{code} --------------------------------- -- ARITY -getIdArity :: Id -> ArityInfo -getIdArity id = arityInfo (idInfo id) +idArityInfo :: Id -> ArityInfo +idArityInfo id = arityInfo (idInfo id) + +idArity :: Id -> Arity +idArity id = arityLowerBound (idArityInfo id) -setIdArity :: Id -> ArityInfo -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +setIdArityInfo :: Id -> ArityInfo -> Id +setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- -- STRICTNESS -getIdStrictness :: Id -> StrictnessInfo -getIdStrictness id = strictnessInfo (idInfo id) +idStrictness :: Id -> StrictnessInfo +idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictnessInfo -> Id setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id -- isBottomingId returns true if an application to n args would diverge isBottomingId :: Id -> Bool -isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id)) - -idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n +isBottomingId id = isBottomingStrictness (idStrictness 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 --------------------------------- -- DEMAND -getIdDemandInfo :: Id -> Demand -getIdDemandInfo id = demandInfo (idInfo id) +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) setIdDemandInfo :: Id -> Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id --------------------------------- - -- UPDATE INFO -getIdUpdateInfo :: Id -> UpdateInfo -getIdUpdateInfo id = updateInfo (idInfo id) - -setIdUpdateInfo :: Id -> UpdateInfo -> Id -setIdUpdateInfo id upd_info = modifyIdInfo (`setUpdateInfo` upd_info) id - - --------------------------------- -- SPECIALISATION -getIdSpecialisation :: Id -> CoreRules -getIdSpecialisation id = specInfo (idInfo id) +idSpecialisation :: Id -> CoreRules +idSpecialisation id = specInfo (idInfo id) setIdSpecialisation :: Id -> CoreRules -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- -- CAF INFO -getIdCafInfo :: Id -> CafInfo -getIdCafInfo id = cafInfo (idInfo id) +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) setIdCafInfo :: Id -> CafInfo -> Id setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id --------------------------------- -- CPR INFO -getIdCprInfo :: Id -> CprInfo -getIdCprInfo id = cprInfo (idInfo id) +idCprInfo :: Id -> CprInfo +idCprInfo id = cprInfo (idInfo id) setIdCprInfo :: Id -> CprInfo -> Id setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id --------------------------------- -- Occcurrence INFO -getIdOccInfo :: Id -> OccInfo -getIdOccInfo id = occInfo (idInfo id) +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) setIdOccInfo :: Id -> OccInfo -> Id setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id @@ -375,8 +400,8 @@ 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 @@ -389,8 +414,11 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn ( --------------------------------- -- ONE-SHOT LAMBDAS \begin{code} +idLBVarInfo :: Id -> LBVarInfo +idLBVarInfo id = lbvarInfo (idInfo id) + isOneShotLambda :: Id -> Bool -isOneShotLambda id = case lbvarInfo (idInfo id) of +isOneShotLambda id = case idLBVarInfo id of IsOneShotLambda -> True NoLBVarInfo -> case splitTyConApp_maybe (idType id) of Just (tycon,_) -> tycon == statePrimTyCon @@ -434,3 +462,13 @@ zapLamIdInfo :: Id -> Id zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id \end{code} + + + + + + + + + +