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