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 PrimOp      ( PrimOp(..), tagToEnumKey )
  26 import TysWiredIn
  27 import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
  28 import DataCon     ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
  29 import CoreUtils   ( cheapEqExpr )
  30 import CoreUnfold  ( exprIsConApp_maybe )
  31 import Type
  32 import OccName     ( occNameFS )
  33 import PrelNames
  34 import Maybes      ( orElse )
  35 import Name        ( Name, nameOccName )
  36 import Outputable
  37 import FastString
  38 import StaticFlags ( opt_SimplExcessPrecision )
  39 import Constants
  40
  41 import Data.Bits as Bits
  42 import Data.Int    ( Int64 )
  43 import Data.Word   ( Word, Word64 )
  44 \end{code}
  45
  46
  47 Note [Constant folding]
  48 ~~~~~~~~~~~~~~~~~~~~~~~
  49 primOpRules generates the rewrite rules for each primop
  50 These rules do what is often called "constant folding"
  51 E.g. the rules for +# might say
  52         4 +# 5 = 9
  53 Well, of course you'd need a lot of rules if you did it
  54 like that, so we use a BuiltinRule instead, so that we
  55 can match in any two literal values.  So the rule is really
  56 more like
  57         (Lit 4) +# (Lit y) = Lit (x+#y)
  58 where the (+#) on the rhs is done at compile time
  59
  60 That is why these rules are built in here.  Other rules
  61 which don't need to be built in are in GHC.Base. For
  62 example:
  63         x +# 0 = x
  64
  65
  66 \begin{code}
  67 primOpRules :: PrimOp -> Name -> [CoreRule]
  68 primOpRules op op_name = primop_rule op
  69   where
  70     -- A useful shorthand
  71     one_lit   = oneLit  op_name
  72     two_lits  = twoLits op_name
  73     relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
  74     -- Cunning.  cmpOp compares the values to give an Ordering.
  75     -- It applies its argument to that ordering value to turn
  76     -- the ordering into a boolean value.  (`cmp` EQ) is just the job.
  77
  78     -- ToDo: something for integer-shift ops?
  79     --       NotOp
  80
  81     primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
  82     primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
  83
  84     -- Int operations
  85     primop_rule IntAddOp    = two_lits (intOp2     (+))
  86     primop_rule IntSubOp    = two_lits (intOp2     (-))
  87     primop_rule IntMulOp    = two_lits (intOp2     (*))
  88     primop_rule IntQuotOp   = two_lits (intOp2Z    quot)
  89     primop_rule IntRemOp    = two_lits (intOp2Z    rem)
  90     primop_rule IntNegOp    = one_lit  negOp
  91     primop_rule ISllOp      = two_lits (intShiftOp2 Bits.shiftL)
  92     primop_rule ISraOp      = two_lits (intShiftOp2 Bits.shiftR)
  93     primop_rule ISrlOp      = two_lits (intShiftOp2 shiftRightLogical)
  94
  95     -- Word operations
  96     primop_rule WordAddOp   = two_lits (wordOp2    (+))
  97     primop_rule WordSubOp   = two_lits (wordOp2    (-))
  98     primop_rule WordMulOp   = two_lits (wordOp2    (*))
  99     primop_rule WordQuotOp  = two_lits (wordOp2Z   quot)
 100     primop_rule WordRemOp   = two_lits (wordOp2Z   rem)
 101     primop_rule AndOp       = two_lits (wordBitOp2 (.&.))
 102     primop_rule OrOp        = two_lits (wordBitOp2 (.|.))
 103     primop_rule XorOp       = two_lits (wordBitOp2 xor)
 104     primop_rule SllOp       = two_lits (wordShiftOp2 Bits.shiftL)
 105     primop_rule SrlOp       = two_lits (wordShiftOp2 shiftRightLogical)
 106
 107     -- coercions
 108     primop_rule Word2IntOp     = one_lit (litCoerce word2IntLit)
 109     primop_rule Int2WordOp     = one_lit (litCoerce int2WordLit)
 110     primop_rule Narrow8IntOp   = one_lit (litCoerce narrow8IntLit)
 111     primop_rule Narrow16IntOp  = one_lit (litCoerce narrow16IntLit)
 112     primop_rule Narrow32IntOp  = one_lit (litCoerce narrow32IntLit)
 113     primop_rule Narrow8WordOp  = one_lit (litCoerce narrow8WordLit)
 114     primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
 115     primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
 116     primop_rule OrdOp          = one_lit (litCoerce char2IntLit)
 117     primop_rule ChrOp          = one_lit (predLitCoerce litFitsInChar int2CharLit)
 118     primop_rule Float2IntOp    = one_lit (litCoerce float2IntLit)
 119     primop_rule Int2FloatOp    = one_lit (litCoerce int2FloatLit)
 120     primop_rule Double2IntOp   = one_lit (litCoerce double2IntLit)
 121     primop_rule Int2DoubleOp   = one_lit (litCoerce int2DoubleLit)
 122     -- SUP: Not sure what the standard says about precision in the following 2 cases
 123     primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
 124     primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
 125
 126     -- Float
 127     primop_rule FloatAddOp   = two_lits (floatOp2  (+))
 128     primop_rule FloatSubOp   = two_lits (floatOp2  (-))
 129     primop_rule FloatMulOp   = two_lits (floatOp2  (*))
 130     primop_rule FloatDivOp   = two_lits (floatOp2Z (/))
 131     primop_rule FloatNegOp   = one_lit  negOp
 132
 133     -- Double
 134     primop_rule DoubleAddOp   = two_lits (doubleOp2  (+))
 135     primop_rule DoubleSubOp   = two_lits (doubleOp2  (-))
 136     primop_rule DoubleMulOp   = two_lits (doubleOp2  (*))
 137     primop_rule DoubleDivOp   = two_lits (doubleOp2Z (/))
 138     primop_rule DoubleNegOp   = one_lit  negOp
 139
 140     -- Relational operators
 141     primop_rule IntEqOp    = relop (==) ++ litEq op_name True
 142     primop_rule IntNeOp    = relop (/=) ++ litEq op_name False
 143     primop_rule CharEqOp   = relop (==) ++ litEq op_name True
 144     primop_rule CharNeOp   = relop (/=) ++ litEq op_name False
 145
 146     primop_rule IntGtOp    = relop (>)  ++ boundsCmp op_name Gt
 147     primop_rule IntGeOp    = relop (>=) ++ boundsCmp op_name Ge
 148     primop_rule IntLeOp    = relop (<=) ++ boundsCmp op_name Le
 149     primop_rule IntLtOp    = relop (<)  ++ boundsCmp op_name Lt
 150
 151     primop_rule CharGtOp   = relop (>)  ++ boundsCmp op_name Gt
 152     primop_rule CharGeOp   = relop (>=) ++ boundsCmp op_name Ge
 153     primop_rule CharLeOp   = relop (<=) ++ boundsCmp op_name Le
 154     primop_rule CharLtOp   = relop (<)  ++ boundsCmp op_name Lt
 155
 156     primop_rule FloatGtOp  = relop (>)
 157     primop_rule FloatGeOp  = relop (>=)
 158     primop_rule FloatLeOp  = relop (<=)
 159     primop_rule FloatLtOp  = relop (<)
 160     primop_rule FloatEqOp  = relop (==)
 161     primop_rule FloatNeOp  = relop (/=)
 162
 163     primop_rule DoubleGtOp = relop (>)
 164     primop_rule DoubleGeOp = relop (>=)
 165     primop_rule DoubleLeOp = relop (<=)
 166     primop_rule DoubleLtOp = relop (<)
 167     primop_rule DoubleEqOp = relop (==)
 168     primop_rule DoubleNeOp = relop (/=)
 169
 170     primop_rule WordGtOp   = relop (>)  ++ boundsCmp op_name Gt
 171     primop_rule WordGeOp   = relop (>=) ++ boundsCmp op_name Ge
 172     primop_rule WordLeOp   = relop (<=) ++ boundsCmp op_name Le
 173     primop_rule WordLtOp   = relop (<)  ++ boundsCmp op_name Lt
 174     primop_rule WordEqOp   = relop (==)
 175     primop_rule WordNeOp   = relop (/=)
 176
 177     primop_rule _          = []
 178
 179
 180 \end{code}
 181
 182 %************************************************************************
 183 %*                                                                      *
 184 \subsection{Doing the business}
 185 %*                                                                      *
 186 %************************************************************************
 187
 188 ToDo: the reason these all return Nothing is because there used to be
 189 the possibility of an argument being a litlit.  Litlits are now gone,
 190 so this could be cleaned up.
 191
 192 \begin{code}
 193 --------------------------
 194 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
 195 litCoerce fn lit = Just (Lit (fn lit))
 196
 197 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
 198 predLitCoerce p fn lit
 199    | p lit     = Just (Lit (fn lit))
 200    | otherwise = Nothing
 201
 202 --------------------------
 203 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
 204 cmpOp cmp l1 l2
 205   = go l1 l2
 206   where
 207     done res | cmp res   = Just trueVal
 208              | otherwise = Just falseVal
 209
 210     -- These compares are at different types
 211     go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
 212     go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
 213     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
 214     go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
 215     go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
 216     go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
 217     go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
 218     go _               _               = Nothing
 219
 220 --------------------------
 221
 222 negOp :: Literal -> Maybe CoreExpr  -- Negate
 223 negOp (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
 224 negOp (MachFloat f)    = Just (mkFloatVal (-f))
 225 negOp (MachDouble 0.0) = Nothing
 226 negOp (MachDouble d)   = Just (mkDoubleVal (-d))
 227 negOp (MachInt i)      = intResult (-i)
 228 negOp _                = Nothing
 229
 230 --------------------------
 231 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
 232 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
 233 intOp2 _  _            _            = Nothing  -- Could find LitLit
 234
 235 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
 236 -- Like intOp2, but Nothing if i2=0
 237 intOp2Z op (MachInt i1) (MachInt i2)
 238   | i2 /= 0 = intResult (i1 `op` i2)
 239 intOp2Z _ _ _ = Nothing  -- LitLit or zero dividend
 240
 241 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
 242 -- Shifts take an Int; hence second arg of op is Int
 243 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
 244 intShiftOp2 _  _            _            = Nothing
 245
 246 shiftRightLogical :: Integer -> Int -> Integer
 247 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
 248 -- Do this by converting to Word and back.  Obviously this won't work for big
 249 -- values, but its ok as we use it here
 250 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
 251
 252
 253 --------------------------
 254 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
 255 wordOp2 op (MachWord w1) (MachWord w2)
 256   = wordResult (w1 `op` w2)
 257 wordOp2 _ _ _ = Nothing  -- Could find LitLit
 258
 259 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
 260 wordOp2Z op (MachWord w1) (MachWord w2)
 261   | w2 /= 0 = wordResult (w1 `op` w2)
 262 wordOp2Z _ _ _ = Nothing  -- LitLit or zero dividend
 263
 264 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
 265            -> Maybe CoreExpr
 266 wordBitOp2 op (MachWord w1) (MachWord w2)
 267   = wordResult (w1 `op` w2)
 268 wordBitOp2 _ _ _ = Nothing  -- Could find LitLit
 269
 270 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
 271 -- Shifts take an Int; hence second arg of op is Int
 272 wordShiftOp2 op (MachWord x) (MachInt n)
 273   = wordResult (x `op` fromInteger n)
 274     -- Do the shift at type Integer
 275 wordShiftOp2 _ _ _ = Nothing
 276
 277 --------------------------
 278 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
 279          -> Maybe (Expr CoreBndr)
 280 floatOp2  op (MachFloat f1) (MachFloat f2)
 281   = Just (mkFloatVal (f1 `op` f2))
 282 floatOp2 _ _ _ = Nothing
 283
 284 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
 285           -> Maybe (Expr CoreBndr)
 286 floatOp2Z op (MachFloat f1) (MachFloat f2)
 287   | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
 288   && f2 /= 0             -- avoid NaN and Infinity/-Infinity
 289   = Just (mkFloatVal (f1 `op` f2))
 290 floatOp2Z _ _ _ = Nothing
 291
 292 --------------------------
 293 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
 294           -> Maybe (Expr CoreBndr)
 295 doubleOp2  op (MachDouble f1) (MachDouble f2)
 296   = Just (mkDoubleVal (f1 `op` f2))
 297 doubleOp2 _ _ _ = Nothing
 298
 299 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
 300            -> Maybe (Expr CoreBndr)
 301 doubleOp2Z op (MachDouble f1) (MachDouble f2)
 302   | (f1 /= 0 || f2 > 0)  -- see Note [negative zero]
 303   && f2 /= 0             -- avoid NaN and Infinity/-Infinity
 304   = Just (mkDoubleVal (f1 `op` f2))
 305   -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
 306   -- zero, but we might want to preserve the negative zero here which
 307   -- is representable in Float/Double but not in (normalised)
 308   -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
 309 doubleOp2Z _ _ _ = Nothing
 310
 311
 312 --------------------------
 313 -- This stuff turns
 314 --      n ==# 3#
 315 -- into
 316 --      case n of
 317 --        3# -> True
 318 --        m  -> False
 319 --
 320 -- This is a Good Thing, because it allows case-of case things
 321 -- to happen, and case-default absorption to happen.  For
 322 -- example:
 323 --
 324 --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 325 -- will transform to
 326 --      case n of
 327 --        3# -> e1
 328 --        4# -> e1
 329 --        m  -> e2
 330 -- (modulo the usual precautions to avoid duplicating e1)
 331
 332 litEq :: Name
 333       -> Bool  -- True <=> equality, False <=> inequality
 334       -> [CoreRule]
 335 litEq op_name is_eq
 336   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
 337                                 `appendFS` (fsLit "->case"),
 338                    ru_fn = op_name,
 339                    ru_nargs = 2, ru_try = rule_fn }]
 340   where
 341     rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
 342     rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
 343     rule_fn _ _               = Nothing
 344
 345     do_lit_eq lit expr
 346       = Just (mkWildCase expr (literalType lit) boolTy
 347                     [(DEFAULT,    [], val_if_neq),
 348                      (LitAlt lit, [], val_if_eq)])
 349     val_if_eq  | is_eq     = trueVal
 350                | otherwise = falseVal
 351     val_if_neq | is_eq     = falseVal
 352                | otherwise = trueVal
 353
 354
 355 -- | Check if there is comparison with minBound or maxBound, that is
 356 -- always true or false. For instance, an Int cannot be smaller than its
 357 -- minBound, so we can replace such comparison with False.
 358 boundsCmp :: Name -> Comparison -> [CoreRule]
 359 boundsCmp op_name op = [ rule ]
 360   where
 361     rule = BuiltinRule
 362       { ru_name = occNameFS (nameOccName op_name)
 363                     `appendFS` (fsLit "min/maxBound")
 364       , ru_fn = op_name
 365       , ru_nargs = 2
 366       , ru_try = rule_fn
 367       }
 368     rule_fn _ [a, b] = mkRuleFn op a b
 369     rule_fn _ _      = Nothing
 370
 371 data Comparison = Gt | Ge | Lt | Le
 372
 373 mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
 374 mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal
 375 mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal
 376 mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal
 377 mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal
 378 mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal
 379 mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal
 380 mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal
 381 mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal
 382 mkRuleFn _ _ _                           = Nothing
 383
 384 isMinBound :: Literal -> Bool
 385 isMinBound (MachChar c)   = c == minBound
 386 isMinBound (MachInt i)    = i == toInteger (minBound :: Int)
 387 isMinBound (MachInt64 i)  = i == toInteger (minBound :: Int64)
 388 isMinBound (MachWord i)   = i == toInteger (minBound :: Word)
 389 isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64)
 390 isMinBound _              = False
 391
 392 isMaxBound :: Literal -> Bool
 393 isMaxBound (MachChar c)   = c == maxBound
 394 isMaxBound (MachInt i)    = i == toInteger (maxBound :: Int)
 395 isMaxBound (MachInt64 i)  = i == toInteger (maxBound :: Int64)
 396 isMaxBound (MachWord i)   = i == toInteger (maxBound :: Word)
 397 isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64)
 398 isMaxBound _              = False
 399
 400
 401 -- Note that we *don't* warn the user about overflow. It's not done at
 402 -- runtime either, and compilation of completely harmless things like
 403 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 404 -- would yield a warning. Instead we simply squash the value into the
 405 -- *target* Int/Word range.
 406 intResult :: Integer -> Maybe CoreExpr
 407 intResult result
 408   = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
 409
 410 wordResult :: Integer -> Maybe CoreExpr
 411 wordResult result
 412   = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
 413 \end{code}
 414
 415
 416 %************************************************************************
 417 %*                                                                      *
 418 \subsection{Vaguely generic functions}
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 \begin{code}
 423 mkBasicRule :: Name -> Int
 424             -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
 425             -> [CoreRule]
 426 -- Gives the Rule the same name as the primop itself
 427 mkBasicRule op_name n_args rule_fn
 428   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
 429                    ru_fn = op_name,
 430                    ru_nargs = n_args, ru_try = rule_fn }]
 431
 432 oneLit :: Name -> (Literal -> Maybe CoreExpr)
 433        -> [CoreRule]
 434 oneLit op_name test
 435   = mkBasicRule op_name 1 rule_fn
 436   where
 437     rule_fn _ [Lit l1] = test (convFloating l1)
 438     rule_fn _ _        = Nothing
 439
 440 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
 441         -> [CoreRule]
 442 twoLits op_name test
 443   = mkBasicRule op_name 2 rule_fn
 444   where
 445     rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
 446     rule_fn _ _                = Nothing
 447
 448 -- When excess precision is not requested, cut down the precision of the
 449 -- Rational value to that of Float/Double. We confuse host architecture
 450 -- and target architecture here, but it's convenient (and wrong :-).
 451 convFloating :: Literal -> Literal
 452 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
 453    MachFloat  (toRational ((fromRational f) :: Float ))
 454 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
 455    MachDouble (toRational ((fromRational d) :: Double))
 456 convFloating l = l
 457
 458 trueVal, falseVal :: Expr CoreBndr
 459 trueVal       = Var trueDataConId
 460 falseVal      = Var falseDataConId
 461 mkIntVal :: Integer -> Expr CoreBndr
 462 mkIntVal    i = Lit (mkMachInt  i)
 463 mkWordVal :: Integer -> Expr CoreBndr
 464 mkWordVal   w = Lit (mkMachWord w)
 465 mkFloatVal :: Rational -> Expr CoreBndr
 466 mkFloatVal  f = Lit (convFloating (MachFloat  f))
 467 mkDoubleVal :: Rational -> Expr CoreBndr
 468 mkDoubleVal d = Lit (convFloating (MachDouble d))
 469 \end{code}
 470
 471
 472 %************************************************************************
 473 %*                                                                      *
 474 \subsection{Special rules for seq, tagToEnum, dataToTag}
 475 %*                                                                      *
 476 %************************************************************************
 477
 478 Note [tagToEnum#]
 479 ~~~~~~~~~~~~~~~~~
 480 Nasty check to ensure that tagToEnum# is applied to a type that is an
 481 enumeration TyCon.  Unification may refine the type later, but this
 482 check won't see that, alas.  It's crude but it works.
 483
 484 Here's are two cases that should fail
 485         f :: forall a. a
 486         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
 487
 488         g :: Int
 489         g = tagToEnum# 0        -- Int is not an enumeration
 490
 491 We used to make this check in the type inference engine, but it's quite
 492 ugly to do so, because the delayed constraint solving means that we don't
 493 really know what's going on until the end. It's very much a corner case
 494 because we don't expect the user to call tagToEnum# at all; we merely
 495 generate calls in derived instances of Enum.  So we compromise: a
 496 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
 497 and emits a warning.
 498
 499 \begin{code}
 500 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 501 -- If     data T a = A | B | C
 502 -- then   tag2Enum# (T ty) 2# -->  B ty
 503 tagToEnumRule _ [Type ty, Lit (MachInt i)]
 504   | Just (tycon, tc_args) <- splitTyConApp_maybe ty
 505   , isEnumerationTyCon tycon
 506   = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
 507         []        -> Nothing  -- Abstract type
 508         (dc:rest) -> ASSERT( null rest )
 509                      Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
 510   | otherwise  -- See Note [tagToEnum#]
 511   = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
 512     Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
 513   where
 514     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
 515     tag = fromInteger i
 516
 517 tagToEnumRule _ _ = Nothing
 518 \end{code}
 519
 520
 521 For dataToTag#, we can reduce if either
 522
 523         (a) the argument is a constructor
 524         (b) the argument is a variable whose unfolding is a known constructor
 525
 526 \begin{code}
 527 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
 528 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
 529   | tag_to_enum `hasKey` tagToEnumKey
 530   , ty1 `coreEqType` ty2
 531   = Just tag  -- dataToTag (tagToEnum x)   ==>   x
 532
 533 dataToTagRule id_unf [_, val_arg]
 534   | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
 535   = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
 536     Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
 537
 538 dataToTagRule _ _ = Nothing
 539 \end{code}
 540
 541 %************************************************************************
 542 %*                                                                      *
 543 \subsection{Built in rules}
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 Note [Scoping for Builtin rules]
 548 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 549 When compiling a (base-package) module that defines one of the
 550 functions mentioned in the RHS of a built-in rule, there's a danger
 551 that we'll see
 552
 553         f = ...(eq String x)....
 554
 555         ....and lower down...
 556
 557         eqString = ...
 558
 559 Then a rewrite would give
 560
 561         f = ...(eqString x)...
 562         ....and lower down...
 563         eqString = ...
 564
 565 and lo, eqString is not in scope.  This only really matters when we get to code
 566 generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
 567 set of bindings, which sorts out the dependency.  Without -O we don't do any rule
 568 rewriting so again we are fine.
 569
 570 (This whole thing doesn't show up for non-built-in rules because their dependencies
 571 are explicit.)
 572
 573
 574 \begin{code}
 575 builtinRules :: [CoreRule]
 576 -- Rules for non-primops that can't be expressed using a RULE pragma
 577 builtinRules
 578   = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
 579                     ru_nargs = 4, ru_try = match_append_lit },
 580       BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
 581                     ru_nargs = 2, ru_try = match_eq_string },
 582       BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
 583                     ru_nargs = 2, ru_try = match_inline }
 584     ]
 585
 586
 587 ---------------------------------------------------
 588 -- The rule is this:
 589 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
 590 --      =  unpackFoldrCString# "foobaz" c n
 591
 592 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 593 match_append_lit _ [Type ty1,
 594                     Lit (MachStr s1),
 595                     c1,
 596                     Var unpk `App` Type ty2
 597                              `App` Lit (MachStr s2)
 598                              `App` c2
 599                              `App` n
 600                    ]
 601   | unpk `hasKey` unpackCStringFoldrIdKey &&
 602     c1 `cheapEqExpr` c2
 603   = ASSERT( ty1 `coreEqType` ty2 )
 604     Just (Var unpk `App` Type ty1
 605                    `App` Lit (MachStr (s1 `appendFS` s2))
 606                    `App` c1
 607                    `App` n)
 608
 609 match_append_lit _ _ = Nothing
 610
 611 ---------------------------------------------------
 612 -- The rule is this:
 613 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 614
 615 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 616 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
 617                    Var unpk2 `App` Lit (MachStr s2)]
 618   | unpk1 `hasKey` unpackCStringIdKey,
 619     unpk2 `hasKey` unpackCStringIdKey
 620   = Just (if s1 == s2 then trueVal else falseVal)
 621
 622 match_eq_string _ _ = Nothing
 623
 624
 625 ---------------------------------------------------
 626 -- The rule is this:
 627 --      inline f_ty (f a b c) = <f's unfolding> a b c
 628 -- (if f has an unfolding, EVEN if it's a loop breaker)
 629 --
 630 -- It's important to allow the argument to 'inline' to have args itself
 631 -- (a) because its more forgiving to allow the programmer to write
 632 --       inline f a b c
 633 --   or  inline (f a b c)
 634 -- (b) because a polymorphic f wll get a type argument that the
 635 --     programmer can't avoid
 636 --
 637 -- Also, don't forget about 'inline's type argument!
 638 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 639 match_inline _ (Type _ : e : _)
 640   | (Var f, args1) <- collectArgs e,
 641     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
 642              -- Ignore the IdUnfoldingFun here!
 643   = Just (mkApps unf args1)
 644
 645 match_inline _ _ = Nothing
 646 \end{code}