X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=c7ce818adb64b34fe7e59fc5ca7542377fd50cd2;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=b21292005f7a4f7d0fe8f89f099269a0766a5d63;hpb=713b32a591db467a8e9e266ffa3a3bf453b7d4c3;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index b212920..c7ce818 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,119 +8,128 @@ module Id ( Id, DictId, -- Simple construction - mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkGlobalId, mkLocalId, mkLocalIdWithInfo, mkSysLocal, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, - mkWorkerId, + mkWorkerId, mkExportedLocalId, -- Taking an Id apart idName, idType, idUnique, idInfo, - idPrimRep, isId, globalIdDetails, + isId, globalIdDetails, idPrimRep, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, setIdType, setIdLocalExported, setGlobalIdDetails, + setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapDemandIdInfo, -- Predicates - isImplicitId, isDeadBinder, - isSpecPragmaId, isExportedId, isLocalId, isGlobalId, - isRecordSelector, + isImplicitId, isDeadBinder, isDictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isClassOpId_maybe, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, - isDataConId, isDataConId_maybe, - isDataConWrapId, isDataConWrapId_maybe, - isBottomingId, - hasNoBinding, + isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, + isBottomingId, idIsFrom, + hasNoBinding, -- Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, -- One shot lambda stuff - isOneShotLambda, setOneShotLambda, clearOneShotLambda, + isOneShotBndr, isOneShotLambda, isStateHackType, + setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, setIdArity, - setIdDemandInfo, setIdNewDemandInfo, - setIdStrictness, setIdNewStrictness, zapIdNewStrictness, - setIdTyGenInfo, + setIdNewDemandInfo, + setIdNewStrictness, zapIdNewStrictness, setIdWorkerInfo, setIdSpecialisation, - setIdCgInfo, - setIdCprInfo, + setIdCafInfo, setIdOccInfo, +#ifdef OLD_STRICTNESS + idDemandInfo, + idStrictness, + idCprInfo, + setIdStrictness, + setIdDemandInfo, + setIdCprInfo, +#endif + idArity, - idDemandInfo, idNewDemandInfo, - idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness, - idTyGenInfo, + idNewDemandInfo, idNewDemandInfo_maybe, + idNewStrictness, idNewStrictness_maybe, idWorkerInfo, idUnfolding, - idSpecialisation, - idCgInfo, + idSpecialisation, idCoreRules, idCafInfo, - idCgArity, - idCprInfo, idLBVarInfo, idOccInfo, +#ifdef OLD_STRICTNESS newStrictnessFromOld -- Temporary +#endif ) where #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules ) +import CoreSyn ( Unfolding, CoreRule ) import BasicTypes ( Arity ) import Var ( Id, DictId, - isId, isExportedId, isSpecPragmaId, isLocalId, + isId, isExportedId, isLocalId, idName, idType, idUnique, idInfo, isGlobalId, - setIdName, setVarType, setIdUnique, setIdLocalExported, + setIdName, setIdType, setIdUnique, + setIdExported, setIdNotExported, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - globalIdDetails, setGlobalIdDetails + globalIdDetails ) -import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId ) -import Type ( Type, typePrimRep, addFreeTyVars, - usOnce, eqUsage, seqType, splitTyConApp_maybe ) - +import qualified Var ( mkLocalId, mkGlobalId, mkExportedLocalId ) +import TyCon ( FieldLabel, TyCon ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType, + splitTyConApp_maybe, PrimRep ) +import TcType ( isDictTy ) +import TysPrim ( statePrimTyCon ) import IdInfo +#ifdef OLD_STRICTNESS import qualified Demand ( Demand ) -import NewDemand ( Demand, DmdResult(..), StrictSig, topSig, isBotRes, - isBottomingSig, splitStrictSig, strictSigResInfo - ) -import Name ( Name, OccName, - mkSysLocalName, mkLocalName, - getOccName, getSrcLoc - ) -import OccName ( UserFS, mkWorkerOcc ) -import PrimRep ( PrimRep ) -import TysPrim ( statePrimTyCon ) -import FieldLabel ( FieldLabel ) +#endif +import DataCon ( DataCon, isUnboxedTupleCon ) +import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) +import Name ( Name, OccName, nameIsLocalOrFrom, + mkSystemVarName, mkInternalName, getOccName, + getSrcLoc ) +import Module ( Module ) +import OccName ( mkWorkerOcc ) import Maybes ( orElse ) import SrcLoc ( SrcLoc ) import Outputable import Unique ( Unique, mkBuiltinUnique ) +import FastString ( FastString ) +import StaticFlags ( opt_NoStateHack ) +-- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, `setIdArity`, - `setIdDemandInfo`, - `setIdStrictness`, `setIdNewDemandInfo`, `setIdNewStrictness`, - `setIdTyGenInfo`, `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} @@ -139,10 +148,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 +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 @@ -155,11 +162,12 @@ 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 :: FastString -> 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 +mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty + +mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkVanillaGlobal = mkGlobalId VanillaGlobal \end{code} @@ -170,14 +178,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] @@ -188,7 +196,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} @@ -201,7 +209,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) @@ -214,26 +222,24 @@ idPrimRep id = typePrimRep (idType 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. - - \begin{code} -recordSelectorFieldLabel :: Id -> FieldLabel +recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) recordSelectorFieldLabel id = case globalIdDetails id of - RecordSelId lbl -> lbl + RecordSelId tycon lbl _ -> (tycon,lbl) + other -> panic "recordSelectorFieldLabel" isRecordSelector id = case globalIdDetails id of - RecordSelId lbl -> True + RecordSelId {} -> True other -> False +isNaughtyRecordSelector id = case globalIdDetails id of + RecordSelId { sel_naughty = n } -> n + other -> False + +isClassOpId_maybe id = case globalIdDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + isPrimOpId id = case globalIdDetails id of PrimOpId op -> True other -> False @@ -250,30 +256,45 @@ isFCallId_maybe id = case globalIdDetails id of FCallId call -> Just call other -> Nothing -isDataConId id = case globalIdDetails id of - DataConId _ -> True - other -> False - -isDataConId_maybe id = case globalIdDetails id of - DataConId con -> Just con - other -> Nothing +isDataConWorkId id = case globalIdDetails id of + DataConWorkId _ -> True + other -> False -isDataConWrapId_maybe id = case globalIdDetails id of - DataConWrapId con -> Just con - other -> Nothing +isDataConWorkId_maybe id = case globalIdDetails id of + DataConWorkId con -> Just con + other -> Nothing -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. +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case globalIdDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + other -> Nothing + +idDataCon :: Id -> DataCon +-- Get from either the worker or the wrapper to the DataCon +-- Currently used only in the desugarer +-- INVARIANT: idDataCon (dataConWrapId d) = d +-- (Remember, dataConWrapId can return either the wrapper or the worker.) +idDataCon id = case globalIdDetails id of + DataConWorkId con -> con + DataConWrapId con -> con + other -> pprPanic "idDataCon" (ppr id) + + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +-- 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 - DataConId _ -> True - PrimOpId _ -> True - FCallId _ -> True - other -> False + PrimOpId _ -> True + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc + other -> False isImplicitId :: Id -> Bool -- isImplicitId tells whether an Id's info is implied by other @@ -281,16 +302,20 @@ isImplicitId :: Id -> Bool -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case globalIdDetails id of - RecordSelId _ -> True -- Includes dictionary selectors + 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} @@ -315,17 +340,15 @@ idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +#ifdef OLD_STRICTNESS --------------------------------- - -- STRICTNESS + -- (OLD) STRICTNESS idStrictness :: Id -> StrictnessInfo -idStrictness id = case strictnessInfo (idInfo id) of - NoStrictnessInfo -> case idNewStrictness_maybe id of - Just sig -> oldStrictnessFromNew sig - Nothing -> NoStrictnessInfo - strictness -> strictness +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 @@ -337,20 +360,6 @@ idNewStrictness :: Id -> StrictSig idNewStrictness_maybe id = newStrictnessInfo (idInfo id) idNewStrictness id = idNewStrictness_maybe id `orElse` topSig -getNewStrictness :: Id -> StrictSig --- First tries the "new-strictness" field, and then --- reverts to the old one. This is just until we have --- cross-module info for new strictness -getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id - -newStrictnessFromOld :: Id -> StrictSig -newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id) - -oldStrictnessFromNew :: StrictSig -> StrictnessInfo -oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) - where - (dmds, res_info) = splitStrictSig sig - setIdNewStrictness :: Id -> StrictSig -> Id setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id @@ -358,14 +367,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) @@ -381,75 +382,59 @@ idUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id +#ifdef OLD_STRICTNESS --------------------------------- - -- DEMAND + -- (OLD) DEMAND idDemandInfo :: Id -> Demand.Demand idDemandInfo id = demandInfo (idInfo 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 :: Id -> NewDemand.Demand -idNewDemandInfo id = newDemandInfo (idInfo id) +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 idSpecialisation id = specInfo (idInfo id) -setIdSpecialisation :: Id -> CoreRules -> Id -setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id - - --------------------------------- - -- CG INFO -idCgInfo :: Id -> CgInfo -#ifdef DEBUG -idCgInfo id = case cgInfo (idInfo id) of - NoCgInfo -> pprPanic "idCgInfo" (ppr id) - info -> info -#else -idCgInfo id = cgInfo (idInfo id) -#endif +idCoreRules :: Id -> [CoreRule] +idCoreRules id = specInfoRules (idSpecialisation id) -setIdCgInfo :: Id -> CgInfo -> Id -setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id +setIdSpecialisation :: Id -> SpecInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_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 #else -idCafInfo id = cgCafInfo (idCgInfo id) +idCafInfo id = cafInfo (idInfo id) #endif - --------------------------------- - -- CG ARITY -idCgArity :: Id -> Arity -#ifdef DEBUG -idCgArity id = case cgInfo (idInfo id) of - NoCgInfo -> pprPanic "idCgArity" (ppr id) - info -> cgArity info -#else -idCgArity id = cgArity (idCgInfo 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 = case cprInfo (idInfo id) of - NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of - RetCPR -> ReturnsCPR - other -> NoCPRInfo - ReturnsCPR -> ReturnsCPR +idCprInfo id = cprInfo (idInfo id) setIdCprInfo :: Id -> CprInfo -> Id setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id +#endif --------------------------------- -- Occcurrence INFO @@ -484,16 +469,20 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn ( 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 +isOneShotBndr :: Id -> Bool +-- This one is the "business end", called externally. +-- Its main purpose is to encapsulate the Horrible State Hack +isOneShotBndr id = isOneShotLambda id || (isStateHackType (idType id)) + +isStateHackType :: Type -> Bool +isStateHackType ty + | opt_NoStateHack + = False + | otherwise + = case splitTyConApp_maybe ty of + Just (tycon,_) -> tycon == statePrimTyCon + other -> False + -- This 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 @@ -511,8 +500,15 @@ isOneShotLambda id = analysis || hack -- 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. + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +isOneShotLambda :: Id -> Bool +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