Tell built-in rules the Id that the rule has matched
[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 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
16
17 module PrelRules ( primOpRules, builtinRules ) where
18
19 #include "HsVersions.h"
20
21 import CoreSyn
22 import MkCore
23 import Id
24 import Literal
25 import CoreSubst   ( exprIsLiteral_maybe )
26 import PrimOp      ( PrimOp(..), tagToEnumKey )
27 import TysWiredIn
28 import TysPrim
29 import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
30 import DataCon     ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
31 import CoreUtils   ( cheapEqExpr, exprIsHNF )
32 import CoreUnfold  ( exprIsConApp_maybe )
33 import Type
34 import TypeRep
35 import OccName     ( occNameFS )
36 import PrelNames
37 import Maybes      ( orElse )
38 import Name        ( Name, nameOccName )
39 import Outputable
40 import FastString
41 import StaticFlags ( opt_SimplExcessPrecision )
42 import Constants
43 import BasicTypes
44 import Util
45
46 import Data.Bits as Bits
47 import Data.Int    ( Int64 )
48 import Data.Word   ( Word, Word64 )
49 \end{code}
50
51
52 Note [Constant folding]
53 ~~~~~~~~~~~~~~~~~~~~~~~
54 primOpRules generates the rewrite rules for each primop
55 These rules do what is often called "constant folding"
56 E.g. the rules for +# might say
57         4 +# 5 = 9
58 Well, of course you'd need a lot of rules if you did it
59 like that, so we use a BuiltinRule instead, so that we
60 can match in any two literal values.  So the rule is really
61 more like
62         (Lit x) +# (Lit y) = Lit (x+#y)
63 where the (+#) on the rhs is done at compile time
64
65 That is why these rules are built in here.  Other rules
66 which don't need to be built in are in GHC.Base. For
67 example:
68         x +# 0 = x
69
70
71 \begin{code}
72 primOpRules :: PrimOp -> Name -> [CoreRule]
73 primOpRules op op_name = primop_rule op
74   where
75     -- A useful shorthand
76     one_lit   = oneLit  op_name
77     two_lits  = twoLits op_name
78     relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
79     -- Cunning.  cmpOp compares the values to give an Ordering.
80     -- It applies its argument to that ordering value to turn
81     -- the ordering into a boolean value.  (`cmp` EQ) is just the job.
82
83     -- ToDo: something for integer-shift ops?
84     --       NotOp
85
86     primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
87     primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
88
89     -- Int operations
90     primop_rule IntAddOp    = two_lits (intOp2     (+))
91     primop_rule IntSubOp    = two_lits (intOp2     (-))
92     primop_rule IntMulOp    = two_lits (intOp2     (*))
93     primop_rule IntQuotOp   = two_lits (intOp2Z    quot)
94     primop_rule IntRemOp    = two_lits (intOp2Z    rem)
95     primop_rule IntNegOp    = one_lit  negOp
96     primop_rule ISllOp      = two_lits (intShiftOp2 Bits.shiftL)
97     primop_rule ISraOp      = two_lits (intShiftOp2 Bits.shiftR)
98     primop_rule ISrlOp      = two_lits (intShiftOp2 shiftRightLogical)
99
100     -- Word operations
101     primop_rule WordAddOp   = two_lits (wordOp2    (+))
102     primop_rule WordSubOp   = two_lits (wordOp2    (-))
103     primop_rule WordMulOp   = two_lits (wordOp2    (*))
104     primop_rule WordQuotOp  = two_lits (wordOp2Z   quot)
105     primop_rule WordRemOp   = two_lits (wordOp2Z   rem)
106     primop_rule AndOp       = two_lits (wordBitOp2 (.&.))
107     primop_rule OrOp        = two_lits (wordBitOp2 (.|.))
108     primop_rule XorOp       = two_lits (wordBitOp2 xor)
109     primop_rule SllOp       = two_lits (wordShiftOp2 Bits.shiftL)
110     primop_rule SrlOp       = two_lits (wordShiftOp2 shiftRightLogical)
111
112     -- coercions
113     primop_rule Word2IntOp     = one_lit (litCoerce word2IntLit)
114     primop_rule Int2WordOp     = one_lit (litCoerce int2WordLit)
115     primop_rule Narrow8IntOp   = one_lit (litCoerce narrow8IntLit)
116     primop_rule Narrow16IntOp  = one_lit (litCoerce narrow16IntLit)
117     primop_rule Narrow32IntOp  = one_lit (litCoerce narrow32IntLit)
118     primop_rule Narrow8WordOp  = one_lit (litCoerce narrow8WordLit)
119     primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
120     primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
121     primop_rule OrdOp          = one_lit (litCoerce char2IntLit)
122     primop_rule ChrOp          = one_lit (predLitCoerce litFitsInChar int2CharLit)
123     primop_rule Float2IntOp    = one_lit (litCoerce float2IntLit)
124     primop_rule Int2FloatOp    = one_lit (litCoerce int2FloatLit)
125     primop_rule Double2IntOp   = one_lit (litCoerce double2IntLit)
126     primop_rule Int2DoubleOp   = one_lit (litCoerce int2DoubleLit)
127     -- SUP: Not sure what the standard says about precision in the following 2 cases
128     primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
129     primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
130
131     -- Float
132     primop_rule FloatAddOp   = two_lits (floatOp2  (+))
133     primop_rule FloatSubOp   = two_lits (floatOp2  (-))
134     primop_rule FloatMulOp   = two_lits (floatOp2  (*))
135     primop_rule FloatDivOp   = two_lits (floatOp2Z (/))
136     primop_rule FloatNegOp   = one_lit  negOp
137
138     -- Double
139     primop_rule DoubleAddOp   = two_lits (doubleOp2  (+))
140     primop_rule DoubleSubOp   = two_lits (doubleOp2  (-))
141     primop_rule DoubleMulOp   = two_lits (doubleOp2  (*))
142     primop_rule DoubleDivOp   = two_lits (doubleOp2Z (/))
143     primop_rule DoubleNegOp   = one_lit  negOp
144
145     -- Relational operators
146     primop_rule IntEqOp    = relop (==) ++ litEq op_name True
147     primop_rule IntNeOp    = relop (/=) ++ litEq op_name False
148     primop_rule CharEqOp   = relop (==) ++ litEq op_name True
149     primop_rule CharNeOp   = relop (/=) ++ litEq op_name False
150
151     primop_rule IntGtOp    = relop (>)  ++ boundsCmp op_name Gt
152     primop_rule IntGeOp    = relop (>=) ++ boundsCmp op_name Ge
153     primop_rule IntLeOp    = relop (<=) ++ boundsCmp op_name Le
154     primop_rule IntLtOp    = relop (<)  ++ boundsCmp op_name Lt
155
156     primop_rule CharGtOp   = relop (>)  ++ boundsCmp op_name Gt
157     primop_rule CharGeOp   = relop (>=) ++ boundsCmp op_name Ge
158     primop_rule CharLeOp   = relop (<=) ++ boundsCmp op_name Le
159     primop_rule CharLtOp   = relop (<)  ++ boundsCmp op_name Lt
160
161     primop_rule FloatGtOp  = relop (>)
162     primop_rule FloatGeOp  = relop (>=)
163     primop_rule FloatLeOp  = relop (<=)
164     primop_rule FloatLtOp  = relop (<)
165     primop_rule FloatEqOp  = relop (==)
166     primop_rule FloatNeOp  = relop (/=)
167
168     primop_rule DoubleGtOp = relop (>)
169     primop_rule DoubleGeOp = relop (>=)
170     primop_rule DoubleLeOp = relop (<=)
171     primop_rule DoubleLtOp = relop (<)
172     primop_rule DoubleEqOp = relop (==)
173     primop_rule DoubleNeOp = relop (/=)
174
175     primop_rule WordGtOp   = relop (>)  ++ boundsCmp op_name Gt
176     primop_rule WordGeOp   = relop (>=) ++ boundsCmp op_name Ge
177     primop_rule WordLeOp   = relop (<=) ++ boundsCmp op_name Le
178     primop_rule WordLtOp   = relop (<)  ++ boundsCmp op_name Lt
179     primop_rule WordEqOp   = relop (==)
180     primop_rule WordNeOp   = relop (/=)
181
182     primop_rule SeqOp      = mkBasicRule op_name 4 seqRule
183     primop_rule SparkOp    = mkBasicRule op_name 4 sparkRule
184
185     primop_rule _          = []
186 \end{code}
187
188 %************************************************************************
189 %*                                                                      *
190 \subsection{Doing the business}
191 %*                                                                      *
192 %************************************************************************
193
194 ToDo: the reason these all return Nothing is because there used to be
195 the possibility of an argument being a litlit.  Litlits are now gone,
196 so this could be cleaned up.
197
198 \begin{code}
199 --------------------------
200 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
201 litCoerce fn lit = Just (Lit (fn lit))
202
203 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
204 predLitCoerce p fn lit
205    | p lit     = Just (Lit (fn lit))
206    | otherwise = Nothing
207
208 --------------------------
209 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
210 cmpOp cmp l1 l2
211   = go l1 l2
212   where
213     done res | cmp res   = Just trueVal
214              | otherwise = Just falseVal
215
216     -- These compares are at different types
217     go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
218     go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
219     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
220     go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
221     go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
222     go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
223     go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
224     go _               _               = Nothing
225
226 --------------------------
227
228 negOp :: Literal -> Maybe CoreExpr  -- Negate
229 negOp (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
230 negOp (MachFloat f)    = Just (mkFloatVal (-f))
231 negOp (MachDouble 0.0) = Nothing
232 negOp (MachDouble d)   = Just (mkDoubleVal (-d))
233 negOp (MachInt i)      = intResult (-i)
234 negOp _                = Nothing
235
236 --------------------------
237 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
238 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
239 intOp2 _  _            _            = Nothing  -- Could find LitLit
240
241 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
242 -- Like intOp2, but Nothing if i2=0
243 intOp2Z op (MachInt i1) (MachInt i2)
244   | i2 /= 0 = intResult (i1 `op` i2)
245 intOp2Z _ _ _ = Nothing  -- LitLit or zero dividend
246
247 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
248 -- Shifts take an Int; hence second arg of op is Int
249 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
250 intShiftOp2 _  _            _            = Nothing
251
252 shiftRightLogical :: Integer -> Int -> Integer
253 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
254 -- Do this by converting to Word and back.  Obviously this won't work for big
255 -- values, but its ok as we use it here
256 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
257
258
259 --------------------------
260 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
261 wordOp2 op (MachWord w1) (MachWord w2)
262   = wordResult (w1 `op` w2)
263 wordOp2 _ _ _ = Nothing  -- Could find LitLit
264
265 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
266 wordOp2Z op (MachWord w1) (MachWord w2)
267   | w2 /= 0 = wordResult (w1 `op` w2)
268 wordOp2Z _ _ _ = Nothing  -- LitLit or zero dividend
269
270 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
271            -> Maybe CoreExpr
272 wordBitOp2 op (MachWord w1) (MachWord w2)
273   = wordResult (w1 `op` w2)
274 wordBitOp2 _ _ _ = Nothing  -- Could find LitLit
275
276 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
277 -- Shifts take an Int; hence second arg of op is Int
278 wordShiftOp2 op (MachWord x) (MachInt n)
279   = wordResult (x `op` fromInteger n)
280     -- Do the shift at type Integer
281 wordShiftOp2 _ _ _ = Nothing
282
283 --------------------------
284 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
285          -> Maybe (Expr CoreBndr)
286 floatOp2  op (MachFloat f1) (MachFloat f2)
287   = Just (mkFloatVal (f1 `op` f2))
288 floatOp2 _ _ _ = Nothing
289
290 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
291           -> Maybe (Expr CoreBndr)
292 floatOp2Z op (MachFloat f1) (MachFloat f2)
293   | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
294   && f2 /= 0             -- avoid NaN and Infinity/-Infinity
295   = Just (mkFloatVal (f1 `op` f2))
296 floatOp2Z _ _ _ = Nothing
297
298 --------------------------
299 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
300           -> Maybe (Expr CoreBndr)
301 doubleOp2  op (MachDouble f1) (MachDouble f2)
302   = Just (mkDoubleVal (f1 `op` f2))
303 doubleOp2 _ _ _ = Nothing
304
305 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
306            -> Maybe (Expr CoreBndr)
307 doubleOp2Z op (MachDouble f1) (MachDouble f2)
308   | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
309   && f2 /= 0             -- avoid NaN and Infinity/-Infinity
310   = Just (mkDoubleVal (f1 `op` f2))
311   -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
312   -- zero, but we might want to preserve the negative zero here which
313   -- is representable in Float/Double but not in (normalised)
314   -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
315 doubleOp2Z _ _ _ = Nothing
316
317
318 --------------------------
319 -- This stuff turns
320 --      n ==# 3#
321 -- into
322 --      case n of
323 --        3# -> True
324 --        m  -> False
325 --
326 -- This is a Good Thing, because it allows case-of case things
327 -- to happen, and case-default absorption to happen.  For
328 -- example:
329 --
330 --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
331 -- will transform to
332 --      case n of
333 --        3# -> e1
334 --        4# -> e1
335 --        m  -> e2
336 -- (modulo the usual precautions to avoid duplicating e1)
337
338 litEq :: Name
339       -> Bool  -- True <=> equality, False <=> inequality
340       -> [CoreRule]
341 litEq op_name is_eq
342   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
343                                 `appendFS` (fsLit "->case"),
344                    ru_fn = op_name,
345                    ru_nargs = 2, ru_try = rule_fn }]
346   where
347     rule_fn _ _ [Lit lit, expr] = do_lit_eq lit expr
348     rule_fn _ _ [expr, Lit lit] = do_lit_eq lit expr
349     rule_fn _ _ _               = Nothing
350
351     do_lit_eq lit expr
352       | litIsLifted lit 
353       = Nothing
354       | otherwise
355       = Just (mkWildCase expr (literalType lit) boolTy
356                     [(DEFAULT,    [], val_if_neq),
357                      (LitAlt lit, [], val_if_eq)])
358     val_if_eq  | is_eq     = trueVal
359                | otherwise = falseVal
360     val_if_neq | is_eq     = falseVal
361                | otherwise = trueVal
362
363
364 -- | Check if there is comparison with minBound or maxBound, that is
365 -- always true or false. For instance, an Int cannot be smaller than its
366 -- minBound, so we can replace such comparison with False.
367 boundsCmp :: Name -> Comparison -> [CoreRule]
368 boundsCmp op_name op = [ rule ]
369   where
370     rule = BuiltinRule
371       { ru_name = occNameFS (nameOccName op_name)
372                     `appendFS` (fsLit "min/maxBound")
373       , ru_fn = op_name
374       , ru_nargs = 2
375       , ru_try = rule_fn
376       }
377     rule_fn _ _ [a, b] = mkRuleFn op a b
378     rule_fn _ _ _      = Nothing
379
380 data Comparison = Gt | Ge | Lt | Le
381
382 mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
383 mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal
384 mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal
385 mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal
386 mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal
387 mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal
388 mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal
389 mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal
390 mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal
391 mkRuleFn _ _ _                           = Nothing
392
393 isMinBound :: Literal -> Bool
394 isMinBound (MachChar c)   = c == minBound
395 isMinBound (MachInt i)    = i == toInteger (minBound :: Int)
396 isMinBound (MachInt64 i)  = i == toInteger (minBound :: Int64)
397 isMinBound (MachWord i)   = i == toInteger (minBound :: Word)
398 isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64)
399 isMinBound _              = False
400
401 isMaxBound :: Literal -> Bool
402 isMaxBound (MachChar c)   = c == maxBound
403 isMaxBound (MachInt i)    = i == toInteger (maxBound :: Int)
404 isMaxBound (MachInt64 i)  = i == toInteger (maxBound :: Int64)
405 isMaxBound (MachWord i)   = i == toInteger (maxBound :: Word)
406 isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64)
407 isMaxBound _              = False
408
409
410 -- Note that we *don't* warn the user about overflow. It's not done at
411 -- runtime either, and compilation of completely harmless things like
412 --    ((124076834 :: Word32) + (2147483647 :: Word32))
413 -- would yield a warning. Instead we simply squash the value into the
414 -- *target* Int/Word range.
415 intResult :: Integer -> Maybe CoreExpr
416 intResult result
417   = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
418
419 wordResult :: Integer -> Maybe CoreExpr
420 wordResult result
421   = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
422 \end{code}
423
424
425 %************************************************************************
426 %*                                                                      *
427 \subsection{Vaguely generic functions}
428 %*                                                                      *
429 %************************************************************************
430
431 \begin{code}
432 mkBasicRule :: Name -> Int
433             -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
434             -> [CoreRule]
435 -- Gives the Rule the same name as the primop itself
436 mkBasicRule op_name n_args rule_fn
437   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
438                    ru_fn = op_name,
439                    ru_nargs = n_args, ru_try = \_ -> rule_fn }]
440
441 oneLit :: Name -> (Literal -> Maybe CoreExpr)
442        -> [CoreRule]
443 oneLit op_name test
444   = mkBasicRule op_name 1 rule_fn
445   where
446     rule_fn _ [Lit l1] = test (convFloating l1)
447     rule_fn _ _        = Nothing
448
449 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
450         -> [CoreRule]
451 twoLits op_name test
452   = mkBasicRule op_name 2 rule_fn
453   where
454     rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
455     rule_fn _ _                = Nothing
456
457 -- When excess precision is not requested, cut down the precision of the
458 -- Rational value to that of Float/Double. We confuse host architecture
459 -- and target architecture here, but it's convenient (and wrong :-).
460 convFloating :: Literal -> Literal
461 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
462    MachFloat  (toRational ((fromRational f) :: Float ))
463 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
464    MachDouble (toRational ((fromRational d) :: Double))
465 convFloating l = l
466
467 trueVal, falseVal :: Expr CoreBndr
468 trueVal       = Var trueDataConId
469 falseVal      = Var falseDataConId
470
471 ltVal, eqVal, gtVal :: Expr CoreBndr
472 ltVal = Var ltDataConId
473 eqVal = Var eqDataConId
474 gtVal = Var gtDataConId
475
476 mkIntVal :: Integer -> Expr CoreBndr
477 mkIntVal    i = Lit (mkMachInt  i)
478 mkWordVal :: Integer -> Expr CoreBndr
479 mkWordVal   w = Lit (mkMachWord w)
480 mkFloatVal :: Rational -> Expr CoreBndr
481 mkFloatVal  f = Lit (convFloating (MachFloat  f))
482 mkDoubleVal :: Rational -> Expr CoreBndr
483 mkDoubleVal d = Lit (convFloating (MachDouble d))
484 \end{code}
485
486
487 %************************************************************************
488 %*                                                                      *
489 \subsection{Special rules for seq, tagToEnum, dataToTag}
490 %*                                                                      *
491 %************************************************************************
492
493 Note [tagToEnum#]
494 ~~~~~~~~~~~~~~~~~
495 Nasty check to ensure that tagToEnum# is applied to a type that is an
496 enumeration TyCon.  Unification may refine the type later, but this
497 check won't see that, alas.  It's crude but it works.
498
499 Here's are two cases that should fail
500         f :: forall a. a
501         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
502
503         g :: Int
504         g = tagToEnum# 0        -- Int is not an enumeration
505
506 We used to make this check in the type inference engine, but it's quite
507 ugly to do so, because the delayed constraint solving means that we don't
508 really know what's going on until the end. It's very much a corner case
509 because we don't expect the user to call tagToEnum# at all; we merely
510 generate calls in derived instances of Enum.  So we compromise: a
511 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
512 and emits a warning.
513
514 \begin{code}
515 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
516 -- If     data T a = A | B | C
517 -- then   tag2Enum# (T ty) 2# -->  B ty
518 tagToEnumRule _ [Type ty, Lit (MachInt i)]
519   | Just (tycon, tc_args) <- splitTyConApp_maybe ty
520   , isEnumerationTyCon tycon
521   = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
522         []        -> Nothing  -- Abstract type
523         (dc:rest) -> ASSERT( null rest )
524                      Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
525   | otherwise  -- See Note [tagToEnum#]
526   = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
527     Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
528   where
529     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
530     tag = fromInteger i
531
532 tagToEnumRule _ _ = Nothing
533 \end{code}
534
535
536 For dataToTag#, we can reduce if either
537
538         (a) the argument is a constructor
539         (b) the argument is a variable whose unfolding is a known constructor
540
541 \begin{code}
542 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
543 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
544   | tag_to_enum `hasKey` tagToEnumKey
545   , ty1 `eqType` ty2
546   = Just tag  -- dataToTag (tagToEnum x)   ==>   x
547
548 dataToTagRule id_unf [_, val_arg]
549   | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
550   = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
551     Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
552
553 dataToTagRule _ _ = Nothing
554 \end{code}
555
556 %************************************************************************
557 %*                                                                      *
558 \subsection{Rules for seq# and spark#}
559 %*                                                                      *
560 %************************************************************************
561
562 \begin{code}
563 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
564 seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
565 seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a
566    = Just (mkConApp (tupleCon UnboxedTuple 2)
567                     [Type (mkStatePrimTy ty_s), ty_a, s, a])
568 seqRule _ _ = Nothing
569
570 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
571 sparkRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
572 sparkRule = seqRule -- reduce on HNF, just the same
573   -- XXX perhaps we shouldn't do this, because a spark eliminated by
574   -- this rule won't be counted as a dud at runtime?
575 \end{code}
576
577 %************************************************************************
578 %*                                                                      *
579 \subsection{Built in rules}
580 %*                                                                      *
581 %************************************************************************
582
583 Note [Scoping for Builtin rules]
584 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
585 When compiling a (base-package) module that defines one of the
586 functions mentioned in the RHS of a built-in rule, there's a danger
587 that we'll see
588
589         f = ...(eq String x)....
590
591         ....and lower down...
592
593         eqString = ...
594
595 Then a rewrite would give
596
597         f = ...(eqString x)...
598         ....and lower down...
599         eqString = ...
600
601 and lo, eqString is not in scope.  This only really matters when we get to code
602 generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
603 set of bindings, which sorts out the dependency.  Without -O we don't do any rule
604 rewriting so again we are fine.
605
606 (This whole thing doesn't show up for non-built-in rules because their dependencies
607 are explicit.)
608
609
610 \begin{code}
611 builtinRules :: [CoreRule]
612 -- Rules for non-primops that can't be expressed using a RULE pragma
613 builtinRules
614   = [BuiltinRule { ru_name = fsLit "AppendLitString",
615                    ru_fn = unpackCStringFoldrName,
616                    ru_nargs = 4, ru_try = \_ -> match_append_lit },
617      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
618                    ru_nargs = 2, ru_try = \_ -> match_eq_string },
619      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
620                    ru_nargs = 2, ru_try = \_ -> match_inline }]
621  ++ builtinIntegerRules
622
623 builtinIntegerRules :: [CoreRule]
624 builtinIntegerRules =
625  [-- TODO: smallInteger rule
626   -- TODO: wordToInteger rule
627   rule_convert        "integerToWord"       integerToWordName       mkWordLitWord,
628   rule_convert        "integerToInt"        integerToIntName        mkIntLitInt,
629   rule_convert        "integerToWord64"     integerToWord64Name     mkWord64LitWord64,
630   -- TODO: word64ToInteger rule
631   rule_convert        "integerToInt64"      integerToInt64Name      mkInt64LitInt64,
632   -- TODO: int64ToInteger rule
633   rule_binop          "plusInteger"         plusIntegerName         (+),
634   rule_binop          "minusInteger"        minusIntegerName        (-),
635   rule_binop          "timesInteger"        timesIntegerName        (*),
636   rule_unop           "negateInteger"       negateIntegerName       negate,
637   rule_binop_Bool     "eqInteger"           eqIntegerName           (==),
638   rule_binop_Bool     "neqInteger"          neqIntegerName          (/=),
639   rule_unop           "absInteger"          absIntegerName          abs,
640   rule_unop           "signumInteger"       signumIntegerName       signum,
641   rule_binop_Bool     "leInteger"           leIntegerName           (<=),
642   rule_binop_Bool     "gtInteger"           gtIntegerName           (>),
643   rule_binop_Bool     "ltInteger"           ltIntegerName           (<),
644   rule_binop_Bool     "geInteger"           geIntegerName           (>=),
645   rule_binop_Ordering "compareInteger"      compareIntegerName      compare,
646   rule_divop_both     "divModInteger"       divModIntegerName       divMod,
647   rule_divop_both     "quotRemInteger"      quotRemIntegerName      quotRem,
648   rule_divop_one      "quotInteger"         quotIntegerName         quot,
649   rule_divop_one      "remInteger"          remIntegerName          rem,
650   rule_encodeFloat    "encodeFloatInteger"  encodeFloatIntegerName  mkFloatLitFloat,
651   rule_convert        "floatFromInteger"    floatFromIntegerName    mkFloatLitFloat,
652   rule_encodeFloat    "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
653   -- TODO: decodeDoubleInteger rule
654   rule_convert        "doubleFromInteger"   doubleFromIntegerName   mkDoubleLitDouble,
655   rule_binop          "gcdInteger"          gcdIntegerName          gcd,
656   rule_binop          "lcmInteger"          lcmIntegerName          lcm,
657   rule_binop          "andInteger"          andIntegerName          (.&.),
658   rule_binop          "orInteger"           orIntegerName           (.|.),
659   rule_binop          "xorInteger"          xorIntegerName          xor,
660   rule_unop           "complementInteger"   complementIntegerName   complement,
661   rule_Int_binop      "shiftLInteger"       shiftLIntegerName       shiftL,
662   rule_Int_binop      "shiftRInteger"       shiftRIntegerName       shiftR]
663     where rule_convert str name convert
664            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
665                            ru_try = match_Integer_convert convert }
666           rule_unop str name op
667            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
668                            ru_try = match_Integer_unop op }
669           rule_binop str name op
670            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
671                            ru_try = match_Integer_binop op }
672           rule_divop_both str name op
673            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
674                            ru_try = match_Integer_divop_both op }
675           rule_divop_one str name op
676            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
677                            ru_try = match_Integer_divop_one op }
678           rule_Int_binop str name op
679            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
680                            ru_try = match_Integer_Int_binop op }
681           rule_binop_Bool str name op
682            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
683                            ru_try = match_Integer_binop_Bool op }
684           rule_binop_Ordering str name op
685            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
686                            ru_try = match_Integer_binop_Ordering op }
687           rule_encodeFloat str name op
688            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
689                            ru_try = match_Integer_Int_encodeFloat op }
690
691 ---------------------------------------------------
692 -- The rule is this:
693 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
694 --      =  unpackFoldrCString# "foobaz" c n
695
696 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
697 match_append_lit _ [Type ty1,
698                     Lit (MachStr s1),
699                     c1,
700                     Var unpk `App` Type ty2
701                              `App` Lit (MachStr s2)
702                              `App` c2
703                              `App` n
704                    ]
705   | unpk `hasKey` unpackCStringFoldrIdKey &&
706     c1 `cheapEqExpr` c2
707   = ASSERT( ty1 `eqType` ty2 )
708     Just (Var unpk `App` Type ty1
709                    `App` Lit (MachStr (s1 `appendFS` s2))
710                    `App` c1
711                    `App` n)
712
713 match_append_lit _ _ = Nothing
714
715 ---------------------------------------------------
716 -- The rule is this:
717 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
718
719 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
720 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
721                    Var unpk2 `App` Lit (MachStr s2)]
722   | unpk1 `hasKey` unpackCStringIdKey,
723     unpk2 `hasKey` unpackCStringIdKey
724   = Just (if s1 == s2 then trueVal else falseVal)
725
726 match_eq_string _ _ = Nothing
727
728
729 ---------------------------------------------------
730 -- The rule is this:
731 --      inline f_ty (f a b c) = <f's unfolding> a b c
732 -- (if f has an unfolding, EVEN if it's a loop breaker)
733 --
734 -- It's important to allow the argument to 'inline' to have args itself
735 -- (a) because its more forgiving to allow the programmer to write
736 --       inline f a b c
737 --   or  inline (f a b c)
738 -- (b) because a polymorphic f wll get a type argument that the
739 --     programmer can't avoid
740 --
741 -- Also, don't forget about 'inline's type argument!
742 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
743 match_inline _ (Type _ : e : _)
744   | (Var f, args1) <- collectArgs e,
745     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
746              -- Ignore the IdUnfoldingFun here!
747   = Just (mkApps unf args1)
748
749 match_inline _ _ = Nothing
750
751 -- Integer rules
752
753 match_Integer_convert :: Num a
754                       => (a -> Expr CoreBndr)
755                       -> Id
756                       -> IdUnfoldingFun
757                       -> [Expr CoreBndr]
758                       -> Maybe (Expr CoreBndr)
759 match_Integer_convert convert _ id_unf [xl]
760   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
761   = Just (convert (fromInteger x))
762 match_Integer_convert _ _ _ _ = Nothing
763
764 match_Integer_unop :: (Integer -> Integer)
765                    -> Id
766                    -> IdUnfoldingFun
767                    -> [Expr CoreBndr]
768                    -> Maybe (Expr CoreBndr)
769 match_Integer_unop unop _ id_unf [xl]
770   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
771   = Just (Lit (LitInteger (unop x) i))
772 match_Integer_unop _ _ _ _ = Nothing
773
774 match_Integer_binop :: (Integer -> Integer -> Integer)
775                     -> Id
776                     -> IdUnfoldingFun
777                     -> [Expr CoreBndr]
778                     -> Maybe (Expr CoreBndr)
779 match_Integer_binop binop _ id_unf [xl,yl]
780   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
781   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
782   = Just (Lit (LitInteger (x `binop` y) i))
783 match_Integer_binop _ _ _ _ = Nothing
784
785 -- This helper is used for the quotRem and divMod functions
786 match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer))
787                          -> Id
788                          -> IdUnfoldingFun
789                          -> [Expr CoreBndr]
790                          -> Maybe (Expr CoreBndr)
791 match_Integer_divop_both divop _ id_unf [xl,yl]
792   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
793   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
794   , y /= 0
795   , (r,s) <- x `divop` y
796   = case idType i of
797       FunTy _ (FunTy _ integerTy) ->
798               Just $ mkConApp (tupleCon UnboxedTuple 2)
799                               [Type integerTy,
800                                Type integerTy,
801                                Lit (LitInteger r i),
802                                Lit (LitInteger s i)]
803       _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type"
804 match_Integer_divop_both _ _ _ _ = Nothing
805
806 -- This helper is used for the quotRem and divMod functions
807 match_Integer_divop_one :: (Integer -> Integer -> Integer)
808                         -> Id
809                         -> IdUnfoldingFun
810                         -> [Expr CoreBndr]
811                         -> Maybe (Expr CoreBndr)
812 match_Integer_divop_one divop _ id_unf [xl,yl]
813   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
814   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
815   , y /= 0
816   = Just (Lit (LitInteger (x `divop` y) i))
817 match_Integer_divop_one _ _ _ _ = Nothing
818
819 match_Integer_Int_binop :: (Integer -> Int -> Integer)
820                         -> Id
821                         -> IdUnfoldingFun
822                         -> [Expr CoreBndr]
823                         -> Maybe (Expr CoreBndr)
824 match_Integer_Int_binop binop _ id_unf [xl,yl]
825   | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
826   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
827   = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
828 match_Integer_Int_binop _ _ _ _ = Nothing
829
830 match_Integer_binop_Bool :: (Integer -> Integer -> Bool)
831                          -> Id
832                          -> IdUnfoldingFun
833                          -> [Expr CoreBndr]
834                          -> Maybe (Expr CoreBndr)
835 match_Integer_binop_Bool binop _ id_unf [xl, yl]
836   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
837   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
838   = Just (if x `binop` y then trueVal else falseVal)
839 match_Integer_binop_Bool _ _ _ _ = Nothing
840
841 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering)
842                              -> Id
843                              -> IdUnfoldingFun
844                              -> [Expr CoreBndr]
845                              -> Maybe (Expr CoreBndr)
846 match_Integer_binop_Ordering binop _ id_unf [xl, yl]
847   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
848   , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
849   = Just $ case x `binop` y of
850              LT -> ltVal
851              EQ -> eqVal
852              GT -> gtVal
853 match_Integer_binop_Ordering _ _ _ _ = Nothing
854
855 match_Integer_Int_encodeFloat :: RealFloat a
856                               => (a -> Expr CoreBndr)
857                               -> Id
858                               -> IdUnfoldingFun
859                               -> [Expr CoreBndr]
860                               -> Maybe (Expr CoreBndr)
861 match_Integer_Int_encodeFloat mkLit _ id_unf [xl,yl]
862   | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
863   , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
864   = Just (mkLit $ encodeFloat x (fromInteger y))
865 match_Integer_Int_encodeFloat _ _ _ _ = Nothing
866 \end{code}