2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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.
9 See the @IntDivOp@ below.
12 #include "HsVersions.h"
14 module ConFold ( completePrim ) where
23 import AbsPrel ( trueDataCon, falseDataCon, PrimOp(..), PrimKind
24 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
25 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
27 import BasicLit ( mkMachInt, mkMachWord, BasicLit(..) )
28 import Id ( Id, getIdUniType )
29 import Maybes ( Maybe(..) )
34 completePrim :: SimplEnv
35 -> PrimOp -> [OutType] -> [OutAtom]
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:
44 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
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 b will be evaluated.
52 This is fine, but we'd like to get rid of the extraneous code. Hence,
53 we *do* let the simplifier know that seq# is strict in its argument.
54 As a result, we hope that `a' will be evaluated before seq# is called.
55 At this point, we have a very special and magical simpification which
56 says that ``seq# a'' can be immediately simplified to `1#' if we
57 know that `a' is already evaluated.
59 NB: If we ever do case-floating, we have an extra worry:
62 a' -> let b' = case seq# a of { True -> b; False -> parError# }
68 a' -> let b' = case True of { True -> b; False -> parError# }
82 The second case must never be floated outside of the first!
85 completePrim env SeqOp [ty] [CoLitAtom lit]
86 = returnSmpl (CoLit (mkMachInt 1))
88 completePrim env op@SeqOp tys@[ty] args@[CoVarAtom var]
89 = case (lookupUnfolding env var) of
90 NoUnfoldingDetails -> give_up
91 LiteralForm _ -> hooray
92 OtherLiteralForm _ -> hooray
93 ConstructorForm _ _ _ -> hooray
94 OtherConstructorForm _ -> hooray
95 GeneralForm _ WhnfForm _ _ -> hooray
98 give_up = returnSmpl (CoPrim op tys args)
99 hooray = returnSmpl (CoLit (mkMachInt 1))
103 completePrim env op tys args
105 [CoLitAtom (MachChar char_lit)] -> oneCharLit op char_lit
106 [CoLitAtom (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
108 [CoLitAtom (MachFloat float_lit)] -> oneFloatLit op float_lit
109 [CoLitAtom (MachDouble double_lit)] -> oneDoubleLit op double_lit
110 [CoLitAtom other_lit] -> oneLit op other_lit
112 [CoLitAtom (MachChar char_lit1),
113 CoLitAtom (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
115 [CoLitAtom (MachInt int_lit1 True), -- both *signed* literals
116 CoLitAtom (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
118 [CoLitAtom (MachInt int_lit1 False), -- both *unsigned* literals
119 CoLitAtom (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
121 [CoLitAtom (MachInt int_lit1 False), -- unsigned+signed (shift ops)
122 CoLitAtom (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
124 [CoLitAtom (MachFloat float_lit1),
125 CoLitAtom (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
127 [CoLitAtom (MachDouble double_lit1),
128 CoLitAtom (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
130 [CoLitAtom lit, CoVarAtom var] -> litVar op lit var
131 [CoVarAtom var, CoLitAtom lit] -> litVar op lit var
136 give_up = returnSmpl (CoPrim op tys args)
138 return_char c = returnSmpl (CoLit (MachChar c))
139 return_int i = returnSmpl (CoLit (mkMachInt i))
140 return_word i = returnSmpl (CoLit (mkMachWord i))
141 return_float f = returnSmpl (CoLit (MachFloat f))
142 return_double d = returnSmpl (CoLit (MachDouble d))
143 return_lit lit = returnSmpl (CoLit lit)
145 return_bool True = returnSmpl trueVal
146 return_bool False = returnSmpl falseVal
148 return_prim_case var lit val_if_eq val_if_neq
149 = newId (getIdUniType var) `thenSmpl` \ unused_binder ->
153 (CoPrimAlts [(lit,val_if_eq)]
154 (CoBindDefault unused_binder val_if_neq))
156 -- pprTrace "return_prim_case:" (ppr PprDebug result) (
160 --------- Ints --------------
161 oneIntLit IntNegOp i = return_int (-i)
162 oneIntLit ChrOp i = return_char (chr (fromInteger i))
163 -- SIGH: these two cause trouble in unfoldery
164 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
165 -- oneIntLit Int2WordOp i = ASSERT( i>=0 ) return_word i
166 -- oneIntLit Int2AddrOp i = ASSERT( i>=0 ) return_lit (MachAddr i)
167 oneIntLit Int2FloatOp i = return_float (fromInteger i)
168 oneIntLit Int2DoubleOp i = return_double (fromInteger i)
169 oneIntLit _ _ = {-trace "oneIntLit: giving up"-} give_up
171 oneWordLit Word2IntOp w = {-lazy:ASSERT( w<= maxInt)-} return_int w
172 -- oneWordLit NotOp w = ??? ToDo: sort-of a pain
173 oneWordLit _ _ = {-trace "oneIntLit: giving up"-} give_up
175 twoIntLits IntAddOp i1 i2 = return_int (i1+i2)
176 twoIntLits IntSubOp i1 i2 = return_int (i1-i2)
177 twoIntLits IntMulOp i1 i2 = return_int (i1*i2)
178 twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
179 twoIntLits IntDivOp i1 i2 | i2 /= 0 = return_int (i1 `div` 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 _ _ _ = {-trace "twoIntLits: giving up"-} give_up
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 _ _ _ = {-trace "twoWordLits: giving up"-} give_up
199 -- ToDo: something for shifts
200 oneWordOneIntLit _ _ _ = {-trace "oneWordOneIntLit: giving up"-} give_up
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)
218 -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
220 oneFloatLit _ _ = {-trace "oneFloatLits: giving up"-} give_up
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 #if __GLASGOW_HASKELL__ <= 22
233 twoFloatLits FloatPowerOp f1 f2 = return_float (f1 ** f2)
235 -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
237 twoFloatLits _ _ _ = {-trace "twoFloatLits: giving up"-} give_up
239 --------- Doubles --------------
240 oneDoubleLit DoubleNegOp d = return_double (-d)
241 #if __GLASGOW_HASKELL__ <= 22
242 oneDoubleLit DoubleExpOp d = return_double (exp d)
243 oneDoubleLit DoubleLogOp d = return_double (log d)
244 oneDoubleLit DoubleSqrtOp d = return_double (sqrt d)
245 oneDoubleLit DoubleSinOp d = return_double (sin d)
246 oneDoubleLit DoubleCosOp d = return_double (cos d)
247 oneDoubleLit DoubleTanOp d = return_double (tan d)
248 oneDoubleLit DoubleAsinOp d = return_double (asin d)
249 oneDoubleLit DoubleAcosOp d = return_double (acos d)
250 oneDoubleLit DoubleAtanOp d = return_double (atan d)
251 oneDoubleLit DoubleSinhOp d = return_double (sinh d)
252 oneDoubleLit DoubleCoshOp d = return_double (cosh d)
253 oneDoubleLit DoubleTanhOp d = return_double (tanh d)
255 -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
257 oneDoubleLit _ _ = {-trace "oneDoubleLit: giving up"-} give_up
259 twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2)
260 twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2)
261 twoDoubleLits DoubleEqOp d1 d2 = return_bool (d1 == d2)
262 twoDoubleLits DoubleNeOp d1 d2 = return_bool (d1 /= d2)
263 twoDoubleLits DoubleLtOp d1 d2 = return_bool (d1 < d2)
264 twoDoubleLits DoubleLeOp d1 d2 = return_bool (d1 <= d2)
265 twoDoubleLits DoubleAddOp d1 d2 = return_double (d1 + d2)
266 twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2)
267 twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2)
268 twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2)
269 #if __GLASGOW_HASKELL__ <= 22
270 twoDoubleLits DoublePowerOp d1 d2 = return_double (d1 ** d2)
272 -- hard to do all that in Rationals ?? (WDP 94/10) ToDo
274 twoDoubleLits _ _ _ = {-trace "twoDoubleLits: giving up"-} give_up
276 --------- Characters --------------
277 oneCharLit OrdOp c = return_int (fromInt (ord c))
278 oneCharLit _ _ = {-trace "oneCharLIt: giving up"-} give_up
280 twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2)
281 twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
282 twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
283 twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
284 twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2)
285 twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
286 twoCharLits _ _ _ = {-trace "twoCharLits: giving up"-} give_up
288 --------- Miscellaneous --------------
289 oneLit Addr2IntOp (MachAddr i) = return_int i
290 oneLit op lit = give_up
292 --------- Equality and inequality for Int/Char --------------
300 -- This is a Good Thing, because it allows case-of case things
301 -- to happen, and case-default absorption to happen. For
304 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
310 -- (modulo the usual precautions to avoid duplicating e1)
312 litVar IntEqOp lit var = return_prim_case var lit trueVal falseVal
313 litVar IntNeOp lit var = return_prim_case var lit falseVal trueVal
314 litVar CharEqOp lit var = return_prim_case var lit trueVal falseVal
315 litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
316 litVar other_op lit var = give_up
319 trueVal = CoCon trueDataCon [] []
320 falseVal = CoCon falseDataCon [] []