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