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