-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
- eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID,
- rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID,
+
+ mkRuntimeErrorApp,
+ rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
- aBSENT_ERROR_ID, pAR_ERROR_ID
+ pAT_ERROR_ID
) where
#include "HsVersions.h"
mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idNewStrictness, idName
)
-import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
+import IdInfo ( IdInfo, noCafIdInfo,
setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
setAllStrictnessInfo,
GlobalIdDetails(..), CafInfo(..)
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
- mkTopDmdType, topDmd, evalDmd, lazyDmd,
+ mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
Demand(..), Demands(..) )
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
import Maybe ( isJust )
import Util ( dropList, isSingleton )
import Outputable
+import FastString
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
-- error-reporting functions that they have an 'open'
-- result type. -- sof 1/99]
- aBSENT_ERROR_ID,
- eRROR_ID,
- eRROR_CSTRING_ID,
+ eRROR_ID, -- This one isn't used anywhere else in the compiler
+ -- But we still need it in wiredInIds so that when GHC
+ -- compiles a program that mentions 'error' we don't
+ -- import its type from the interface file; we just get
+ -- the Id defined here. Which has an 'open-tyvar' type.
+
+ rUNTIME_ERROR_ID,
iRREFUT_PAT_ERROR_ID,
nON_EXHAUSTIVE_GUARDS_ERROR_ID,
nO_METHOD_BINDING_ERROR_ID,
- pAR_ERROR_ID,
pAT_ERROR_ID,
- rEC_CON_ERROR_ID,
- rEC_UPD_ERROR_ID
+ rEC_CON_ERROR_ID
] ++ ghcPrimIds
-- These Ids are exported from GHC.Prim
mkDataConId work_name data_con
= mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
where
- info = noCafNoTyGenIdInfo
+ info = noCafIdInfo
`setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
cpr_info | isProductTyCon tycon &&
isDataTyCon tycon &&
arity > 0 &&
- arity <= mAX_CPR_SIZE = RetCPR
+ 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
where
work_id = dataConWorkId data_con
- info = noCafNoTyGenIdInfo
+ info = noCafIdInfo
`setUnfoldingInfo` wrap_unf
- -- The NoCaf-ness is set by noCafNoTyGenIdInfo
+ -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
unN = /\a -> \n:N -> coerce (a->a) n
\begin{code}
-mkRecordSelId tycon field_label unpack_id unpackUtf8_id
+mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
--
-- Annoyingly, we have to pass in the unpackCString# Id, because
-- Use the demand analyser to work out strictness.
-- With all this unpackery it's not easy!
- info = noCafNoTyGenIdInfo
+ info = noCafIdInfo
`setCafInfo` caf_info
`setArityInfo` arity
`setUnfoldingInfo` mkTopUnfolding rhs_w_str
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
field_lbls = dataConFieldLabels data_con
- error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type field_tau, err_string]
- err_string
- | all safeChar full_msg
- = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg)))
- | otherwise
- = App (Var unpackUtf8_id) (Lit (MachStr (_PK_ (stringToUtf8 (map ord full_msg)))))
- where
- safeChar c = c >= '\1' && c <= '\xFF'
- -- TODO: Putting this Unicode stuff here is ugly. Find a better
- -- generic place to make string literals. This logic is repeated
- -- in DsUtils.
+ error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
field_lbl = mkFieldLabel name tycon sel_ty tag
tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
- info = noCafNoTyGenIdInfo
+ info = noCafIdInfo
`setArityInfo` 1
`setUnfoldingInfo` mkTopUnfolding rhs
`setAllStrictnessInfo` Just strict_sig
name = mkPrimOpIdName prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
- info = noCafNoTyGenIdInfo
+ info = noCafIdInfo
`setSpecInfo` rules
`setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
name = mkFCallName uniq occ_str
- info = noCafNoTyGenIdInfo
+ info = noCafIdInfo
`setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
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 noCafIdInfo
mkDictFunId :: Name -- Name to use for the dict fun;
-> Class
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
- = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
+ = mkVanillaGlobal dfun_name dfun_ty noCafIdInfo
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info
where
- info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
nullAddrId
= pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info
where
- info = noCafNoTyGenIdInfo `setUnfoldingInfo`
+ info = noCafIdInfo `setUnfoldingInfo`
mkCompulsoryUnfolding (Lit nullAddrLit)
seqId
= pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info
where
- info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [alphaTyVar,betaTyVar]
getTagId
= pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info
where
- info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#")
realWorldStatePrimTy
- (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
+ (noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
-- which in turn makes INLINE things applied to realWorld# likely
templates, but we don't ever expect to generate code for it.
\begin{code}
-eRROR_ID
- = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
-eRROR_CSTRING_ID
- = pc_bottoming_Id errorCStringIdKey pREL_ERR FSLIT("errorCString")
- (mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy))
-pAT_ERROR_ID
- = generic_ERROR_ID patErrorIdKey FSLIT("patError")
-rEC_SEL_ERROR_ID
- = generic_ERROR_ID recSelErrIdKey FSLIT("recSelError")
-rEC_CON_ERROR_ID
- = generic_ERROR_ID recConErrorIdKey FSLIT("recConError")
-rEC_UPD_ERROR_ID
- = generic_ERROR_ID recUpdErrorIdKey FSLIT("recUpdError")
-iRREFUT_PAT_ERROR_ID
- = generic_ERROR_ID irrefutPatErrorIdKey FSLIT("irrefutPatError")
-nON_EXHAUSTIVE_GUARDS_ERROR_ID
- = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError")
-nO_METHOD_BINDING_ERROR_ID
- = generic_ERROR_ID noMethodBindingErrorIdKey FSLIT("noMethodBindingError")
-
-aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey pREL_ERR FSLIT("absentErr")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
-
-pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey pREL_ERR FSLIT("parError")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
+mkRuntimeErrorApp
+ :: Id -- Should be of type (forall a. Addr# -> a)
+ -- where Addr# points to a UTF8 encoded string
+ -> Type -- The type to instantiate 'a'
+ -> String -- The string to print
+ -> CoreExpr
+
+mkRuntimeErrorApp err_id res_ty err_msg
+ = mkApps (Var err_id) [Type res_ty, err_string]
+ 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")
+
+-- 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)
+\end{code}
+
+\begin{code}
+eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy
+
+errorTy :: Type
+errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+ -- Notice the openAlphaTyVar. It says that "error" can be applied
+ -- to unboxed as well as boxed types. This is OK because it never
+ -- returns, so the return type is irrelevant.
\end{code}
%************************************************************************
\begin{code}
-pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
+pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id
pcMiscPrelId key mod str ty info
= let
name = mkWiredInName mod (mkVarOcc str) key
= pcMiscPrelId key mod name ty bottoming_info
where
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
- bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig
+ bottoming_info = noCafIdInfo `setAllStrictnessInfo` Just strict_sig
-- these "bottom" out, no matter what their arguments
-generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
-
(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
-
-errorTy :: Type
-errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy]
- openAlphaTy)
- -- Notice the openAlphaTyVar. It says that "error" can be applied
- -- to unboxed as well as boxed types. This is OK because it never
- -- returns, so the return type is irrelevant.
\end{code}
projects / ghc-hetmet.git / blobdiff