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