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