X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FPrelRules.lhs;h=10cc821e259a6d6731707b0e68e924da992d3529;hp=8604647a70e27dd95946124d685828beb6c0e514;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=7a327c1297615a9498e7117a0017b09ff2458d53 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 8604647..10cc821 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -15,6 +15,13 @@ ToDo: {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" @@ -28,7 +35,7 @@ import Literal ( Literal(..), mkMachInt, mkMachWord , narrow8WordLit, narrow16WordLit, narrow32WordLit , char2IntLit, int2CharLit , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , float2DoubleLit, double2FloatLit + , float2DoubleLit, double2FloatLit, litFitsInChar ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) @@ -44,13 +51,8 @@ import Name ( Name, nameOccName ) import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) - -import Data.Bits ( Bits(..) ) -#if __GLASGOW_HASKELL__ >= 500 +import Data.Bits as Bits import Data.Word ( Word ) -#else -import Data.Word ( Word64 ) -#endif \end{code} @@ -98,20 +100,21 @@ primOpRules op op_name = primop_rule op primop_rule IntQuotOp = two_lits (intOp2Z quot) primop_rule IntRemOp = two_lits (intOp2Z rem) primop_rule IntNegOp = one_lit negOp + primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL) + primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR) + primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical) -- Word operations -#if __GLASGOW_HASKELL__ >= 500 primop_rule WordAddOp = two_lits (wordOp2 (+)) primop_rule WordSubOp = two_lits (wordOp2 (-)) primop_rule WordMulOp = two_lits (wordOp2 (*)) -#endif primop_rule WordQuotOp = two_lits (wordOp2Z quot) primop_rule WordRemOp = two_lits (wordOp2Z rem) -#if __GLASGOW_HASKELL__ >= 407 primop_rule AndOp = two_lits (wordBitOp2 (.&.)) primop_rule OrOp = two_lits (wordBitOp2 (.|.)) primop_rule XorOp = two_lits (wordBitOp2 xor) -#endif + primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL) + primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical) -- coercions primop_rule Word2IntOp = one_lit (litCoerce word2IntLit) @@ -123,7 +126,7 @@ primOpRules op op_name = primop_rule op primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit) primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit) primop_rule OrdOp = one_lit (litCoerce char2IntLit) - primop_rule ChrOp = one_lit (litCoerce int2CharLit) + primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit) primop_rule Float2IntOp = one_lit (litCoerce float2IntLit) primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit) primop_rule Double2IntOp = one_lit (litCoerce double2IntLit) @@ -203,6 +206,11 @@ so this could be cleaned up. litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr litCoerce fn lit = Just (Lit (fn lit)) +predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr +predLitCoerce p fn lit + | p lit = Just (Lit (fn lit)) + | otherwise = Nothing + -------------------------- cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr cmpOp cmp l1 l2 @@ -223,42 +231,59 @@ cmpOp cmp l1 l2 -------------------------- -negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational -negOp (MachFloat f) = Just (mkFloatVal (-f)) +negOp :: Literal -> Maybe CoreExpr -- Negate +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 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) intOp2 op l1 l2 = Nothing -- Could find LitLit +intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr +-- Like intOp2, but Nothing if i2=0 intOp2Z op (MachInt i1) (MachInt i2) - | i2 /= 0 = Just (mkIntVal (i1 `op` i2)) + | i2 /= 0 = intResult (i1 `op` i2) intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend +intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr + -- Shifts take an Int; hence second arg of op is Int +intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2) +intShiftOp2 op l1 l2 = Nothing + +shiftRightLogical :: Integer -> Int -> Integer +-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do +-- Do this by converting to Word and back. Obviously this won't work for big +-- values, but its ok as we use it here +shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word) + + -------------------------- -#if __GLASGOW_HASKELL__ >= 500 +wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordOp2 op (MachWord w1) (MachWord w2) = wordResult (w1 `op` w2) wordOp2 op l1 l2 = Nothing -- Could find LitLit -#endif +wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordOp2Z op (MachWord w1) (MachWord w2) - | w2 /= 0 = Just (mkWordVal (w1 `op` w2)) + | w2 /= 0 = wordResult (w1 `op` w2) wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend -#if __GLASGOW_HASKELL__ >= 500 -wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) - = Just (mkWordVal (w1 `op` w2)) -#else --- Integer is not an instance of Bits, so we operate on Word64 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2) - = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))) -#endif + = wordResult (w1 `op` w2) wordBitOp2 op l1 l2 = Nothing -- Could find LitLit +wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr + -- Shifts take an Int; hence second arg of op is Int +wordShiftOp2 op (MachWord x) (MachInt n) + = wordResult (x `op` fromInteger n) + -- Do the shift at type Integer +wordShiftOp2 op l1 l2 = Nothing + -------------------------- floatOp2 op (MachFloat f1) (MachFloat f2) = Just (mkFloatVal (f1 `op` f2)) @@ -329,11 +354,9 @@ intResult :: Integer -> Maybe CoreExpr intResult result = Just (mkIntVal (toInteger (fromInteger result :: Int))) -#if __GLASGOW_HASKELL__ >= 500 wordResult :: Integer -> Maybe CoreExpr wordResult result = Just (mkWordVal (toInteger (fromInteger result :: Word))) -#endif \end{code} @@ -434,13 +457,43 @@ dataToTagRule other = Nothing %* * %************************************************************************ +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in rule, there's a danger +that we'll see + + f = ...(eq String x).... + + ....and lower down... + + eqString = ... + +Then a rewrite would give + + f = ...(eqString x)... + ....and lower down... + eqString = ... + +and lo, eqString is not in scope. This only really matters when we get to code +generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole +set of bindings, which sorts out the dependency. Without -O we don't do any rule +rewriting so again we are fine. + +(This whole thing doesn't show up for non-built-in rules because their dependencies +are explicit.) + + \begin{code} builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName 4 match_append_lit, - BuiltinRule FSLIT("EqString") eqStringName 2 match_eq_string, - BuiltinRule FSLIT("Inline") inlineIdName 1 match_inline + = [ BuiltinRule { ru_name = FSLIT("AppendLitString"), ru_fn = unpackCStringFoldrName, + ru_nargs = 4, ru_try = match_append_lit }, + BuiltinRule { ru_name = FSLIT("EqString"), ru_fn = eqStringName, + ru_nargs = 2, ru_try = match_eq_string }, + BuiltinRule { ru_name = FSLIT("Inline"), ru_fn = inlineIdName, + ru_nargs = 2, ru_try = match_inline } ] @@ -481,9 +534,18 @@ match_eq_string other = Nothing --------------------------------------------------- -- The rule is this: --- inline (f a b c) = a b c +-- inline f_ty (f a b c) = a b c -- (if f has an unfolding) -match_inline (e:_) +-- +-- It's important to allow the argument to 'inline' to have args itself +-- (a) because its more forgiving to allow the programmer to write +-- inline f a b c +-- or inline (f a b c) +-- (b) because a polymorphic f wll get a type argument that the +-- programmer can't avoid +-- +-- Also, don't forget about 'inline's type argument! +match_inline (Type _ : e : _) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (idUnfolding f) = Just (mkApps unf args1)