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   | f2 /= 0   = Just (mkFloatVal (f1 `op` f2))
 297 floatOp2Z _ _ _ = Nothing
 298
 299 --------------------------
 300 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
 301           -> Maybe (Expr CoreBndr)
 302 doubleOp2  op (MachDouble f1) (MachDouble f2)
 303   = Just (mkDoubleVal (f1 `op` f2))
 304 doubleOp2 _ _ _ = Nothing
 305
 306 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
 307            -> Maybe (Expr CoreBndr)
 308 doubleOp2Z op (MachDouble f1) (MachDouble f2)
 309   | f2 /= 0   = Just (mkDoubleVal (f1 `op` f2))
 310 doubleOp2Z _ _ _ = Nothing
 311
 312
 313 --------------------------
 314         -- This stuff turns
 315         --      n ==# 3#
 316         -- into
 317         --      case n of
 318         --        3# -> True
 319         --        m  -> False
 320         --
 321         -- This is a Good Thing, because it allows case-of case things
 322         -- to happen, and case-default absorption to happen.  For
 323         -- example:
 324         --
 325         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 326         -- will transform to
 327         --      case n of
 328         --        3# -> e1
 329         --        4# -> e1
 330         --        m  -> e2
 331         -- (modulo the usual precautions to avoid duplicating e1)
 332
 333 litEq :: Name
 334       -> Bool           -- True <=> equality, False <=> inequality
 335       -> [CoreRule]
 336 litEq op_name is_eq
 337   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
 338                                 `appendFS` (fsLit "->case"),
 339                    ru_fn = op_name,
 340                    ru_nargs = 2, ru_try = rule_fn }]
 341   where
 342     rule_fn [Lit lit, expr] = do_lit_eq lit expr
 343     rule_fn [expr, Lit lit] = do_lit_eq lit expr
 344     rule_fn _               = Nothing
 345
 346     do_lit_eq lit expr
 347       = Just (mkWildCase expr (literalType lit) boolTy
 348                     [(DEFAULT,    [], val_if_neq),
 349                      (LitAlt lit, [], val_if_eq)])
 350     val_if_eq  | is_eq     = trueVal
 351                | otherwise = falseVal
 352     val_if_neq | is_eq     = falseVal
 353                | otherwise = trueVal
 354
 355 -- Note that we *don't* warn the user about overflow. It's not done at
 356 -- runtime either, and compilation of completely harmless things like
 357 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 358 -- would yield a warning. Instead we simply squash the value into the
 359 -- *target* Int/Word range.
 360 intResult :: Integer -> Maybe CoreExpr
 361 intResult result
 362   = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
 363
 364 wordResult :: Integer -> Maybe CoreExpr
 365 wordResult result
 366   = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
 367 \end{code}
 368
 369
 370 %************************************************************************
 371 %*                                                                      *
 372 \subsection{Vaguely generic functions
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
 378 -- Gives the Rule the same name as the primop itself
 379 mkBasicRule op_name n_args rule_fn
 380   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
 381                    ru_fn = op_name,
 382                    ru_nargs = n_args, ru_try = rule_fn }]
 383
 384 oneLit :: Name -> (Literal -> Maybe CoreExpr)
 385        -> [CoreRule]
 386 oneLit op_name test
 387   = mkBasicRule op_name 1 rule_fn
 388   where
 389     rule_fn [Lit l1] = test (convFloating l1)
 390     rule_fn _        = Nothing
 391
 392 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
 393         -> [CoreRule]
 394 twoLits op_name test
 395   = mkBasicRule op_name 2 rule_fn
 396   where
 397     rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
 398     rule_fn _                = Nothing
 399
 400 -- When excess precision is not requested, cut down the precision of the
 401 -- Rational value to that of Float/Double. We confuse host architecture
 402 -- and target architecture here, but it's convenient (and wrong :-).
 403 convFloating :: Literal -> Literal
 404 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
 405    MachFloat  (toRational ((fromRational f) :: Float ))
 406 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
 407    MachDouble (toRational ((fromRational d) :: Double))
 408 convFloating l = l
 409
 410 trueVal, falseVal :: Expr CoreBndr
 411 trueVal       = Var trueDataConId
 412 falseVal      = Var falseDataConId
 413 mkIntVal :: Integer -> Expr CoreBndr
 414 mkIntVal    i = Lit (mkMachInt  i)
 415 mkWordVal :: Integer -> Expr CoreBndr
 416 mkWordVal   w = Lit (mkMachWord w)
 417 mkFloatVal :: Rational -> Expr CoreBndr
 418 mkFloatVal  f = Lit (convFloating (MachFloat  f))
 419 mkDoubleVal :: Rational -> Expr CoreBndr
 420 mkDoubleVal d = Lit (convFloating (MachDouble d))
 421 \end{code}
 422
 423
 424 %************************************************************************
 425 %*                                                                      *
 426 \subsection{Special rules for seq, tagToEnum, dataToTag}
 427 %*                                                                      *
 428 %************************************************************************
 429
 430 \begin{code}
 431 tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 432 tagToEnumRule [Type ty, Lit (MachInt i)]
 433   = ASSERT( isEnumerationTyCon tycon )
 434     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
 435
 436
 437         []        -> Nothing    -- Abstract type
 438         (dc:rest) -> ASSERT( null rest )
 439                      Just (Var (dataConWorkId dc))
 440   where
 441     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
 442     tag   = fromInteger i
 443     tycon = tyConAppTyCon ty
 444
 445 tagToEnumRule _ = Nothing
 446 \end{code}
 447
 448 For dataToTag#, we can reduce if either
 449
 450         (a) the argument is a constructor
 451         (b) the argument is a variable whose unfolding is a known constructor
 452
 453 \begin{code}
 454 dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr)
 455 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
 456   | tag_to_enum `hasKey` tagToEnumKey
 457   , ty1 `coreEqType` ty2
 458   = Just tag    -- dataToTag (tagToEnum x)   ==>   x
 459
 460 dataToTagRule [_, val_arg]
 461   | Just (dc,_,_) <- exprIsConApp_maybe val_arg
 462   = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
 463     Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
 464
 465 dataToTagRule _ = Nothing
 466 \end{code}
 467
 468 %************************************************************************
 469 %*                                                                      *
 470 \subsection{Built in rules}
 471 %*                                                                      *
 472 %************************************************************************
 473
 474 Note [Scoping for Builtin rules]
 475 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 476 When compiling a (base-package) module that defines one of the
 477 functions mentioned in the RHS of a built-in rule, there's a danger
 478 that we'll see
 479
 480         f = ...(eq String x)....
 481
 482         ....and lower down...
 483
 484         eqString = ...
 485
 486 Then a rewrite would give
 487
 488         f = ...(eqString x)...
 489         ....and lower down...
 490         eqString = ...
 491
 492 and lo, eqString is not in scope.  This only really matters when we get to code
 493 generation.  With -O we do a GlomBinds step that does a new SCC analysis on the whole
 494 set of bindings, which sorts out the dependency.  Without -O we don't do any rule
 495 rewriting so again we are fine.
 496
 497 (This whole thing doesn't show up for non-built-in rules because their dependencies
 498 are explicit.)
 499
 500
 501 \begin{code}
 502 builtinRules :: [CoreRule]
 503 -- Rules for non-primops that can't be expressed using a RULE pragma
 504 builtinRules
 505   = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
 506                     ru_nargs = 4, ru_try = match_append_lit },
 507       BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
 508                     ru_nargs = 2, ru_try = match_eq_string },
 509       BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
 510                     ru_nargs = 2, ru_try = match_inline }
 511     ]
 512
 513
 514 ---------------------------------------------------
 515 -- The rule is this:
 516 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 517
 518 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 519 match_append_lit [Type ty1,
 520                    Lit (MachStr s1),
 521                    c1,
 522                    Var unpk `App` Type ty2
 523                             `App` Lit (MachStr s2)
 524                             `App` c2
 525                             `App` n
 526                   ]
 527   | unpk `hasKey` unpackCStringFoldrIdKey &&
 528     c1 `cheapEqExpr` c2
 529   = ASSERT( ty1 `coreEqType` ty2 )
 530     Just (Var unpk `App` Type ty1
 531                    `App` Lit (MachStr (s1 `appendFS` s2))
 532                    `App` c1
 533                    `App` n)
 534
 535 match_append_lit _ = Nothing
 536
 537 ---------------------------------------------------
 538 -- The rule is this:
 539 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 540
 541 match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 542 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
 543                  Var unpk2 `App` Lit (MachStr s2)]
 544   | unpk1 `hasKey` unpackCStringIdKey,
 545     unpk2 `hasKey` unpackCStringIdKey
 546   = Just (if s1 == s2 then trueVal else falseVal)
 547
 548 match_eq_string _ = Nothing
 549
 550
 551 ---------------------------------------------------
 552 -- The rule is this:
 553 --      inline f_ty (f a b c) = <f's unfolding> a b c
 554 -- (if f has an unfolding, EVEN if it's a loop breaker)
 555 --
 556 -- It's important to allow the argument to 'inline' to have args itself
 557 -- (a) because its more forgiving to allow the programmer to write
 558 --       inline f a b c
 559 --   or  inline (f a b c)
 560 -- (b) because a polymorphic f wll get a type argument that the
 561 --     programmer can't avoid
 562 --
 563 -- Also, don't forget about 'inline's type argument!
 564 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 565 match_inline (Type _ : e : _)
 566   | (Var f, args1) <- collectArgs e,
 567     Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
 568   = Just (mkApps unf args1)
 569
 570 match_inline _ = Nothing
 571 \end{code}