2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[ConFold]{Constant Folder}
7 check boundaries before folding, e.g. we can fold the Float addition
8 (i1 + i2) only if it results in a valid Float.
11 module ConFold ( tryPrimOp ) where
13 #include "HsVersions.h"
16 import Id ( getIdUnfolding )
17 import Const ( mkMachInt, mkMachWord, Literal(..), Con(..) )
18 import PrimOp ( PrimOp(..) )
20 import TysWiredIn ( trueDataCon, falseDataCon )
21 import TyCon ( tyConDataCons, isEnumerationTyCon )
22 import DataCon ( dataConTag, fIRST_TAG )
23 import Const ( conOkForAlt )
24 import CoreUnfold ( Unfolding(..) )
25 import Type ( splitTyConApp_maybe )
27 import Char ( ord, chr )
32 tryPrimOp :: PrimOp -> [CoreArg] -- op arg1 ... argn
33 -- Args are already simplified
34 -> Maybe CoreExpr -- Nothing => no transformation
35 -- Just e => transforms to e
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:
43 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
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.
51 If we didn't have the extra case, then after inlining the compiler might
53 f p q = case seq# p of { _ -> p+q }
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!
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.
67 NB: If we ever do case-floating, we have an extra worry:
70 a' -> let b' = case seq# a of { True -> b; False -> parError# }
76 a' -> let b' = case True of { True -> b; False -> parError# }
90 The second case must never be floated outside of the first!
93 tryPrimOp SeqOp [Type ty, Con (Literal lit) _]
94 = Just (Con (Literal (mkMachInt 1)) [])
96 tryPrimOp SeqOp args@[Type ty, Var var]
97 | isEvaluated (getIdUnfolding var) = Just (Con (Literal (mkMachInt 1)) [])) -- var is eval'd
98 | otherwise = Nothing -- var not eval'd
102 tryPrimOp TagToEnumOp [Type ty, Con (Literal (MachInt i _)) _]
103 | isEnumerationTyCon tycon = Just (Con (DataCon dc) [])
104 | otherwise = panic "tryPrimOp: tagToEnum# on non-enumeration type"
105 where tag = fromInteger i
106 constrs = tyConDataCons tycon
107 (dc:_) = [ dc | dc <- constrs, tag == dataConTag dc - fIRST_TAG ]
108 (Just (tycon,_)) = splitTyConApp_maybe ty
111 For dataToTag#, we can reduce if either
113 (a) the argument is a constructor
114 (b) the argument is a variable whose unfolding is a known constructor
117 tryPrimOp DataToTagOp [Type ty, Con (DataCon dc) _]
118 = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
119 tryPrimOp DataToTagOp [Type ty, Var x]
120 | has_unfolding && unfolding_is_constr
121 = Just (Con (Literal (mkMachInt (toInteger (dataConTag dc - fIRST_TAG)))) [])
123 has_unfolding = case unfolding of
124 CoreUnfolding _ _ _ -> True
126 unfolding = getIdUnfolding x
127 CoreUnfolding form guidance unf_template = unfolding
128 unfolding_is_constr = case unf_template of
129 Con con@(DataCon _) _ -> conOkForAlt con
131 Con (DataCon dc) con_args = unf_template
137 [Con (Literal (MachChar char_lit)) _] -> oneCharLit op char_lit
138 [Con (Literal (MachInt int_lit signed)) _] -> (if signed then oneIntLit else oneWordLit)
140 [Con (Literal (MachFloat float_lit)) _] -> oneFloatLit op float_lit
141 [Con (Literal (MachDouble double_lit)) _] -> oneDoubleLit op double_lit
142 [Con (Literal other_lit) _] -> oneLit op other_lit
144 [Con (Literal (MachChar char_lit1)) _,
145 Con (Literal (MachChar char_lit2)) _] -> twoCharLits op char_lit1 char_lit2
147 [Con (Literal (MachInt int_lit1 True)) _, -- both *signed* literals
148 Con (Literal (MachInt int_lit2 True)) _] -> twoIntLits op int_lit1 int_lit2
150 [Con (Literal (MachInt int_lit1 False)) _, -- both *unsigned* literals
151 Con (Literal (MachInt int_lit2 False)) _] -> twoWordLits op int_lit1 int_lit2
153 [Con (Literal (MachInt int_lit1 False)) _, -- unsigned+signed (shift ops)
154 Con (Literal (MachInt int_lit2 True)) _] -> oneWordOneIntLit op int_lit1 int_lit2
156 [Con (Literal (MachFloat float_lit1)) _,
157 Con (Literal (MachFloat float_lit2)) _] -> twoFloatLits op float_lit1 float_lit2
159 [Con (Literal (MachDouble double_lit1)) _,
160 Con (Literal (MachDouble double_lit2)) _] -> twoDoubleLits op double_lit1 double_lit2
162 [Con (Literal lit) _, Var var] -> litVar op lit var
163 [Var var, Con (Literal lit) _] -> litVar op lit var
169 return_char c = Just (Con (Literal (MachChar c)) [])
170 return_int i = Just (Con (Literal (mkMachInt i)) [])
171 return_word i = Just (Con (Literal (mkMachWord i)) [])
172 return_float f = Just (Con (Literal (MachFloat f)) [])
173 return_double d = Just (Con (Literal (MachDouble d)) [])
174 return_lit lit = Just (Con (Literal lit) [])
176 return_bool True = Just trueVal
177 return_bool False = Just falseVal
179 return_prim_case var lit val_if_eq val_if_neq
180 = Just (Case (Var var) var [(Literal lit, [], val_if_eq),
181 (DEFAULT, [], val_if_neq)])
183 --------- Ints --------------
184 oneIntLit IntNegOp i = return_int (-i)
185 oneIntLit ChrOp i = return_char (chr (fromInteger i))
186 -- SIGH: these two cause trouble in unfoldery
187 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
188 -- oneIntLit Int2WordOp i = ASSERT( i>=0 ) return_word i
189 -- oneIntLit Int2AddrOp i = ASSERT( i>=0 ) return_lit (MachAddr i)
190 oneIntLit Int2FloatOp i = return_float (fromInteger i)
191 oneIntLit Int2DoubleOp i = return_double (fromInteger i)
192 oneIntLit _ _ = {-trace "oneIntLit: giving up"-} give_up
194 oneWordLit Word2IntOp w = {-lazy:ASSERT( w<= maxInt)-} return_int w
195 -- oneWordLit NotOp w = ??? ToDo: sort-of a pain
196 oneWordLit _ _ = {-trace "oneIntLit: giving up"-} give_up
198 twoIntLits IntAddOp i1 i2 = checkRange (i1+i2)
199 twoIntLits IntSubOp i1 i2 = checkRange (i1-i2)
200 twoIntLits IntMulOp i1 i2 = checkRange (i1*i2)
201 twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
202 twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
203 twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2)
204 twoIntLits IntGeOp i1 i2 = return_bool (i1 >= i2)
205 twoIntLits IntEqOp i1 i2 = return_bool (i1 == i2)
206 twoIntLits IntNeOp i1 i2 = return_bool (i1 /= i2)
207 twoIntLits IntLtOp i1 i2 = return_bool (i1 < i2)
208 twoIntLits IntLeOp i1 i2 = return_bool (i1 <= i2)
209 -- ToDo: something for integer-shift ops?
210 twoIntLits _ _ _ = give_up
212 twoWordLits WordGtOp w1 w2 = return_bool (w1 > w2)
213 twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
214 twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
215 twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
216 twoWordLits WordLtOp w1 w2 = return_bool (w1 < w2)
217 twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
218 -- ToDo: something for AndOp, OrOp?
219 twoWordLits _ _ _ = give_up
221 -- ToDo: something for shifts
222 oneWordOneIntLit _ _ _ = give_up
224 --------- Floats --------------
225 oneFloatLit FloatNegOp f = return_float (-f)
226 -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo
227 oneFloatLit _ _ = give_up
229 twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2)
230 twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2)
231 twoFloatLits FloatEqOp f1 f2 = return_bool (f1 == f2)
232 twoFloatLits FloatNeOp f1 f2 = return_bool (f1 /= f2)
233 twoFloatLits FloatLtOp f1 f2 = return_bool (f1 < f2)
234 twoFloatLits FloatLeOp f1 f2 = return_bool (f1 <= f2)
235 twoFloatLits FloatAddOp f1 f2 = return_float (f1 + f2)
236 twoFloatLits FloatSubOp f1 f2 = return_float (f1 - f2)
237 twoFloatLits FloatMulOp f1 f2 = return_float (f1 * f2)
238 twoFloatLits FloatDivOp f1 f2 | f2 /= 0 = return_float (f1 / f2)
239 twoFloatLits _ _ _ = give_up
241 --------- Doubles --------------
242 oneDoubleLit DoubleNegOp d = return_double (-d)
243 oneDoubleLit _ _ = give_up
245 twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2)
246 twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2)
247 twoDoubleLits DoubleEqOp d1 d2 = return_bool (d1 == d2)
248 twoDoubleLits DoubleNeOp d1 d2 = return_bool (d1 /= d2)
249 twoDoubleLits DoubleLtOp d1 d2 = return_bool (d1 < d2)
250 twoDoubleLits DoubleLeOp d1 d2 = return_bool (d1 <= d2)
251 twoDoubleLits DoubleAddOp d1 d2 = return_double (d1 + d2)
252 twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2)
253 twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2)
254 twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2)
255 twoDoubleLits _ _ _ = give_up
257 --------- Characters --------------
258 oneCharLit OrdOp c = return_int (fromInt (ord c))
259 oneCharLit _ _ = give_up
261 twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2)
262 twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
263 twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
264 twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
265 twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2)
266 twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
267 twoCharLits _ _ _ = give_up
269 --------- Miscellaneous --------------
270 oneLit Addr2IntOp (MachAddr i) = return_int (fromInteger i)
271 oneLit op lit = give_up
273 --------- Equality and inequality for Int/Char --------------
281 -- This is a Good Thing, because it allows case-of case things
282 -- to happen, and case-default absorption to happen. For
285 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
291 -- (modulo the usual precautions to avoid duplicating e1)
293 litVar IntEqOp lit var = return_prim_case var lit trueVal falseVal
294 litVar IntNeOp lit var = return_prim_case var lit falseVal trueVal
295 litVar CharEqOp lit var = return_prim_case var lit trueVal falseVal
296 litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
297 litVar other_op lit var = give_up
300 checkRange :: Integer -> Maybe CoreExpr
302 | (val > fromInt maxInt) || (val < fromInt minInt) =
303 -- Better tell the user that we've overflowed...
304 pprTrace "Warning:" (text "Integer overflow in expression: " <>
305 ppr ((mkPrimApp op args)::CoreExpr)) $
306 -- ..not that it stops us from actually folding!
307 -- ToDo: a SrcLoc would be nice.
309 | otherwise = return_int val
311 trueVal = Con (DataCon trueDataCon) []
312 falseVal = Con (DataCon falseDataCon) []