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