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 module PrelRules ( primOpRule, builtinRules ) where
  16
  17 #include "HsVersions.h"
  18
  19 import CoreSyn
  20 import Id               ( mkWildId )
  21 import Literal          ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
  22                         , literalType
  23                         , word2IntLit, int2WordLit
  24                         , intToInt8Lit, intToInt16Lit, intToInt32Lit
  25                         , wordToWord8Lit, wordToWord16Lit, wordToWord32Lit
  26                         , char2IntLit, int2CharLit
  27                         , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
  28                         , addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
  29                         )
  30 import PrimOp           ( PrimOp(..), primOpOcc )
  31 import TysWiredIn       ( trueDataConId, falseDataConId )
  32 import TyCon            ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
  33 import DataCon          ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
  34 import CoreUtils        ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
  35 import Type             ( tyConAppTyCon )
  36 import OccName          ( occNameUserString)
  37 import PrelNames        ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
  38 import Name             ( Name )
  39 import Bits             ( Bits(..) )
  40 #if __GLASGOW_HASKELL__ >= 500
  41 import Word             ( Word )
  42 #else
  43 import Word             ( Word64 )
  44 #endif
  45 import Outputable
  46 import CmdLineOpts      ( opt_SimplExcessPrecision )
  47 \end{code}
  48
  49
  50 \begin{code}
  51 primOpRule :: PrimOp -> CoreRule
  52 primOpRule op
  53   = BuiltinRule (primop_rule op)
  54   where
  55     op_name = _PK_ (occNameUserString (primOpOcc op))
  56     op_name_case = op_name _APPEND_ SLIT("->case")
  57
  58     -- ToDo:    something for integer-shift ops?
  59     --          NotOp
  60
  61     primop_rule SeqOp       = seqRule
  62     primop_rule TagToEnumOp = tagToEnumRule
  63     primop_rule DataToTagOp = dataToTagRule
  64
  65         -- Int operations
  66     primop_rule IntAddOp    = twoLits (intOp2     (+)   op_name)
  67     primop_rule IntSubOp    = twoLits (intOp2     (-)   op_name)
  68     primop_rule IntMulOp    = twoLits (intOp2     (*)   op_name)
  69     primop_rule IntQuotOp   = twoLits (intOp2Z    quot  op_name)
  70     primop_rule IntRemOp    = twoLits (intOp2Z    rem   op_name)
  71     primop_rule IntNegOp    = oneLit  (negOp            op_name)
  72
  73         -- Word operations
  74 #if __GLASGOW_HASKELL__ >= 500
  75     primop_rule WordAddOp   = twoLits (wordOp2    (+)   op_name)
  76     primop_rule WordSubOp   = twoLits (wordOp2    (-)   op_name)
  77     primop_rule WordMulOp   = twoLits (wordOp2    (*)   op_name)
  78 #endif
  79     primop_rule WordQuotOp  = twoLits (wordOp2Z   quot  op_name)
  80     primop_rule WordRemOp   = twoLits (wordOp2Z   rem   op_name)
  81 #if __GLASGOW_HASKELL__ >= 407
  82     primop_rule AndOp       = twoLits (wordBitOp2 (.&.) op_name)
  83     primop_rule OrOp        = twoLits (wordBitOp2 (.|.) op_name)
  84     primop_rule XorOp       = twoLits (wordBitOp2 xor   op_name)
  85 #endif
  86
  87         -- coercions
  88     primop_rule Word2IntOp      = oneLit (litCoerce word2IntLit     op_name)
  89     primop_rule Int2WordOp      = oneLit (litCoerce int2WordLit     op_name)
  90     primop_rule IntToInt8Op     = oneLit (litCoerce intToInt8Lit    op_name)
  91     primop_rule IntToInt16Op    = oneLit (litCoerce intToInt16Lit   op_name)
  92     primop_rule IntToInt32Op    = oneLit (litCoerce intToInt32Lit   op_name)
  93     primop_rule WordToWord8Op   = oneLit (litCoerce wordToWord8Lit  op_name)
  94     primop_rule WordToWord16Op  = oneLit (litCoerce wordToWord16Lit op_name)
  95     primop_rule WordToWord32Op  = oneLit (litCoerce wordToWord32Lit op_name)
  96     primop_rule OrdOp           = oneLit (litCoerce char2IntLit     op_name)
  97     primop_rule ChrOp           = oneLit (litCoerce int2CharLit     op_name)
  98     primop_rule Float2IntOp     = oneLit (litCoerce float2IntLit    op_name)
  99     primop_rule Int2FloatOp     = oneLit (litCoerce int2FloatLit    op_name)
 100     primop_rule Double2IntOp    = oneLit (litCoerce double2IntLit   op_name)
 101     primop_rule Int2DoubleOp    = oneLit (litCoerce int2DoubleLit   op_name)
 102     primop_rule Addr2IntOp      = oneLit (litCoerce addr2IntLit     op_name)
 103     primop_rule Int2AddrOp      = oneLit (litCoerce int2AddrLit     op_name)
 104         -- SUP: Not sure what the standard says about precision in the following 2 cases
 105     primop_rule Float2DoubleOp  = oneLit (litCoerce float2DoubleLit op_name)
 106     primop_rule Double2FloatOp  = oneLit (litCoerce double2FloatLit op_name)
 107
 108         -- Float
 109     primop_rule FloatAddOp   = twoLits (floatOp2 (+) op_name)
 110     primop_rule FloatSubOp   = twoLits (floatOp2 (-) op_name)
 111     primop_rule FloatMulOp   = twoLits (floatOp2 (*) op_name)
 112     primop_rule FloatDivOp   = twoLits (floatOp2Z (/) op_name)
 113     primop_rule FloatNegOp   = oneLit  (negOp op_name)
 114
 115         -- Double
 116     primop_rule DoubleAddOp   = twoLits (doubleOp2 (+) op_name)
 117     primop_rule DoubleSubOp   = twoLits (doubleOp2 (-) op_name)
 118     primop_rule DoubleMulOp   = twoLits (doubleOp2 (*) op_name)
 119     primop_rule DoubleDivOp   = twoLits (doubleOp2Z (/) op_name)
 120     primop_rule DoubleNegOp   = oneLit  (negOp op_name)
 121
 122         -- Relational operators
 123     primop_rule IntEqOp  = relop (==) `or_rule` litEq True  op_name_case
 124     primop_rule IntNeOp  = relop (/=) `or_rule` litEq False op_name_case
 125     primop_rule CharEqOp = relop (==) `or_rule` litEq True  op_name_case
 126     primop_rule CharNeOp = relop (/=) `or_rule` litEq False op_name_case
 127
 128     primop_rule IntGtOp         = relop (>)
 129     primop_rule IntGeOp         = relop (>=)
 130     primop_rule IntLeOp         = relop (<=)
 131     primop_rule IntLtOp         = relop (<)
 132
 133     primop_rule CharGtOp        = relop (>)
 134     primop_rule CharGeOp        = relop (>=)
 135     primop_rule CharLeOp        = relop (<=)
 136     primop_rule CharLtOp        = relop (<)
 137
 138     primop_rule FloatGtOp       = relop (>)
 139     primop_rule FloatGeOp       = relop (>=)
 140     primop_rule FloatLeOp       = relop (<=)
 141     primop_rule FloatLtOp       = relop (<)
 142     primop_rule FloatEqOp       = relop (==)
 143     primop_rule FloatNeOp       = relop (/=)
 144
 145     primop_rule DoubleGtOp      = relop (>)
 146     primop_rule DoubleGeOp      = relop (>=)
 147     primop_rule DoubleLeOp      = relop (<=)
 148     primop_rule DoubleLtOp      = relop (<)
 149     primop_rule DoubleEqOp      = relop (==)
 150     primop_rule DoubleNeOp      = relop (/=)
 151
 152     primop_rule WordGtOp        = relop (>)
 153     primop_rule WordGeOp        = relop (>=)
 154     primop_rule WordLeOp        = relop (<=)
 155     primop_rule WordLtOp        = relop (<)
 156     primop_rule WordEqOp        = relop (==)
 157     primop_rule WordNeOp        = relop (/=)
 158
 159     primop_rule other           = \args -> Nothing
 160
 161
 162     relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ) op_name)
 163         -- Cunning.  cmpOp compares the values to give an Ordering.
 164         -- It applies its argument to that ordering value to turn
 165         -- the ordering into a boolean value.  (`cmp` EQ) is just the job.
 166 \end{code}
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection{Doing the business}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174         IMPORTANT NOTE
 175
 176 In all these operations we might find a LitLit as an operand; that's
 177 why we have the catch-all Nothing case.
 178
 179 \begin{code}
 180 --------------------------
 181 litCoerce :: (Literal -> Literal) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr)
 182 litCoerce fn name lit | isLitLitLit lit = Nothing
 183                       | otherwise       = Just (name, Lit (fn lit))
 184
 185 --------------------------
 186 cmpOp :: (Ordering -> Bool) -> FAST_STRING -> Literal -> Literal -> Maybe (RuleName, CoreExpr)
 187 cmpOp cmp name l1 l2
 188   = go l1 l2
 189   where
 190     done res | cmp res = Just (name, trueVal)
 191              | otherwise    = Just (name, falseVal)
 192
 193         -- These compares are at different types
 194     go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
 195     go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
 196     go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
 197     go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
 198     go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
 199     go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
 200     go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
 201     go l1              l2              = Nothing
 202
 203 --------------------------
 204
 205 negOp name (MachFloat f)  = Just (name, mkFloatVal (-f))
 206 negOp name (MachDouble d) = Just (name, mkDoubleVal (-d))
 207 negOp name (MachInt i)    = intResult name (-i)
 208 negOp name l              = Nothing
 209
 210 --------------------------
 211 intOp2 op name (MachInt i1) (MachInt i2)
 212   = intResult name (i1 `op` i2)
 213 intOp2 op name l1 l2 = Nothing          -- Could find LitLit
 214
 215 intOp2Z op name (MachInt i1) (MachInt i2)
 216   | i2 /= 0 = Just (name, mkIntVal (i1 `op` i2))
 217 intOp2Z op name l1 l2 = Nothing         -- LitLit or zero dividend
 218
 219 --------------------------
 220 #if __GLASGOW_HASKELL__ >= 500
 221 wordOp2 op name (MachWord w1) (MachWord w2)
 222   = wordResult name (w1 `op` w2)
 223 wordOp2 op name l1 l2 = Nothing         -- Could find LitLit
 224 #endif
 225
 226 wordOp2Z op name (MachWord w1) (MachWord w2)
 227   | w2 /= 0 = Just (name, mkWordVal (w1 `op` w2))
 228 wordOp2Z op name l1 l2 = Nothing        -- LitLit or zero dividend
 229
 230 #if __GLASGOW_HASKELL__ >= 500
 231 wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2)
 232   = Just (name, mkWordVal (w1 `op` w2))
 233 #else
 234 -- Integer is not an instance of Bits, so we operate on Word64
 235 wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2)
 236   = Just (name, mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
 237 #endif
 238 wordBitOp2 op name l1 l2 = Nothing              -- Could find LitLit
 239
 240 --------------------------
 241 floatOp2  op name (MachFloat f1) (MachFloat f2)
 242   = Just (name, mkFloatVal (f1 `op` f2))
 243 floatOp2  op name l1 l2 = Nothing
 244
 245 floatOp2Z op name (MachFloat f1) (MachFloat f2)
 246   | f2 /= 0   = Just (name, mkFloatVal (f1 `op` f2))
 247 floatOp2Z op name l1 l2 = Nothing
 248
 249 --------------------------
 250 doubleOp2  op name (MachDouble f1) (MachDouble f2)
 251   = Just (name, mkDoubleVal (f1 `op` f2))
 252 doubleOp2 op name l1 l2 = Nothing
 253
 254 doubleOp2Z op name (MachDouble f1) (MachDouble f2)
 255   | f2 /= 0   = Just (name, mkDoubleVal (f1 `op` f2))
 256 doubleOp2Z op name l1 l2 = Nothing
 257
 258
 259 --------------------------
 260         -- This stuff turns
 261         --      n ==# 3#
 262         -- into
 263         --      case n of
 264         --        3# -> True
 265         --        m  -> False
 266         --
 267         -- This is a Good Thing, because it allows case-of case things
 268         -- to happen, and case-default absorption to happen.  For
 269         -- example:
 270         --
 271         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 272         -- will transform to
 273         --      case n of
 274         --        3# -> e1
 275         --        4# -> e1
 276         --        m  -> e2
 277         -- (modulo the usual precautions to avoid duplicating e1)
 278
 279 litEq :: Bool           -- True <=> equality, False <=> inequality
 280         -> RuleName
 281         -> RuleFun
 282 litEq is_eq name [Lit lit, expr] = do_lit_eq is_eq name lit expr
 283 litEq is_eq name [expr, Lit lit] = do_lit_eq is_eq name lit expr
 284 litEq is_eq name other           = Nothing
 285
 286 do_lit_eq is_eq name lit expr
 287   = Just (name, Case expr (mkWildId (literalType lit))
 288                      [(LitAlt lit, [], val_if_eq),
 289                       (DEFAULT,    [], val_if_neq)])
 290   where
 291     val_if_eq  | is_eq     = trueVal
 292                | otherwise = falseVal
 293     val_if_neq | is_eq     = falseVal
 294                | otherwise = trueVal
 295
 296 -- Note that we *don't* warn the user about overflow. It's not done at
 297 -- runtime either, and compilation of completely harmless things like
 298 --    ((124076834 :: Word32) + (2147483647 :: Word32))
 299 -- would yield a warning. Instead we simply squash the value into the
 300 -- Int range, but not in a way suitable for cross-compiling... :-(
 301 intResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr)
 302 intResult name result
 303   = Just (name, mkIntVal (toInteger (fromInteger result :: Int)))
 304
 305 #if __GLASGOW_HASKELL__ >= 500
 306 wordResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr)
 307 wordResult name result
 308   = Just (name, mkWordVal (toInteger (fromInteger result :: Word)))
 309 #endif
 310 \end{code}
 311
 312
 313 %************************************************************************
 314 %*                                                                      *
 315 \subsection{Vaguely generic functions
 316 %*                                                                      *
 317 %************************************************************************
 318
 319 \begin{code}
 320 type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr)
 321
 322 or_rule :: RuleFun -> RuleFun -> RuleFun
 323 or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args
 324
 325 twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
 326 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
 327 twoLits rule other            = Nothing
 328
 329 oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
 330 oneLit rule [Lit l1] = rule (convFloating l1)
 331 oneLit rule other    = 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 (SLIT("Seq"), 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 (tyConDataConsIfAvailable tycon) of
 423
 424
 425         []        -> Nothing    -- Abstract type
 426         (dc:rest) -> ASSERT( null rest )
 427                      Just (SLIT("TagToEnum"), Var (dataConId 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 (SLIT("DataToTag"),
 446                              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 match_append_lit_str)
 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_str [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 == ty2 )
 481     Just (SLIT("AppendLitString"),
 482           Var unpk `App` Type ty1
 483                    `App` Lit (MachStr (s1 _APPEND_ s2))
 484                    `App` c1
 485                    `App` n)
 486
 487 match_append_lit_str other = Nothing
 488 \end{code}