X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FbasicTypes%2FMkId.lhs;h=9382d57bdd2757ddadd854b2d3e07a6ffe3fd26b;hb=990dd09b4303a31ffdfc0a696ff9162ccd0e8960;hp=f5f19b62ade1f24fb3ffece204a340dbc2ce34b2;hpb=f2f40c0fd667bf83aab71cce188bd3ccc2096e7f;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index f5f19b6..9382d57 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -25,10 +25,11 @@ module MkId ( -- 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" @@ -72,14 +73,14 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 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 @@ -92,6 +93,7 @@ import PrelNames import Maybe ( isJust ) import Util ( dropList, isSingleton ) import Outputable +import FastString import ListSetOps ( assoc, assocMaybe ) import UnicodeUtil ( stringToUtf8 ) import List ( nubBy ) @@ -115,16 +117,18 @@ wiredInIds -- 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 @@ -152,7 +156,7 @@ mkDataConId :: Name -> DataCon -> Id 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 @@ -179,7 +183,7 @@ mkDataConId work_name data_con 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 @@ -239,9 +243,9 @@ mkDataConWrapId data_con 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 @@ -390,7 +394,7 @@ Similarly for newtypes 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 @@ -451,7 +455,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id -- 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 @@ -512,17 +516,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id 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]) @@ -612,7 +606,7 @@ mkDictSelId name clas 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 @@ -672,7 +666,7 @@ mkPrimOpId prim_op name = mkPrimOpIdName prim_op id = mkGlobalId (PrimOpId prim_op) name ty info - info = noCafNoTyGenIdInfo + info = noCafIdInfo `setSpecInfo` rules `setArityInfo` arity `setAllStrictnessInfo` Just strict_sig @@ -702,7 +696,7 @@ mkFCallId uniq fcall ty name = mkFCallName uniq occ_str - info = noCafNoTyGenIdInfo + info = noCafIdInfo `setArityInfo` arity `setAllStrictnessInfo` Just strict_sig @@ -746,7 +740,7 @@ 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 noCafIdInfo mkDictFunId :: Name -- Name to use for the dict fun; -> Class @@ -756,7 +750,7 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> 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) @@ -816,7 +810,7 @@ another gun with which to shoot yourself in the foot. unsafeCoerceId = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info where - info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] @@ -831,13 +825,13 @@ unsafeCoerceId 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] @@ -853,7 +847,7 @@ evaluate its argument and call the dataToTag# primitive. 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) @@ -878,7 +872,7 @@ This comes up in strictness analysis 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 @@ -911,33 +905,40 @@ not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ 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} @@ -948,7 +949,7 @@ pAR_ERROR_ID %************************************************************************ \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 @@ -965,20 +966,11 @@ pc_bottoming_Id key mod name ty = 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}