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       ( whnfDetails, UnfoldingDetails(..), FormSummary(..) )
  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 ord = fromEnum :: Char -> Int
  29 chr = toEnum   :: Int -> Char
  30 #endif
  31 \end{code}
  32
  33 \begin{code}
  34 completePrim :: SimplEnv
  35              -> PrimOp -> [OutArg]
  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 y will be evaluated.
  51
  52 If we didn't have the extra case, then after inlining the compiler might
  53 see:
  54         f p q = case seq# p of { _ -> p+q }
  55
  56 If it sees that, it can see that f is strict in q, and hence it might
  57 evaluate q before p!  The "0# ->" case prevents this happening.
  58 By having the parError# branch we make sure that anything in the
  59 other branch stays there!
  60
  61 This is fine, but we'd like to get rid of the extraneous code.  Hence,
  62 we *do* let the simplifier know that seq# is strict in its argument.
  63 As a result, we hope that `a' will be evaluated before seq# is called.
  64 At this point, we have a very special and magical simpification which
  65 says that ``seq# a'' can be immediately simplified to `1#' if we
  66 know that `a' is already evaluated.
  67
  68 NB: If we ever do case-floating, we have an extra worry:
  69
  70     case a of
  71       a' -> let b' = case seq# a of { True -> b; False -> parError# }
  72             in case b' of ...
  73
  74     =>
  75
  76     case a of
  77       a' -> let b' = case True of { True -> b; False -> parError# }
  78             in case b' of ...
  79
  80     =>
  81
  82     case a of
  83       a' -> let b' = b
  84             in case b' of ...
  85
  86     =>
  87
  88     case a of
  89       a' -> case b of ...
  90
  91 The second case must never be floated outside of the first!
  92
  93 \begin{code}
  94 completePrim env SeqOp [TyArg ty, LitArg lit]
  95   = returnSmpl (Lit (mkMachInt 1))
  96
  97 completePrim env op@SeqOp args@[TyArg ty, VarArg var]
  98   | whnfDetails (lookupUnfolding env var)
  99   = returnSmpl (Lit (mkMachInt 1))
 100   | otherwise
 101   = returnSmpl (Prim op args)
 102 \end{code}
 103
 104 \begin{code}
 105 completePrim env op args
 106   = case args of
 107      [LitArg (MachChar char_lit)]      -> oneCharLit   op char_lit
 108      [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
 109                                                           op int_lit
 110      [LitArg (MachFloat float_lit)]    -> oneFloatLit  op float_lit
 111      [LitArg (MachDouble double_lit)]  -> oneDoubleLit op double_lit
 112      [LitArg other_lit]                -> oneLit       op other_lit
 113
 114      [LitArg (MachChar char_lit1),
 115       LitArg (MachChar char_lit2)]     -> twoCharLits op char_lit1 char_lit2
 116
 117      [LitArg (MachInt int_lit1 True),  -- both *signed* literals
 118       LitArg (MachInt int_lit2 True)]  -> twoIntLits op int_lit1 int_lit2
 119
 120      [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
 121       LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
 122
 123      [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
 124       LitArg (MachInt int_lit2 True)]  -> oneWordOneIntLit op int_lit1 int_lit2
 125
 126      [LitArg (MachFloat float_lit1),
 127       LitArg (MachFloat float_lit2)]   -> twoFloatLits op float_lit1 float_lit2
 128
 129      [LitArg (MachDouble double_lit1),
 130       LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
 131
 132      [LitArg lit, VarArg var]          -> litVar op lit var
 133      [VarArg var, LitArg lit]          -> litVar op lit var
 134
 135      other                             -> give_up
 136   where
 137     give_up = returnSmpl (Prim op args)
 138
 139     return_char c   = returnSmpl (Lit (MachChar   c))
 140     return_int i    = returnSmpl (Lit (mkMachInt  i))
 141     return_word i   = returnSmpl (Lit (mkMachWord i))
 142     return_float f  = returnSmpl (Lit (MachFloat  f))
 143     return_double d = returnSmpl (Lit (MachDouble d))
 144     return_lit lit  = returnSmpl (Lit lit)
 145
 146     return_bool True  = returnSmpl trueVal
 147     return_bool False = returnSmpl falseVal
 148
 149     return_prim_case var lit val_if_eq val_if_neq
 150       = newId (idType var)      `thenSmpl` \ unused_binder ->
 151         let
 152             result
 153               = Case (Var var)
 154                   (PrimAlts [(lit,val_if_eq)]
 155                   (BindDefault unused_binder val_if_neq))
 156         in
 157         returnSmpl result
 158
 159         ---------   Ints --------------
 160     oneIntLit IntNegOp     i = return_int (-i)
 161     oneIntLit ChrOp        i = return_char (chr (fromInteger i))
 162 -- SIGH: these two cause trouble in unfoldery
 163 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
 164 --  oneIntLit Int2WordOp   i = ASSERT( i>=0 ) return_word i
 165 --  oneIntLit Int2AddrOp   i = ASSERT( i>=0 ) return_lit (MachAddr i)
 166     oneIntLit Int2FloatOp  i = return_float (fromInteger i)
 167     oneIntLit Int2DoubleOp i = return_double (fromInteger i)
 168     oneIntLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 169
 170     oneWordLit Word2IntOp   w = {-lazy:ASSERT( w<= maxInt)-} return_int w
 171 --  oneWordLit NotOp        w = ??? ToDo: sort-of a pain
 172     oneWordLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 173
 174     twoIntLits IntAddOp  i1 i2           = return_int (i1+i2)
 175     twoIntLits IntSubOp  i1 i2           = return_int (i1-i2)
 176     twoIntLits IntMulOp  i1 i2           = return_int (i1*i2)
 177     twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
 178     twoIntLits IntRemOp  i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
 179     twoIntLits IntGtOp   i1 i2           = return_bool (i1 >  i2)
 180     twoIntLits IntGeOp   i1 i2           = return_bool (i1 >= i2)
 181     twoIntLits IntEqOp   i1 i2           = return_bool (i1 == i2)
 182     twoIntLits IntNeOp   i1 i2           = return_bool (i1 /= i2)
 183     twoIntLits IntLtOp   i1 i2           = return_bool (i1 <  i2)
 184     twoIntLits IntLeOp   i1 i2           = return_bool (i1 <= i2)
 185     -- ToDo: something for integer-shift ops?
 186     twoIntLits _         _  _            = give_up
 187
 188     twoWordLits WordGtOp w1 w2 = return_bool (w1 >  w2)
 189     twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
 190     twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
 191     twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
 192     twoWordLits WordLtOp w1 w2 = return_bool (w1 <  w2)
 193     twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
 194     -- ToDo: something for AndOp, OrOp?
 195     twoWordLits _        _  _  = give_up
 196
 197     -- ToDo: something for shifts
 198     oneWordOneIntLit _ _  _    = give_up
 199
 200         ---------   Floats --------------
 201     oneFloatLit FloatNegOp  f   = return_float (-f)
 202 #if __GLASGOW_HASKELL__ <= 22
 203     oneFloatLit FloatExpOp  f   = return_float (exp f)
 204     oneFloatLit FloatLogOp  f   = return_float (log f)
 205     oneFloatLit FloatSqrtOp f   = return_float (sqrt f)
 206     oneFloatLit FloatSinOp  f   = return_float (sin f)
 207     oneFloatLit FloatCosOp  f   = return_float (cos f)
 208     oneFloatLit FloatTanOp  f   = return_float (tan f)
 209     oneFloatLit FloatAsinOp f   = return_float (asin f)
 210     oneFloatLit FloatAcosOp f   = return_float (acos f)
 211     oneFloatLit FloatAtanOp f   = return_float (atan f)
 212     oneFloatLit FloatSinhOp f   = return_float (sinh f)
 213     oneFloatLit FloatCoshOp f   = return_float (cosh f)
 214     oneFloatLit FloatTanhOp f   = return_float (tanh f)
 215 #else
 216     -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
 217 #endif
 218     oneFloatLit _           _   = give_up
 219
 220     twoFloatLits FloatGtOp    f1 f2           = return_bool (f1 >  f2)
 221     twoFloatLits FloatGeOp    f1 f2           = return_bool (f1 >= f2)
 222     twoFloatLits FloatEqOp    f1 f2           = return_bool (f1 == f2)
 223     twoFloatLits FloatNeOp    f1 f2           = return_bool (f1 /= f2)
 224     twoFloatLits FloatLtOp    f1 f2           = return_bool (f1 <  f2)
 225     twoFloatLits FloatLeOp    f1 f2           = return_bool (f1 <= f2)
 226     twoFloatLits FloatAddOp   f1 f2           = return_float (f1 + f2)
 227     twoFloatLits FloatSubOp   f1 f2           = return_float (f1 - f2)
 228     twoFloatLits FloatMulOp   f1 f2           = return_float (f1 * f2)
 229     twoFloatLits FloatDivOp   f1 f2 | f2 /= 0 = return_float (f1 / f2)
 230     twoFloatLits _            _  _            = give_up
 231
 232         ---------   Doubles --------------
 233     oneDoubleLit DoubleNegOp  d = return_double (-d)
 234     oneDoubleLit _            _ = give_up
 235
 236     twoDoubleLits DoubleGtOp    d1 d2           = return_bool (d1 >  d2)
 237     twoDoubleLits DoubleGeOp    d1 d2           = return_bool (d1 >= d2)
 238     twoDoubleLits DoubleEqOp    d1 d2           = return_bool (d1 == d2)
 239     twoDoubleLits DoubleNeOp    d1 d2           = return_bool (d1 /= d2)
 240     twoDoubleLits DoubleLtOp    d1 d2           = return_bool (d1 <  d2)
 241     twoDoubleLits DoubleLeOp    d1 d2           = return_bool (d1 <= d2)
 242     twoDoubleLits DoubleAddOp   d1 d2           = return_double (d1 + d2)
 243     twoDoubleLits DoubleSubOp   d1 d2           = return_double (d1 - d2)
 244     twoDoubleLits DoubleMulOp   d1 d2           = return_double (d1 * d2)
 245     twoDoubleLits DoubleDivOp   d1 d2 | d2 /= 0 = return_double (d1 / d2)
 246     twoDoubleLits _             _  _            = give_up
 247
 248         ---------   Characters --------------
 249     oneCharLit OrdOp c = return_int (fromInt (ord c))
 250     oneCharLit _     _ = give_up
 251
 252     twoCharLits CharGtOp c1 c2 = return_bool (c1 >  c2)
 253     twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
 254     twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
 255     twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
 256     twoCharLits CharLtOp c1 c2 = return_bool (c1 <  c2)
 257     twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
 258     twoCharLits _        _  _  = give_up
 259
 260         ---------   Miscellaneous --------------
 261     oneLit Addr2IntOp (MachAddr i) = return_int i
 262     oneLit op         lit          = give_up
 263
 264         ---------   Equality and inequality for Int/Char --------------
 265         -- This stuff turns
 266         --      n ==# 3#
 267         -- into
 268         --      case n of
 269         --        3# -> True
 270         --        m  -> False
 271         --
 272         -- This is a Good Thing, because it allows case-of case things
 273         -- to happen, and case-default absorption to happen.  For
 274         -- example:
 275         --
 276         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 277         -- will transform to
 278         --      case n of
 279         --        3# -> e1
 280         --        4# -> e1
 281         --        m  -> e2
 282         -- (modulo the usual precautions to avoid duplicating e1)
 283
 284     litVar IntEqOp  lit var = return_prim_case var lit trueVal  falseVal
 285     litVar IntNeOp  lit var = return_prim_case var lit falseVal trueVal
 286     litVar CharEqOp lit var = return_prim_case var lit trueVal  falseVal
 287     litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
 288     litVar other_op lit var = give_up
 289
 290
 291 trueVal  = Con trueDataCon  []
 292 falseVal = Con falseDataCon []
 293 \end{code}