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