2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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 ( completePrim ) where
13 #include "HsVersions.h"
16 import CoreUnfold ( Unfolding, SimpleUnfolding )
18 import Literal ( mkMachInt, mkMachWord, Literal(..) )
19 import PrimOp ( PrimOp(..) )
22 import SimplUtils ( newId )
23 import TysWiredIn ( trueDataCon, falseDataCon )
25 import Char ( ord, chr )
29 completePrim :: SimplEnv
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:
39 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
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.
47 If we didn't have the extra case, then after inlining the compiler might
49 f p q = case seq# p of { _ -> p+q }
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!
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.
63 NB: If we ever do case-floating, we have an extra worry:
66 a' -> let b' = case seq# a of { True -> b; False -> parError# }
72 a' -> let b' = case True of { True -> b; False -> parError# }
86 The second case must never be floated outside of the first!
89 completePrim env SeqOp [TyArg ty, LitArg lit]
90 = returnSmpl (Lit (mkMachInt 1))
92 completePrim env op@SeqOp args@[TyArg ty, VarArg var]
93 | isEvaluated (lookupRhsInfo env var) = returnSmpl (Lit (mkMachInt 1)) -- var is eval'd
94 | otherwise = returnSmpl (Prim op args) -- var not eval'd
98 completePrim env op args
100 [LitArg (MachChar char_lit)] -> oneCharLit op char_lit
101 [LitArg (MachInt int_lit signed)] -> (if signed then oneIntLit else oneWordLit)
103 [LitArg (MachFloat float_lit)] -> oneFloatLit op float_lit
104 [LitArg (MachDouble double_lit)] -> oneDoubleLit op double_lit
105 [LitArg other_lit] -> oneLit op other_lit
107 [LitArg (MachChar char_lit1),
108 LitArg (MachChar char_lit2)] -> twoCharLits op char_lit1 char_lit2
110 [LitArg (MachInt int_lit1 True), -- both *signed* literals
111 LitArg (MachInt int_lit2 True)] -> twoIntLits op int_lit1 int_lit2
113 [LitArg (MachInt int_lit1 False), -- both *unsigned* literals
114 LitArg (MachInt int_lit2 False)] -> twoWordLits op int_lit1 int_lit2
116 [LitArg (MachInt int_lit1 False), -- unsigned+signed (shift ops)
117 LitArg (MachInt int_lit2 True)] -> oneWordOneIntLit op int_lit1 int_lit2
119 [LitArg (MachFloat float_lit1),
120 LitArg (MachFloat float_lit2)] -> twoFloatLits op float_lit1 float_lit2
122 [LitArg (MachDouble double_lit1),
123 LitArg (MachDouble double_lit2)] -> twoDoubleLits op double_lit1 double_lit2
125 [LitArg lit, VarArg var] -> litVar op lit var
126 [VarArg var, LitArg lit] -> litVar op lit var
130 give_up = returnSmpl (Prim op args)
132 return_char c = returnSmpl (Lit (MachChar c))
133 return_int i = returnSmpl (Lit (mkMachInt i))
134 return_word i = returnSmpl (Lit (mkMachWord i))
135 return_float f = returnSmpl (Lit (MachFloat f))
136 return_double d = returnSmpl (Lit (MachDouble d))
137 return_lit lit = returnSmpl (Lit lit)
139 return_bool True = returnSmpl trueVal
140 return_bool False = returnSmpl falseVal
142 return_prim_case var lit val_if_eq val_if_neq
143 = newId (idType var) `thenSmpl` \ unused_binder ->
147 (PrimAlts [(lit,val_if_eq)]
148 (BindDefault unused_binder val_if_neq))
152 --------- Ints --------------
153 oneIntLit IntNegOp i = return_int (-i)
154 oneIntLit ChrOp i = return_char (chr (fromInteger i))
155 -- SIGH: these two cause trouble in unfoldery
156 -- as we can't distinguish unsigned literals in interfaces (ToDo?)
157 -- oneIntLit Int2WordOp i = ASSERT( i>=0 ) return_word i
158 -- oneIntLit Int2AddrOp i = ASSERT( i>=0 ) return_lit (MachAddr i)
159 oneIntLit Int2FloatOp i = return_float (fromInteger i)
160 oneIntLit Int2DoubleOp i = return_double (fromInteger i)
161 oneIntLit _ _ = {-trace "oneIntLit: giving up"-} give_up
163 oneWordLit Word2IntOp w = {-lazy:ASSERT( w<= maxInt)-} return_int w
164 -- oneWordLit NotOp w = ??? ToDo: sort-of a pain
165 oneWordLit _ _ = {-trace "oneIntLit: giving up"-} give_up
167 twoIntLits IntAddOp i1 i2 = return_int (i1+i2)
168 twoIntLits IntSubOp i1 i2 = return_int (i1-i2)
169 twoIntLits IntMulOp i1 i2 = return_int (i1*i2)
170 twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
171 twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
172 twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2)
173 twoIntLits IntGeOp i1 i2 = return_bool (i1 >= i2)
174 twoIntLits IntEqOp i1 i2 = return_bool (i1 == i2)
175 twoIntLits IntNeOp i1 i2 = return_bool (i1 /= i2)
176 twoIntLits IntLtOp i1 i2 = return_bool (i1 < i2)
177 twoIntLits IntLeOp i1 i2 = return_bool (i1 <= i2)
178 -- ToDo: something for integer-shift ops?
179 twoIntLits _ _ _ = give_up
181 twoWordLits WordGtOp w1 w2 = return_bool (w1 > w2)
182 twoWordLits WordGeOp w1 w2 = return_bool (w1 >= w2)
183 twoWordLits WordEqOp w1 w2 = return_bool (w1 == w2)
184 twoWordLits WordNeOp w1 w2 = return_bool (w1 /= w2)
185 twoWordLits WordLtOp w1 w2 = return_bool (w1 < w2)
186 twoWordLits WordLeOp w1 w2 = return_bool (w1 <= w2)
187 -- ToDo: something for AndOp, OrOp?
188 twoWordLits _ _ _ = give_up
190 -- ToDo: something for shifts
191 oneWordOneIntLit _ _ _ = give_up
193 --------- Floats --------------
194 oneFloatLit FloatNegOp f = return_float (-f)
195 -- hard to do float ops in Rationals ?? (WDP 94/10) ToDo
196 oneFloatLit _ _ = give_up
198 twoFloatLits FloatGtOp f1 f2 = return_bool (f1 > f2)
199 twoFloatLits FloatGeOp f1 f2 = return_bool (f1 >= f2)
200 twoFloatLits FloatEqOp f1 f2 = return_bool (f1 == f2)
201 twoFloatLits FloatNeOp f1 f2 = return_bool (f1 /= f2)
202 twoFloatLits FloatLtOp f1 f2 = return_bool (f1 < f2)
203 twoFloatLits FloatLeOp f1 f2 = return_bool (f1 <= f2)
204 twoFloatLits FloatAddOp f1 f2 = return_float (f1 + f2)
205 twoFloatLits FloatSubOp f1 f2 = return_float (f1 - f2)
206 twoFloatLits FloatMulOp f1 f2 = return_float (f1 * f2)
207 twoFloatLits FloatDivOp f1 f2 | f2 /= 0 = return_float (f1 / f2)
208 twoFloatLits _ _ _ = give_up
210 --------- Doubles --------------
211 oneDoubleLit DoubleNegOp d = return_double (-d)
212 oneDoubleLit _ _ = give_up
214 twoDoubleLits DoubleGtOp d1 d2 = return_bool (d1 > d2)
215 twoDoubleLits DoubleGeOp d1 d2 = return_bool (d1 >= d2)
216 twoDoubleLits DoubleEqOp d1 d2 = return_bool (d1 == d2)
217 twoDoubleLits DoubleNeOp d1 d2 = return_bool (d1 /= d2)
218 twoDoubleLits DoubleLtOp d1 d2 = return_bool (d1 < d2)
219 twoDoubleLits DoubleLeOp d1 d2 = return_bool (d1 <= d2)
220 twoDoubleLits DoubleAddOp d1 d2 = return_double (d1 + d2)
221 twoDoubleLits DoubleSubOp d1 d2 = return_double (d1 - d2)
222 twoDoubleLits DoubleMulOp d1 d2 = return_double (d1 * d2)
223 twoDoubleLits DoubleDivOp d1 d2 | d2 /= 0 = return_double (d1 / d2)
224 twoDoubleLits _ _ _ = give_up
226 --------- Characters --------------
227 oneCharLit OrdOp c = return_int (fromInt (ord c))
228 oneCharLit _ _ = give_up
230 twoCharLits CharGtOp c1 c2 = return_bool (c1 > c2)
231 twoCharLits CharGeOp c1 c2 = return_bool (c1 >= c2)
232 twoCharLits CharEqOp c1 c2 = return_bool (c1 == c2)
233 twoCharLits CharNeOp c1 c2 = return_bool (c1 /= c2)
234 twoCharLits CharLtOp c1 c2 = return_bool (c1 < c2)
235 twoCharLits CharLeOp c1 c2 = return_bool (c1 <= c2)
236 twoCharLits _ _ _ = give_up
238 --------- Miscellaneous --------------
239 oneLit Addr2IntOp (MachAddr i) = return_int i
240 oneLit op lit = give_up
242 --------- Equality and inequality for Int/Char --------------
250 -- This is a Good Thing, because it allows case-of case things
251 -- to happen, and case-default absorption to happen. For
254 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
260 -- (modulo the usual precautions to avoid duplicating e1)
262 litVar IntEqOp lit var = return_prim_case var lit trueVal falseVal
263 litVar IntNeOp lit var = return_prim_case var lit falseVal trueVal
264 litVar CharEqOp lit var = return_prim_case var lit trueVal falseVal
265 litVar CharNeOp lit var = return_prim_case var lit falseVal trueVal
266 litVar other_op lit var = give_up
269 trueVal = Con trueDataCon []
270 falseVal = Con falseDataCon []