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