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