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