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