-- And some particular Ids; see below for why they are wired in
wiredInIds,
- unsafeCoerceId, realWorldPrimId,
- eRROR_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
+ unsafeCoerceId, realWorldPrimId, nullAddrId,
+ eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
) where
#include "HsVersions.h"
-import BasicTypes ( Arity )
-import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
- intPrimTy, realWorldStatePrimTy
+import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
+import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, betaTyVar, betaTy,
+ intPrimTy, realWorldStatePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, mkListTy )
-import PrelNames ( pREL_ERR, pREL_GHC )
-import PrelRules ( primOpRule )
+import PrelRules ( primOpRules )
import Rules ( addRule )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
mkTyVarTys, mkClassPred, tcEqPred,
tcSplitFunTys, tcSplitForAllTys, mkPredTy
)
import Module ( Module )
-import CoreUtils ( exprType, mkInlineMe )
+import CoreUtils ( mkInlineMe )
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
-import Literal ( Literal(..) )
+import Literal ( Literal(..), nullAddrLit )
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classTyVars, classSelIds )
import OccName ( mkVarOcc )
import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
import ForeignCall ( ForeignCall )
-import Demand ( wwStrict, wwPrim, mkStrictnessInfo, noStrictnessInfo,
- StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import DataCon ( DataCon,
dataConFieldLabels, dataConRepArity, dataConTyCon,
- dataConArgTys, dataConRepType, dataConRepStrictness,
+ dataConArgTys, dataConRepType,
dataConInstOrigArgTys,
dataConName, dataConTheta,
dataConSig, dataConStrictMarks, dataConId,
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum,
- mkTemplateLocal, idCprInfo, idName
+ mkTemplateLocal, idNewStrictness, idName
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
- exactArity, setUnfoldingInfo, setCprInfo,
- setArityInfo, setSpecInfo, setCgInfo,
- setStrictnessInfo,
+ setUnfoldingInfo,
+ setArityInfo, setSpecInfo, setCgInfo, setCafInfo,
mkNewStrictnessInfo, setNewStrictnessInfo,
GlobalIdDetails(..), CafInfo(..), CprInfo(..),
- CgInfo(..), setCgArity
+ CgInfo
)
+import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
+ mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
+import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique )
import Maybes
aBSENT_ERROR_ID
, eRROR_ID
+ , eRROR_CSTRING_ID
, iRREFUT_PAT_ERROR_ID
, nON_EXHAUSTIVE_GUARDS_ERROR_ID
, nO_METHOD_BINDING_ERROR_ID
, rEC_CON_ERROR_ID
, rEC_UPD_ERROR_ID
- -- These three can't be defined in Haskell
+ -- These can't be defined in Haskell, but they have
+ -- perfectly reasonable unfoldings in Core
, realWorldPrimId
, unsafeCoerceId
+ , nullAddrId
, getTagId
+ , seqId
]
\end{code}
= mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
where
info = noCafNoTyGenIdInfo
- `setCgArity` arity
- `setArityInfo` exactArity arity
- `setCprInfo` cpr_info
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo arity strict_info cpr_info
-
- arity = dataConRepArity data_con
- strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
+ `setArityInfo` arity
+ `setNewStrictnessInfo` Just strict_sig
+
+ arity = dataConRepArity data_con
+
+ strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info)
+ -- Notice that we do *not* say the worker is strict
+ -- even if the data constructor is declared strict
+ -- e.g. data T = MkT !(Int,Int)
+ -- Why? Because the *wrapper* is strict (and its unfolding has case
+ -- expresssions that do the evals) but the *worker* itself is not.
+ -- If we pretend it is strict then when we see
+ -- case x of y -> $wMkT y
+ -- the simplifier thinks that y is "sure to be evaluated" (because
+ -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
+ --
+ -- When the simplifer sees a pattern
+ -- case e of MkT x -> ...
+ -- it uses the dataConRepStrictness of MkT to mark x as evaluated;
+ -- but that's fine... dataConRepStrictness comes from the data con
+ -- not from the worker Id.
tycon = dataConTyCon data_con
cpr_info | isProductTyCon tycon &&
isDataTyCon tycon &&
arity > 0 &&
- arity <= mAX_CPR_SIZE = ReturnsCPR
- | otherwise = NoCPRInfo
- -- ReturnsCPR is only true for products that are real data types;
+ arity <= mAX_CPR_SIZE = RetCPR
+ | otherwise = TopRes
+ -- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
mAX_CPR_SIZE :: Arity
\begin{code}
mkDataConWrapId data_con
- = wrap_id
+ = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
where
- wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
work_id = dataConId data_con
info = noCafNoTyGenIdInfo
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
- `setCprInfo` cpr_info
- -- The Cpr info can be important inside INLINE rhss, where the
- -- wrapper constructor isn't inlined
- `setCgArity` arity
-- The NoCaf-ness is set by noCafNoTyGenIdInfo
- `setArityInfo` exactArity arity
+ `setArityInfo` arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
- `setNewStrictnessInfo` mkNewStrictnessInfo arity noStrictnessInfo cpr_info
+ `setNewStrictnessInfo` Just wrap_sig
- wrap_ty = mkForAllTys all_tyvars $
- mkFunTys all_arg_tys
- result_ty
+ wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
- cpr_info = idCprInfo work_id
+ res_info = strictSigResInfo (idNewStrictness work_id)
+ wrap_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) res_info)
+ -- The Cpr info can be important inside INLINE rhss, where the
+ -- wrapper constructor isn't inlined
+ -- But we are sloppy about the argument demands, because we expect
+ -- to inline the constructor very vigorously.
wrap_rhs | isNewTyCon tycon
= ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
mkFunTy data_ty field_tau
arity = 1 + n_dict_tys + n_field_dict_tys
- info = noCafNoTyGenIdInfo
- `setCgInfo` (CgInfo arity caf_info)
- `setArityInfo` exactArity arity
- `setUnfoldingInfo` unfolding
- -- ToDo: consider adding further IdInfo
- unfolding = mkTopUnfolding sel_rhs
+ (strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
+ -- Use the demand analyser to work out strictness.
+ -- With all this unpackery it's not easy!
+
+ info = noCafNoTyGenIdInfo
+ `setCafInfo` caf_info
+ `setArityInfo` arity
+ `setUnfoldingInfo` mkTopUnfolding rhs_w_str
+ `setNewStrictnessInfo` Just strict_sig
-- Allocate Ids. We do it a funny way round because field_dict_tys is
-- almost always empty. Also note that we use length_tycon_theta
tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
info = noCafNoTyGenIdInfo
- `setCgArity` 1
- `setArityInfo` exactArity 1
- `setUnfoldingInfo` unfolding
-
+ `setArityInfo` 1
+ `setUnfoldingInfo` mkTopUnfolding rhs
+ `setNewStrictnessInfo` Just strict_sig
+
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
- unfolding = mkTopUnfolding rhs
+ -- The strictness signature is of the form U(AAAVAAAA) -> T
+ -- where the V depends on which item we are selecting
+ -- It's worth giving one, so that absence info etc is generated
+ -- even if the selector isn't inlined
+ strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
+ arg_dmd | isNewTyCon tycon = Eval
+ | otherwise = Seq Drop [ if the_arg_id == id then Eval else Abs
+ | id <- arg_ids ]
tyvars = classTyVars clas
info = noCafNoTyGenIdInfo
`setSpecInfo` rules
- `setCgArity` arity
- `setArityInfo` exactArity arity
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo arity strict_info NoCPRInfo
+ `setArityInfo` arity
+ `setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
+ -- Until we modify the primop generation code
- rules = maybe emptyCoreRules (addRule emptyCoreRules id)
- (primOpRule prim_op)
+ rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
-- For each ccall we manufacture a separate CCallOpId, giving it
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
- `setCgArity` arity
- `setArityInfo` exactArity arity
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo arity strict_info NoCPRInfo
+ `setArityInfo` arity
+ `setNewStrictnessInfo` Just strict_sig
(_, tau) = tcSplitForAllTys ty
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
- strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False)
+ strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
\end{code}
%* *
%************************************************************************
+Important notes about dict funs and default methods
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Dict funs and default methods are *not* ImplicitIds. Their definition
+involves user-written code, so we can't figure out their strictness etc
+based on fixed info, as we can for constructors and record selectors (say).
+
+We build them as GlobalIds, but when in the module where they are
+bound, we turn the Id at the *binding site* into an exported LocalId.
+This ensures that they are taken to account by free-variable finding
+and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier
+will propagate the LocalId to all occurrence sites.
+
+Why shouldn't they be bound as GlobalIds? Because, in particular, if
+they are globals, the specialiser floats dict uses above their defns,
+which prevents good simplifications happening. Also the strictness
+analyser treats a occurrence of a GlobalId as imported and assumes it
+contains strictness in its IdInfo, which isn't true if the thing is
+bound in the same module as the occurrence.
+
+It's OK for dfuns to be LocalIds, because we form the instance-env to
+pass on to the next module (md_insts) in CoreTidy, afer tidying
+and globalising the top-level Ids.
+
+BUT make sure they are *exported* LocalIds (setIdLocalExported) so
+that they aren't discarded by the occurrence analyser.
+
\begin{code}
-mkDefaultMethodId dm_name ty
- = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
+mkDefaultMethodId dm_name ty = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
mkDictFunId :: Name -- Name to use for the dict fun;
-> Class
%* *
%************************************************************************
-These two can't be defined in Haskell.
+These Ids can't be defined in Haskell. They could be defined in
+unfoldings in PrelGHC.hi-boot, but we'd have to ensure that they
+were definitely, definitely inlined, because there is no curried
+identifier for them. That's what mkCompulsoryUnfolding does.
+If we had a way to get a compulsory unfolding from an interface file,
+we could do that, but we don't right now.
unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that
just gets expanded into a type coercion wherever it occurs. Hence we
another gun with which to shoot yourself in the foot.
\begin{code}
+-- unsafeCoerce# :: forall a b. a -> b
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
where
[x] = mkTemplateLocals [openAlphaTy]
rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
Note (Coerce openBetaTy openAlphaTy) (Var x)
-\end{code}
+-- nullAddr# :: Addr#
+-- The reason is is here is because we don't provide
+-- a way to write this literal in Haskell.
+nullAddrId
+ = pcMiscPrelId nullAddrIdKey pREL_GHC SLIT("nullAddr#") addrPrimTy info
+ where
+ info = noCafNoTyGenIdInfo `setUnfoldingInfo`
+ mkCompulsoryUnfolding (Lit nullAddrLit)
+
+seqId
+ = pcMiscPrelId seqIdKey pREL_GHC SLIT("seq") ty info
+ where
+ info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+
+
+ ty = mkForAllTys [alphaTyVar,betaTyVar]
+ (mkFunTy alphaTy (mkFunTy betaTy betaTy))
+ [x,y] = mkTemplateLocals [alphaTy, betaTy]
+ rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
+\end{code}
@getTag#@ is another function which can't be defined in Haskell. It needs to
evaluate its argument and call the dataToTag# primitive.
\begin{code}
eRROR_ID
= pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy
+eRROR_CSTRING_ID
+ = pc_bottoming_Id errorCStringIdKey pREL_ERR SLIT("errorCString")
+ (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
rEC_SEL_ERROR_ID
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
- strict_info = mkStrictnessInfo ([wwStrict], True)
- bottoming_info = noCafNoTyGenIdInfo
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo 1 strict_info NoCPRInfo
-
-
+ strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+ bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
-- these "bottom" out, no matter what their arguments
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy