X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=59562a2b2982b58892f2eb677298082e0538d68e;hp=c14875373d24305b65a953762d938684b7e286fd;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=1285cf63bc086f323d6b935948388970ce047f59 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index c148753..59562a2 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -12,35 +12,22 @@ ToDo: (i1 + i2) only if it results in a valid Float. \begin{code} - {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -module PrelRules ( - primOpRules, builtinRules, - - -- Error Ids defined here because may be called here - mkRuntimeErrorApp, mkImpossibleExpr, - rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, - ) where +module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import MkCore ( mkWildCase ) +import MkCore import Id -import IdInfo -import Demand import Literal import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn -import TysPrim import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) import CoreUtils ( cheapEqExpr ) import CoreUnfold ( exprIsConApp_maybe ) -import TcType ( mkSigmaTy ) import Type import OccName ( occNameFS ) import PrelNames @@ -614,116 +601,3 @@ match_inline _ (Type _ : e : _) match_inline _ _ = Nothing \end{code} -%************************************************************************ -%* * -\subsection[PrelVals-error-related]{@error@ and friends; @trace@} -%* * -%************************************************************************ -b -GHC randomly injects these into the code. - -@patError@ is just a version of @error@ for pattern-matching -failures. It knows various ``codes'' which expand to longer -strings---this saves space! - -@absentErr@ is a thing we put in for ``absent'' arguments. They jolly -well shouldn't be yanked on, but if one is, then you will get a -friendly message from @absentErr@ (rather than a totally random -crash). - -@parError@ is a special version of @error@ which the compiler does -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} -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 (mkMachString err_msg) - -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" - -errorName, recSelErrorName, runtimeErrorName :: Name -irrefutPatErrorName, recConErrorName, patErrorName :: Name -nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name -errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID -recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID -runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID -recConErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError") patErrorIdKey pAT_ERROR_ID -noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError") - noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID -nonExhaustiveGuardsErrorName - = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") - nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID - -rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id -pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -pAT_ERROR_ID = mkRuntimeErrorId patErrorName -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName - --- The runtime error Ids take a UTF8-encoded string as argument - -mkRuntimeErrorId :: Name -> Id -mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy - -runtimeErrorTy :: Type -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) -\end{code} - -\begin{code} -eRROR_ID :: Id -eRROR_ID = pc_bottoming_Id errorName 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} - - -%************************************************************************ -%* * -\subsection{Utilities} -%* * -%************************************************************************ - -\begin{code} -pc_bottoming_Id :: Name -> Type -> Id --- Function of arity 1, which diverges after being given one argument -pc_bottoming_Id name ty - = mkVanillaGlobalWithInfo name ty bottoming_info - where - bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig - `setArityInfo` 1 - -- Make arity and strictness agree - - -- 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) - -- These "bottom" out, no matter what their arguments -\end{code} -