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