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