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