X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelRules.lhs;h=9cdddc9065738ba1b188eea3852412431346a84a;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=94e4ddbab890c3039ec1aeb3e4fe4a39f97e8926;hpb=5ab261bb3fd75f45a4f219f1399be84208e12463;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 94e4ddb..9cdddc9 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -20,51 +20,58 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import Id ( mkWildId ) -import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord +import Id ( mkWildId, isPrimOpId_maybe ) +import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit , narrow8IntLit, narrow16IntLit, narrow32IntLit , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, float2DoubleLit, double2FloatLit + , float2DoubleLit, double2FloatLit ) import PrimOp ( PrimOp(..), primOpOcc ) -import TysWiredIn ( trueDataConId, falseDataConId ) -import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon ) -import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG ) -import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) -import Type ( tyConAppTyCon, eqType ) -import OccName ( occNameUserString) -import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey ) +import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) +import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) +import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) +import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) +import Type ( tyConAppTyCon, coreEqType ) +import OccName ( occNameFS ) +import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, + eqStringName, unpackCStringIdKey ) +import Maybes ( orElse ) import Name ( Name ) -import Bits ( Bits(..) ) +import Outputable +import FastString +import StaticFlags ( opt_SimplExcessPrecision ) + +import DATA_BITS ( Bits(..) ) #if __GLASGOW_HASKELL__ >= 500 -import Word ( Word ) +import DATA_WORD ( Word ) #else -import Word ( Word64 ) +import DATA_WORD ( Word64 ) #endif -import Outputable -import CmdLineOpts ( opt_SimplExcessPrecision ) \end{code} \begin{code} -primOpRules :: PrimOp -> [CoreRule] -primOpRules op = primop_rule op +primOpRules :: PrimOp -> Name -> [CoreRule] +primOpRules op op_name = primop_rule op where - op_name = _PK_ (occNameUserString (primOpOcc op)) - op_name_case = op_name _APPEND_ SLIT("->case") + rule_name = occNameFS (primOpOcc op) + rule_name_case = rule_name `appendFS` FSLIT("->case") -- A useful shorthand - one_rule rule_fn = [BuiltinRule op_name rule_fn] + one_rule rule_fn = [BuiltinRule { ru_name = rule_name, + ru_fn = op_name, + ru_try = rule_fn }] + case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case, + ru_fn = op_name, + ru_try = rule_fn }] -- ToDo: something for integer-shift ops? -- NotOp - primop_rule AddrNullOp = one_rule nullAddrRule - primop_rule SeqOp = one_rule seqRule primop_rule TagToEnumOp = one_rule tagToEnumRule primop_rule DataToTagOp = one_rule dataToTagRule @@ -124,10 +131,10 @@ primOpRules op = primop_rule op primop_rule DoubleNegOp = one_rule (oneLit negOp) -- Relational operators - primop_rule IntEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)] - primop_rule IntNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)] - primop_rule CharEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)] - primop_rule CharNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)] + primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True) + primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) + primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True) + primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) primop_rule IntGtOp = one_rule (relop (>)) primop_rule IntGeOp = one_rule (relop (>=)) @@ -175,16 +182,14 @@ primOpRules op = primop_rule op %* * %************************************************************************ - IMPORTANT NOTE - -In all these operations we might find a LitLit as an operand; that's -why we have the catch-all Nothing case. +ToDo: the reason these all return Nothing is because there used to be +the possibility of an argument being a litlit. Litlits are now gone, +so this could be cleaned up. \begin{code} -------------------------- litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr -litCoerce fn lit | isLitLitLit lit = Nothing - | otherwise = Just (Lit (fn lit)) +litCoerce fn lit = Just (Lit (fn lit)) -------------------------- cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr @@ -206,10 +211,12 @@ cmpOp cmp l1 l2 -------------------------- -negOp (MachFloat f) = Just (mkFloatVal (-f)) -negOp (MachDouble d) = Just (mkDoubleVal (-d)) -negOp (MachInt i) = intResult (-i) -negOp l = Nothing +negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp (MachFloat f) = Just (mkFloatVal (-f)) +negOp (MachDouble 0.0) = Nothing +negOp (MachDouble d) = Just (mkDoubleVal (-d)) +negOp (MachInt i) = intResult (-i) +negOp l = Nothing -------------------------- intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) @@ -286,7 +293,7 @@ litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr litEq is_eq other = Nothing do_lit_eq is_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) + = Just (Case expr (mkWildId (literalType lit)) boolTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) where @@ -321,9 +328,6 @@ wordResult result \begin{code} type RuleFun = [CoreExpr] -> Maybe CoreExpr -or_rule :: RuleFun -> RuleFun -> RuleFun -or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args - twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2) twoLits rule _ = Nothing @@ -351,10 +355,6 @@ mkFloatVal f = Lit (convFloating (MachFloat f)) mkDoubleVal d = Lit (convFloating (MachDouble d)) \end{code} -\begin{code} -nullAddrRule _ = Just(Lit nullAddrLit) -\end{code} - %************************************************************************ %* * @@ -362,75 +362,15 @@ nullAddrRule _ = Just(Lit nullAddrLit) %* * %************************************************************************ -In the parallel world, we use _seq_ to control the order in which -certain expressions will be evaluated. Operationally, the expression -``_seq_ a b'' evaluates a and then evaluates b. We have an inlining -for _seq_ which translates _seq_ to: - - _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y } - -Now, we know that the seq# primitive will never return 0#, but we -don't let the simplifier know that. We also use a special error -value, parError#, which is *not* a bottoming Id, so as far as the -simplifier is concerned, we have to evaluate seq# a before we know -whether or not y will be evaluated. - -If we didn't have the extra case, then after inlining the compiler might -see: - f p q = case seq# p of { _ -> p+q } - -If it sees that, it can see that f is strict in q, and hence it might -evaluate q before p! The "0# ->" case prevents this happening. -By having the parError# branch we make sure that anything in the -other branch stays there! - -This is fine, but we'd like to get rid of the extraneous code. Hence, -we *do* let the simplifier know that seq# is strict in its argument. -As a result, we hope that `a' will be evaluated before seq# is called. -At this point, we have a very special and magical simpification which -says that ``seq# a'' can be immediately simplified to `1#' if we -know that `a' is already evaluated. - -NB: If we ever do case-floating, we have an extra worry: - - case a of - a' -> let b' = case seq# a of { True -> b; False -> parError# } - in case b' of ... - - => - - case a of - a' -> let b' = case True of { True -> b; False -> parError# } - in case b' of ... - - => - - case a of - a' -> let b' = b - in case b' of ... - - => - - case a of - a' -> case b of ... - -The second case must never be floated outside of the first! - -\begin{code} -seqRule [Type ty, arg] | exprIsValue arg = Just (mkIntVal 1) -seqRule other = Nothing -\end{code} - - \begin{code} tagToEnumRule [Type ty, Lit (MachInt i)] = ASSERT( isEnumerationTyCon tycon ) - case filter correct_tag (tyConDataConsIfAvailable tycon) of + case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of [] -> Nothing -- Abstract type (dc:rest) -> ASSERT( null rest ) - Just (Var (dataConId dc)) + Just (Var (dataConWorkId dc)) where correct_tag dc = (dataConTag dc - fIRST_TAG) == tag tag = fromInteger i @@ -445,12 +385,15 @@ For dataToTag#, we can reduce if either (b) the argument is a variable whose unfolding is a known constructor \begin{code} -dataToTagRule [_, val_arg] - = case exprIsConApp_maybe val_arg of - Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) ) - Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) +dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] + | Just TagToEnumOp <- isPrimOpId_maybe tag_to_enum + , ty1 `coreEqType` ty2 + = Just tag -- dataToTag (tagToEnum x) ==> x - other -> Nothing +dataToTagRule [_, val_arg] + | Just (dc,_) <- exprIsConApp_maybe val_arg + = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) + Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) dataToTagRule other = Nothing \end{code} @@ -462,31 +405,43 @@ dataToTagRule other = Nothing %************************************************************************ \begin{code} -builtinRules :: [(Name, CoreRule)] +builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit_str) + = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit, + BuiltinRule FSLIT("EqString") eqStringName match_eq_string ] -- The rule is this: -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n -match_append_lit_str [Type ty1, - Lit (MachStr s1), - c1, - Var unpk `App` Type ty2 - `App` Lit (MachStr s2) - `App` c2 - `App` n - ] +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 `eqType` ty2 ) + = ASSERT( ty1 `coreEqType` ty2 ) Just (Var unpk `App` Type ty1 - `App` Lit (MachStr (s1 _APPEND_ s2)) + `App` Lit (MachStr (s1 `appendFS` s2)) `App` c1 `App` n) -match_append_lit_str other = Nothing +match_append_lit other = Nothing + +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 + +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 other = Nothing \end{code}