-- 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,
+ 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 BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
- intPrimTy, realWorldStatePrimTy
+ intPrimTy, realWorldStatePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, mkListTy )
-import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
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,
splitProductType
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
+ mkLocalIdWithInfo, setIdNoDiscard,
mkTemplateLocals, mkTemplateLocalsNum,
- mkTemplateLocal, idCprInfo, idName
+ mkTemplateLocal, idNewStrictness, idName
)
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
exactArity, setUnfoldingInfo, setCprInfo,
setArityInfo, setSpecInfo, setCgInfo,
- setStrictnessInfo,
mkNewStrictnessInfo, setNewStrictnessInfo,
GlobalIdDetails(..), CafInfo(..), CprInfo(..),
CgInfo(..), setCgArity
)
+import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
+ mkTopDmdType, topDmd, evalDmd )
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
)
aBSENT_ERROR_ID
, eRROR_ID
+ , eRROR_CSTRING_ID
, iRREFUT_PAT_ERROR_ID
, nON_EXHAUSTIVE_GUARDS_ERROR_ID
, nO_METHOD_BINDING_ERROR_ID
-- Makes the *worker* for the data constructor; that is, the function
-- that takes the reprsentation arguments and builds the constructor.
mkDataConId work_name data_con
- = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
+ = id
where
+ id = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
info = noCafNoTyGenIdInfo
- `setCgArity` arity
- `setArityInfo` exactArity arity
- `setCprInfo` cpr_info
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo arity strict_info cpr_info
+ `setCgArity` arity
+ `setArityInfo` arity
+ `setNewStrictnessInfo` Just strict_sig
arity = dataConRepArity data_con
- strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False)
+ strict_sig = mkStrictSig id arity (mkTopDmdType (replicate arity topDmd) cpr_info)
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
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
- cpr_info = idCprInfo work_id
+ res_info = strictSigResInfo (idNewStrictness work_id)
+ wrap_sig = mkStrictSig wrap_id arity (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 )
arity = 1 + n_dict_tys + n_field_dict_tys
info = noCafNoTyGenIdInfo
`setCgInfo` (CgInfo arity caf_info)
- `setArityInfo` exactArity arity
+ `setArityInfo` arity
`setUnfoldingInfo` unfolding
-- ToDo: consider adding further IdInfo
info = noCafNoTyGenIdInfo
`setCgArity` 1
- `setArityInfo` exactArity 1
+ `setArityInfo` 1
`setUnfoldingInfo` unfolding
-- We no longer use 'must-inline' on record selectors. They'll
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)
= ASSERT( isEmptyVarSet (tyVarsOfType ty) )
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
- mkGlobalId (FCallId fcall) name ty info
+ id
where
+ id = mkGlobalId (FCallId fcall) name ty info
occ_str = showSDocIface (braces (ppr fcall <+> ppr ty))
-- The "occurrence name" of a ccall is the full info about the
-- ccall; it is encoded, but may have embedded spaces etc!
name = mkFCallName uniq occ_str
info = noCafNoTyGenIdInfo
- `setCgArity` arity
- `setArityInfo` exactArity arity
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo arity strict_info NoCPRInfo
+ `setCgArity` arity
+ `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 id arity (mkTopDmdType (replicate arity evalDmd) TopRes)
\end{code}
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
- = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
+ = setIdNoDiscard (mkLocalIdWithInfo dfun_name dfun_ty noCafNoTyGenIdInfo)
+ -- NB: It's important that dict funs are *local* Ids
+ -- This ensures that they are taken to account by free-variable finding
+ -- and dependency analysis (e.g. CoreFVs.exprFreeVars).
+ -- In particular, if they are globals, the
+ -- specialiser floats dict uses above their defns, which prevents
+ -- good simplifications happening.
+ --
+ -- It's OK for them to be locals, because we form the instance-env to
+ -- pass on to the next module (md_insts) in CoreTidy, afer tdying
+ -- and globalising the top-level Ids.
+ --
+ -- BUT Make sure it's an exported Id (setIdNoDiscard) so that it's not dropped!
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
\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
-- will be in "the right place" to be in scope.
pc_bottoming_Id key mod name ty
- = pcMiscPrelId key mod name ty bottoming_info
+ = id
where
- strict_info = mkStrictnessInfo ([wwStrict], True)
- bottoming_info = noCafNoTyGenIdInfo
- `setStrictnessInfo` strict_info
- `setNewStrictnessInfo` mkNewStrictnessInfo 1 strict_info NoCPRInfo
-
-
+ id = pcMiscPrelId key mod name ty bottoming_info
+ arity = 1
+ strict_sig = mkStrictSig id arity (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
projects / ghc-hetmet.git / blobdiff