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