Update and clean-up the implmenation of GHC.TypeLits
[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, 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 import Control.Applicative ( Applicative(..), Alternative(..) )
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 Functor RuleM where
544     fmap = liftM
545
546 instance Applicative RuleM where
547     pure = return
548     (<*>) = ap
549
550 instance Monad RuleM where
551   return x = RuleM $ \_ _ _ -> Just x
552   RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
553     Nothing -> Nothing
554     Just r -> runRuleM (g r) dflags iu e
555   fail _ = mzero
556
557 instance Alternative RuleM where
558     empty = mzero
559     (<|>) = mplus
560
561 instance MonadPlus RuleM where
562   mzero = RuleM $ \_ _ _ -> Nothing
563   mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
564     f1 dflags iu args `mplus` f2 dflags iu args
565
566 instance HasDynFlags RuleM where
567     getDynFlags = RuleM $ \dflags _ _ -> Just dflags
568
569 liftMaybe :: Maybe a -> RuleM a
570 liftMaybe Nothing = mzero
571 liftMaybe (Just x) = return x
572
573 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
574 liftLit f = liftLitDynFlags (const f)
575
576 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
577 liftLitDynFlags f = do
578   dflags <- getDynFlags
579   [Lit lit] <- getArgs
580   return $ Lit (f dflags lit)
581
582 removeOp32 :: RuleM CoreExpr
583 #if WORD_SIZE_IN_BITS == 32
584 removeOp32 = do
585   [e] <- getArgs
586   return e
587 #else
588 removeOp32 = mzero
589 #endif
590
591 getArgs :: RuleM [CoreExpr]
592 getArgs = RuleM $ \_ _ args -> Just args
593
594 getInScopeEnv :: RuleM InScopeEnv
595 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
596
597 -- return the n-th argument of this rule, if it is a literal
598 -- argument indices start from 0
599 getLiteral :: Int -> RuleM Literal
600 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
601   (Lit l:_) -> Just l
602   _ -> Nothing
603
604 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
605 unaryLit op = do
606   dflags <- getDynFlags
607   [Lit l] <- getArgs
608   liftMaybe $ op dflags (convFloating dflags l)
609
610 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
611 binaryLit op = do
612   dflags <- getDynFlags
613   [Lit l1, Lit l2] <- getArgs
614   liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
615
616 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
617 binaryCmpLit op = do
618   dflags <- getDynFlags
619   binaryLit (\_ -> cmpOp dflags op)
620
621 leftIdentity :: Literal -> RuleM CoreExpr
622 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
623
624 rightIdentity :: Literal -> RuleM CoreExpr
625 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
626
627 identity :: Literal -> RuleM CoreExpr
628 identity lit = leftIdentity lit `mplus` rightIdentity lit
629
630 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
631 leftIdentityDynFlags id_lit = do
632   dflags <- getDynFlags
633   [Lit l1, e2] <- getArgs
634   guard $ l1 == id_lit dflags
635   return e2
636
637 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
638 rightIdentityDynFlags id_lit = do
639   dflags <- getDynFlags
640   [e1, Lit l2] <- getArgs
641   guard $ l2 == id_lit dflags
642   return e1
643
644 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
645 identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
646
647 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
648 leftZero zero = do
649   dflags <- getDynFlags
650   [Lit l1, _] <- getArgs
651   guard $ l1 == zero dflags
652   return $ Lit l1
653
654 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
655 rightZero zero = do
656   dflags <- getDynFlags
657   [_, Lit l2] <- getArgs
658   guard $ l2 == zero dflags
659   return $ Lit l2
660
661 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
662 zeroElem lit = leftZero lit `mplus` rightZero lit
663
664 equalArgs :: RuleM ()
665 equalArgs = do
666   [e1, e2] <- getArgs
667   guard $ e1 `cheapEqExpr` e2
668
669 nonZeroLit :: Int -> RuleM ()
670 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
671
672 -- When excess precision is not requested, cut down the precision of the
673 -- Rational value to that of Float/Double. We confuse host architecture
674 -- and target architecture here, but it's convenient (and wrong :-).
675 convFloating :: DynFlags -> Literal -> Literal
676 convFloating dflags (MachFloat  f) | not (gopt Opt_ExcessPrecision dflags) =
677    MachFloat  (toRational (fromRational f :: Float ))
678 convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
679    MachDouble (toRational (fromRational d :: Double))
680 convFloating _ l = l
681
682 guardFloatDiv :: RuleM ()
683 guardFloatDiv = do
684   [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
685   guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
686        && f2 /= 0            -- avoid NaN and Infinity/-Infinity
687
688 guardDoubleDiv :: RuleM ()
689 guardDoubleDiv = do
690   [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
691   guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
692        && d2 /= 0            -- avoid NaN and Infinity/-Infinity
693 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
694 -- zero, but we might want to preserve the negative zero here which
695 -- is representable in Float/Double but not in (normalised)
696 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
697
698 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
699 strengthReduction two_lit add_op = do -- Note [Strength reduction]
700   arg <- msum [ do [arg, Lit mult_lit] <- getArgs
701                    guard (mult_lit == two_lit)
702                    return arg
703               , do [Lit mult_lit, arg] <- getArgs
704                    guard (mult_lit == two_lit)
705                    return arg ]
706   return $ Var (mkPrimOpId add_op) `App` arg `App` arg
707
708 -- Note [Strength reduction]
709 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
710 --
711 -- This rule turns floating point multiplications of the form 2.0 * x and
712 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
713 -- See #7116
714
715 -- Note [What's true and false]
716 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
717 --
718 -- trueValInt and falseValInt represent true and false values returned by
719 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
720 -- True is represented as an unboxed 1# literal, while false is represented
721 -- as 0# literal.
722 -- We still need Bool data constructors (True and False) to use in a rule
723 -- for constant folding of equal Strings
724
725 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
726 trueValInt  dflags = Lit $ onei  dflags -- see Note [What's true and false]
727 falseValInt dflags = Lit $ zeroi dflags
728
729 trueValBool, falseValBool :: Expr CoreBndr
730 trueValBool   = Var trueDataConId -- see Note [What's true and false]
731 falseValBool  = Var falseDataConId
732
733 ltVal, eqVal, gtVal :: Expr CoreBndr
734 ltVal = Var ltDataConId
735 eqVal = Var eqDataConId
736 gtVal = Var gtDataConId
737
738 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
739 mkIntVal dflags i = Lit (mkMachInt dflags i)
740 mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
741 mkWordVal dflags w = Lit (mkMachWord dflags w)
742 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
743 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat  f))
744 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
745 mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
746
747 matchPrimOpId :: PrimOp -> Id -> RuleM ()
748 matchPrimOpId op id = do
749   op' <- liftMaybe $ isPrimOpId_maybe id
750   guard $ op == op'
751
752 \end{code}
753
754 %************************************************************************
755 %*                                                                      *
756 \subsection{Special rules for seq, tagToEnum, dataToTag}
757 %*                                                                      *
758 %************************************************************************
759
760 Note [tagToEnum#]
761 ~~~~~~~~~~~~~~~~~
762 Nasty check to ensure that tagToEnum# is applied to a type that is an
763 enumeration TyCon.  Unification may refine the type later, but this
764 check won't see that, alas.  It's crude but it works.
765
766 Here's are two cases that should fail
767         f :: forall a. a
768         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
769
770         g :: Int
771         g = tagToEnum# 0        -- Int is not an enumeration
772
773 We used to make this check in the type inference engine, but it's quite
774 ugly to do so, because the delayed constraint solving means that we don't
775 really know what's going on until the end. It's very much a corner case
776 because we don't expect the user to call tagToEnum# at all; we merely
777 generate calls in derived instances of Enum.  So we compromise: a
778 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
779 and emits a warning.
780
781 \begin{code}
782 tagToEnumRule :: RuleM CoreExpr
783 -- If     data T a = A | B | C
784 -- then   tag2Enum# (T ty) 2# -->  B ty
785 tagToEnumRule = do
786   [Type ty, Lit (MachInt i)] <- getArgs
787   case splitTyConApp_maybe ty of
788     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
789       let tag = fromInteger i
790           correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
791       (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
792       ASSERT(null rest) return ()
793       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
794
795     -- See Note [tagToEnum#]
796     _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
797          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
798 \end{code}
799
800
801 For dataToTag#, we can reduce if either
802
803         (a) the argument is a constructor
804         (b) the argument is a variable whose unfolding is a known constructor
805
806 \begin{code}
807 dataToTagRule :: RuleM CoreExpr
808 dataToTagRule = a `mplus` b
809   where
810     a = do
811       [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
812       guard $ tag_to_enum `hasKey` tagToEnumKey
813       guard $ ty1 `eqType` ty2
814       return tag -- dataToTag (tagToEnum x)   ==>   x
815     b = do
816       dflags <- getDynFlags
817       [_, val_arg] <- getArgs
818       in_scope <- getInScopeEnv
819       (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
820       ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
821       return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
822 \end{code}
823
824 %************************************************************************
825 %*                                                                      *
826 \subsection{Rules for seq# and spark#}
827 %*                                                                      *
828 %************************************************************************
829
830 \begin{code}
831 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
832 seqRule :: RuleM CoreExpr
833 seqRule = do
834   [ty_a, Type ty_s, a, s] <- getArgs
835   guard $ exprIsHNF a
836   return $ mkConApp (tupleCon UnboxedTuple 2)
837     [Type (mkStatePrimTy ty_s), ty_a, s, a]
838
839 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
840 sparkRule :: RuleM CoreExpr
841 sparkRule = seqRule -- reduce on HNF, just the same
842   -- XXX perhaps we shouldn't do this, because a spark eliminated by
843   -- this rule won't be counted as a dud at runtime?
844 \end{code}
845
846 %************************************************************************
847 %*                                                                      *
848 \subsection{Built in rules}
849 %*                                                                      *
850 %************************************************************************
851
852 Note [Scoping for Builtin rules]
853 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
854 When compiling a (base-package) module that defines one of the
855 functions mentioned in the RHS of a built-in rule, there's a danger
856 that we'll see
857
858         f = ...(eq String x)....
859
860         ....and lower down...
861
862         eqString = ...
863
864 Then a rewrite would give
865
866         f = ...(eqString x)...
867         ....and lower down...
868         eqString = ...
869
870 and lo, eqString is not in scope.  This only really matters when we get to code
871 generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
872 set of bindings, which sorts out the dependency.  Without -O we don't do any rule
873 rewriting so again we are fine.
874
875 (This whole thing doesn't show up for non-built-in rules because their dependencies
876 are explicit.)
877
878
879 \begin{code}
880 builtinRules :: [CoreRule]
881 -- Rules for non-primops that can't be expressed using a RULE pragma
882 builtinRules
883   = [BuiltinRule { ru_name = fsLit "AppendLitString",
884                    ru_fn = unpackCStringFoldrName,
885                    ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
886      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
887                    ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
888      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
889                    ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
890      BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
891                    ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }
892      ]
893  ++ builtinIntegerRules
894
895 builtinIntegerRules :: [CoreRule]
896 builtinIntegerRules =
897  [rule_IntToInteger   "smallInteger"        smallIntegerName,
898   rule_WordToInteger  "wordToInteger"       wordToIntegerName,
899   rule_Int64ToInteger  "int64ToInteger"     int64ToIntegerName,
900   rule_Word64ToInteger "word64ToInteger"    word64ToIntegerName,
901   rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
902   rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
903   rule_convert        "integerToWord64"     integerToWord64Name     (\_ -> mkWord64LitWord64),
904   rule_convert        "integerToInt64"      integerToInt64Name      (\_ -> mkInt64LitInt64),
905   rule_binop          "plusInteger"         plusIntegerName         (+),
906   rule_binop          "minusInteger"        minusIntegerName        (-),
907   rule_binop          "timesInteger"        timesIntegerName        (*),
908   rule_unop           "negateInteger"       negateIntegerName       negate,
909   rule_binop_Prim     "eqInteger#"          eqIntegerPrimName       (==),
910   rule_binop_Prim     "neqInteger#"         neqIntegerPrimName      (/=),
911   rule_unop           "absInteger"          absIntegerName          abs,
912   rule_unop           "signumInteger"       signumIntegerName       signum,
913   rule_binop_Prim     "leInteger#"          leIntegerPrimName       (<=),
914   rule_binop_Prim     "gtInteger#"          gtIntegerPrimName       (>),
915   rule_binop_Prim     "ltInteger#"          ltIntegerPrimName       (<),
916   rule_binop_Prim     "geInteger#"          geIntegerPrimName       (>=),
917   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
918   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
919   rule_convert        "floatFromInteger"    floatFromIntegerName    (\_ -> mkFloatLitFloat),
920   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
921   rule_decodeDouble   "decodeDoubleInteger" decodeDoubleIntegerName,
922   rule_convert        "doubleFromInteger"   doubleFromIntegerName   (\_ -> mkDoubleLitDouble),
923   rule_rationalTo     "rationalToFloat"     rationalToFloatName     mkFloatExpr,
924   rule_rationalTo     "rationalToDouble"    rationalToDoubleName    mkDoubleExpr,
925   rule_binop          "gcdInteger"          gcdIntegerName          gcd,
926   rule_binop          "lcmInteger"          lcmIntegerName          lcm,
927   rule_binop          "andInteger"          andIntegerName          (.&.),
928   rule_binop          "orInteger"           orIntegerName           (.|.),
929   rule_binop          "xorInteger"          xorIntegerName          xor,
930   rule_unop           "complementInteger"   complementIntegerName   complement,
931   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
932   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR,
933   -- See Note [Integer division constant folding] in libraries/base/GHC/Real.lhs
934   rule_divop_one      "quotInteger"         quotIntegerName         quot,
935   rule_divop_one      "remInteger"          remIntegerName          rem,
936   rule_divop_one      "divInteger"          divIntegerName          div,
937   rule_divop_one      "modInteger"          modIntegerName          mod,
938   rule_divop_both     "divModInteger"       divModIntegerName       divMod,
939   rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
940   -- These rules below don't actually have to be built in, but if we
941   -- put them in the Haskell source then we'd have to duplicate them
942   -- between all Integer implementations
943   rule_XToIntegerToX "smallIntegerToInt"       integerToIntName    smallIntegerName,
944   rule_XToIntegerToX "wordToIntegerToWord"     integerToWordName   wordToIntegerName,
945   rule_XToIntegerToX "int64ToIntegerToInt64"   integerToInt64Name  int64ToIntegerName,
946   rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
947   rule_smallIntegerTo "smallIntegerToWord"   integerToWordName     Int2WordOp,
948   rule_smallIntegerTo "smallIntegerToFloat"  floatFromIntegerName  Int2FloatOp,
949   rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
950   ]
951     where rule_convert str name convert
952            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
953                            ru_try = match_Integer_convert convert }
954           rule_IntToInteger str name
955            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
956                            ru_try = match_IntToInteger }
957           rule_WordToInteger str name
958            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
959                            ru_try = match_WordToInteger }
960           rule_Int64ToInteger str name
961            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
962                            ru_try = match_Int64ToInteger }
963           rule_Word64ToInteger str name
964            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
965                            ru_try = match_Word64ToInteger }
966           rule_unop str name op
967            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
968                            ru_try = match_Integer_unop op }
969           rule_binop str name op
970            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
971                            ru_try = match_Integer_binop op }
972           rule_divop_both str name op
973            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
974                            ru_try = match_Integer_divop_both op }
975           rule_divop_one str name op
976            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
977                            ru_try = match_Integer_divop_one op }
978           rule_Int_binop str name op
979            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
980                            ru_try = match_Integer_Int_binop op }
981           rule_binop_Prim str name op
982            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
983                            ru_try = match_Integer_binop_Prim op }
984           rule_binop_Ordering str name op
985            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
986                            ru_try = match_Integer_binop_Ordering op }
987           rule_encodeFloat str name op
988            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
989                            ru_try = match_Integer_Int_encodeFloat op }
990           rule_decodeDouble str name
991            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
992                            ru_try = match_decodeDouble }
993           rule_XToIntegerToX str name toIntegerName
994            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
995                            ru_try = match_XToIntegerToX toIntegerName }
996           rule_smallIntegerTo str name primOp
997            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
998                            ru_try = match_smallIntegerTo primOp }
999           rule_rationalTo str name mkLit
1000            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1001                            ru_try = match_rationalTo mkLit }
1002
1003 ---------------------------------------------------
1004 -- The rule is this:
1005 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1006 --      =  unpackFoldrCString# "foobaz" c n
1007
1008 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1009 match_append_lit [Type ty1,
1010                     Lit (MachStr s1),
1011                     c1,
1012                     Var unpk `App` Type ty2
1013                              `App` Lit (MachStr s2)
1014                              `App` c2
1015                              `App` n
1016                    ]
1017   | unpk `hasKey` unpackCStringFoldrIdKey &&
1018     c1 `cheapEqExpr` c2
1019   = ASSERT( ty1 `eqType` ty2 )
1020     Just (Var unpk `App` Type ty1
1021                    `App` Lit (MachStr (s1 `BS.append` s2))
1022                    `App` c1
1023                    `App` n)
1024
1025 match_append_lit _ = Nothing
1026
1027 ---------------------------------------------------
1028 -- The rule is this:
1029 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
1030
1031 match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1032 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
1033                         Var unpk2 `App` Lit (MachStr s2)]
1034   | unpk1 `hasKey` unpackCStringIdKey,
1035     unpk2 `hasKey` unpackCStringIdKey
1036   = Just (if s1 == s2 then trueValBool else falseValBool)
1037
1038 match_eq_string _ _ = Nothing
1039
1040
1041 ---------------------------------------------------
1042 -- The rule is this:
1043 --      inline f_ty (f a b c) = <f's unfolding> a b c
1044 -- (if f has an unfolding, EVEN if it's a loop breaker)
1045 --
1046 -- It's important to allow the argument to 'inline' to have args itself
1047 -- (a) because its more forgiving to allow the programmer to write
1048 --       inline f a b c
1049 --   or  inline (f a b c)
1050 -- (b) because a polymorphic f wll get a type argument that the
1051 --     programmer can't avoid
1052 --
1053 -- Also, don't forget about 'inline's type argument!
1054 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1055 match_inline (Type _ : e : _)
1056   | (Var f, args1) <- collectArgs e,
1057     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1058              -- Ignore the IdUnfoldingFun here!
1059   = Just (mkApps unf args1)
1060
1061 match_inline _ = Nothing
1062
1063
1064 -- See Note [magicDictId magic] in `basicTypes/MkId.lhs`
1065 -- for a description of what is going on here.
1066 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1067 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1068   | Just (fieldTy, _)   <- splitFunTy_maybe $ dropForAlls $ idType wrap
1069   , Just (dictTy, _)    <- splitFunTy_maybe fieldTy
1070   , Just dictTc         <- tyConAppTyCon_maybe dictTy
1071   , Just (_,_,co)       <- unwrapNewTyCon_maybe dictTc
1072   = Just
1073   $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a]))
1074       `App` y
1075
1076 match_magicDict _ = Nothing
1077
1078 -------------------------------------------------
1079 -- Integer rules
1080 --   smallInteger  (79::Int#)  = 79::Integer
1081 --   wordToInteger (79::Word#) = 79::Integer
1082 -- Similarly Int64, Word64
1083
1084 match_IntToInteger :: RuleFun
1085 match_IntToInteger _ id_unf fn [xl]
1086   | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
1087   = case idType fn of
1088     FunTy _ integerTy ->
1089         Just (Lit (LitInteger x integerTy))
1090     _ ->
1091         panic "match_IntToInteger: Id has the wrong type"
1092 match_IntToInteger _ _ _ _ = Nothing
1093
1094 match_WordToInteger :: RuleFun
1095 match_WordToInteger _ id_unf id [xl]
1096   | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
1097   = case idType id of
1098     FunTy _ integerTy ->
1099         Just (Lit (LitInteger x integerTy))
1100     _ ->
1101         panic "match_WordToInteger: Id has the wrong type"
1102 match_WordToInteger _ _ _ _ = Nothing
1103
1104 match_Int64ToInteger :: RuleFun
1105 match_Int64ToInteger _ id_unf id [xl]
1106   | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
1107   = case idType id of
1108     FunTy _ integerTy ->
1109         Just (Lit (LitInteger x integerTy))
1110     _ ->
1111         panic "match_Int64ToInteger: Id has the wrong type"
1112 match_Int64ToInteger _ _ _ _ = Nothing
1113
1114 match_Word64ToInteger :: RuleFun
1115 match_Word64ToInteger _ id_unf id [xl]
1116   | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
1117   = case idType id of
1118     FunTy _ integerTy ->
1119         Just (Lit (LitInteger x integerTy))
1120     _ ->
1121         panic "match_Word64ToInteger: Id has the wrong type"
1122 match_Word64ToInteger _ _ _ _ = Nothing
1123
1124 -------------------------------------------------
1125 match_Integer_convert :: Num a
1126                       => (DynFlags -> a -> Expr CoreBndr)
1127                       -> RuleFun
1128 match_Integer_convert convert dflags id_unf _ [xl]
1129   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1130   = Just (convert dflags (fromInteger x))
1131 match_Integer_convert _ _ _ _ _ = Nothing
1132
1133 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1134 match_Integer_unop unop _ id_unf _ [xl]
1135   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1136   = Just (Lit (LitInteger (unop x) i))
1137 match_Integer_unop _ _ _ _ _ = Nothing
1138
1139 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1140 match_Integer_binop binop _ id_unf _ [xl,yl]
1141   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1142   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1143   = Just (Lit (LitInteger (x `binop` y) i))
1144 match_Integer_binop _ _ _ _ _ = Nothing
1145
1146 -- This helper is used for the quotRem and divMod functions
1147 match_Integer_divop_both
1148    :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1149 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1150   | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
1151   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1152   , y /= 0
1153   , (r,s) <- x `divop` y
1154   = Just $ mkConApp (tupleCon UnboxedTuple 2)
1155                     [Type t,
1156                      Type t,
1157                      Lit (LitInteger r t),
1158                      Lit (LitInteger s t)]
1159 match_Integer_divop_both _ _ _ _ _ = Nothing
1160
1161 -- This helper is used for the quot and rem functions
1162 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1163 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1164   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1165   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1166   , y /= 0
1167   = Just (Lit (LitInteger (x `divop` y) i))
1168 match_Integer_divop_one _ _ _ _ _ = Nothing
1169
1170 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
1171 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
1172   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1173   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1174   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1175 match_Integer_Int_binop _ _ _ _ _ = Nothing
1176
1177 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1178 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1179   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1180   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1181   = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1182 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1183
1184 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1185 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1186   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1187   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1188   = Just $ case x `binop` y of
1189              LT -> ltVal
1190              EQ -> eqVal
1191              GT -> gtVal
1192 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1193
1194 match_Integer_Int_encodeFloat :: RealFloat a
1195                               => (a -> Expr CoreBndr)
1196                               -> RuleFun
1197 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1198   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1199   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
1200   = Just (mkLit $ encodeFloat x (fromInteger y))
1201 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1202
1203 ---------------------------------------------------
1204 -- constant folding for Float/Double
1205 --
1206 -- This turns
1207 --      rationalToFloat n d
1208 -- into a literal Float, and similarly for Doubles.
1209 --
1210 -- it's important to not match d == 0, because that may represent a
1211 -- literal "0/0" or similar, and we can't produce a literal value for
1212 -- NaN or +-Inf
1213 match_rationalTo :: RealFloat a
1214                  => (a -> Expr CoreBndr)
1215                  -> RuleFun
1216 match_rationalTo mkLit _ id_unf _ [xl, yl]
1217   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1218   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1219   , y /= 0
1220   = Just (mkLit (fromRational (x % y)))
1221 match_rationalTo _ _ _ _ _ = Nothing
1222
1223 match_decodeDouble :: RuleFun
1224 match_decodeDouble _ id_unf fn [xl]
1225   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1226   = case idType fn of
1227     FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
1228         case decodeFloat (fromRational x :: Double) of
1229         (y, z) ->
1230             Just $ mkConApp (tupleCon UnboxedTuple 2)
1231                             [Type integerTy,
1232                              Type intHashTy,
1233                              Lit (LitInteger y integerTy),
1234                              Lit (MachInt (toInteger z))]
1235     _ ->
1236         panic "match_decodeDouble: Id has the wrong type"
1237 match_decodeDouble _ _ _ _ = Nothing
1238
1239 match_XToIntegerToX :: Name -> RuleFun
1240 match_XToIntegerToX n _ _ _ [App (Var x) y]
1241   | idName x == n
1242   = Just y
1243 match_XToIntegerToX _ _ _ _ _ = Nothing
1244
1245 match_smallIntegerTo :: PrimOp -> RuleFun
1246 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1247   | idName x == smallIntegerName
1248   = Just $ App (Var (mkPrimOpId primOp)) y
1249 match_smallIntegerTo _ _ _ _ _ = Nothing
1250 \end{code}