{-# 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"
, narrow8WordLit, narrow16WordLit, narrow32WordLit
, char2IntLit, int2CharLit
, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
- , float2DoubleLit, double2FloatLit
+ , float2DoubleLit, double2FloatLit, litFitsInChar
)
import PrimOp ( PrimOp(..), tagToEnumKey )
import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
import Outputable
import FastString
import StaticFlags ( opt_SimplExcessPrecision )
-
-import Data.Bits as Bits ( 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)
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
--------------------------
-#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 = 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)
= 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
wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> 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}
%* *
%************************************************************************
+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:
--- inline (f a b c) = <f's unfolding> a b c
+-- inline f_ty (f a b c) = <f's unfolding> 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)
projects / ghc-hetmet.git / blobdiff