ghc/compiler/simplCore/ConFold.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 ConFold  ( tryPrimOp ) where
  12
  13 #include "HsVersions.h"
  14
  15 import CoreSyn
  16 import Id               ( getIdUnfolding )
  17 import Const            ( mkMachInt, mkMachWord, Literal(..), Con(..) )
  18 import PrimOp           ( PrimOp(..) )
  19 import SimplMonad
  20 import TysWiredIn       ( trueDataCon, falseDataCon )
  21 import TyCon            ( tyConDataCons, isEnumerationTyCon )
  22 import DataCon          ( dataConTag, fIRST_TAG )
  23 import Const            ( conOkForAlt )
  24 import CoreUnfold       ( Unfolding(..) )
  25 import Type             ( splitTyConApp_maybe )
  26
  27 import Char             ( ord, chr )
  28 import Outputable
  29 \end{code}
  30
  31 \begin{code}
  32 tryPrimOp :: PrimOp -> [CoreArg]  -- op arg1 ... argn
  33                                   --   Args are already simplified
  34           -> Maybe CoreExpr       -- Nothing => no transformation
  35                                   -- Just e  => transforms to e
  36 \end{code}
  37
  38 In the parallel world, we use _seq_ to control the order in which
  39 certain expressions will be evaluated.  Operationally, the expression
  40 ``_seq_ a b'' evaluates a and then evaluates b.  We have an inlining
  41 for _seq_ which translates _seq_ to:
  42
  43    _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
  44
  45 Now, we know that the seq# primitive will never return 0#, but we
  46 don't let the simplifier know that.  We also use a special error
  47 value, parError#, which is *not* a bottoming Id, so as far as the
  48 simplifier is concerned, we have to evaluate seq# a before we know
  49 whether or not y will be evaluated.
  50
  51 If we didn't have the extra case, then after inlining the compiler might
  52 see:
  53         f p q = case seq# p of { _ -> p+q }
  54
  55 If it sees that, it can see that f is strict in q, and hence it might
  56 evaluate q before p!  The "0# ->" case prevents this happening.
  57 By having the parError# branch we make sure that anything in the
  58 other branch stays there!
  59
  60 This is fine, but we'd like to get rid of the extraneous code.  Hence,
  61 we *do* let the simplifier know that seq# is strict in its argument.
  62 As a result, we hope that `a' will be evaluated before seq# is called.
  63 At this point, we have a very special and magical simpification which
  64 says that ``seq# a'' can be immediately simplified to `1#' if we
  65 know that `a' is already evaluated.
  66
  67 NB: If we ever do case-floating, we have an extra worry:
  68
  69     case a of
  70       a' -> let b' = case seq# a of { True -> b; False -> parError# }
  71             in case b' of ...
  72
  73     =>
  74
  75     case a of
  76       a' -> let b' = case True of { True -> b; False -> parError# }
  77             in case b' of ...
  78
  79     =>
  80
  81     case a of
  82       a' -> let b' = b
  83             in case b' of ...
  84
  85     =>
  86
  87     case a of
  88       a' -> case b of ...
  89
  90 The second case must never be floated outside of the first!
  91
  92 \begin{code}p
  93 tryPrimOp SeqOp [Type ty, Con (Literal lit) _]
  94   = Just (Con (Literal (mkMachInt 1)) [])
  95
  96 tryPrimOp SeqOp args@[Type ty, Var var]
  97   | isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) []))   -- var is eval'd
  98   | otherwise                        = Nothing                                  -- var not eval'd
  99 \end{code}
 100
 101 \begin{code}
 102 tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
 103   | isEnumerationTyCon tycon = Just (Con (DataCon dc) [])
 104   | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type"
 105     where tag = fromInteger i
 106           constrs = tyConDataCons tycon
 107           (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc ]
 108           (Just (tycon,_)) = splitTyConApp_maybe ty
 109 \end{code}
 110
 111 For dataToTag#, we can reduce if either
 112
 113         (a) the argument is a constructor
 114         (b) the argument is a variable whose unfolding is a known constructor
 115
 116 \begin{code}
 117 tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
 118   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
 119 tryPrimOp DataToTagOp [Type ty, Var x]
 120   | has_unfolding && unfolding_is_constr
 121   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
 122   where
 123     has_unfolding = case unfolding of
 124                         CoreUnfolding _ _ _ -> True
 125                         other               -> False
 126     unfolding = getIdUnfolding x
 127     CoreUnfolding form guidance unf_template = unfolding
 128     unfolding_is_constr = case unf_template of
 129                                   Con con@(DataCon _) _ -> conOkForAlt con
 130                                   other     -> False
 131     Con (DataCon dc) con_args = unf_template
 132 \end{code}
 133
 134 \begin{code}
 135 tryPrimOp op args
 136   = case args of
 137      [Con (Literal (MachChar char_lit))      _] -> oneCharLit   op char_lit
 138      [Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit)
 139                                                           op int_lit
 140      [Con (Literal (MachFloat float_lit))   _]  -> oneFloatLit  op float_lit
 141      [Con (Literal (MachDouble double_lit)) _]  -> oneDoubleLit op double_lit
 142      [Con (Literal other_lit)               _]  -> oneLit       op other_lit
 143
 144      [Con (Literal (MachChar char_lit1)) _,
 145       Con (Literal (MachChar char_lit2)) _]     -> twoCharLits op char_lit1 char_lit2
 146
 147      [Con (Literal (MachInt int_lit1 True)) _,  -- both *signed* literals
 148       Con (Literal (MachInt int_lit2 True)) _]  -> twoIntLits op int_lit1 int_lit2
 149
 150      [Con (Literal (MachInt int_lit1 False)) _, -- both *unsigned* literals
 151       Con (Literal (MachInt int_lit2 False)) _] -> twoWordLits op int_lit1 int_lit2
 152
 153      [Con (Literal (MachInt int_lit1 False)) _, -- unsigned+signed (shift ops)
 154       Con (Literal (MachInt int_lit2 True))  _] -> oneWordOneIntLit op int_lit1 int_lit2
 155
 156      [Con (Literal (MachFloat float_lit1)) _,
 157       Con (Literal (MachFloat float_lit2)) _]   -> twoFloatLits op float_lit1 float_lit2
 158
 159      [Con (Literal (MachDouble double_lit1)) _,
 160       Con (Literal (MachDouble double_lit2)) _] -> twoDoubleLits op double_lit1 double_lit2
 161
 162      [Con (Literal lit) _, Var var]             -> litVar op lit var
 163      [Var var, Con (Literal lit) _]             -> litVar op lit var
 164
 165      other                                      -> give_up
 166   where
 167     give_up = Nothing
 168
 169     return_char c   = Just (Con (Literal (MachChar   c)) [])
 170     return_int i    = Just (Con (Literal (mkMachInt  i)) [])
 171     return_word i   = Just (Con (Literal (mkMachWord i)) [])
 172     return_float f  = Just (Con (Literal (MachFloat  f)) [])
 173     return_double d = Just (Con (Literal (MachDouble d)) [])
 174     return_lit lit  = Just (Con (Literal lit) [])
 175
 176     return_bool True  = Just trueVal
 177     return_bool False = Just falseVal
 178
 179     return_prim_case var lit val_if_eq val_if_neq
 180       = Just (Case (Var var) var [(Literal lit, [], val_if_eq),
 181                                   (DEFAULT,     [], val_if_neq)])
 182
 183         ---------   Ints --------------
 184     oneIntLit IntNegOp     i = return_int (-i)
 185     oneIntLit ChrOp        i = return_char (chr (fromInteger i))
 186 -- SIGH: these two cause trouble in unfoldery
 187 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
 188 --  oneIntLit Int2WordOp   i = ASSERT( i>=0 ) return_word i
 189 --  oneIntLit Int2AddrOp   i = ASSERT( i>=0 ) return_lit (MachAddr i)
 190     oneIntLit Int2FloatOp  i = return_float (fromInteger i)
 191     oneIntLit Int2DoubleOp i = return_double (fromInteger i)
 192     oneIntLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 193
 194     oneWordLit Word2IntOp   w = {-lazy:ASSERT( w<= maxInt)-} return_int w
 195 --  oneWordLit NotOp        w = ??? ToDo: sort-of a pain
 196     oneWordLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 197
 198     twoIntLits IntAddOp  i1 i2           = checkRange (i1+i2)
 199     twoIntLits IntSubOp  i1 i2           = checkRange (i1-i2)
 200     twoIntLits IntMulOp  i1 i2           = checkRange (i1*i2)
 201     twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
 202     twoIntLits IntRemOp  i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
 203     twoIntLits IntGtOp   i1 i2           = return_bool (i1 >  i2)
 204     twoIntLits IntGeOp   i1 i2           = return_bool (i1 >= i2)
 205     twoIntLits IntEqOp   i1 i2           = return_bool (i1 == i2)
 206     twoIntLits IntNeOp   i1 i2           = return_bool (i1 /= i2)
 207     twoIntLits IntLtOp   i1 i2           = return_bool (i1 <  i2)
 208     twoIntLits IntLeOp   i1 i2           = return_bool (i1 <= i2)
 209     -- ToDo: something for integer-shift ops?
 210     twoIntLits _         _  _            = give_up
 211
 212     twoWordLits WordGtOp w1 w2 = return_bool (w1 >  w2)
 213     twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
 214     twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
 215     twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
 216     twoWordLits WordLtOp w1 w2 = return_bool (w1 <  w2)
 217     twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
 218     -- ToDo: something for AndOp, OrOp?
 219     twoWordLits _        _  _  = give_up
 220
 221     -- ToDo: something for shifts
 222     oneWordOneIntLit _ _  _    = give_up
 223
 224         ---------   Floats --------------
 225     oneFloatLit FloatNegOp  f   = return_float (-f)
 226     -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo
 227     oneFloatLit _           _   = give_up
 228
 229     twoFloatLits FloatGtOp    f1 f2           = return_bool (f1 >  f2)
 230     twoFloatLits FloatGeOp    f1 f2           = return_bool (f1 >= f2)
 231     twoFloatLits FloatEqOp    f1 f2           = return_bool (f1 == f2)
 232     twoFloatLits FloatNeOp    f1 f2           = return_bool (f1 /= f2)
 233     twoFloatLits FloatLtOp    f1 f2           = return_bool (f1 <  f2)
 234     twoFloatLits FloatLeOp    f1 f2           = return_bool (f1 <= f2)
 235     twoFloatLits FloatAddOp   f1 f2           = return_float (f1 + f2)
 236     twoFloatLits FloatSubOp   f1 f2           = return_float (f1 - f2)
 237     twoFloatLits FloatMulOp   f1 f2           = return_float (f1 * f2)
 238     twoFloatLits FloatDivOp   f1 f2 | f2 /= 0 = return_float (f1 / f2)
 239     twoFloatLits _            _  _            = give_up
 240
 241         ---------   Doubles --------------
 242     oneDoubleLit DoubleNegOp  d = return_double (-d)
 243     oneDoubleLit _            _ = give_up
 244
 245     twoDoubleLits DoubleGtOp    d1 d2           = return_bool (d1 >  d2)
 246     twoDoubleLits DoubleGeOp    d1 d2           = return_bool (d1 >= d2)
 247     twoDoubleLits DoubleEqOp    d1 d2           = return_bool (d1 == d2)
 248     twoDoubleLits DoubleNeOp    d1 d2           = return_bool (d1 /= d2)
 249     twoDoubleLits DoubleLtOp    d1 d2           = return_bool (d1 <  d2)
 250     twoDoubleLits DoubleLeOp    d1 d2           = return_bool (d1 <= d2)
 251     twoDoubleLits DoubleAddOp   d1 d2           = return_double (d1 + d2)
 252     twoDoubleLits DoubleSubOp   d1 d2           = return_double (d1 - d2)
 253     twoDoubleLits DoubleMulOp   d1 d2           = return_double (d1 * d2)
 254     twoDoubleLits DoubleDivOp   d1 d2 | d2 /= 0 = return_double (d1 / d2)
 255     twoDoubleLits _             _  _            = give_up
 256
 257         ---------   Characters --------------
 258     oneCharLit OrdOp c = return_int (fromInt (ord c))
 259     oneCharLit _     _ = give_up
 260
 261     twoCharLits CharGtOp c1 c2 = return_bool (c1 >  c2)
 262     twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
 263     twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
 264     twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
 265     twoCharLits CharLtOp c1 c2 = return_bool (c1 <  c2)
 266     twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
 267     twoCharLits _        _  _  = give_up
 268
 269         ---------   Miscellaneous --------------
 270     oneLit Addr2IntOp (MachAddr i) = return_int (fromInteger i)
 271     oneLit op         lit          = give_up
 272
 273         ---------   Equality and inequality for Int/Char --------------
 274         -- This stuff turns
 275         --      n ==# 3#
 276         -- into
 277         --      case n of
 278         --        3# -> True
 279         --        m  -> False
 280         --
 281         -- This is a Good Thing, because it allows case-of case things
 282         -- to happen, and case-default absorption to happen.  For
 283         -- example:
 284         --
 285         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 286         -- will transform to
 287         --      case n of
 288         --        3# -> e1
 289         --        4# -> e1
 290         --        m  -> e2
 291         -- (modulo the usual precautions to avoid duplicating e1)
 292
 293     litVar IntEqOp  lit var = return_prim_case var lit trueVal  falseVal
 294     litVar IntNeOp  lit var = return_prim_case var lit falseVal trueVal
 295     litVar CharEqOp lit var = return_prim_case var lit trueVal  falseVal
 296     litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
 297     litVar other_op lit var = give_up
 298
 299
 300     checkRange :: Integer -> Maybe CoreExpr
 301     checkRange val
 302      | (val > fromInt maxInt) || (val < fromInt minInt)  =
 303         -- Better tell the user that we've overflowed...
 304        pprTrace "Warning:" (text "Integer overflow in expression: " <>
 305                            ppr ((mkPrimApp op args)::CoreExpr)) $
 306         -- ..not that it stops us from actually folding!
 307         -- ToDo: a SrcLoc would be nice.
 308        return_int val
 309      | otherwise = return_int val
 310
 311 trueVal  = Con (DataCon trueDataCon)  []
 312 falseVal = Con (DataCon falseDataCon) []
 313 \end{code}