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