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