X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FId.lhs;h=c7ce818adb64b34fe7e59fc5ca7542377fd50cd2;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=1a2cb50b7de6b1e4ba876bb8bd081670fead4860;hpb=f714e6b642fd614a9971717045ae47c3d871275e;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 1a2cb50..c7ce818 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -8,28 +8,29 @@ module Id ( Id, DictId, -- Simple construction - mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo, - mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal, + mkGlobalId, mkLocalId, mkLocalIdWithInfo, + mkSysLocal, mkUserLocal, mkVanillaGlobal, mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, mkWorkerId, mkExportedLocalId, -- Taking an Id apart idName, idType, idUnique, idInfo, - idPrimRep, isId, globalIdDetails, + isId, globalIdDetails, idPrimRep, recordSelectorFieldLabel, -- Modifying an Id - setIdName, setIdUnique, Id.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, - isDataConWorkId, isDataConWorkId_maybe, + isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, isBottomingId, idIsFrom, hasNoBinding, @@ -38,7 +39,8 @@ module Id ( -- One shot lambda stuff - isOneShotLambda, setOneShotLambda, clearOneShotLambda, + isOneShotBndr, isOneShotLambda, isStateHackType, + setOneShotLambda, clearOneShotLambda, -- IdInfo stuff setIdUnfolding, @@ -78,38 +80,41 @@ module Id ( #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules, IdCoreRule, rulesRules ) +import CoreSyn ( Unfolding, CoreRule ) import BasicTypes ( Arity ) import Var ( Id, DictId, - isId, isExportedId, isSpecPragmaId, isLocalId, + isId, isExportedId, isLocalId, idName, idType, idUnique, idInfo, isGlobalId, - setIdName, setIdType, setIdUnique, setIdLocalExported, + setIdName, setIdType, setIdUnique, + setIdExported, setIdNotExported, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - globalIdDetails, setGlobalIdDetails + globalIdDetails ) -import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId ) -import Type ( Type, typePrimRep, addFreeTyVars, seqType) - +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 ) #endif -import DataCon ( isUnboxedTupleCon ) +import DataCon ( DataCon, isUnboxedTupleCon ) import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig ) import Name ( Name, OccName, nameIsLocalOrFrom, - mkSystemName, mkSystemNameEncoded, mkInternalName, - getOccName, getSrcLoc - ) + mkSystemVarName, mkInternalName, getOccName, + getSrcLoc ) import Module ( Module ) -import OccName ( EncodedFS, mkWorkerOcc ) -import PrimRep ( PrimRep ) -import FieldLabel ( FieldLabel ) +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`, @@ -143,9 +148,6 @@ where it can easily be found. 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 @@ -160,15 +162,10 @@ 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 :: EncodedFS -> Unique -> Type -> Id +mkSysLocal :: FastString -> 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 = mkLocalId (mkSystemVarName uniq fs) ty mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty mkVanillaGlobal = mkGlobalId VanillaGlobal @@ -225,27 +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 @@ -270,6 +264,26 @@ isDataConWorkId_maybe id = case globalIdDetails id of DataConWorkId con -> Just con other -> Nothing +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 @@ -288,7 +302,7 @@ isImplicitId :: Id -> Bool -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case globalIdDetails id of - RecordSelId _ -> True + RecordSelId {} -> True FCallId _ -> True PrimOpId _ -> True ClassOpId _ -> True @@ -389,13 +403,13 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id --------------------------------- -- SPECIALISATION -idSpecialisation :: Id -> CoreRules +idSpecialisation :: Id -> SpecInfo idSpecialisation id = specInfo (idInfo id) -idCoreRules :: Id -> [IdCoreRule] -idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)] +idCoreRules :: Id -> [CoreRule] +idCoreRules id = specInfoRules (idSpecialisation id) -setIdSpecialisation :: Id -> CoreRules -> Id +setIdSpecialisation :: Id -> SpecInfo -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- @@ -455,6 +469,39 @@ modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn ( idLBVarInfo :: Id -> LBVarInfo idLBVarInfo id = lbvarInfo (idInfo id) +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 + -- 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. + + +-- The OneShotLambda functions simply fiddle with the IdInfo flag isOneShotLambda :: Id -> Bool isOneShotLambda id = case idLBVarInfo id of IsOneShotLambda -> True