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