ghc/compiler/simplCore/ConFold.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 IMP_Ubiq(){-uitous-}
  16
  17 import CoreSyn
  18 import CoreUnfold       ( Unfolding, SimpleUnfolding )
  19 import Id               ( idType )
  20 import Literal          ( mkMachInt, mkMachWord, Literal(..) )
  21 -- import MagicUFs              ( MagicUnfoldingFun )
  22 import PrimOp           ( PrimOp(..) )
  23 import SimplEnv
  24 import SimplMonad
  25 import TysWiredIn       ( trueDataCon, falseDataCon )
  26
  27 #ifdef REALLY_HASKELL_1_3
  28 import Char(ord,chr)
  29 #endif
  30 \end{code}
  31
  32 \begin{code}
  33 completePrim :: SimplEnv
  34              -> PrimOp -> [OutArg]
  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 [TyArg ty, LitArg lit]
  94   = returnSmpl (Lit (mkMachInt 1))
  95
  96 completePrim env op@SeqOp args@[TyArg ty, VarArg var]
  97   | isEvaluated (lookupRhsInfo env var) = returnSmpl (Lit (mkMachInt 1))  -- var is eval'd
  98   | otherwise                           = returnSmpl (Prim op args)       -- var not eval'd
  99 \end{code}
 100
 101 \begin{code}
 102 completePrim env op args
 103   = case args of
 104      [LitArg (MachChar char_lit)]      -> oneCharLit   op char_lit
 105      [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
 106                                                           op int_lit
 107      [LitArg (MachFloat float_lit)]    -> oneFloatLit  op float_lit
 108      [LitArg (MachDouble double_lit)]  -> oneDoubleLit op double_lit
 109      [LitArg other_lit]                -> oneLit       op other_lit
 110
 111      [LitArg (MachChar char_lit1),
 112       LitArg (MachChar char_lit2)]     -> twoCharLits op char_lit1 char_lit2
 113
 114      [LitArg (MachInt int_lit1 True),  -- both *signed* literals
 115       LitArg (MachInt int_lit2 True)]  -> twoIntLits op int_lit1 int_lit2
 116
 117      [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
 118       LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
 119
 120      [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
 121       LitArg (MachInt int_lit2 True)]  -> oneWordOneIntLit op int_lit1 int_lit2
 122
 123      [LitArg (MachFloat float_lit1),
 124       LitArg (MachFloat float_lit2)]   -> twoFloatLits op float_lit1 float_lit2
 125
 126      [LitArg (MachDouble double_lit1),
 127       LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
 128
 129      [LitArg lit, VarArg var]          -> litVar op lit var
 130      [VarArg var, LitArg lit]          -> litVar op lit var
 131
 132      other                             -> give_up
 133   where
 134     give_up = returnSmpl (Prim op args)
 135
 136     return_char c   = returnSmpl (Lit (MachChar   c))
 137     return_int i    = returnSmpl (Lit (mkMachInt  i))
 138     return_word i   = returnSmpl (Lit (mkMachWord i))
 139     return_float f  = returnSmpl (Lit (MachFloat  f))
 140     return_double d = returnSmpl (Lit (MachDouble d))
 141     return_lit lit  = returnSmpl (Lit lit)
 142
 143     return_bool True  = returnSmpl trueVal
 144     return_bool False = returnSmpl falseVal
 145
 146     return_prim_case var lit val_if_eq val_if_neq
 147       = newId (idType var)      `thenSmpl` \ unused_binder ->
 148         let
 149             result
 150               = Case (Var var)
 151                   (PrimAlts [(lit,val_if_eq)]
 152                   (BindDefault unused_binder val_if_neq))
 153         in
 154         returnSmpl result
 155
 156         ---------   Ints --------------
 157     oneIntLit IntNegOp     i = return_int (-i)
 158     oneIntLit ChrOp        i = return_char (chr (fromInteger i))
 159 -- SIGH: these two cause trouble in unfoldery
 160 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
 161 --  oneIntLit Int2WordOp   i = ASSERT( i>=0 ) return_word i
 162 --  oneIntLit Int2AddrOp   i = ASSERT( i>=0 ) return_lit (MachAddr i)
 163     oneIntLit Int2FloatOp  i = return_float (fromInteger i)
 164     oneIntLit Int2DoubleOp i = return_double (fromInteger i)
 165     oneIntLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 166
 167     oneWordLit Word2IntOp   w = {-lazy:ASSERT( w<= maxInt)-} return_int w
 168 --  oneWordLit NotOp        w = ??? ToDo: sort-of a pain
 169     oneWordLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 170
 171     twoIntLits IntAddOp  i1 i2           = return_int (i1+i2)
 172     twoIntLits IntSubOp  i1 i2           = return_int (i1-i2)
 173     twoIntLits IntMulOp  i1 i2           = return_int (i1*i2)
 174     twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
 175     twoIntLits IntRemOp  i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
 176     twoIntLits IntGtOp   i1 i2           = return_bool (i1 >  i2)
 177     twoIntLits IntGeOp   i1 i2           = return_bool (i1 >= i2)
 178     twoIntLits IntEqOp   i1 i2           = return_bool (i1 == i2)
 179     twoIntLits IntNeOp   i1 i2           = return_bool (i1 /= i2)
 180     twoIntLits IntLtOp   i1 i2           = return_bool (i1 <  i2)
 181     twoIntLits IntLeOp   i1 i2           = return_bool (i1 <= i2)
 182     -- ToDo: something for integer-shift ops?
 183     twoIntLits _         _  _            = give_up
 184
 185     twoWordLits WordGtOp w1 w2 = return_bool (w1 >  w2)
 186     twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
 187     twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
 188     twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
 189     twoWordLits WordLtOp w1 w2 = return_bool (w1 <  w2)
 190     twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
 191     -- ToDo: something for AndOp, OrOp?
 192     twoWordLits _        _  _  = give_up
 193
 194     -- ToDo: something for shifts
 195     oneWordOneIntLit _ _  _    = give_up
 196
 197         ---------   Floats --------------
 198     oneFloatLit FloatNegOp  f   = return_float (-f)
 199 #if __GLASGOW_HASKELL__ <= 22
 200     oneFloatLit FloatExpOp  f   = return_float (exp f)
 201     oneFloatLit FloatLogOp  f   = return_float (log f)
 202     oneFloatLit FloatSqrtOp f   = return_float (sqrt f)
 203     oneFloatLit FloatSinOp  f   = return_float (sin f)
 204     oneFloatLit FloatCosOp  f   = return_float (cos f)
 205     oneFloatLit FloatTanOp  f   = return_float (tan f)
 206     oneFloatLit FloatAsinOp f   = return_float (asin f)
 207     oneFloatLit FloatAcosOp f   = return_float (acos f)
 208     oneFloatLit FloatAtanOp f   = return_float (atan f)
 209     oneFloatLit FloatSinhOp f   = return_float (sinh f)
 210     oneFloatLit FloatCoshOp f   = return_float (cosh f)
 211     oneFloatLit FloatTanhOp f   = return_float (tanh f)
 212 #else
 213     -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
 214 #endif
 215     oneFloatLit _           _   = give_up
 216
 217     twoFloatLits FloatGtOp    f1 f2           = return_bool (f1 >  f2)
 218     twoFloatLits FloatGeOp    f1 f2           = return_bool (f1 >= f2)
 219     twoFloatLits FloatEqOp    f1 f2           = return_bool (f1 == f2)
 220     twoFloatLits FloatNeOp    f1 f2           = return_bool (f1 /= f2)
 221     twoFloatLits FloatLtOp    f1 f2           = return_bool (f1 <  f2)
 222     twoFloatLits FloatLeOp    f1 f2           = return_bool (f1 <= f2)
 223     twoFloatLits FloatAddOp   f1 f2           = return_float (f1 + f2)
 224     twoFloatLits FloatSubOp   f1 f2           = return_float (f1 - f2)
 225     twoFloatLits FloatMulOp   f1 f2           = return_float (f1 * f2)
 226     twoFloatLits FloatDivOp   f1 f2 | f2 /= 0 = return_float (f1 / f2)
 227     twoFloatLits _            _  _            = give_up
 228
 229         ---------   Doubles --------------
 230     oneDoubleLit DoubleNegOp  d = return_double (-d)
 231     oneDoubleLit _            _ = give_up
 232
 233     twoDoubleLits DoubleGtOp    d1 d2           = return_bool (d1 >  d2)
 234     twoDoubleLits DoubleGeOp    d1 d2           = return_bool (d1 >= d2)
 235     twoDoubleLits DoubleEqOp    d1 d2           = return_bool (d1 == d2)
 236     twoDoubleLits DoubleNeOp    d1 d2           = return_bool (d1 /= d2)
 237     twoDoubleLits DoubleLtOp    d1 d2           = return_bool (d1 <  d2)
 238     twoDoubleLits DoubleLeOp    d1 d2           = return_bool (d1 <= d2)
 239     twoDoubleLits DoubleAddOp   d1 d2           = return_double (d1 + d2)
 240     twoDoubleLits DoubleSubOp   d1 d2           = return_double (d1 - d2)
 241     twoDoubleLits DoubleMulOp   d1 d2           = return_double (d1 * d2)
 242     twoDoubleLits DoubleDivOp   d1 d2 | d2 /= 0 = return_double (d1 / d2)
 243     twoDoubleLits _             _  _            = give_up
 244
 245         ---------   Characters --------------
 246     oneCharLit OrdOp c = return_int (fromInt (ord c))
 247     oneCharLit _     _ = give_up
 248
 249     twoCharLits CharGtOp c1 c2 = return_bool (c1 >  c2)
 250     twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
 251     twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
 252     twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
 253     twoCharLits CharLtOp c1 c2 = return_bool (c1 <  c2)
 254     twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
 255     twoCharLits _        _  _  = give_up
 256
 257         ---------   Miscellaneous --------------
 258     oneLit Addr2IntOp (MachAddr i) = return_int i
 259     oneLit op         lit          = give_up
 260
 261         ---------   Equality and inequality for Int/Char --------------
 262         -- This stuff turns
 263         --      n ==# 3#
 264         -- into
 265         --      case n of
 266         --        3# -> True
 267         --        m  -> False
 268         --
 269         -- This is a Good Thing, because it allows case-of case things
 270         -- to happen, and case-default absorption to happen.  For
 271         -- example:
 272         --
 273         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 274         -- will transform to
 275         --      case n of
 276         --        3# -> e1
 277         --        4# -> e1
 278         --        m  -> e2
 279         -- (modulo the usual precautions to avoid duplicating e1)
 280
 281     litVar IntEqOp  lit var = return_prim_case var lit trueVal  falseVal
 282     litVar IntNeOp  lit var = return_prim_case var lit falseVal trueVal
 283     litVar CharEqOp lit var = return_prim_case var lit trueVal  falseVal
 284     litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
 285     litVar other_op lit var = give_up
 286
 287
 288 trueVal  = Con trueDataCon  []
 289 falseVal = Con falseDataCon []
 290 \end{code}