Id, DictId,
-- Simple construction
- mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
+ 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, setIdExported, setIdNotExported,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
isDataConWorkId, isDataConWorkId_maybe,
- isBottomingId,
- hasNoBinding,
+ isBottomingId, idIsFrom,
+ hasNoBinding,
-- Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
-- One shot lambda stuff
- isOneShotLambda, setOneShotLambda, clearOneShotLambda,
+ isOneShotBndr, isOneShotLambda, isStateHackType,
+ setOneShotLambda, clearOneShotLambda,
-- IdInfo stuff
setIdUnfolding,
#include "HsVersions.h"
-import CoreSyn ( Unfolding, CoreRules, IdCoreRule, rulesRules )
+import CoreSyn ( Unfolding, CoreRules, IdCoreRule(..), rulesRules )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, 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, seqType)
-
+import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
+import TyCon ( FieldLabel, TyCon )
+import Type ( Type, typePrimRep, addFreeTyVars, seqType,
+ splitTyConApp_maybe, PrimRep )
+import TysPrim ( statePrimTyCon )
import IdInfo
#ifdef OLD_STRICTNESS
#endif
import DataCon ( isUnboxedTupleCon )
import NewDemand ( Demand, StrictSig, topDmd, topSig, isBottomingSig )
-import Name ( Name, OccName,
- mkSystemName, mkSystemNameEncoded, mkInternalName,
+import Name ( Name, OccName, nameIsLocalOrFrom,
+ mkSystemVarName, mkSystemVarNameEncoded, mkInternalName,
getOccName, getSrcLoc
)
+import Module ( Module )
import OccName ( EncodedFS, mkWorkerOcc )
-import PrimRep ( PrimRep )
-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`,
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}
-- 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
+mkSysLocal fs uniq ty = mkLocalId (mkSystemVarNameEncoded uniq fs) ty
-- version to use when the faststring needs to be encoded
-mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemName uniq fs) ty
+mkSysLocalUnencoded fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty
mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
mkVanillaGlobal = mkGlobalId VanillaGlobal
\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)
\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
isPrimOpId id = case globalIdDetails id of
-- 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
-- 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}
idSpecialisation id = specInfo (idInfo id)
idCoreRules :: Id -> [IdCoreRule]
-idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
+idCoreRules id = [IdCoreRule id False rule | rule <- rulesRules (idSpecialisation id)]
setIdSpecialisation :: Id -> CoreRules -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
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
projects / ghc-hetmet.git / blobdiff