X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=4b7f131634f6a198239855964504cea1d5d4bf03;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=b1a4a1a5d7223b210f7574524b603a3b23f600c8;hpb=7d841483081735f5f906a6bb5e80249d97f3226b;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index b1a4a1a..4b7f131 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,18 +8,18 @@ module Id ( Id, DictId, -- Simple construction - mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, - mkSysLocal, mkUserLocal, mkVanillaGlobal, + mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, + mkSysLocal, mkSysLocalUnencoded, 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, setIdLocalExported, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapDemandIdInfo, @@ -29,27 +29,26 @@ module Id ( isRecordSelector, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, - isDataConId, isDataConId_maybe, - isDataConWrapId, isDataConWrapId_maybe, - isBottomingId, - hasNoBinding, + isDataConWorkId, isDataConWorkId_maybe, + 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, setIdNewDemandInfo, setIdNewStrictness, zapIdNewStrictness, - setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, - setIdCgInfo, + setIdCafInfo, setIdOccInfo, #ifdef OLD_STRICTNESS @@ -62,13 +61,11 @@ module Id ( #endif idArity, - idNewDemandInfo, + idNewDemandInfo, idNewDemandInfo_maybe, idNewStrictness, idNewStrictness_maybe, - idTyGenInfo, idWorkerInfo, idUnfolding, idSpecialisation, idCoreRules, - idCgInfo, idCafInfo, idLBVarInfo, idOccInfo, @@ -87,38 +84,40 @@ import BasicTypes ( Arity ) import Var ( Id, DictId, isId, isExportedId, isSpecPragmaId, isLocalId, idName, idType, idUnique, idInfo, isGlobalId, - setIdName, setVarType, setIdUnique, setIdLocalExported, + setIdName, setIdType, setIdUnique, setIdLocalExported, 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, mkSpecPragmaId, mkExportedLocalId ) +import Type ( Type, typePrimRep, addFreeTyVars, seqType, + splitTyConApp_maybe, PrimRep ) +import TysPrim ( statePrimTyCon ) import IdInfo +#ifdef OLD_STRICTNESS import qualified Demand ( Demand ) -import NewDemand ( Demand, StrictSig, topSig, isBottomingSig ) -import Name ( Name, OccName, - mkSystemName, mkInternalName, +#endif +import DataCon ( isUnboxedTupleCon ) +import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) +import Name ( Name, OccName, nameIsLocalOrFrom, + mkSystemName, mkSystemNameEncoded, mkInternalName, getOccName, getSrcLoc ) -import OccName ( EncodedFS, UserFS, mkWorkerOcc ) -import PrimRep ( PrimRep ) -import TysPrim ( statePrimTyCon ) +import Module ( Module ) +import OccName ( EncodedFS, mkWorkerOcc ) import FieldLabel ( FieldLabel ) import Maybes ( orElse ) import SrcLoc ( SrcLoc ) import Outputable import Unique ( Unique, mkBuiltinUnique ) +import CmdLineOpts ( opt_NoStateHack ) -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, `setIdArity`, `setIdNewDemandInfo`, `setIdNewStrictness`, - `setIdTyGenInfo`, `setIdWorkerInfo`, `setIdSpecialisation`, `setInlinePragma`, @@ -149,6 +148,9 @@ 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} @@ -165,7 +167,11 @@ 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 (mkSystemName uniq fs) ty +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 + mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkVanillaGlobal = mkGlobalId VanillaGlobal \end{code} @@ -208,7 +214,7 @@ mkTemplateLocal i ty = mkSysLocal FSLIT("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) @@ -236,6 +242,7 @@ Meanwhile, it is not discarded as dead code. recordSelectorFieldLabel :: Id -> FieldLabel recordSelectorFieldLabel id = case globalIdDetails id of RecordSelId lbl -> lbl + other -> panic "recordSelectorFieldLabel" isRecordSelector id = case globalIdDetails id of RecordSelId lbl -> True @@ -257,31 +264,25 @@ 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 - -isDataConWrapId_maybe id = case globalIdDetails id of - DataConWrapId con -> Just con - other -> Nothing +isDataConWorkId id = case globalIdDetails id of + DataConWorkId _ -> True + other -> False -isDataConWrapId id = case globalIdDetails id of - DataConWrapId con -> 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. +-- them at the CorePrep stage. +-- EXCEPT: unboxed tuples, which definitely have no binding hasNoBinding id = case globalIdDetails id of - 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 @@ -289,16 +290,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} @@ -350,14 +355,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) @@ -383,11 +380,14 @@ setIdDemandInfo :: Id -> Demand.Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id #endif -idNewDemandInfo :: Id -> NewDemand.Demand -idNewDemandInfo id = newDemandInfo (idInfo id) +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` dmd) id +setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id --------------------------------- -- SPECIALISATION @@ -401,20 +401,6 @@ setIdSpecialisation :: Id -> CoreRules -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- - -- CG INFO -idCgInfo :: Id -> CgInfo -#ifdef OLD_STRICTNESS -idCgInfo id = case cgInfo (idInfo id) of - NoCgInfo -> pprPanic "idCgInfo" (ppr id) - info -> info -#else -idCgInfo id = cgInfo (idInfo id) -#endif - -setIdCgInfo :: Id -> CgInfo -> Id -setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id - - --------------------------------- -- CAF INFO idCafInfo :: Id -> CafInfo #ifdef OLD_STRICTNESS @@ -422,8 +408,12 @@ 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 + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + --------------------------------- -- CPR INFO #ifdef OLD_STRICTNESS @@ -467,16 +457,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 @@ -494,8 +488,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