ghc/compiler/prelude/PrelRules.lhs

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