Add Edit warning to Parser.y.pp
[ghc.git] / compiler / prelude / PrelRules.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[ConFold]{Constant Folder}
5
6 Conceptually, constant folding should be parameterized with the kind
7 of target machine to get identical behaviour during compilation time
8 and runtime. We cheat a little bit here...
9
10 ToDo:
11    check boundaries before folding, e.g. we can fold the Float addition
12    (i1 + i2) only if it results in a valid Float.
13
14 \begin{code}
15 {-# LANGUAGE Rank2Types #-}
16 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
17
18 module PrelRules ( primOpRules, builtinRules ) where
19
20 #include "HsVersions.h"
21 #include "../includes/MachDeps.h"
22
23 import {-# SOURCE #-} MkId ( mkPrimOpId )
24
25 import CoreSyn
26 import MkCore
27 import Id
28 import Literal
29 import CoreSubst   ( exprIsLiteral_maybe )
30 import PrimOp      ( PrimOp(..), tagToEnumKey )
31 import TysWiredIn
32 import TysPrim
33 import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
34 import DataCon     ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
35 import CoreUtils   ( cheapEqExpr, exprIsHNF )
36 import CoreUnfold  ( exprIsConApp_maybe )
37 import Type
38 import TypeRep
39 import OccName     ( occNameFS )
40 import PrelNames
41 import Maybes      ( orElse )
42 import Name        ( Name, nameOccName )
43 import Outputable
44 import FastString
45 import StaticFlags ( opt_SimplExcessPrecision )
46 import Constants
47 import BasicTypes
48 import Util
49
50 import Control.Monad
51 import Data.Bits as Bits
52 import Data.Int    ( Int64 )
53 import Data.Word   ( Word, Word64 )
54 \end{code}
55
56
57 Note [Constant folding]
58 ~~~~~~~~~~~~~~~~~~~~~~~
59 primOpRules generates a rewrite rule for each primop
60 These rules do what is often called "constant folding"
61 E.g. the rules for +# might say
62         4 +# 5 = 9
63 Well, of course you'd need a lot of rules if you did it
64 like that, so we use a BuiltinRule instead, so that we
65 can match in any two literal values.  So the rule is really
66 more like
67         (Lit x) +# (Lit y) = Lit (x+#y)
68 where the (+#) on the rhs is done at compile time
69
70 That is why these rules are built in here.
71
72
73 \begin{code}
74 primOpRules :: Name -> PrimOp -> Maybe CoreRule
75     -- ToDo: something for integer-shift ops?
76     --       NotOp
77 primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
78 primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
79
80 -- Int operations
81 primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
82                                                , identity zeroi ]
83 primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
84                                                , rightIdentity zeroi
85                                                , equalArgs >> return (Lit zeroi) ]
86 primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
87                                                , zeroElem zeroi
88                                                , identity onei ]
89 primOpRules nm IntQuotOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
90                                                , leftZero zeroi
91                                                , rightIdentity onei
92                                                , equalArgs >> return (Lit onei) ]
93 primOpRules nm IntRemOp    = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
94                                                , leftZero zeroi
95                                                , do l <- getLiteral 1
96                                                     guard (l == onei)
97                                                     return (Lit zeroi)
98                                                , equalArgs >> return (Lit zeroi)
99                                                , equalArgs >> return (Lit zeroi) ]
100 primOpRules nm IntNegOp    = mkPrimOpRule nm 1 [ unaryLit negOp ]
101 primOpRules nm ISllOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
102                                                , rightIdentity zeroi ]
103 primOpRules nm ISraOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
104                                                , rightIdentity zeroi ]
105 primOpRules nm ISrlOp      = mkPrimOpRule nm 2 [ binaryLit (intOp2 shiftRightLogical)
106                                                , rightIdentity zeroi ]
107
108 -- Word operations
109 primOpRules nm WordAddOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
110                                                , identity zerow ]
111 primOpRules nm WordSubOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
112                                                , rightIdentity zerow
113                                                , equalArgs >> return (Lit zerow) ]
114 primOpRules nm WordMulOp   = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
115                                                , identity onew ]
116 primOpRules nm WordQuotOp  = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
117                                                , rightIdentity onew ]
118 primOpRules nm WordRemOp   = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
119                                                , rightIdentity onew ]
120 primOpRules nm AndOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
121                                                , zeroElem zerow ]
122 primOpRules nm OrOp        = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
123                                                , identity zerow ]
124 primOpRules nm XorOp       = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
125                                                , identity zerow
126                                                , equalArgs >> return (Lit zerow) ]
127 primOpRules nm SllOp       = mkPrimOpRule nm 2 [ binaryLit (wordShiftOp2 Bits.shiftL)
128                                                , rightIdentity zeroi ]
129 primOpRules nm SrlOp       = mkPrimOpRule nm 2 [ binaryLit (wordShiftOp2 shiftRightLogical)
130                                                , rightIdentity zeroi ]
131
132 -- coercions
133 primOpRules nm Word2IntOp     = mkPrimOpRule nm 1 [ liftLit word2IntLit
134                                                   , inversePrimOp Int2WordOp ]
135 primOpRules nm Int2WordOp     = mkPrimOpRule nm 1 [ liftLit int2WordLit
136                                                   , inversePrimOp Word2IntOp ]
137 primOpRules nm Narrow8IntOp   = mkPrimOpRule nm 1 [ liftLit narrow8IntLit ]
138 primOpRules nm Narrow16IntOp  = mkPrimOpRule nm 1 [ liftLit narrow16IntLit ]
139 primOpRules nm Narrow32IntOp  = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
140                                                   , removeOp32 ]
141 primOpRules nm Narrow8WordOp  = mkPrimOpRule nm 1 [ liftLit narrow8WordLit ]
142 primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit ]
143 primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
144                                                   , removeOp32 ]
145 primOpRules nm OrdOp          = mkPrimOpRule nm 1 [ liftLit char2IntLit ]
146 primOpRules nm ChrOp          = mkPrimOpRule nm 1 [ do { [Lit lit] <- getArgs
147                                                   ; guard (litFitsInChar lit)
148                                                   ; liftLit int2CharLit } ]
149 primOpRules nm Float2IntOp    = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
150 primOpRules nm Int2FloatOp    = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
151 primOpRules nm Double2IntOp   = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
152 primOpRules nm Int2DoubleOp   = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
153 -- SUP: Not sure what the standard says about precision in the following 2 cases
154 primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
155 primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
156
157 -- Float
158 primOpRules nm FloatAddOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
159                                                 , identity zerof ]
160 primOpRules nm FloatSubOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
161                                                 , rightIdentity zerof ]
162 primOpRules nm FloatMulOp   = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
163                                                 , identity onef ]
164                          -- zeroElem zerof doesn't hold because of NaN
165 primOpRules nm FloatDivOp   = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
166                                                 , rightIdentity onef ]
167 primOpRules nm FloatNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp ]
168
169 -- Double
170 primOpRules nm DoubleAddOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
171                                                  , identity zerod ]
172 primOpRules nm DoubleSubOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
173                                                  , rightIdentity zerod ]
174 primOpRules nm DoubleMulOp   = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
175                                                  , identity oned ]
176                           -- zeroElem zerod doesn't hold because of NaN
177 primOpRules nm DoubleDivOp   = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
178                                                  , rightIdentity oned ]
179 primOpRules nm DoubleNegOp   = mkPrimOpRule nm 1 [ unaryLit negOp ]
180
181 -- Relational operators
182 primOpRules nm IntEqOp    = mkRelOpRule nm (==) [ litEq True ]
183 primOpRules nm IntNeOp    = mkRelOpRule nm (/=) [ litEq False ]
184 primOpRules nm CharEqOp   = mkRelOpRule nm (==) [ litEq True ]
185 primOpRules nm CharNeOp   = mkRelOpRule nm (/=) [ litEq False ]
186
187 primOpRules nm IntGtOp    = mkRelOpRule nm (>)  [ boundsCmp Gt ]
188 primOpRules nm IntGeOp    = mkRelOpRule nm (>=) [ boundsCmp Ge ]
189 primOpRules nm IntLeOp    = mkRelOpRule nm (<=) [ boundsCmp Le ]
190 primOpRules nm IntLtOp    = mkRelOpRule nm (<)  [ boundsCmp Lt ]
191
192 primOpRules nm CharGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
193 primOpRules nm CharGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
194 primOpRules nm CharLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
195 primOpRules nm CharLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
196
197 primOpRules nm FloatGtOp  = mkRelOpRule nm (>)  []
198 primOpRules nm FloatGeOp  = mkRelOpRule nm (>=) []
199 primOpRules nm FloatLeOp  = mkRelOpRule nm (<=) []
200 primOpRules nm FloatLtOp  = mkRelOpRule nm (<)  []
201 primOpRules nm FloatEqOp  = mkRelOpRule nm (==) [ litEq True ]
202 primOpRules nm FloatNeOp  = mkRelOpRule nm (/=) [ litEq False ]
203
204 primOpRules nm DoubleGtOp = mkRelOpRule nm (>)  []
205 primOpRules nm DoubleGeOp = mkRelOpRule nm (>=) []
206 primOpRules nm DoubleLeOp = mkRelOpRule nm (<=) []
207 primOpRules nm DoubleLtOp = mkRelOpRule nm (<)  []
208 primOpRules nm DoubleEqOp = mkRelOpRule nm (==) [ litEq True ]
209 primOpRules nm DoubleNeOp = mkRelOpRule nm (/=) [ litEq False ]
210
211 primOpRules nm WordGtOp   = mkRelOpRule nm (>)  [ boundsCmp Gt ]
212 primOpRules nm WordGeOp   = mkRelOpRule nm (>=) [ boundsCmp Ge ]
213 primOpRules nm WordLeOp   = mkRelOpRule nm (<=) [ boundsCmp Le ]
214 primOpRules nm WordLtOp   = mkRelOpRule nm (<)  [ boundsCmp Lt ]
215 primOpRules nm WordEqOp   = mkRelOpRule nm (==) [ litEq True ]
216 primOpRules nm WordNeOp   = mkRelOpRule nm (/=) [ litEq False ]
217
218 primOpRules nm SeqOp      = mkPrimOpRule nm 4 [ seqRule ]
219 primOpRules nm SparkOp    = mkPrimOpRule nm 4 [ sparkRule ]
220
221 primOpRules _  _          = Nothing
222
223 \end{code}
224
225 %************************************************************************
226 %*                                                                      *
227 \subsection{Doing the business}
228 %*                                                                      *
229 %************************************************************************
230
231 \begin{code}
232
233 -- useful shorthands
234 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
235 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
236
237 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
238             -> [RuleM CoreExpr] -> Maybe CoreRule
239 mkRelOpRule nm cmp extra
240   = mkPrimOpRule nm 2 $ rules ++ extra
241   where
242     rules = [ binaryLit (cmpOp cmp)
243             , equalArgs >>
244               -- x `cmp` x does not depend on x, so
245               -- compute it for the arbitrary value 'True'
246               -- and use that result
247               return (if cmp True True
248                         then trueVal
249                         else falseVal) ]
250
251 -- common constants
252 zeroi, onei, zerow, onew, zerof, onef, zerod, oned :: Literal
253 zeroi = mkMachInt 0
254 onei  = mkMachInt 1
255 zerow = mkMachWord 0
256 onew  = mkMachWord 1
257 zerof = mkMachFloat 0.0
258 onef  = mkMachFloat 1.0
259 zerod = mkMachDouble 0.0
260 oned  = mkMachDouble 1.0
261
262 cmpOp :: (forall a . Ord a => a -> a -> Bool)
263       -> Literal -> Literal -> Maybe CoreExpr
264 cmpOp cmp = go
265   where
266     done True  = Just trueVal
267     done False = Just falseVal
268
269     -- These compares are at different types
270     go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
271     go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)
272     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)
273     go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)
274     go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
275     go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)
276     go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
277     go _               _               = Nothing
278
279 --------------------------
280
281 negOp :: Literal -> Maybe CoreExpr  -- Negate
282 negOp (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
283 negOp (MachFloat f)    = Just (mkFloatVal (-f))
284 negOp (MachDouble 0.0) = Nothing
285 negOp (MachDouble d)   = Just (mkDoubleVal (-d))
286 negOp (MachInt i)      = intResult (-i)
287 negOp _                = Nothing
288
289 --------------------------
290 intOp2 :: (Integral a, Integral b)
291        => (a -> b -> Integer)
292        -> Literal -> Literal -> Maybe CoreExpr
293 intOp2 op (MachInt i1) (MachInt i2) = intResult (fromInteger i1 `op` fromInteger i2)
294 intOp2 _  _            _            = Nothing  -- Could find LitLit
295
296 shiftRightLogical :: Integer -> Int -> Integer
297 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
298 -- Do this by converting to Word and back.  Obviously this won't work for big
299 -- values, but its ok as we use it here
300 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
301
302
303 --------------------------
304 wordOp2 :: (Integral a, Integral b)
305         => (a -> b -> Integer)
306         -> Literal -> Literal -> Maybe CoreExpr
307 wordOp2 op (MachWord w1) (MachWord w2) = wordResult (fromInteger w1 `op` fromInteger w2)
308 wordOp2 _ _ _ = Nothing  -- Could find LitLit
309
310 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
311 -- Shifts take an Int; hence second arg of op is Int
312 wordShiftOp2 op (MachWord x) (MachInt n)
313   = wordResult (x `op` fromInteger n)
314     -- Do the shift at type Integer
315 wordShiftOp2 _ _ _ = Nothing
316
317 --------------------------
318 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
319          -> Maybe (Expr CoreBndr)
320 floatOp2  op (MachFloat f1) (MachFloat f2)
321   = Just (mkFloatVal (f1 `op` f2))
322 floatOp2 _ _ _ = Nothing
323
324 --------------------------
325 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
326           -> Maybe (Expr CoreBndr)
327 doubleOp2  op (MachDouble f1) (MachDouble f2)
328   = Just (mkDoubleVal (f1 `op` f2))
329 doubleOp2 _ _ _ = Nothing
330
331 --------------------------
332 -- This stuff turns
333 --      n ==# 3#
334 -- into
335 --      case n of
336 --        3# -> True
337 --        m  -> False
338 --
339 -- This is a Good Thing, because it allows case-of case things
340 -- to happen, and case-default absorption to happen.  For
341 -- example:
342 --
343 --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
344 -- will transform to
345 --      case n of
346 --        3# -> e1
347 --        4# -> e1
348 --        m  -> e2
349 -- (modulo the usual precautions to avoid duplicating e1)
350
351 litEq :: Bool  -- True <=> equality, False <=> inequality
352       -> RuleM CoreExpr
353 litEq is_eq = msum
354   [ do [Lit lit, expr] <- getArgs
355        do_lit_eq lit expr
356   , do [expr, Lit lit] <- getArgs
357        do_lit_eq lit expr ]
358   where
359     do_lit_eq lit expr = do
360       guard (not (litIsLifted lit))
361       return (mkWildCase expr (literalType lit) boolTy
362                     [(DEFAULT,    [], val_if_neq),
363                      (LitAlt lit, [], val_if_eq)])
364     val_if_eq  | is_eq     = trueVal
365                | otherwise = falseVal
366     val_if_neq | is_eq     = falseVal
367                | otherwise = trueVal
368
369
370 -- | Check if there is comparison with minBound or maxBound, that is
371 -- always true or false. For instance, an Int cannot be smaller than its
372 -- minBound, so we can replace such comparison with False.
373 boundsCmp :: Comparison -> RuleM CoreExpr
374 boundsCmp op = do
375   [a, b] <- getArgs
376   liftMaybe $ mkRuleFn op a b
377
378 data Comparison = Gt | Ge | Lt | Le
379
380 mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
381 mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal
382 mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal
383 mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal
384 mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal
385 mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal
386 mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal
387 mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal
388 mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal
389 mkRuleFn _ _ _                           = Nothing
390
391 isMinBound :: Literal -> Bool
392 isMinBound (MachChar c)   = c == minBound
393 isMinBound (MachInt i)    = i == toInteger (minBound :: Int)
394 isMinBound (MachInt64 i)  = i == toInteger (minBound :: Int64)
395 isMinBound (MachWord i)   = i == toInteger (minBound :: Word)
396 isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64)
397 isMinBound _              = False
398
399 isMaxBound :: Literal -> Bool
400 isMaxBound (MachChar c)   = c == maxBound
401 isMaxBound (MachInt i)    = i == toInteger (maxBound :: Int)
402 isMaxBound (MachInt64 i)  = i == toInteger (maxBound :: Int64)
403 isMaxBound (MachWord i)   = i == toInteger (maxBound :: Word)
404 isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64)
405 isMaxBound _              = False
406
407
408 -- Note that we *don't* warn the user about overflow. It's not done at
409 -- runtime either, and compilation of completely harmless things like
410 --    ((124076834 :: Word32) + (2147483647 :: Word32))
411 -- would yield a warning. Instead we simply squash the value into the
412 -- *target* Int/Word range.
413 intResult :: Integer -> Maybe CoreExpr
414 intResult result
415   = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
416
417 wordResult :: Integer -> Maybe CoreExpr
418 wordResult result
419   = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
420
421 inversePrimOp :: PrimOp -> RuleM CoreExpr
422 inversePrimOp primop = do
423   [Var primop_id `App` e] <- getArgs
424   matchPrimOpId primop primop_id
425   return e
426
427 \end{code}
428
429 %************************************************************************
430 %*                                                                      *
431 \subsection{Vaguely generic functions}
432 %*                                                                      *
433 %************************************************************************
434
435 \begin{code}
436 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
437 -- Gives the Rule the same name as the primop itself
438 mkBasicRule op_name n_args rm
439   = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
440                   ru_fn = op_name,
441                   ru_nargs = n_args,
442                   ru_try = \_ -> runRuleM rm }
443
444 newtype RuleM r = RuleM
445   { runRuleM :: IdUnfoldingFun -> [CoreExpr] -> Maybe r }
446
447 instance Monad RuleM where
448   return x = RuleM $ \_ _ -> Just x
449   RuleM f >>= g = RuleM $ \iu e -> case f iu e of
450     Nothing -> Nothing
451     Just r -> runRuleM (g r) iu e
452   fail _ = mzero
453
454 instance MonadPlus RuleM where
455   mzero = RuleM $ \_ _ -> Nothing
456   mplus (RuleM f1) (RuleM f2) = RuleM $ \iu args ->
457     f1 iu args `mplus` f2 iu args
458
459 liftMaybe :: Maybe a -> RuleM a
460 liftMaybe Nothing = mzero
461 liftMaybe (Just x) = return x
462
463 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
464 liftLit f = do
465   [Lit lit] <- getArgs
466   return $ Lit (f lit)
467
468 removeOp32 :: RuleM CoreExpr
469 #if WORD_SIZE_IN_BITS == 32
470 removeOp32 = do
471   [e] <- getArgs
472   return e
473 #else
474 removeOp32 = mzero
475 #endif
476
477 getArgs :: RuleM [CoreExpr]
478 getArgs = RuleM $ \_ args -> Just args
479
480 getIdUnfoldingFun :: RuleM IdUnfoldingFun
481 getIdUnfoldingFun = RuleM $ \iu _ -> Just iu
482
483 -- return the n-th argument of this rule, if it is a literal
484 -- argument indices start from 0
485 getLiteral :: Int -> RuleM Literal
486 getLiteral n = RuleM $ \_ exprs -> case drop n exprs of
487   (Lit l:_) -> Just l
488   _ -> Nothing
489
490 unaryLit :: (Literal -> Maybe CoreExpr) -> RuleM CoreExpr
491 unaryLit op = do
492   [Lit l] <- getArgs
493   liftMaybe $ op (convFloating l)
494
495 binaryLit :: (Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
496 binaryLit op = do
497   [Lit l1, Lit l2] <- getArgs
498   liftMaybe $ convFloating l1 `op` convFloating l2
499
500 leftIdentity :: Literal -> RuleM CoreExpr
501 leftIdentity id_lit = do
502   [Lit l1, e2] <- getArgs
503   guard $ l1 == id_lit
504   return e2
505
506 rightIdentity :: Literal -> RuleM CoreExpr
507 rightIdentity id_lit = do
508   [e1, Lit l2] <- getArgs
509   guard $ l2 == id_lit
510   return e1
511
512 identity :: Literal -> RuleM CoreExpr
513 identity lit = leftIdentity lit `mplus` rightIdentity lit
514
515 leftZero :: Literal -> RuleM CoreExpr
516 leftZero zero = do
517   [Lit l1, _] <- getArgs
518   guard $ l1 == zero
519   return $ Lit zero
520
521 rightZero :: Literal -> RuleM CoreExpr
522 rightZero zero = do
523   [_, Lit l2] <- getArgs
524   guard $ l2 == zero
525   return $ Lit zero
526
527 zeroElem :: Literal -> RuleM CoreExpr
528 zeroElem lit = leftZero lit `mplus` rightZero lit
529
530 equalArgs :: RuleM ()
531 equalArgs = do
532   [e1, e2] <- getArgs
533   guard $ e1 `cheapEqExpr` e2
534
535 nonZeroLit :: Int -> RuleM ()
536 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
537
538 -- When excess precision is not requested, cut down the precision of the
539 -- Rational value to that of Float/Double. We confuse host architecture
540 -- and target architecture here, but it's convenient (and wrong :-).
541 convFloating :: Literal -> Literal
542 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
543    MachFloat  (toRational (fromRational f :: Float ))
544 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
545    MachDouble (toRational (fromRational d :: Double))
546 convFloating l = l
547
548 guardFloatDiv :: RuleM ()
549 guardFloatDiv = do
550   [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
551   guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
552        && f2 /= 0            -- avoid NaN and Infinity/-Infinity
553
554 guardDoubleDiv :: RuleM ()
555 guardDoubleDiv = do
556   [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
557   guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
558        && d2 /= 0            -- avoid NaN and Infinity/-Infinity
559 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
560 -- zero, but we might want to preserve the negative zero here which
561 -- is representable in Float/Double but not in (normalised)
562 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
563
564 trueVal, falseVal :: Expr CoreBndr
565 trueVal       = Var trueDataConId
566 falseVal      = Var falseDataConId
567
568 ltVal, eqVal, gtVal :: Expr CoreBndr
569 ltVal = Var ltDataConId
570 eqVal = Var eqDataConId
571 gtVal = Var gtDataConId
572
573 mkIntVal :: Integer -> Expr CoreBndr
574 mkIntVal    i = Lit (mkMachInt  i)
575 mkWordVal :: Integer -> Expr CoreBndr
576 mkWordVal   w = Lit (mkMachWord w)
577 mkFloatVal :: Rational -> Expr CoreBndr
578 mkFloatVal  f = Lit (convFloating (MachFloat  f))
579 mkDoubleVal :: Rational -> Expr CoreBndr
580 mkDoubleVal d = Lit (convFloating (MachDouble d))
581
582 matchPrimOpId :: PrimOp -> Id -> RuleM ()
583 matchPrimOpId op id = do
584   op' <- liftMaybe $ isPrimOpId_maybe id
585   guard $ op == op'
586
587 \end{code}
588
589 %************************************************************************
590 %*                                                                      *
591 \subsection{Special rules for seq, tagToEnum, dataToTag}
592 %*                                                                      *
593 %************************************************************************
594
595 Note [tagToEnum#]
596 ~~~~~~~~~~~~~~~~~
597 Nasty check to ensure that tagToEnum# is applied to a type that is an
598 enumeration TyCon.  Unification may refine the type later, but this
599 check won't see that, alas.  It's crude but it works.
600
601 Here's are two cases that should fail
602         f :: forall a. a
603         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
604
605         g :: Int
606         g = tagToEnum# 0        -- Int is not an enumeration
607
608 We used to make this check in the type inference engine, but it's quite
609 ugly to do so, because the delayed constraint solving means that we don't
610 really know what's going on until the end. It's very much a corner case
611 because we don't expect the user to call tagToEnum# at all; we merely
612 generate calls in derived instances of Enum.  So we compromise: a
613 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
614 and emits a warning.
615
616 \begin{code}
617 tagToEnumRule :: RuleM CoreExpr
618 -- If     data T a = A | B | C
619 -- then   tag2Enum# (T ty) 2# -->  B ty
620 tagToEnumRule = do
621   [Type ty, Lit (MachInt i)] <- getArgs
622   case splitTyConApp_maybe ty of
623     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
624       let tag = fromInteger i
625           correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
626       (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
627       ASSERT (null rest) return ()
628       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
629
630     -- See Note [tagToEnum#]
631     _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
632          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
633 \end{code}
634
635
636 For dataToTag#, we can reduce if either
637
638         (a) the argument is a constructor
639         (b) the argument is a variable whose unfolding is a known constructor
640
641 \begin{code}
642 dataToTagRule :: RuleM CoreExpr
643 dataToTagRule = a `mplus` b
644   where
645     a = do
646       [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
647       guard $ tag_to_enum `hasKey` tagToEnumKey
648       guard $ ty1 `eqType` ty2
649       return tag -- dataToTag (tagToEnum x)   ==>   x
650     b = do
651       [_, val_arg] <- getArgs
652       id_unf <- getIdUnfoldingFun
653       (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg
654       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
655       return $ mkIntVal (toInteger (dataConTag dc - fIRST_TAG))
656 \end{code}
657
658 %************************************************************************
659 %*                                                                      *
660 \subsection{Rules for seq# and spark#}
661 %*                                                                      *
662 %************************************************************************
663
664 \begin{code}
665 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
666 seqRule :: RuleM CoreExpr
667 seqRule = do
668   [ty_a, Type ty_s, a, s] <- getArgs
669   guard $ exprIsHNF a
670   return $ mkConApp (tupleCon UnboxedTuple 2)
671     [Type (mkStatePrimTy ty_s), ty_a, s, a]
672
673 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
674 sparkRule :: RuleM CoreExpr
675 sparkRule = seqRule -- reduce on HNF, just the same
676   -- XXX perhaps we shouldn't do this, because a spark eliminated by
677   -- this rule won't be counted as a dud at runtime?
678 \end{code}
679
680 %************************************************************************
681 %*                                                                      *
682 \subsection{Built in rules}
683 %*                                                                      *
684 %************************************************************************
685
686 Note [Scoping for Builtin rules]
687 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
688 When compiling a (base-package) module that defines one of the
689 functions mentioned in the RHS of a built-in rule, there's a danger
690 that we'll see
691
692         f = ...(eq String x)....
693
694         ....and lower down...
695
696         eqString = ...
697
698 Then a rewrite would give
699
700         f = ...(eqString x)...
701         ....and lower down...
702         eqString = ...
703
704 and lo, eqString is not in scope.  This only really matters when we get to code
705 generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
706 set of bindings, which sorts out the dependency.  Without -O we don't do any rule
707 rewriting so again we are fine.
708
709 (This whole thing doesn't show up for non-built-in rules because their dependencies
710 are explicit.)
711
712
713 \begin{code}
714 builtinRules :: [CoreRule]
715 -- Rules for non-primops that can't be expressed using a RULE pragma
716 builtinRules
717   = [BuiltinRule { ru_name = fsLit "AppendLitString",
718                    ru_fn = unpackCStringFoldrName,
719                    ru_nargs = 4, ru_try = \_ -> match_append_lit },
720      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
721                    ru_nargs = 2, ru_try = \_ -> match_eq_string },
722      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
723                    ru_nargs = 2, ru_try = \_ -> match_inline }]
724  ++ builtinIntegerRules
725
726 builtinIntegerRules :: [CoreRule]
727 builtinIntegerRules =
728  [rule_IntToInteger   "smallInteger"        smallIntegerName,
729   rule_WordToInteger  "wordToInteger"       wordToIntegerName,
730   rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,
731   rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,
732   rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
733   rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
734   rule_convert        "integerToWord64"     integerToWord64Name     mkWord64LitWord64,
735   rule_convert        "integerToInt64"      integerToInt64Name      mkInt64LitInt64,
736   rule_binop          "plusInteger"         plusIntegerName         (+),
737   rule_binop          "minusInteger"        minusIntegerName        (-),
738   rule_binop          "timesInteger"        timesIntegerName        (*),
739   rule_unop           "negateInteger"       negateIntegerName       negate,
740   rule_binop_Bool     "eqInteger"           eqIntegerName           (==),
741   rule_binop_Bool     "neqInteger"          neqIntegerName          (/=),
742   rule_unop           "absInteger"          absIntegerName          abs,
743   rule_unop           "signumInteger"       signumIntegerName       signum,
744   rule_binop_Bool     "leInteger"           leIntegerName           (<=),
745   rule_binop_Bool     "gtInteger"           gtIntegerName           (>),
746   rule_binop_Bool     "ltInteger"           ltIntegerName           (<),
747   rule_binop_Bool     "geInteger"           geIntegerName           (>=),
748   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
749   rule_divop_both     "divModInteger"       divModIntegerName       divMod,
750   rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
751   rule_divop_one      "quotInteger"         quotIntegerName         quot,
752   rule_divop_one      "remInteger"          remIntegerName          rem,
753   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
754   rule_convert        "floatFromInteger"    floatFromIntegerName    mkFloatLitFloat,
755   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
756   rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,
757   rule_convert        "doubleFromInteger"   doubleFromIntegerName   mkDoubleLitDouble,
758   rule_binop          "gcdInteger"          gcdIntegerName          gcd,
759   rule_binop          "lcmInteger"          lcmIntegerName          lcm,
760   rule_binop          "andInteger"          andIntegerName          (.&.),
761   rule_binop          "orInteger"           orIntegerName           (.|.),
762   rule_binop          "xorInteger"          xorIntegerName          xor,
763   rule_unop           "complementInteger"   complementIntegerName   complement,
764   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
765   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
766   -- These rules below don't actually have to be built in, but if we
767   -- put them in the Haskell source then we'd have to duplicate them
768   -- between all Integer implementations
769   rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,
770   rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,
771   rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,
772   rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
773   rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,
774   rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,
775   rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
776   ]
777     where rule_convert str name convert
778            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
779                            ru_try = match_Integer_convert convert }
780           rule_IntToInteger str name
781            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
782                            ru_try = match_IntToInteger }
783           rule_WordToInteger str name
784            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
785                            ru_try = match_WordToInteger }
786           rule_Int64ToInteger str name
787            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
788                            ru_try = match_Int64ToInteger }
789           rule_Word64ToInteger str name
790            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
791                            ru_try = match_Word64ToInteger }
792           rule_unop str name op
793            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
794                            ru_try = match_Integer_unop op }
795           rule_binop str name op
796            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
797                            ru_try = match_Integer_binop op }
798           rule_divop_both str name op
799            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
800                            ru_try = match_Integer_divop_both op }
801           rule_divop_one str name op
802            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
803                            ru_try = match_Integer_divop_one op }
804           rule_Int_binop str name op
805            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
806                            ru_try = match_Integer_Int_binop op }
807           rule_binop_Bool str name op
808            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
809                            ru_try = match_Integer_binop_Bool op }
810           rule_binop_Ordering str name op
811            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
812                            ru_try = match_Integer_binop_Ordering op }
813           rule_encodeFloat str name op
814            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
815                            ru_try = match_Integer_Int_encodeFloat op }
816           rule_decodeDouble str name
817            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
818                            ru_try = match_decodeDouble }
819           rule_XToIntegerToX str name toIntegerName
820            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
821                            ru_try = match_XToIntegerToX toIntegerName }
822           rule_smallIntegerTo str name primOp
823            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
824                            ru_try = match_smallIntegerTo primOp }
825
826 ---------------------------------------------------
827 -- The rule is this:
828 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
829 --      =  unpackFoldrCString# "foobaz" c n
830
831 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
832 match_append_lit _ [Type ty1,
833                     Lit (MachStr s1),
834                     c1,
835                     Var unpk `App` Type ty2
836                              `App` Lit (MachStr s2)
837                              `App` c2
838                              `App` n
839                    ]
840   | unpk `hasKey` unpackCStringFoldrIdKey &&
841     c1 `cheapEqExpr` c2
842   = ASSERT( ty1 `eqType` ty2 )
843     Just (Var unpk `App` Type ty1
844                    `App` Lit (MachStr (s1 `appendFB` s2))
845                    `App` c1
846                    `App` n)
847
848 match_append_lit _ _ = Nothing
849
850 ---------------------------------------------------
851 -- The rule is this:
852 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
853
854 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
855 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
856                    Var unpk2 `App` Lit (MachStr s2)]
857   | unpk1 `hasKey` unpackCStringIdKey,
858     unpk2 `hasKey` unpackCStringIdKey
859   = Just (if s1 == s2 then trueVal else falseVal)
860
861 match_eq_string _ _ = Nothing
862
863
864 ---------------------------------------------------
865 -- The rule is this:
866 --      inline f_ty (f a b c) = <f's unfolding> a b c
867 -- (if f has an unfolding, EVEN if it's a loop breaker)
868 --
869 -- It's important to allow the argument to 'inline' to have args itself
870 -- (a) because its more forgiving to allow the programmer to write
871 --       inline f a b c
872 --   or  inline (f a b c)
873 -- (b) because a polymorphic f wll get a type argument that the
874 --     programmer can't avoid
875 --
876 -- Also, don't forget about 'inline's type argument!
877 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
878 match_inline _ (Type _ : e : _)
879   | (Var f, args1) <- collectArgs e,
880     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
881              -- Ignore the IdUnfoldingFun here!
882   = Just (mkApps unf args1)
883
884 match_inline _ _ = Nothing
885
886 -------------------------------------------------
887 -- Integer rules
888 --   smallInteger  (79::Int#)  = 79::Integer   
889 --   wordToInteger (79::Word#) = 79::Integer   
890 -- Similarly Int64, Word64
891
892 match_IntToInteger :: Id
893                    -> IdUnfoldingFun
894                    -> [Expr CoreBndr]
895                    -> Maybe (Expr CoreBndr)
896 match_IntToInteger id id_unf [xl]
897   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
898   = case idType id of
899     FunTy _ integerTy ->
900         Just (Lit (LitInteger x integerTy))
901     _ ->
902         panic "match_IntToInteger: Id has the wrong type"
903 match_IntToInteger _ _ _ = Nothing
904
905 match_WordToInteger :: Id
906                     -> IdUnfoldingFun
907                     -> [Expr CoreBndr]
908                     -> Maybe (Expr CoreBndr)
909 match_WordToInteger id id_unf [xl]
910   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
911   = case idType id of
912     FunTy _ integerTy ->
913         Just (Lit (LitInteger x integerTy))
914     _ ->
915         panic "match_WordToInteger: Id has the wrong type"
916 match_WordToInteger _ _ _ = Nothing
917
918 match_Int64ToInteger :: Id
919                      -> IdUnfoldingFun
920                      -> [Expr CoreBndr]
921                      -> Maybe (Expr CoreBndr)
922 match_Int64ToInteger id id_unf [xl]
923   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
924   = case idType id of
925     FunTy _ integerTy ->
926         Just (Lit (LitInteger x integerTy))
927     _ ->
928         panic "match_Int64ToInteger: Id has the wrong type"
929 match_Int64ToInteger _ _ _ = Nothing
930
931 match_Word64ToInteger :: Id
932                       -> IdUnfoldingFun
933                       -> [Expr CoreBndr]
934                       -> Maybe (Expr CoreBndr)
935 match_Word64ToInteger id id_unf [xl]
936   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
937   = case idType id of
938     FunTy _ integerTy ->
939         Just (Lit (LitInteger x integerTy))
940     _ ->
941         panic "match_Word64ToInteger: Id has the wrong type"
942 match_Word64ToInteger _ _ _ = Nothing
943
944 -------------------------------------------------
945 match_Integer_convert :: Num a
946                       => (a -> Expr CoreBndr)
947                       -> Id
948                       -> IdUnfoldingFun
949                       -> [Expr CoreBndr]
950                       -> Maybe (Expr CoreBndr)
951 match_Integer_convert convert _ id_unf [xl]
952   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
953   = Just (convert (fromInteger x))
954 match_Integer_convert _ _ _ _ = Nothing
955
956 match_Integer_unop :: (Integer -> Integer)
957                    -> Id
958                    -> IdUnfoldingFun
959                    -> [Expr CoreBndr]
960                    -> Maybe (Expr CoreBndr)
961 match_Integer_unop unop _ id_unf [xl]
962   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
963   = Just (Lit (LitInteger (unop x) i))
964 match_Integer_unop _ _ _ _ = Nothing
965
966 match_Integer_binop :: (Integer -> Integer -> Integer)
967                     -> Id
968                     -> IdUnfoldingFun
969                     -> [Expr CoreBndr]
970                     -> Maybe (Expr CoreBndr)
971 match_Integer_binop binop _ id_unf [xl,yl]
972   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
973   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
974   = Just (Lit (LitInteger (x `binop` y) i))
975 match_Integer_binop _ _ _ _ = Nothing
976
977 -- This helper is used for the quotRem and divMod functions
978 match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
979                          -> Id
980                          -> IdUnfoldingFun
981                          -> [Expr CoreBndr]
982                          -> Maybe (Expr CoreBndr)
983 match_Integer_divop_both divop _ id_unf [xl,yl]
984   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
985   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
986   , y /= 0
987   , (r,s) <- x `divop` y
988   = Just $ mkConApp (tupleCon UnboxedTuple 2)
989                     [Type t,
990                      Type t,
991                      Lit (LitInteger r t),
992                      Lit (LitInteger s t)]
993 match_Integer_divop_both _ _ _ _ = Nothing
994
995 -- This helper is used for the quotRem and divMod functions
996 match_Integer_divop_one :: (Integer -> Integer -> Integer)
997                         -> Id
998                         -> IdUnfoldingFun
999                         -> [Expr CoreBndr]
1000                         -> Maybe (Expr CoreBndr)
1001 match_Integer_divop_one divop _ id_unf [xl,yl]
1002   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1003   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1004   , y /= 0
1005   = Just (Lit (LitInteger (x `divop` y) i))
1006 match_Integer_divop_one _ _ _ _ = Nothing
1007
1008 match_Integer_Int_binop :: (Integer -> Int -> Integer)
1009                         -> Id
1010                         -> IdUnfoldingFun
1011                         -> [Expr CoreBndr]
1012                         -> Maybe (Expr CoreBndr)
1013 match_Integer_Int_binop binop _ id_unf [xl,yl]
1014   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1015   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1016   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1017 match_Integer_Int_binop _ _ _ _ = Nothing
1018
1019 match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
1020                          -> Id
1021                          -> IdUnfoldingFun
1022                          -> [Expr CoreBndr]
1023                          -> Maybe (Expr CoreBndr)
1024 match_Integer_binop_Bool binop _ id_unf [xl, yl]
1025   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1026   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1027   = Just (if x `binop` y then trueVal else falseVal)
1028 match_Integer_binop_Bool _ _ _ _ = Nothing
1029
1030 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
1031                              -> Id
1032                              -> IdUnfoldingFun
1033                              -> [Expr CoreBndr]
1034                              -> Maybe (Expr CoreBndr)
1035 match_Integer_binop_Ordering binop _ id_unf [xl, yl]
1036   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1037   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1038   = Just $ case x `binop` y of
1039              LT -> ltVal
1040              EQ -> eqVal
1041              GT -> gtVal
1042 match_Integer_binop_Ordering _ _ _ _ = Nothing
1043
1044 match_Integer_Int_encodeFloat :: RealFloat a
1045                               => (a -> Expr CoreBndr)
1046                               -> Id
1047                               -> IdUnfoldingFun
1048                               -> [Expr CoreBndr]
1049                               -> Maybe (Expr CoreBndr)
1050 match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
1051   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1052   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1053   = Just (mkLit $ encodeFloat x (fromInteger y))
1054 match_Integer_Int_encodeFloat _ _ _ _ = Nothing
1055
1056 match_decodeDouble :: Id
1057                    -> IdUnfoldingFun
1058                    -> [Expr CoreBndr]
1059                    -> Maybe (Expr CoreBndr)
1060 match_decodeDouble fn id_unf [xl]
1061   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1062   = case idType fn of
1063     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
1064         case decodeFloat (fromRational x :: Double) of
1065         (y, z) ->
1066             Just $ mkConApp (tupleCon UnboxedTuple 2)
1067                             [Type integerTy,
1068                              Type intHashTy,
1069                              Lit (LitInteger y integerTy),
1070                              Lit (MachInt (toInteger z))]
1071     _ ->
1072         panic "match_decodeDouble: Id has the wrong type"
1073 match_decodeDouble _ _ _ = Nothing
1074
1075 match_XToIntegerToX :: Name
1076                     -> Id
1077                     -> IdUnfoldingFun
1078                     -> [Expr CoreBndr]
1079                     -> Maybe (Expr CoreBndr)
1080 match_XToIntegerToX n _ _ [App (Var x) y]
1081   | idName x == n
1082   = Just y
1083 match_XToIntegerToX _ _ _ _ = Nothing
1084
1085 match_smallIntegerTo :: PrimOp
1086                      -> Id
1087                      -> IdUnfoldingFun
1088                      -> [Expr CoreBndr]
1089                      -> Maybe (Expr CoreBndr)
1090 match_smallIntegerTo primOp _ _ [App (Var x) y]
1091   | idName x == smallIntegerName
1092   = Just $ App (Var (mkPrimOpId primOp)) y
1093 match_smallIntegerTo _ _ _ _ = Nothing
1094 \end{code}