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