-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
+ lazyId, lazyIdUnfolding, lazyIdKey,
mkRuntimeErrorApp,
rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
tcSplitFunTys, tcSplitForAllTys, mkPredTy
)
-import Module ( Module )
import CoreUtils ( exprType )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
import Literal ( Literal(..), nullAddrLit )
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet )
-import Name ( mkWiredInName, mkFCallName, Name )
-import OccName ( mkVarOcc )
+import Name ( mkFCallName, Name )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon,
mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idNewStrictness, idName
)
-import IdInfo ( IdInfo, noCafIdInfo,
+import IdInfo ( IdInfo, noCafIdInfo, hasCafIdInfo,
setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
setAllStrictnessInfo,
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
-import Char ( ord )
\end{code}
%************************************************************************
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
pAT_ERROR_ID,
- rEC_CON_ERROR_ID
+ rEC_CON_ERROR_ID,
+
+ lazyId
] ++ ghcPrimIds
-- These Ids are exported from GHC.Prim
default_alt | no_default = []
| otherwise = [(DEFAULT, [], error_expr)]
- -- the default branch may have CAF refs, because it calls recSelError etc.
+ -- The default branch may have CAF refs, because it calls recSelError etc.
caf_info | no_default = NoCafRefs
| otherwise = MayHaveCafRefs
\begin{code}
-- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId
- = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info
+ = pcMiscPrelId unsafeCoerceName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- The reason is is here is because we don't provide
-- a way to write this literal in Haskell.
nullAddrId
- = pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info
+ = pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit)
seqId
- = pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info
+ = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
(mkFunTy alphaTy (mkFunTy betaTy betaTy))
[x,y] = mkTemplateLocals [alphaTy, betaTy]
rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
+
+-- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
+-- Used to lazify pseq: pseq a b = a `seq` lazy b
+-- No unfolding: it gets "inlined" by the worker/wrapper pass
+-- Also, no strictness: by being a built-in Id, it overrides all
+-- the info in PrelBase.hi. This is important, because the strictness
+-- analyser will spot it as strict!
+lazyId
+ = pcMiscPrelId lazyIdName ty info
+ where
+ info = noCafIdInfo
+ ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy)
+
+lazyIdUnfolding :: CoreExpr -- Used to expand LazyOp after strictness anal
+lazyIdUnfolding = mkLams [openAlphaTyVar,x] (Var x)
+ where
+ [x] = mkTemplateLocals [openAlphaTy]
\end{code}
@getTag#@ is another function which can't be defined in Haskell. It needs to
\begin{code}
getTagId
- = pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info
+ = pcMiscPrelId getTagName ty info
where
info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
\begin{code}
realWorldPrimId -- :: State# RealWorld
- = pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#")
- realWorldStatePrimTy
+ = pcMiscPrelId realWorldName realWorldStatePrimTy
(noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
where
err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
-rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError")
-rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError")
-
-iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError")
-rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError")
-nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
-pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError")
-nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
+rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
+rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
+iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName
+rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+pAT_ERROR_ID = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName
-- The runtime error Ids take a UTF8-encoded string as argument
-mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy
-runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
+mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
\end{code}
\begin{code}
-eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
+eRROR_ID = pc_bottoming_Id errorName errorTy
errorTy :: Type
errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
%************************************************************************
\begin{code}
-pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id
-pcMiscPrelId key mod str ty info
- = let
- name = mkWiredInName mod (mkVarOcc str) key
- imp = mkVanillaGlobal name ty info -- the usual case...
- in
- imp
+pcMiscPrelId :: Name -> Type -> IdInfo -> Id
+pcMiscPrelId name ty info
+ = mkVanillaGlobal name ty info
-- We lie and say the thing is imported; otherwise, we get into
-- a mess with dependency analysis; e.g., core2stg may heave in
-- random calls to GHCbase.unpackPS__. If GHCbase is the module
-- being compiled, then it's just a matter of luck if the definition
-- will be in "the right place" to be in scope.
-pc_bottoming_Id key mod name ty
- = pcMiscPrelId key mod name ty bottoming_info
+pc_bottoming_Id name ty
+ = pcMiscPrelId name ty bottoming_info
where
+ bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
+ -- Do *not* mark them as NoCafRefs, because they can indeed have
+ -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
+ -- which has some CAFs
+ -- In due course we may arrange that these error-y things are
+ -- regarded by the GC as permanently live, in which case we
+ -- can give them NoCaf info. As it is, any function that calls
+ -- any pc_bottoming_Id will itself have CafRefs, which bloats
+ -- SRTs.
+
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
- bottoming_info = noCafIdInfo `setAllStrictnessInfo` Just strict_sig
- -- these "bottom" out, no matter what their arguments
+ -- These "bottom" out, no matter what their arguments
(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
openAlphaTy = mkTyVarTy openAlphaTyVar
projects / ghc-hetmet.git / blobdiff