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