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