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