X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=7a8a42e26d11115e80d00e51b6db15c056a13546;hb=83d563cb9ede0ba792836e529b1e2929db926355;hp=c14875373d24305b65a953762d938684b7e286fd;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index c148753..7a8a42e 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 @@ -463,25 +450,21 @@ and emits a warning. \begin{code} tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -tagToEnumRule _ [Type ty, _] - | not (is_enum_ty ty) -- See Note [tagToEnum#] - = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) - Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type") - where - is_enum_ty ty = case splitTyConApp_maybe ty of - Just (tc, _) -> isEnumerationTyCon tc - Nothing -> False - +-- If data T a = A | B | C +-- then tag2Enum# (T ty) 2# --> B ty tagToEnumRule _ [Type ty, Lit (MachInt i)] - = ASSERT( isEnumerationTyCon tycon ) - case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of + | Just (tycon, tc_args) <- splitTyConApp_maybe ty + , isEnumerationTyCon tycon + = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of [] -> Nothing -- Abstract type (dc:rest) -> ASSERT( null rest ) - Just (Var (dataConWorkId dc)) + Just (mkTyApps (Var (dataConWorkId dc)) tc_args) + | otherwise -- See Note [tagToEnum#] + = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) + Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type") where correct_tag dc = (dataConTag dc - fIRST_TAG) == tag - tag = fromInteger i - tycon = tyConAppTyCon ty + tag = fromInteger i tagToEnumRule _ _ = Nothing \end{code} @@ -614,116 +597,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} -