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