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