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