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 import Ubiq{-uitous-}
  16
  17 import CoreSyn
  18 import CoreUnfold       ( 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 \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   = case (lookupUnfolding env var) of
  94       NoUnfoldingDetails     -> give_up
  95       LitForm _              -> hooray
  96       OtherLitForm _         -> hooray
  97       ConForm _ _            -> hooray
  98       OtherConForm _         -> hooray
  99       GenForm _ WhnfForm _ _ -> hooray
 100       _                      -> give_up
 101   where
 102     give_up = returnSmpl (Prim op args)
 103     hooray  = returnSmpl (Lit (mkMachInt 1))
 104 \end{code}
 105
 106 \begin{code}
 107 completePrim env op args
 108   = case args of
 109      [LitArg (MachChar char_lit)]      -> oneCharLit   op char_lit
 110      [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
 111                                                           op int_lit
 112      [LitArg (MachFloat float_lit)]    -> oneFloatLit  op float_lit
 113      [LitArg (MachDouble double_lit)]  -> oneDoubleLit op double_lit
 114      [LitArg other_lit]                -> oneLit       op other_lit
 115
 116      [LitArg (MachChar char_lit1),
 117       LitArg (MachChar char_lit2)]     -> twoCharLits op char_lit1 char_lit2
 118
 119      [LitArg (MachInt int_lit1 True),  -- both *signed* literals
 120       LitArg (MachInt int_lit2 True)]  -> twoIntLits op int_lit1 int_lit2
 121
 122      [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
 123       LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
 124
 125      [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
 126       LitArg (MachInt int_lit2 True)]  -> oneWordOneIntLit op int_lit1 int_lit2
 127
 128      [LitArg (MachFloat float_lit1),
 129       LitArg (MachFloat float_lit2)]   -> twoFloatLits op float_lit1 float_lit2
 130
 131      [LitArg (MachDouble double_lit1),
 132       LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
 133
 134      [LitArg lit, VarArg var]          -> litVar op lit var
 135      [VarArg var, LitArg lit]          -> litVar op lit var
 136
 137      other                             -> give_up
 138   where
 139     give_up = returnSmpl (Prim op args)
 140
 141     return_char c   = returnSmpl (Lit (MachChar   c))
 142     return_int i    = returnSmpl (Lit (mkMachInt  i))
 143     return_word i   = returnSmpl (Lit (mkMachWord i))
 144     return_float f  = returnSmpl (Lit (MachFloat  f))
 145     return_double d = returnSmpl (Lit (MachDouble d))
 146     return_lit lit  = returnSmpl (Lit lit)
 147
 148     return_bool True  = returnSmpl trueVal
 149     return_bool False = returnSmpl falseVal
 150
 151     return_prim_case var lit val_if_eq val_if_neq
 152       = newId (idType var)      `thenSmpl` \ unused_binder ->
 153         let
 154             result
 155               = Case (Var var)
 156                   (PrimAlts [(lit,val_if_eq)]
 157                   (BindDefault unused_binder val_if_neq))
 158         in
 159         returnSmpl result
 160
 161         ---------   Ints --------------
 162     oneIntLit IntNegOp     i = return_int (-i)
 163     oneIntLit ChrOp        i = return_char (chr (fromInteger i))
 164 -- SIGH: these two cause trouble in unfoldery
 165 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
 166 --  oneIntLit Int2WordOp   i = ASSERT( i>=0 ) return_word i
 167 --  oneIntLit Int2AddrOp   i = ASSERT( i>=0 ) return_lit (MachAddr i)
 168     oneIntLit Int2FloatOp  i = return_float (fromInteger i)
 169     oneIntLit Int2DoubleOp i = return_double (fromInteger i)
 170     oneIntLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 171
 172     oneWordLit Word2IntOp   w = {-lazy:ASSERT( w<= maxInt)-} return_int w
 173 --  oneWordLit NotOp        w = ??? ToDo: sort-of a pain
 174     oneWordLit _            _ = {-trace "oneIntLit: giving up"-} give_up
 175
 176     twoIntLits IntAddOp  i1 i2           = return_int (i1+i2)
 177     twoIntLits IntSubOp  i1 i2           = return_int (i1-i2)
 178     twoIntLits IntMulOp  i1 i2           = return_int (i1*i2)
 179     twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` 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 _         _  _            = 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 _        _  _  = give_up
 198
 199     -- ToDo: something for shifts
 200     oneWordOneIntLit _ _  _    = 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 _           _   = 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     twoFloatLits _            _  _            = give_up
 233
 234         ---------   Doubles --------------
 235     oneDoubleLit DoubleNegOp  d = return_double (-d)
 236     oneDoubleLit _            _ = give_up
 237
 238     twoDoubleLits DoubleGtOp    d1 d2           = return_bool (d1 >  d2)
 239     twoDoubleLits DoubleGeOp    d1 d2           = return_bool (d1 >= d2)
 240     twoDoubleLits DoubleEqOp    d1 d2           = return_bool (d1 == d2)
 241     twoDoubleLits DoubleNeOp    d1 d2           = return_bool (d1 /= d2)
 242     twoDoubleLits DoubleLtOp    d1 d2           = return_bool (d1 <  d2)
 243     twoDoubleLits DoubleLeOp    d1 d2           = return_bool (d1 <= d2)
 244     twoDoubleLits DoubleAddOp   d1 d2           = return_double (d1 + d2)
 245     twoDoubleLits DoubleSubOp   d1 d2           = return_double (d1 - d2)
 246     twoDoubleLits DoubleMulOp   d1 d2           = return_double (d1 * d2)
 247     twoDoubleLits DoubleDivOp   d1 d2 | d2 /= 0 = return_double (d1 / d2)
 248     twoDoubleLits _             _  _            = give_up
 249
 250         ---------   Characters --------------
 251     oneCharLit OrdOp c = return_int (fromInt (ord c))
 252     oneCharLit _     _ = give_up
 253
 254     twoCharLits CharGtOp c1 c2 = return_bool (c1 >  c2)
 255     twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
 256     twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
 257     twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
 258     twoCharLits CharLtOp c1 c2 = return_bool (c1 <  c2)
 259     twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
 260     twoCharLits _        _  _  = give_up
 261
 262         ---------   Miscellaneous --------------
 263     oneLit Addr2IntOp (MachAddr i) = return_int i
 264     oneLit op         lit          = give_up
 265
 266         ---------   Equality and inequality for Int/Char --------------
 267         -- This stuff turns
 268         --      n ==# 3#
 269         -- into
 270         --      case n of
 271         --        3# -> True
 272         --        m  -> False
 273         --
 274         -- This is a Good Thing, because it allows case-of case things
 275         -- to happen, and case-default absorption to happen.  For
 276         -- example:
 277         --
 278         --      if (n ==# 3#) || (n ==# 4#) then e1 else e2
 279         -- will transform to
 280         --      case n of
 281         --        3# -> e1
 282         --        4# -> e1
 283         --        m  -> e2
 284         -- (modulo the usual precautions to avoid duplicating e1)
 285
 286     litVar IntEqOp  lit var = return_prim_case var lit trueVal  falseVal
 287     litVar IntNeOp  lit var = return_prim_case var lit falseVal trueVal
 288     litVar CharEqOp lit var = return_prim_case var lit trueVal  falseVal
 289     litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
 290     litVar other_op lit var = give_up
 291
 292
 293 trueVal  = Con trueDataCon  []
 294 falseVal = Con falseDataCon []
 295 \end{code}