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