X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprelude%2FPrelRules.lhs;h=9cdddc9065738ba1b188eea3852412431346a84a;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=2c2a2e40abc7772249070269316d5384216a8577;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8;p=ghc-hetmet.git diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 2c2a2e4..9cdddc9 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -20,8 +20,8 @@ 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 @@ -31,19 +31,19 @@ import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord , float2DoubleLit, double2FloatLit ) import PrimOp ( PrimOp(..), primOpOcc ) -import TysWiredIn ( trueDataConId, falseDataConId ) +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, eqType ) -import OccName ( occNameUserString) +import Type ( tyConAppTyCon, coreEqType ) +import OccName ( occNameFS ) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, eqStringName, unpackCStringIdKey ) import Maybes ( orElse ) import Name ( Name ) import Outputable import FastString -import CmdLineOpts ( opt_SimplExcessPrecision ) +import StaticFlags ( opt_SimplExcessPrecision ) import DATA_BITS ( Bits(..) ) #if __GLASGOW_HASKELL__ >= 500 @@ -55,14 +55,19 @@ import DATA_WORD ( Word64 ) \begin{code} -primOpRules :: PrimOp -> [CoreRule] -primOpRules op = primop_rule op +primOpRules :: PrimOp -> Name -> [CoreRule] +primOpRules op op_name = primop_rule op where - op_name = mkFastString (occNameUserString (primOpOcc op)) - op_name_case = op_name `appendFS` FSLIT("->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 @@ -126,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 (>=)) @@ -177,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 @@ -208,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) @@ -288,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 @@ -380,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} @@ -397,11 +405,11 @@ 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 FSLIT("AppendLitString") match_append_lit), - (eqStringName, BuiltinRule FSLIT("EqString") match_eq_string) + = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit, + BuiltinRule FSLIT("EqString") eqStringName match_eq_string ] @@ -418,7 +426,7 @@ match_append_lit [Type ty1, ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 - = ASSERT( ty1 `eqType` ty2 ) + = ASSERT( ty1 `coreEqType` ty2 ) Just (Var unpk `App` Type ty1 `App` Lit (MachStr (s1 `appendFS` s2)) `App` c1