ghc/compiler/simplCore/ConFold.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   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 #include "HsVersions.h"
  12
  13 module ConFold  ( completePrim ) where
  14
  15 import SimplEnv
  16 import SimplMonad
  17
  18 import PrelInfo         ( trueDataCon, falseDataCon, PrimOp(..), PrimRep
  19                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  20                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  21                         )
  22 import Literal          ( mkMachInt, mkMachWord, Literal(..) )
  23 import Id               ( Id, idType )
  24 import Maybes           ( Maybe(..) )
  25 import Util
  26 \end{code}
  27
  28 \begin{code}
  29 completePrim :: SimplEnv
  30              -> PrimOp -> [OutType] -> [OutAtom]
  31              -> SmplM OutExpr
  32 \end{code}
  33
  34 In the parallel world, we use _seq_ to control the order in which
  35 certain expressions will be evaluated.  Operationally, the expression
  36 ``_seq_ a b'' evaluates a and then evaluates b.  We have an inlining
  37 for _seq_ which translates _seq_ to:
  38
  39    _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
  40
  41 Now, we know that the seq# primitive will never return 0#, but we
  42 don't let the simplifier know that.  We also use a special error
  43 value, parError#, which is *not* a bottoming Id, so as far as the
  44 simplifier is concerned, we have to evaluate seq# a before we know
  45 whether or not y will be evaluated.
  46
  47 If we didn't have the extra case, then after inlining the compiler might
  48 see:
  49         f p q = case seq# p of { _ -> p+q }
  50
  51 If it sees that, it can see that f is strict in q, and hence it might
  52 evaluate q before p!  The "0# ->" case prevents this happening.
  53 By having the parError# branch we make sure that anything in the
  54 other branch stays there!
  55
  56 This is fine, but we'd like to get rid of the extraneous code.  Hence,
  57 we *do* let the simplifier know that seq# is strict in its argument.
  58 As a result, we hope that `a' will be evaluated before seq# is called.
  59 At this point, we have a very special and magical simpification which
  60 says that ``seq# a'' can be immediately simplified to `1#' if we
  61 know that `a' is already evaluated.
  62
  63 NB: If we ever do case-floating, we have an extra worry:
  64
  65     case a of
  66       a' -> let b' = case seq# a of { True -> b; False -> parError# }
  67             in case b' of ...
  68
  69     =>
  70
  71     case a of
  72       a' -> let b' = case True of { True -> b; False -> parError# }
  73             in case b' of ...
  74
  75     =>
  76
  77     case a of
  78       a' -> let b' = b
  79             in case b' of ...
  80
  81     =>
  82
  83     case a of
  84       a' -> case b of ...
  85
  86 The second case must never be floated outside of the first!
  87
  88 \begin{code}
  89 completePrim env SeqOp [ty] [LitArg lit]
  90   = returnSmpl (Lit (mkMachInt 1))
  91
  92 completePrim env op@SeqOp tys@[ty] args@[VarArg var]
  93   = case (lookupUnfolding env var) of
  94       NoUnfoldingDetails -> give_up
  95       LitForm _ -> hooray
  96       OtherLitForm _ -> hooray
  97       ConForm _ _ _ -> hooray
  98       OtherConForm _ -> hooray
  99       GenForm _ WhnfForm _ _ -> hooray
 100       _ -> give_up
 101   where
 102     give_up = returnSmpl (Prim op tys args)
 103     hooray = returnSmpl (Lit (mkMachInt 1))
 104 \end{code}
 105
 106 \begin{code}
 107 completePrim env op tys args
 108   = case args of
 109       [LitArg (MachChar char_lit)]         -> oneCharLit   op char_lit
 110       [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
 111                                                            op int_lit
 112       [LitArg (MachFloat float_lit)]    -> oneFloatLit  op float_lit
 113       [LitArg (MachDouble double_lit)]  -> oneDoubleLit op double_lit
 114       [LitArg other_lit]                   -> oneLit       op other_lit
 115
 116       [LitArg (MachChar char_lit1),
 117        LitArg (MachChar char_lit2)]     -> twoCharLits op char_lit1 char_lit2
 118
 119       [LitArg (MachInt int_lit1 True),     -- both *signed* literals
 120        LitArg (MachInt int_lit2 True)]  -> twoIntLits op int_lit1 int_lit2
 121
 122       [LitArg (MachInt int_lit1 False),    -- both *unsigned* literals
 123        LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
 124
 125       [LitArg (MachInt int_lit1 False),    -- unsigned+signed (shift ops)
 126        LitArg (MachInt int_lit2 True)]  -> oneWordOneIntLit op int_lit1 int_lit2
 127
 128       [LitArg (MachFloat float_lit1),
 129        LitArg (MachFloat float_lit2)]   -> twoFloatLits op float_lit1 float_lit2
 130
 131       [LitArg (MachDouble double_lit1),
 132        LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
 133
 134       [LitArg lit, VarArg var]       -> litVar op lit var
 135       [VarArg var, LitArg lit]       -> litVar op lit var
 136
 137       other                                -> give_up
 138
 139   where
 140     give_up = returnSmpl (Prim op tys args)
 141
 142     return_char c   = returnSmpl (Lit (MachChar   c))
 143     return_int i    = returnSmpl (Lit (mkMachInt  i))
 144     return_word i   = returnSmpl (Lit (mkMachWord i))
 145     return_float f  = returnSmpl (Lit (MachFloat  f))
 146     return_double d = returnSmpl (Lit (MachDouble d))
 147     return_lit lit  = returnSmpl (Lit lit)
 148
 149     return_bool True  = returnSmpl trueVal
 150     return_bool False = returnSmpl falseVal
 151
 152     return_prim_case var lit val_if_eq val_if_neq
 153       = newId (idType var)      `thenSmpl` \ unused_binder ->
 154         let
 155             result
 156               = Case (Var var)
 157                   (PrimAlts [(lit,val_if_eq)]
 158                   (BindDefault unused_binder val_if_neq))
 159         in
 160 --      pprTrace "return_prim_case:" (ppr PprDebug result) (
 161         returnSmpl result
 162 --      )
 163
 164         ---------   Ints --------------
 165     oneIntLit IntNegOp     i = return_int (-i)
 166     oneIntLit ChrOp        i = return_char (chr (fromInteger i))
 167 -- SIGH: these two cause trouble in unfoldery
 168 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
 169 --  oneIntLit Int2WordOp   i = ASSERT( i>=0 ) return_word i
 170 --  oneIntLit Int2AddrOp   i = ASSERT( i>=0 ) return_lit (MachAddr i)
 171     oneIntLit Int2FloatOp  i = return_float (fromInteger i)
 172     oneIntLit Int2DoubleOp i = return_double (fromInteger i)
 173     oneIntLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 174
 175     oneWordLit Word2IntOp   w = {-lazy:ASSERT( w<= maxInt)-} return_int w
 176 --  oneWordLit NotOp        w = ??? ToDo: sort-of a pain
 177     oneWordLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 178
 179     twoIntLits IntAddOp  i1 i2           = return_int (i1+i2)
 180     twoIntLits IntSubOp  i1 i2           = return_int (i1-i2)
 181     twoIntLits IntMulOp  i1 i2           = return_int (i1*i2)
 182     twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
 183     twoIntLits IntRemOp  i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
 184     twoIntLits IntGtOp   i1 i2           = return_bool (i1 >  i2)
 185     twoIntLits IntGeOp   i1 i2           = return_bool (i1 >= i2)
 186     twoIntLits IntEqOp   i1 i2           = return_bool (i1 == i2)
 187     twoIntLits IntNeOp   i1 i2           = return_bool (i1 /= i2)
 188     twoIntLits IntLtOp   i1 i2           = return_bool (i1 <  i2)
 189     twoIntLits IntLeOp   i1 i2           = return_bool (i1 <= i2)
 190     -- ToDo: something for integer-shift ops?
 191     twoIntLits _         _  _            = {-trace "twoIntLits: giving up"-} give_up
 192
 193     twoWordLits WordGtOp w1 w2 = return_bool (w1 >  w2)
 194     twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
 195     twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
 196     twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
 197     twoWordLits WordLtOp w1 w2 = return_bool (w1 <  w2)
 198     twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
 199     -- ToDo: something for AndOp, OrOp?
 200     twoWordLits _        _  _  = {-trace "twoWordLits: giving up"-} give_up
 201
 202     -- ToDo: something for shifts
 203     oneWordOneIntLit _ _  _  = {-trace "oneWordOneIntLit: giving up"-} give_up
 204
 205         ---------   Floats --------------
 206     oneFloatLit FloatNegOp  f   = return_float (-f)
 207 #if __GLASGOW_HASKELL__ <= 22
 208     oneFloatLit FloatExpOp  f   = return_float (exp f)
 209     oneFloatLit FloatLogOp  f   = return_float (log f)
 210     oneFloatLit FloatSqrtOp f   = return_float (sqrt f)
 211     oneFloatLit FloatSinOp  f   = return_float (sin f)
 212     oneFloatLit FloatCosOp  f   = return_float (cos f)
 213     oneFloatLit FloatTanOp  f   = return_float (tan f)
 214     oneFloatLit FloatAsinOp f   = return_float (asin f)
 215     oneFloatLit FloatAcosOp f   = return_float (acos f)
 216     oneFloatLit FloatAtanOp f   = return_float (atan f)
 217     oneFloatLit FloatSinhOp f   = return_float (sinh f)
 218     oneFloatLit FloatCoshOp f   = return_float (cosh f)
 219     oneFloatLit FloatTanhOp f   = return_float (tanh f)
 220 #else
 221     -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
 222 #endif
 223     oneFloatLit _           _   = {-trace "oneFloatLits: giving up"-} give_up
 224
 225     twoFloatLits FloatGtOp    f1 f2           = return_bool (f1 >  f2)
 226     twoFloatLits FloatGeOp    f1 f2           = return_bool (f1 >= f2)
 227     twoFloatLits FloatEqOp    f1 f2           = return_bool (f1 == f2)
 228     twoFloatLits FloatNeOp    f1 f2           = return_bool (f1 /= f2)
 229     twoFloatLits FloatLtOp    f1 f2           = return_bool (f1 <  f2)
 230     twoFloatLits FloatLeOp    f1 f2           = return_bool (f1 <= f2)
 231     twoFloatLits FloatAddOp   f1 f2           = return_float (f1 + f2)
 232     twoFloatLits FloatSubOp   f1 f2           = return_float (f1 - f2)
 233     twoFloatLits FloatMulOp   f1 f2           = return_float (f1 * f2)
 234     twoFloatLits FloatDivOp   f1 f2 | f2 /= 0 = return_float (f1 / f2)
 235 #if __GLASGOW_HASKELL__ <= 22
 236     twoFloatLits FloatPowerOp f1 f2           = return_float (f1 ** f2)
 237 #else
 238     -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
 239 #endif
 240     twoFloatLits _            _  _            = {-trace "twoFloatLits: giving up"-} give_up
 241
 242         ---------   Doubles --------------
 243     oneDoubleLit DoubleNegOp  d = return_double (-d)
 244 #if __GLASGOW_HASKELL__ <= 22
 245     oneDoubleLit DoubleExpOp  d = return_double (exp d)
 246     oneDoubleLit DoubleLogOp  d = return_double (log d)
 247     oneDoubleLit DoubleSqrtOp d = return_double (sqrt d)
 248     oneDoubleLit DoubleSinOp  d = return_double (sin d)
 249     oneDoubleLit DoubleCosOp  d = return_double (cos d)
 250     oneDoubleLit DoubleTanOp  d = return_double (tan d)
 251     oneDoubleLit DoubleAsinOp d = return_double (asin d)
 252     oneDoubleLit DoubleAcosOp d = return_double (acos d)
 253     oneDoubleLit DoubleAtanOp d = return_double (atan d)
 254     oneDoubleLit DoubleSinhOp d = return_double (sinh d)
 255     oneDoubleLit DoubleCoshOp d = return_double (cosh d)
 256     oneDoubleLit DoubleTanhOp d = return_double (tanh d)
 257 #else
 258     -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
 259 #endif
 260     oneDoubleLit _            _ = {-trace "oneDoubleLit: giving up"-} give_up
 261
 262     twoDoubleLits DoubleGtOp    d1 d2           = return_bool (d1 >  d2)
 263     twoDoubleLits DoubleGeOp    d1 d2           = return_bool (d1 >= d2)
 264     twoDoubleLits DoubleEqOp    d1 d2           = return_bool (d1 == d2)
 265     twoDoubleLits DoubleNeOp    d1 d2           = return_bool (d1 /= d2)
 266     twoDoubleLits DoubleLtOp    d1 d2           = return_bool (d1 <  d2)
 267     twoDoubleLits DoubleLeOp    d1 d2           = return_bool (d1 <= d2)
 268     twoDoubleLits DoubleAddOp   d1 d2           = return_double (d1 + d2)
 269     twoDoubleLits DoubleSubOp   d1 d2           = return_double (d1 - d2)
 270     twoDoubleLits DoubleMulOp   d1 d2           = return_double (d1 * d2)
 271     twoDoubleLits DoubleDivOp   d1 d2 | d2 /= 0 = return_double (d1 / d2)
 272 #if __GLASGOW_HASKELL__ <= 22
 273     twoDoubleLits DoublePowerOp d1 d2           = return_double (d1 ** d2)
 274 #else
 275     -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
 276 #endif
 277     twoDoubleLits _             _  _            = {-trace "twoDoubleLits: giving up"-} give_up
 278
 279         ---------   Characters --------------
 280     oneCharLit OrdOp c = return_int (fromInt (ord c))
 281     oneCharLit _     _ = {-trace "oneCharLIt: giving up"-} give_up
 282
 283     twoCharLits CharGtOp c1 c2 = return_bool (c1 >  c2)
 284     twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
 285     twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
 286     twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
 287     twoCharLits CharLtOp c1 c2 = return_bool (c1 <  c2)
 288     twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
 289     twoCharLits _        _  _  = {-trace "twoCharLits: giving up"-} give_up
 290
 291         ---------   Miscellaneous --------------
 292     oneLit Addr2IntOp (MachAddr i) = return_int i
 293     oneLit op         lit          = give_up
 294
 295         ---------   Equality and inequality for Int/Char --------------
 296         -- This stuff turns
 297         --      n ==# 3#
 298         -- into
 299         --      case n of
 300         --        3# -> True
 301         --        m  -> False
 302         --
 303         -- This is a Good Thing, because it allows case-of case things
 304         -- to happen, and case-default absorption to happen.  For
 305         -- example:
 306         --
 307         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 308         -- will transform to
 309         --      case n of
 310         --        3# -> e1
 311         --        4# -> e1
 312         --        m  -> e2
 313         -- (modulo the usual precautions to avoid duplicating e1)
 314
 315     litVar IntEqOp  lit var = return_prim_case var lit trueVal  falseVal
 316     litVar IntNeOp  lit var = return_prim_case var lit falseVal trueVal
 317     litVar CharEqOp lit var = return_prim_case var lit trueVal  falseVal
 318     litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
 319     litVar other_op lit var = give_up
 320
 321
 322 trueVal  = Con trueDataCon  [] []
 323 falseVal = Con falseDataCon [] []
 324 \end{code}