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 (MachFloat 0.0) = Nothing  -- can't represent -0.0 as a Rational
 227 negOp (MachFloat f)   = Just (mkFloatVal (-f))
 228 negOp (MachDouble 0.0) = Nothing
 229 negOp (MachDouble d)   = Just (mkDoubleVal (-d))
 230 negOp (MachInt i)      = intResult (-i)
 231 negOp l                = Nothing
 232
 233 --------------------------
 234 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
 235 intOp2 op l1           l2           = Nothing           -- Could find LitLit
 236
 237 intOp2Z op (MachInt i1) (MachInt i2)
 238   | i2 /= 0 = Just (mkIntVal (i1 `op` i2))
 239 intOp2Z op l1 l2 = Nothing              -- LitLit or zero dividend
 240
 241 --------------------------
 242 #if __GLASGOW_HASKELL__ >= 500
 243 wordOp2 op (MachWord w1) (MachWord w2)
 244   = wordResult (w1 `op` w2)
 245 wordOp2 op l1 l2 = Nothing              -- Could find LitLit
 246 #endif
 247
 248 wordOp2Z op (MachWord w1) (MachWord w2)
 249   | w2 /= 0 = Just (mkWordVal (w1 `op` w2))
 250 wordOp2Z op l1 l2 = Nothing     -- LitLit or zero dividend
 251
 252 #if __GLASGOW_HASKELL__ >= 500
 253 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
 254   = Just (mkWordVal (w1 `op` w2))
 255 #else
 256 -- Integer is not an instance of Bits, so we operate on Word64
 257 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
 258   = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
 259 #endif
 260 wordBitOp2 op l1 l2 = Nothing           -- Could find LitLit
 261
 262 --------------------------
 263 floatOp2  op (MachFloat f1) (MachFloat f2)
 264   = Just (mkFloatVal (f1 `op` f2))
 265 floatOp2  op l1 l2 = Nothing
 266
 267 floatOp2Z op (MachFloat f1) (MachFloat f2)
 268   | f2 /= 0   = Just (mkFloatVal (f1 `op` f2))
 269 floatOp2Z op l1 l2 = Nothing
 270
 271 --------------------------
 272 doubleOp2  op (MachDouble f1) (MachDouble f2)
 273   = Just (mkDoubleVal (f1 `op` f2))
 274 doubleOp2 op l1 l2 = Nothing
 275
 276 doubleOp2Z op (MachDouble f1) (MachDouble f2)
 277   | f2 /= 0   = Just (mkDoubleVal (f1 `op` f2))
 278 doubleOp2Z op l1 l2 = Nothing
 279
 280
 281 --------------------------
 282         -- This stuff turns
 283         --      n ==# 3#
 284         -- into
 285         --      case n of
 286         --        3# -> True
 287         --        m  -> False
 288         --
 289         -- This is a Good Thing, because it allows case-of case things
 290         -- to happen, and case-default absorption to happen.  For
 291         -- example:
 292         --
 293         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 294         -- will transform to
 295         --      case n of
 296         --        3# -> e1
 297         --        4# -> e1
 298         --        m  -> e2
 299         -- (modulo the usual precautions to avoid duplicating e1)
 300
 301 litEq :: Name
 302       -> Bool           -- True <=> equality, False <=> inequality
 303       -> [CoreRule]
 304 litEq op_name is_eq
 305   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
 306                                 `appendFS` FSLIT("->case"),
 307                    ru_fn = op_name,
 308                    ru_nargs = 2, ru_try = rule_fn }]
 309   where
 310     rule_fn [Lit lit, expr] = do_lit_eq lit expr
 311     rule_fn [expr, Lit lit] = do_lit_eq lit expr
 312     rule_fn other           = Nothing
 313
 314     do_lit_eq lit expr
 315       = Just (Case expr (mkWildId (literalType lit)) boolTy
 316                     [(DEFAULT,    [], val_if_neq),
 317                      (LitAlt lit, [], val_if_eq)])
 318     val_if_eq  | is_eq     = trueVal
 319                | otherwise = falseVal
 320     val_if_neq | is_eq     = falseVal
 321                | otherwise = trueVal
 322
 323 -- Note that we *don't* warn the user about overflow. It's not done at
 324 -- runtime either, and compilation of completely harmless things like
 325 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 326 -- would yield a warning. Instead we simply squash the value into the
 327 -- Int range, but not in a way suitable for cross-compiling... :-(
 328 intResult :: Integer -> Maybe CoreExpr
 329 intResult result
 330   = Just (mkIntVal (toInteger (fromInteger result :: Int)))
 331
 332 #if __GLASGOW_HASKELL__ >= 500
 333 wordResult :: Integer -> Maybe CoreExpr
 334 wordResult result
 335   = Just (mkWordVal (toInteger (fromInteger result :: Word)))
 336 #endif
 337 \end{code}
 338
 339
 340 %************************************************************************
 341 %*                                                                      *
 342 \subsection{Vaguely generic functions
 343 %*                                                                      *
 344 %************************************************************************
 345
 346 \begin{code}
 347 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
 348 -- Gives the Rule the same name as the primop itself
 349 mkBasicRule op_name n_args rule_fn
 350   = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
 351                    ru_fn = op_name,
 352                    ru_nargs = n_args, ru_try = rule_fn }]
 353
 354 oneLit :: Name -> (Literal -> Maybe CoreExpr)
 355        -> [CoreRule]
 356 oneLit op_name test
 357   = mkBasicRule op_name 1 rule_fn
 358   where
 359     rule_fn [Lit l1] = test (convFloating l1)
 360     rule_fn _        = Nothing
 361
 362 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
 363         -> [CoreRule]
 364 twoLits op_name test
 365   = mkBasicRule op_name 2 rule_fn
 366   where
 367     rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
 368     rule_fn _                = Nothing
 369
 370 -- When excess precision is not requested, cut down the precision of the
 371 -- Rational value to that of Float/Double. We confuse host architecture
 372 -- and target architecture here, but it's convenient (and wrong :-).
 373 convFloating :: Literal -> Literal
 374 convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
 375    MachFloat  (toRational ((fromRational f) :: Float ))
 376 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
 377    MachDouble (toRational ((fromRational d) :: Double))
 378 convFloating l = l
 379
 380 trueVal       = Var trueDataConId
 381 falseVal      = Var falseDataConId
 382 mkIntVal    i = Lit (mkMachInt  i)
 383 mkWordVal   w = Lit (mkMachWord w)
 384 mkFloatVal  f = Lit (convFloating (MachFloat  f))
 385 mkDoubleVal d = Lit (convFloating (MachDouble d))
 386 \end{code}
 387
 388
 389 %************************************************************************
 390 %*                                                                      *
 391 \subsection{Special rules for seq, tagToEnum, dataToTag}
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 \begin{code}
 396 tagToEnumRule [Type ty, Lit (MachInt i)]
 397   = ASSERT( isEnumerationTyCon tycon )
 398     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
 399
 400
 401         []        -> Nothing    -- Abstract type
 402         (dc:rest) -> ASSERT( null rest )
 403                      Just (Var (dataConWorkId dc))
 404   where
 405     correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
 406     tag   = fromInteger i
 407     tycon = tyConAppTyCon ty
 408
 409 tagToEnumRule other = Nothing
 410 \end{code}
 411
 412 For dataToTag#, we can reduce if either
 413
 414         (a) the argument is a constructor
 415         (b) the argument is a variable whose unfolding is a known constructor
 416
 417 \begin{code}
 418 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
 419   | tag_to_enum `hasKey` tagToEnumKey
 420   , ty1 `coreEqType` ty2
 421   = Just tag    -- dataToTag (tagToEnum x)   ==>   x
 422
 423 dataToTagRule [_, val_arg]
 424   | Just (dc,_) <- exprIsConApp_maybe val_arg
 425   = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
 426     Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
 427
 428 dataToTagRule other = Nothing
 429 \end{code}
 430
 431 %************************************************************************
 432 %*                                                                      *
 433 \subsection{Built in rules}
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 \begin{code}
 438 builtinRules :: [CoreRule]
 439 -- Rules for non-primops that can't be expressed using a RULE pragma
 440 builtinRules
 441   = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName 4 match_append_lit,
 442       BuiltinRule FSLIT("EqString") eqStringName 2 match_eq_string,
 443       BuiltinRule FSLIT("Inline") inlineIdName 1 match_inline
 444     ]
 445
 446
 447 ---------------------------------------------------
 448 -- The rule is this:
 449 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
 450
 451 match_append_lit [Type ty1,
 452                    Lit (MachStr s1),
 453                    c1,
 454                    Var unpk `App` Type ty2
 455                             `App` Lit (MachStr s2)
 456                             `App` c2
 457                             `App` n
 458                   ]
 459   | unpk `hasKey` unpackCStringFoldrIdKey &&
 460     c1 `cheapEqExpr` c2
 461   = ASSERT( ty1 `coreEqType` ty2 )
 462     Just (Var unpk `App` Type ty1
 463                    `App` Lit (MachStr (s1 `appendFS` s2))
 464                    `App` c1
 465                    `App` n)
 466
 467 match_append_lit other = Nothing
 468
 469 ---------------------------------------------------
 470 -- The rule is this:
 471 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 472
 473 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
 474                  Var unpk2 `App` Lit (MachStr s2)]
 475   | unpk1 `hasKey` unpackCStringIdKey,
 476     unpk2 `hasKey` unpackCStringIdKey
 477   = Just (if s1 == s2 then trueVal else falseVal)
 478
 479 match_eq_string other = Nothing
 480
 481
 482 ---------------------------------------------------
 483 -- The rule is this:
 484 --      inline (f a b c) = <f's unfolding> a b c
 485 -- (if f has an unfolding)
 486 match_inline (e:_)
 487   | (Var f, args1) <- collectArgs e,
 488     Just unf <- maybeUnfoldingTemplate (idUnfolding f)
 489   = Just (mkApps unf args1)
 490
 491 match_inline other = Nothing
 492 \end{code}