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