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