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