951fcbc223a292a8c04423848eb025bb4a1462d1
[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      BuiltinRule { ru_name = fsLit "Noupdate", ru_fn = noupdateIdName,
725                    ru_nargs = 2, ru_try = \_ -> match_noupdate }]
726  ++ builtinIntegerRules
727
728 builtinIntegerRules :: [CoreRule]
729 builtinIntegerRules =
730  [rule_IntToInteger   "smallInteger"        smallIntegerName,
731   rule_WordToInteger  "wordToInteger"       wordToIntegerName,
732   rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,
733   rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,
734   rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
735   rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
736   rule_convert        "integerToWord64"     integerToWord64Name     mkWord64LitWord64,
737   rule_convert        "integerToInt64"      integerToInt64Name      mkInt64LitInt64,
738   rule_binop          "plusInteger"         plusIntegerName         (+),
739   rule_binop          "minusInteger"        minusIntegerName        (-),
740   rule_binop          "timesInteger"        timesIntegerName        (*),
741   rule_unop           "negateInteger"       negateIntegerName       negate,
742   rule_binop_Bool     "eqInteger"           eqIntegerName           (==),
743   rule_binop_Bool     "neqInteger"          neqIntegerName          (/=),
744   rule_unop           "absInteger"          absIntegerName          abs,
745   rule_unop           "signumInteger"       signumIntegerName       signum,
746   rule_binop_Bool     "leInteger"           leIntegerName           (<=),
747   rule_binop_Bool     "gtInteger"           gtIntegerName           (>),
748   rule_binop_Bool     "ltInteger"           ltIntegerName           (<),
749   rule_binop_Bool     "geInteger"           geIntegerName           (>=),
750   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
751   rule_divop_both     "divModInteger"       divModIntegerName       divMod,
752   rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
753   rule_divop_one      "quotInteger"         quotIntegerName         quot,
754   rule_divop_one      "remInteger"          remIntegerName          rem,
755   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
756   rule_convert        "floatFromInteger"    floatFromIntegerName    mkFloatLitFloat,
757   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
758   rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,
759   rule_convert        "doubleFromInteger"   doubleFromIntegerName   mkDoubleLitDouble,
760   rule_binop          "gcdInteger"          gcdIntegerName          gcd,
761   rule_binop          "lcmInteger"          lcmIntegerName          lcm,
762   rule_binop          "andInteger"          andIntegerName          (.&.),
763   rule_binop          "orInteger"           orIntegerName           (.|.),
764   rule_binop          "xorInteger"          xorIntegerName          xor,
765   rule_unop           "complementInteger"   complementIntegerName   complement,
766   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
767   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
768   -- These rules below don't actually have to be built in, but if we
769   -- put them in the Haskell source then we'd have to duplicate them
770   -- between all Integer implementations
771   rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,
772   rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,
773   rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,
774   rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
775   rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,
776   rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,
777   rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
778   ]
779     where rule_convert str name convert
780            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
781                            ru_try = match_Integer_convert convert }
782           rule_IntToInteger str name
783            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
784                            ru_try = match_IntToInteger }
785           rule_WordToInteger str name
786            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
787                            ru_try = match_WordToInteger }
788           rule_Int64ToInteger str name
789            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
790                            ru_try = match_Int64ToInteger }
791           rule_Word64ToInteger str name
792            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
793                            ru_try = match_Word64ToInteger }
794           rule_unop str name op
795            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
796                            ru_try = match_Integer_unop op }
797           rule_binop str name op
798            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
799                            ru_try = match_Integer_binop op }
800           rule_divop_both str name op
801            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
802                            ru_try = match_Integer_divop_both op }
803           rule_divop_one str name op
804            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
805                            ru_try = match_Integer_divop_one op }
806           rule_Int_binop str name op
807            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
808                            ru_try = match_Integer_Int_binop op }
809           rule_binop_Bool str name op
810            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
811                            ru_try = match_Integer_binop_Bool op }
812           rule_binop_Ordering str name op
813            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
814                            ru_try = match_Integer_binop_Ordering op }
815           rule_encodeFloat str name op
816            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
817                            ru_try = match_Integer_Int_encodeFloat op }
818           rule_decodeDouble str name
819            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
820                            ru_try = match_decodeDouble }
821           rule_XToIntegerToX str name toIntegerName
822            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
823                            ru_try = match_XToIntegerToX toIntegerName }
824           rule_smallIntegerTo str name primOp
825            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
826                            ru_try = match_smallIntegerTo primOp }
827
828 ---------------------------------------------------
829 -- The rule is this:
830 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
831 --      =  unpackFoldrCString# "foobaz" c n
832
833 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
834 match_append_lit _ [Type ty1,
835                     Lit (MachStr s1),
836                     c1,
837                     Var unpk `App` Type ty2
838                              `App` Lit (MachStr s2)
839                              `App` c2
840                              `App` n
841                    ]
842   | unpk `hasKey` unpackCStringFoldrIdKey &&
843     c1 `cheapEqExpr` c2
844   = ASSERT( ty1 `eqType` ty2 )
845     Just (Var unpk `App` Type ty1
846                    `App` Lit (MachStr (s1 `appendFB` s2))
847                    `App` c1
848                    `App` n)
849
850 match_append_lit _ _ = Nothing
851
852 ---------------------------------------------------
853 -- The rule is this:
854 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
855
856 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
857 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
858                    Var unpk2 `App` Lit (MachStr s2)]
859   | unpk1 `hasKey` unpackCStringIdKey,
860     unpk2 `hasKey` unpackCStringIdKey
861   = Just (if s1 == s2 then trueVal else falseVal)
862
863 match_eq_string _ _ = Nothing
864
865
866 ---------------------------------------------------
867 -- The rule is this:
868 --      inline f_ty (f a b c) = <f's unfolding> a b c
869 -- (if f has an unfolding, EVEN if it's a loop breaker)
870 --
871 -- It's important to allow the argument to 'inline' to have args itself
872 -- (a) because its more forgiving to allow the programmer to write
873 --       inline f a b c
874 --   or  inline (f a b c)
875 -- (b) because a polymorphic f wll get a type argument that the
876 --     programmer can't avoid
877 --
878 -- Also, don't forget about 'inline's type argument!
879 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
880 match_inline _ (Type _ : e : _)
881   | (Var f, args1) <- collectArgs e,
882     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
883              -- Ignore the IdUnfoldingFun here!
884   = Just (mkApps unf args1)
885
886 match_inline _ _ = Nothing
887
888 match_noupdate :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
889 match_noupdate _ (Type _ : e : _) = Just (Tick DontUpdate e)
890 match_noupdate _ _ = Nothing
891
892 -------------------------------------------------
893 -- Integer rules
894 --   smallInteger  (79::Int#)  = 79::Integer   
895 --   wordToInteger (79::Word#) = 79::Integer   
896 -- Similarly Int64, Word64
897
898 match_IntToInteger :: Id
899                    -> IdUnfoldingFun
900                    -> [Expr CoreBndr]
901                    -> Maybe (Expr CoreBndr)
902 match_IntToInteger id id_unf [xl]
903   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
904   = case idType id of
905     FunTy _ integerTy ->
906         Just (Lit (LitInteger x integerTy))
907     _ ->
908         panic "match_IntToInteger: Id has the wrong type"
909 match_IntToInteger _ _ _ = Nothing
910
911 match_WordToInteger :: Id
912                     -> IdUnfoldingFun
913                     -> [Expr CoreBndr]
914                     -> Maybe (Expr CoreBndr)
915 match_WordToInteger id id_unf [xl]
916   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
917   = case idType id of
918     FunTy _ integerTy ->
919         Just (Lit (LitInteger x integerTy))
920     _ ->
921         panic "match_WordToInteger: Id has the wrong type"
922 match_WordToInteger _ _ _ = Nothing
923
924 match_Int64ToInteger :: Id
925                      -> IdUnfoldingFun
926                      -> [Expr CoreBndr]
927                      -> Maybe (Expr CoreBndr)
928 match_Int64ToInteger id id_unf [xl]
929   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
930   = case idType id of
931     FunTy _ integerTy ->
932         Just (Lit (LitInteger x integerTy))
933     _ ->
934         panic "match_Int64ToInteger: Id has the wrong type"
935 match_Int64ToInteger _ _ _ = Nothing
936
937 match_Word64ToInteger :: Id
938                       -> IdUnfoldingFun
939                       -> [Expr CoreBndr]
940                       -> Maybe (Expr CoreBndr)
941 match_Word64ToInteger id id_unf [xl]
942   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
943   = case idType id of
944     FunTy _ integerTy ->
945         Just (Lit (LitInteger x integerTy))
946     _ ->
947         panic "match_Word64ToInteger: Id has the wrong type"
948 match_Word64ToInteger _ _ _ = Nothing
949
950 -------------------------------------------------
951 match_Integer_convert :: Num a
952                       => (a -> Expr CoreBndr)
953                       -> Id
954                       -> IdUnfoldingFun
955                       -> [Expr CoreBndr]
956                       -> Maybe (Expr CoreBndr)
957 match_Integer_convert convert _ id_unf [xl]
958   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
959   = Just (convert (fromInteger x))
960 match_Integer_convert _ _ _ _ = Nothing
961
962 match_Integer_unop :: (Integer -> Integer)
963                    -> Id
964                    -> IdUnfoldingFun
965                    -> [Expr CoreBndr]
966                    -> Maybe (Expr CoreBndr)
967 match_Integer_unop unop _ id_unf [xl]
968   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
969   = Just (Lit (LitInteger (unop x) i))
970 match_Integer_unop _ _ _ _ = Nothing
971
972 match_Integer_binop :: (Integer -> Integer -> Integer)
973                     -> Id
974                     -> IdUnfoldingFun
975                     -> [Expr CoreBndr]
976                     -> Maybe (Expr CoreBndr)
977 match_Integer_binop binop _ id_unf [xl,yl]
978   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
979   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
980   = Just (Lit (LitInteger (x `binop` y) i))
981 match_Integer_binop _ _ _ _ = Nothing
982
983 -- This helper is used for the quotRem and divMod functions
984 match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
985                          -> Id
986                          -> IdUnfoldingFun
987                          -> [Expr CoreBndr]
988                          -> Maybe (Expr CoreBndr)
989 match_Integer_divop_both divop _ id_unf [xl,yl]
990   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
991   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
992   , y /= 0
993   , (r,s) <- x `divop` y
994   = Just $ mkConApp (tupleCon UnboxedTuple 2)
995                     [Type t,
996                      Type t,
997                      Lit (LitInteger r t),
998                      Lit (LitInteger s t)]
999 match_Integer_divop_both _ _ _ _ = Nothing
1000
1001 -- This helper is used for the quotRem and divMod functions
1002 match_Integer_divop_one :: (Integer -> Integer -> Integer)
1003                         -> Id
1004                         -> IdUnfoldingFun
1005                         -> [Expr CoreBndr]
1006                         -> Maybe (Expr CoreBndr)
1007 match_Integer_divop_one divop _ id_unf [xl,yl]
1008   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1009   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1010   , y /= 0
1011   = Just (Lit (LitInteger (x `divop` y) i))
1012 match_Integer_divop_one _ _ _ _ = Nothing
1013
1014 match_Integer_Int_binop :: (Integer -> Int -> Integer)
1015                         -> Id
1016                         -> IdUnfoldingFun
1017                         -> [Expr CoreBndr]
1018                         -> Maybe (Expr CoreBndr)
1019 match_Integer_Int_binop binop _ id_unf [xl,yl]
1020   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1021   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1022   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1023 match_Integer_Int_binop _ _ _ _ = Nothing
1024
1025 match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
1026                          -> Id
1027                          -> IdUnfoldingFun
1028                          -> [Expr CoreBndr]
1029                          -> Maybe (Expr CoreBndr)
1030 match_Integer_binop_Bool binop _ id_unf [xl, yl]
1031   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1032   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1033   = Just (if x `binop` y then trueVal else falseVal)
1034 match_Integer_binop_Bool _ _ _ _ = Nothing
1035
1036 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
1037                              -> Id
1038                              -> IdUnfoldingFun
1039                              -> [Expr CoreBndr]
1040                              -> Maybe (Expr CoreBndr)
1041 match_Integer_binop_Ordering binop _ id_unf [xl, yl]
1042   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1043   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1044   = Just $ case x `binop` y of
1045              LT -> ltVal
1046              EQ -> eqVal
1047              GT -> gtVal
1048 match_Integer_binop_Ordering _ _ _ _ = Nothing
1049
1050 match_Integer_Int_encodeFloat :: RealFloat a
1051                               => (a -> Expr CoreBndr)
1052                               -> Id
1053                               -> IdUnfoldingFun
1054                               -> [Expr CoreBndr]
1055                               -> Maybe (Expr CoreBndr)
1056 match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
1057   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1058   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1059   = Just (mkLit $ encodeFloat x (fromInteger y))
1060 match_Integer_Int_encodeFloat _ _ _ _ = Nothing
1061
1062 match_decodeDouble :: Id
1063                    -> IdUnfoldingFun
1064                    -> [Expr CoreBndr]
1065                    -> Maybe (Expr CoreBndr)
1066 match_decodeDouble fn id_unf [xl]
1067   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1068   = case idType fn of
1069     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
1070         case decodeFloat (fromRational x :: Double) of
1071         (y, z) ->
1072             Just $ mkConApp (tupleCon UnboxedTuple 2)
1073                             [Type integerTy,
1074                              Type intHashTy,
1075                              Lit (LitInteger y integerTy),
1076                              Lit (MachInt (toInteger z))]
1077     _ ->
1078         panic "match_decodeDouble: Id has the wrong type"
1079 match_decodeDouble _ _ _ = Nothing
1080
1081 match_XToIntegerToX :: Name
1082                     -> Id
1083                     -> IdUnfoldingFun
1084                     -> [Expr CoreBndr]
1085                     -> Maybe (Expr CoreBndr)
1086 match_XToIntegerToX n _ _ [App (Var x) y]
1087   | idName x == n
1088   = Just y
1089 match_XToIntegerToX _ _ _ _ = Nothing
1090
1091 match_smallIntegerTo :: PrimOp
1092                      -> Id
1093                      -> IdUnfoldingFun
1094                      -> [Expr CoreBndr]
1095                      -> Maybe (Expr CoreBndr)
1096 match_smallIntegerTo primOp _ _ [App (Var x) y]
1097   | idName x == smallIntegerName
1098   = Just $ App (Var (mkPrimOpId primOp)) y
1099 match_smallIntegerTo _ _ _ _ = Nothing
1100 \end{code}