X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=f53e85d906694310710efa2b8f031dfc14222276;hb=51a571c0f5b0201ea53bec60fcaafb78c01c017e;hp=28bc5dae519f50a1a031b16e85c661a37a571660;hpb=da162afcfc9db8335834bb279217c4707fb67988;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 28bc5da..f53e85d 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,31 +8,29 @@ module Id ( Id, DictId, -- Simple construction - mkId, mkVanillaId, mkSysLocal, mkUserLocal, + mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkSysLocal, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, + mkWorkerId, -- Taking an Id apart idName, idType, idUnique, idInfo, - idPrimRep, isId, + idPrimRep, isId, globalIdDetails, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdNoDiscard, + setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapFragileIdInfo, zapLamIdInfo, + zapLamIdInfo, zapDemandIdInfo, -- Predicates - omitIfaceSigForId, isDeadBinder, - exportWithOrigOccName, - externallyVisibleId, - idFreeTyVars, - isIP, - isSpecPragmaId, isRecordSelector, + isImplicitId, isDeadBinder, + isSpecPragmaId, isExportedId, isLocalId, isGlobalId, + isRecordSelector, isPrimOpId, isPrimOpId_maybe, - isDataConId, isDataConId_maybe, isDataConWrapId, - isDataConWrapId_maybe, + isDataConId, isDataConId_maybe, + isDataConWrapId, isDataConWrapId_maybe, isBottomingId, - isExportedId, isUserExportedId, hasNoBinding, -- Inline pragma stuff @@ -47,6 +45,7 @@ module Id ( setIdArityInfo, setIdDemandInfo, setIdStrictness, + setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, setIdCafInfo, @@ -54,9 +53,9 @@ module Id ( setIdOccInfo, idArity, idArityInfo, - idFlavour, idDemandInfo, idStrictness, + idTyGenInfo, idWorkerInfo, idUnfolding, idSpecialisation, @@ -73,36 +72,38 @@ module Id ( import CoreSyn ( Unfolding, CoreRules ) 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, setVarType, setIdUnique, setIdNoDiscard, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - externallyVisibleId + globalIdDetails, setGlobalIdDetails ) -import VarSet -import Type ( Type, tyVarsOfType, typePrimRep, addFreeTyVars, - seqType, splitTyConApp_maybe ) +import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) +import Type ( Type, typePrimRep, addFreeTyVars, + usOnce, seqType, splitTyConApp_maybe ) import IdInfo import Demand ( Demand ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - isUserExportedName, getOccName, isIPOcc + getOccName, getSrcLoc ) -import OccName ( UserFS ) +import OccName ( UserFS, mkWorkerOcc ) import PrimRep ( PrimRep ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) import SrcLoc ( SrcLoc ) import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques, getNumBuiltinUniques ) +import Outputable infixl 1 `setIdUnfolding`, `setIdArityInfo`, `setIdDemandInfo`, `setIdStrictness`, + `setIdTyGenInfo`, `setIdWorkerInfo`, `setIdSpecialisation`, `setInlinePragma`, @@ -120,41 +121,54 @@ 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' - where - info' | isUserExportedName name = setNoDiscardInfo info - | otherwise = info +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) + noCafIdInfo + +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 noCafIdInfo -- 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 +mkVanillaGlobal :: Name -> Type -> IdInfo -> Id -mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty -mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty +mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty +mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName 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 +mkWorkerId :: Unique -> Id -> Type -> Id +-- A worker gets a local name. CoreTidy will globalise it if necessary. +mkWorkerId uniq unwrkr ty + = mkLocalId wkr_name ty + where + wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr) + -- "Template locals" typically used in unfoldings mkTemplateLocals :: [Type] -> [Id] mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) @@ -162,9 +176,10 @@ mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl")) tys mkTemplateLocalsNum :: Int -> [Type] -> [Id] +-- The Int gives the starting point for unique allocation mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl")) - (getNumBuiltinUniques n (length tys)) - tys + (getNumBuiltinUniques n (length tys)) + tys mkTemplateLocal :: Int -> Type -> Id mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty @@ -178,9 +193,6 @@ mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty %************************************************************************ \begin{code} -idFreeTyVars :: Id -> TyVarSet -idFreeTyVars id = tyVarsOfType (idType id) - setIdType :: Id -> Type -> Id -- Add free tyvar info to the type setIdType id ty = seqType ty `seq` setVarType id (addFreeTyVars ty) @@ -196,84 +208,64 @@ 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 -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 +isDataConId id = case globalIdDetails id of DataConId _ -> True other -> False -isDataConId_maybe id = case idFlavour id of +isDataConId_maybe id = case globalIdDetails id of DataConId con -> Just con other -> Nothing -isDataConWrapId_maybe id = case idFlavour id of +isDataConWrapId_maybe id = case globalIdDetails id of DataConWrapId con -> Just con other -> Nothing -isDataConWrapId id = case idFlavour id of +isDataConWrapId id = case globalIdDetails 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. +hasNoBinding id = case globalIdDetails id of + DataConId _ -> True + PrimOpId _ -> True + other -> False --- Don't drop a binding for an exported Id, --- if it otherwise looks dead. -isExportedId :: Id -> Bool -isExportedId id = isUserExportedId id -- Try this -{- - case idFlavour id of - VanillaId -> False - other -> True -- All the others are no-discard --} - --- Say if an Id was exported by the user --- Implies isExportedId (see mkId above) -isUserExportedId :: Id -> Bool -isUserExportedId id = isUserExportedName (idName id) -\end{code} - - -omitIfaceSigForId 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. - -\begin{code} -omitIfaceSigForId :: Id -> Bool -omitIfaceSigForId id - | otherwise - = case idFlavour id of +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 globalIdDetails id of RecordSelId _ -> True -- Includes dictionary selectors PrimOpId _ -> True DataConId _ -> True @@ -282,22 +274,13 @@ omitIfaceSigForId id -- 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 - - other -> False -- Don't omit! - --- Certain names must be exported with their original occ names, because --- these names are bound by either a class declaration or a data declaration --- or an explicit user export. -exportWithOrigOccName :: Id -> Bool -exportWithOrigOccName id = omitIfaceSigForId id || isUserExportedId id + other -> False \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} @@ -332,6 +315,14 @@ isBottomingId :: Id -> Bool isBottomingId id = isBottomingStrictness (idStrictness 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) @@ -413,11 +404,14 @@ idLBVarInfo :: Id -> LBVarInfo idLBVarInfo id = lbvarInfo (idInfo id) isOneShotLambda :: Id -> Bool -isOneShotLambda id = case idLBVarInfo id of - IsOneShotLambda -> True - NoLBVarInfo -> case splitTyConApp_maybe (idType id) of - Just (tycon,_) -> tycon == statePrimTyCon - other -> False +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 @@ -437,7 +431,7 @@ isOneShotLambda id = case idLBVarInfo id of -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id +setOneShotLambda id = modifyIdInfo (`setLBVarInfo` LBVarInfo usOnce) id clearOneShotLambda :: Id -> Id clearOneShotLambda id @@ -450,20 +444,8 @@ clearOneShotLambda id \end{code} \begin{code} -zapFragileIdInfo :: Id -> Id -zapFragileIdInfo id = maybeModifyIdInfo zapFragileInfo id - zapLamIdInfo :: Id -> Id zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id -\end{code} - - - - - - - - - - +zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id +\end{code}