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