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