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