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