(i1 + i2) only if it results in a valid Float.
\begin{code}
-
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module PrelRules ( primOpRules, builtinRules ) 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
- )
+import MkCore
+import Id
+import Literal
import PrimOp ( PrimOp(..), tagToEnumKey )
-import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
+import TysWiredIn
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 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 ( Bits(..), shiftL, shiftR )
- -- shiftL and shiftR were not always methods of Bits
-#if __GLASGOW_HASKELL__ >= 500
+import Data.Bits as Bits
import Data.Word ( Word )
-#else
-import Data.Word ( Word64 )
-#endif
\end{code}
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)
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)
primop_rule WordEqOp = relop (==)
primop_rule WordNeOp = relop (/=)
- primop_rule other = []
+ primop_rule _ = []
\end{code}
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
go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
- go l1 l2 = Nothing
+ go _ _ = Nothing
--------------------------
negOp (MachDouble 0.0) = Nothing
negOp (MachDouble d) = Just (mkDoubleVal (-d))
negOp (MachInt i) = intResult (-i)
-negOp l = Nothing
+negOp _ = 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
+intOp2 _ _ _ = 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 = intResult (i1 `op` i2)
-intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
+intOp2Z _ _ _ = 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
+intShiftOp2 _ _ _ = Nothing
shiftRightLogical :: Integer -> Int -> Integer
-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
--------------------------
-#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
+wordOp2 _ _ _ = Nothing -- Could find LitLit
wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
wordOp2Z op (MachWord w1) (MachWord w2)
| w2 /= 0 = wordResult (w1 `op` w2)
-wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
+wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
-#if __GLASGOW_HASKELL__ >= 500
-wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
+wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
+ -> Maybe CoreExpr
+wordBitOp2 op (MachWord w1) (MachWord w2)
= wordResult (w1 `op` w2)
-#else
--- Integer is not an instance of Bits, so we operate on Word64
-wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
- = wordResult ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))
-#endif
-wordBitOp2 op l1 l2 = Nothing -- Could find LitLit
+wordBitOp2 _ _ _ = 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
+wordShiftOp2 _ _ _ = Nothing
--------------------------
+floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
+ -> Maybe (Expr CoreBndr)
floatOp2 op (MachFloat f1) (MachFloat f2)
= Just (mkFloatVal (f1 `op` f2))
-floatOp2 op l1 l2 = Nothing
+floatOp2 _ _ _ = Nothing
+floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
+ -> Maybe (Expr CoreBndr)
floatOp2Z op (MachFloat f1) (MachFloat f2)
- | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
-floatOp2Z op l1 l2 = Nothing
+ | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
+ && f2 /= 0 -- avoid NaN and Infinity/-Infinity
+ = Just (mkFloatVal (f1 `op` f2))
+floatOp2Z _ _ _ = Nothing
--------------------------
+doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
+ -> Maybe (Expr CoreBndr)
doubleOp2 op (MachDouble f1) (MachDouble f2)
= Just (mkDoubleVal (f1 `op` f2))
-doubleOp2 op l1 l2 = Nothing
+doubleOp2 _ _ _ = Nothing
+doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
+ -> Maybe (Expr CoreBndr)
doubleOp2Z op (MachDouble f1) (MachDouble f2)
- | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
-doubleOp2Z op l1 l2 = Nothing
+ | (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
--------------------------
-> [CoreRule]
litEq op_name is_eq
= [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
- `appendFS` FSLIT("->case"),
+ `appendFS` (fsLit "->case"),
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 other = 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
-- 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)))
-#if __GLASGOW_HASKELL__ >= 500
wordResult :: Integer -> Maybe CoreExpr
wordResult result
- = Just (mkWordVal (toInteger (fromInteger result :: Word)))
-#endif
+ = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
\end{code}
%************************************************************************
\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),
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
MachDouble (toRational ((fromRational d) :: Double))
convFloating l = l
+trueVal, falseVal :: Expr CoreBndr
trueVal = Var trueDataConId
falseVal = Var falseDataConId
+mkIntVal :: Integer -> Expr CoreBndr
mkIntVal i = Lit (mkMachInt i)
+mkWordVal :: Integer -> Expr CoreBndr
mkWordVal w = Lit (mkMachWord w)
+mkFloatVal :: Rational -> Expr CoreBndr
mkFloatVal f = Lit (convFloating (MachFloat f))
+mkDoubleVal :: Rational -> Expr CoreBndr
mkDoubleVal d = Lit (convFloating (MachDouble d))
\end{code}
%* *
%************************************************************************
+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 [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))
tag = fromInteger i
tycon = tyConAppTyCon ty
-tagToEnumRule other = 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 [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 other = Nothing
+dataToTagRule _ _ = Nothing
\end{code}
%************************************************************************
%* *
%************************************************************************
+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 }
]
---------------------------------------------------
-- The rule is this:
--- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
-
-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 )
`App` c1
`App` n)
-match_append_lit other = Nothing
+match_append_lit _ _ = 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)]
+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 other = Nothing
+match_eq_string _ _ = Nothing
---------------------------------------------------
-- The rule is this:
--- inline (f a b c) = <f's unfolding> a b c
--- (if f has an unfolding)
-match_inline (e:_)
+-- inline f_ty (f a b c) = <f's unfolding> a b c
+-- (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
+-- 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 :: 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 other = Nothing
-\end{code}
+match_inline _ _ = Nothing
+\end{code}
+
projects / ghc-hetmet.git / blobdiff