X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=c14875373d24305b65a953762d938684b7e286fd;hp=2555dcc3eb4c6b1b15f98b88a687cebb6a8761c6;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=934a8cdc2b593acdda1263a737aeadfaa029a478 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 2555dcc..c148753 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -15,35 +15,42 @@ ToDo: {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -module PrelRules ( primOpRules, builtinRules ) where +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 #include "HsVersions.h" import CoreSyn -import Id ( mkWildId, idUnfolding ) -import Literal ( Literal(..), mkMachInt, mkMachWord - , literalType - , word2IntLit, int2WordLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , float2DoubleLit, double2FloatLit, litFitsInChar - ) +import MkCore ( mkWildCase ) +import Id +import IdInfo +import Demand +import Literal import PrimOp ( PrimOp(..), tagToEnumKey ) -import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) +import TysWiredIn +import TysPrim import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) -import Type ( tyConAppTyCon, coreEqType ) +import CoreUtils ( cheapEqExpr ) +import CoreUnfold ( exprIsConApp_maybe ) +import TcType ( mkSigmaTy ) +import Type import OccName ( occNameFS ) -import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, - eqStringName, unpackCStringIdKey, inlineIdName ) +import PrelNames import Maybes ( orElse ) import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) +import Constants + import Data.Bits as Bits import Data.Word ( Word ) \end{code} @@ -289,7 +296,9 @@ floatOp2 _ _ _ = Nothing floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal -> Maybe (Expr CoreBndr) floatOp2Z op (MachFloat f1) (MachFloat f2) - | f2 /= 0 = Just (mkFloatVal (f1 `op` f2)) + | (f1 /= 0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + = Just (mkFloatVal (f1 `op` f2)) floatOp2Z _ _ _ = Nothing -------------------------- @@ -302,7 +311,13 @@ doubleOp2 _ _ _ = Nothing doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal -> Maybe (Expr CoreBndr) doubleOp2Z op (MachDouble f1) (MachDouble f2) - | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2)) + | (f1 /= 0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + = Just (mkDoubleVal (f1 `op` f2)) + -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to + -- zero, but we might want to preserve the negative zero here which + -- is representable in Float/Double but not in (normalised) + -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? doubleOp2Z _ _ _ = Nothing @@ -335,12 +350,12 @@ litEq op_name is_eq ru_fn = op_name, ru_nargs = 2, ru_try = rule_fn }] where - rule_fn [Lit lit, expr] = do_lit_eq lit expr - rule_fn [expr, Lit lit] = do_lit_eq lit expr - rule_fn _ = Nothing + rule_fn _ [Lit lit, expr] = do_lit_eq lit expr + rule_fn _ [expr, Lit lit] = do_lit_eq lit expr + rule_fn _ _ = Nothing do_lit_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) boolTy + = Just (mkWildCase expr (literalType lit) boolTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) val_if_eq | is_eq = trueVal @@ -352,14 +367,14 @@ litEq op_name is_eq -- runtime either, and compilation of completely harmless things like -- ((124076834 :: Word32) + (2147483647 :: Word32)) -- would yield a warning. Instead we simply squash the value into the --- Int range, but not in a way suitable for cross-compiling... :-( +-- *target* Int/Word range. intResult :: Integer -> Maybe CoreExpr intResult result - = Just (mkIntVal (toInteger (fromInteger result :: Int))) + = Just (mkIntVal (toInteger (fromInteger result :: TargetInt))) wordResult :: Integer -> Maybe CoreExpr wordResult result - = Just (mkWordVal (toInteger (fromInteger result :: Word))) + = Just (mkWordVal (toInteger (fromInteger result :: TargetWord))) \end{code} @@ -370,7 +385,9 @@ wordResult result %************************************************************************ \begin{code} -mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule] +mkBasicRule :: Name -> Int + -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr) + -> [CoreRule] -- Gives the Rule the same name as the primop itself mkBasicRule op_name n_args rule_fn = [BuiltinRule { ru_name = occNameFS (nameOccName op_name), @@ -382,16 +399,16 @@ oneLit :: Name -> (Literal -> Maybe CoreExpr) oneLit op_name test = mkBasicRule op_name 1 rule_fn where - rule_fn [Lit l1] = test (convFloating l1) - rule_fn _ = Nothing + rule_fn _ [Lit l1] = test (convFloating l1) + rule_fn _ _ = Nothing twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) -> [CoreRule] twoLits op_name test = mkBasicRule op_name 2 rule_fn where - rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) - rule_fn _ = Nothing + rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) + rule_fn _ _ = Nothing -- When excess precision is not requested, cut down the precision of the -- Rational value to that of Float/Double. We confuse host architecture @@ -423,13 +440,41 @@ mkDoubleVal d = Lit (convFloating (MachDouble d)) %* * %************************************************************************ +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +We used to make this check in the type inference engine, but it's quite +ugly to do so, because the delayed constraint solving means that we don't +really know what's going on until the end. It's very much a corner case +because we don't expect the user to call tagToEnum# at all; we merely +generate calls in derived instances of Enum. So we compromise: a +rewrite rule rewrites a bad instance of tagToEnum# to an error call, +and emits a warning. + \begin{code} -tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -tagToEnumRule [Type ty, Lit (MachInt i)] +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 + +tagToEnumRule _ [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of - - [] -> Nothing -- Abstract type (dc:rest) -> ASSERT( null rest ) Just (Var (dataConWorkId dc)) @@ -438,27 +483,28 @@ tagToEnumRule [Type ty, Lit (MachInt i)] tag = fromInteger i tycon = tyConAppTyCon ty -tagToEnumRule _ = Nothing +tagToEnumRule _ _ = Nothing \end{code} + For dataToTag#, we can reduce if either (a) the argument is a constructor (b) the argument is a variable whose unfolding is a known constructor \begin{code} -dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr) -dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] +dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr) +dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] | tag_to_enum `hasKey` tagToEnumKey , ty1 `coreEqType` ty2 = Just tag -- dataToTag (tagToEnum x) ==> x -dataToTagRule [_, val_arg] - | Just (dc,_) <- exprIsConApp_maybe val_arg +dataToTagRule id_unf [_, val_arg] + | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) -dataToTagRule _ = Nothing +dataToTagRule _ _ = Nothing \end{code} %************************************************************************ @@ -509,17 +555,18 @@ builtinRules --------------------------------------------------- -- The rule is this: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n - -match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_append_lit [Type ty1, - Lit (MachStr s1), - c1, - Var unpk `App` Type ty2 - `App` Lit (MachStr s2) - `App` c2 - `App` n - ] +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) +-- = unpackFoldrCString# "foobaz" c n + +match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_append_lit _ [Type ty1, + Lit (MachStr s1), + c1, + Var unpk `App` Type ty2 + `App` Lit (MachStr s2) + `App` c2 + `App` n + ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 = ASSERT( ty1 `coreEqType` ty2 ) @@ -528,26 +575,26 @@ match_append_lit [Type ty1, `App` c1 `App` n) -match_append_lit _ = Nothing +match_append_lit _ _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 -match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_eq_string [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] +match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), + Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackCStringIdKey, unpk2 `hasKey` unpackCStringIdKey = Just (if s1 == s2 then trueVal else falseVal) -match_eq_string _ = Nothing +match_eq_string _ _ = Nothing --------------------------------------------------- -- The rule is this: -- inline f_ty (f a b c) = a b c --- (if f has an unfolding) +-- (if f has an unfolding, EVEN if it's a loop breaker) -- -- It's important to allow the argument to 'inline' to have args itself -- (a) because its more forgiving to allow the programmer to write @@ -557,11 +604,126 @@ match_eq_string _ = Nothing -- programmer can't avoid -- -- Also, don't forget about 'inline's type argument! -match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) +match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline _ (Type _ : e : _) | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (idUnfolding f) + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) -match_inline _ = Nothing -\end{code} +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} +