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