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 tryPrimOp DataToTagOp [Type ty, Var x]
 111   | unfolding_is_constr
 112   = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
 113   where
 114     unfolding = getIdUnfolding var
 115     CoreUnfolding form guidance unf_template = unfolding
 116     unfolding_is_constr = case unf_template of
 117                                   Con con@(DataCon _) _ -> conOkForAlt con
 118                                   other     -> False
 119     Con (DataCon dc) con_args = unf_template
 120 \end{code}
 121
 122 \begin{code}
 123 tryPrimOp op args
 124   = case args of
 125      [Con (Literal (MachChar char_lit))      _] -> oneCharLit   op char_lit
 126      [Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit)
 127                                                           op int_lit
 128      [Con (Literal (MachFloat float_lit))   _]  -> oneFloatLit  op float_lit
 129      [Con (Literal (MachDouble double_lit)) _]  -> oneDoubleLit op double_lit
 130      [Con (Literal other_lit)               _]  -> oneLit       op other_lit
 131
 132      [Con (Literal (MachChar char_lit1)) _,
 133       Con (Literal (MachChar char_lit2)) _]     -> twoCharLits op char_lit1 char_lit2
 134
 135      [Con (Literal (MachInt int_lit1 True)) _,  -- both *signed* literals
 136       Con (Literal (MachInt int_lit2 True)) _]  -> twoIntLits op int_lit1 int_lit2
 137
 138      [Con (Literal (MachInt int_lit1 False)) _, -- both *unsigned* literals
 139       Con (Literal (MachInt int_lit2 False)) _] -> twoWordLits op int_lit1 int_lit2
 140
 141      [Con (Literal (MachInt int_lit1 False)) _, -- unsigned+signed (shift ops)
 142       Con (Literal (MachInt int_lit2 True))  _] -> oneWordOneIntLit op int_lit1 int_lit2
 143
 144      [Con (Literal (MachFloat float_lit1)) _,
 145       Con (Literal (MachFloat float_lit2)) _]   -> twoFloatLits op float_lit1 float_lit2
 146
 147      [Con (Literal (MachDouble double_lit1)) _,
 148       Con (Literal (MachDouble double_lit2)) _] -> twoDoubleLits op double_lit1 double_lit2
 149
 150      [Con (Literal lit) _, Var var]             -> litVar op lit var
 151      [Var var, Con (Literal lit) _]             -> litVar op lit var
 152
 153      other                                      -> give_up
 154   where
 155     give_up = Nothing
 156
 157     return_char c   = Just (Con (Literal (MachChar   c)) [])
 158     return_int i    = Just (Con (Literal (mkMachInt  i)) [])
 159     return_word i   = Just (Con (Literal (mkMachWord i)) [])
 160     return_float f  = Just (Con (Literal (MachFloat  f)) [])
 161     return_double d = Just (Con (Literal (MachDouble d)) [])
 162     return_lit lit  = Just (Con (Literal lit) [])
 163
 164     return_bool True  = Just trueVal
 165     return_bool False = Just falseVal
 166
 167     return_prim_case var lit val_if_eq val_if_neq
 168       = Just (Case (Var var) var [(Literal lit, [], val_if_eq),
 169                                   (DEFAULT,     [], val_if_neq)])
 170
 171         ---------   Ints --------------
 172     oneIntLit IntNegOp     i = return_int (-i)
 173     oneIntLit ChrOp        i = return_char (chr (fromInteger i))
 174 -- SIGH: these two cause trouble in unfoldery
 175 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
 176 --  oneIntLit Int2WordOp   i = ASSERT( i>=0 ) return_word i
 177 --  oneIntLit Int2AddrOp   i = ASSERT( i>=0 ) return_lit (MachAddr i)
 178     oneIntLit Int2FloatOp  i = return_float (fromInteger i)
 179     oneIntLit Int2DoubleOp i = return_double (fromInteger i)
 180     oneIntLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 181
 182     oneWordLit Word2IntOp   w = {-lazy:ASSERT( w<= maxInt)-} return_int w
 183 --  oneWordLit NotOp        w = ??? ToDo: sort-of a pain
 184     oneWordLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 185
 186     twoIntLits IntAddOp  i1 i2           = checkRange (i1+i2)
 187     twoIntLits IntSubOp  i1 i2           = checkRange (i1-i2)
 188     twoIntLits IntMulOp  i1 i2           = checkRange (i1*i2)
 189     twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
 190     twoIntLits IntRemOp  i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
 191     twoIntLits IntGtOp   i1 i2           = return_bool (i1 >  i2)
 192     twoIntLits IntGeOp   i1 i2           = return_bool (i1 >= i2)
 193     twoIntLits IntEqOp   i1 i2           = return_bool (i1 == i2)
 194     twoIntLits IntNeOp   i1 i2           = return_bool (i1 /= i2)
 195     twoIntLits IntLtOp   i1 i2           = return_bool (i1 <  i2)
 196     twoIntLits IntLeOp   i1 i2           = return_bool (i1 <= i2)
 197     -- ToDo: something for integer-shift ops?
 198     twoIntLits _         _  _            = give_up
 199
 200     twoWordLits WordGtOp w1 w2 = return_bool (w1 >  w2)
 201     twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
 202     twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
 203     twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
 204     twoWordLits WordLtOp w1 w2 = return_bool (w1 <  w2)
 205     twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
 206     -- ToDo: something for AndOp, OrOp?
 207     twoWordLits _        _  _  = give_up
 208
 209     -- ToDo: something for shifts
 210     oneWordOneIntLit _ _  _    = give_up
 211
 212         ---------   Floats --------------
 213     oneFloatLit FloatNegOp  f   = return_float (-f)
 214     -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo
 215     oneFloatLit _           _   = give_up
 216
 217     twoFloatLits FloatGtOp    f1 f2           = return_bool (f1 >  f2)
 218     twoFloatLits FloatGeOp    f1 f2           = return_bool (f1 >= f2)
 219     twoFloatLits FloatEqOp    f1 f2           = return_bool (f1 == f2)
 220     twoFloatLits FloatNeOp    f1 f2           = return_bool (f1 /= f2)
 221     twoFloatLits FloatLtOp    f1 f2           = return_bool (f1 <  f2)
 222     twoFloatLits FloatLeOp    f1 f2           = return_bool (f1 <= f2)
 223     twoFloatLits FloatAddOp   f1 f2           = return_float (f1 + f2)
 224     twoFloatLits FloatSubOp   f1 f2           = return_float (f1 - f2)
 225     twoFloatLits FloatMulOp   f1 f2           = return_float (f1 * f2)
 226     twoFloatLits FloatDivOp   f1 f2 | f2 /= 0 = return_float (f1 / f2)
 227     twoFloatLits _            _  _            = give_up
 228
 229         ---------   Doubles --------------
 230     oneDoubleLit DoubleNegOp  d = return_double (-d)
 231     oneDoubleLit _            _ = give_up
 232
 233     twoDoubleLits DoubleGtOp    d1 d2           = return_bool (d1 >  d2)
 234     twoDoubleLits DoubleGeOp    d1 d2           = return_bool (d1 >= d2)
 235     twoDoubleLits DoubleEqOp    d1 d2           = return_bool (d1 == d2)
 236     twoDoubleLits DoubleNeOp    d1 d2           = return_bool (d1 /= d2)
 237     twoDoubleLits DoubleLtOp    d1 d2           = return_bool (d1 <  d2)
 238     twoDoubleLits DoubleLeOp    d1 d2           = return_bool (d1 <= d2)
 239     twoDoubleLits DoubleAddOp   d1 d2           = return_double (d1 + d2)
 240     twoDoubleLits DoubleSubOp   d1 d2           = return_double (d1 - d2)
 241     twoDoubleLits DoubleMulOp   d1 d2           = return_double (d1 * d2)
 242     twoDoubleLits DoubleDivOp   d1 d2 | d2 /= 0 = return_double (d1 / d2)
 243     twoDoubleLits _             _  _            = give_up
 244
 245         ---------   Characters --------------
 246     oneCharLit OrdOp c = return_int (fromInt (ord c))
 247     oneCharLit _     _ = give_up
 248
 249     twoCharLits CharGtOp c1 c2 = return_bool (c1 >  c2)
 250     twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
 251     twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
 252     twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
 253     twoCharLits CharLtOp c1 c2 = return_bool (c1 <  c2)
 254     twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
 255     twoCharLits _        _  _  = give_up
 256
 257         ---------   Miscellaneous --------------
 258     oneLit Addr2IntOp (MachAddr i) = return_int (fromInteger i)
 259     oneLit op         lit          = give_up
 260
 261         ---------   Equality and inequality for Int/Char --------------
 262         -- This stuff turns
 263         --      n ==# 3#
 264         -- into
 265         --      case n of
 266         --        3# -> True
 267         --        m  -> False
 268         --
 269         -- This is a Good Thing, because it allows case-of case things
 270         -- to happen, and case-default absorption to happen.  For
 271         -- example:
 272         --
 273         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 274         -- will transform to
 275         --      case n of
 276         --        3# -> e1
 277         --        4# -> e1
 278         --        m  -> e2
 279         -- (modulo the usual precautions to avoid duplicating e1)
 280
 281     litVar IntEqOp  lit var = return_prim_case var lit trueVal  falseVal
 282     litVar IntNeOp  lit var = return_prim_case var lit falseVal trueVal
 283     litVar CharEqOp lit var = return_prim_case var lit trueVal  falseVal
 284     litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
 285     litVar other_op lit var = give_up
 286
 287
 288     checkRange :: Integer -> Maybe CoreExpr
 289     checkRange val
 290      | (val > fromInt maxInt) || (val < fromInt minInt)  =
 291         -- Better tell the user that we've overflowed...
 292        pprTrace "Warning:" (text "Integer overflow in expression: " <>
 293                            ppr ((mkPrimApp op args)::CoreExpr)) $
 294         -- ..not that it stops us from actually folding!
 295         -- ToDo: a SrcLoc would be nice.
 296        return_int val
 297      | otherwise = return_int val
 298
 299 trueVal  = Con (DataCon trueDataCon)  []
 300 falseVal = Con (DataCon falseDataCon) []
 301 \end{code}