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