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