2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[ConFold]{Constant Folder}
6 Conceptually, constant folding should be parameterized with the kind
7 of target machine to get identical behaviour during compilation time
8 and runtime. We cheat a little bit here...
11 check boundaries before folding, e.g. we can fold the Float addition
12 (i1 + i2) only if it results in a valid Float.
16 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
18 module PrelRules ( primOpRules, builtinRules ) where
20 #include "HsVersions.h"
23 import Id ( mkWildId, idUnfolding )
24 import Literal ( Literal(..), mkMachInt, mkMachWord
26 , word2IntLit, int2WordLit
27 , narrow8IntLit, narrow16IntLit, narrow32IntLit
28 , narrow8WordLit, narrow16WordLit, narrow32WordLit
29 , char2IntLit, int2CharLit
30 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
31 , float2DoubleLit, double2FloatLit
33 import PrimOp ( PrimOp(..), tagToEnumKey )
34 import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
35 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
36 import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
37 import CoreUtils ( cheapEqExpr, exprIsConApp_maybe )
38 import Type ( tyConAppTyCon, coreEqType )
39 import OccName ( occNameFS )
40 import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
41 eqStringName, unpackCStringIdKey, inlineIdName )
42 import Maybes ( orElse )
43 import Name ( Name, nameOccName )
46 import StaticFlags ( opt_SimplExcessPrecision )
48 import Data.Bits as Bits ( Bits(..), shiftL, shiftR )
49 -- shiftL and shiftR were not always methods of Bits
50 import Data.Word ( Word )
54 Note [Constant folding]
55 ~~~~~~~~~~~~~~~~~~~~~~~
56 primOpRules generates the rewrite rules for each primop
57 These rules do what is often called "constant folding"
58 E.g. the rules for +# might say
60 Well, of course you'd need a lot of rules if you did it
61 like that, so we use a BuiltinRule instead, so that we
62 can match in any two literal values. So the rule is really
64 (Lit 4) +# (Lit y) = Lit (x+#y)
65 where the (+#) on the rhs is done at compile time
67 That is why these rules are built in here. Other rules
68 which don't need to be built in are in GHC.Base. For
74 primOpRules :: PrimOp -> Name -> [CoreRule]
75 primOpRules op op_name = primop_rule op
78 one_lit = oneLit op_name
79 two_lits = twoLits op_name
80 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
81 -- Cunning. cmpOp compares the values to give an Ordering.
82 -- It applies its argument to that ordering value to turn
83 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
85 -- ToDo: something for integer-shift ops?
88 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
89 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
92 primop_rule IntAddOp = two_lits (intOp2 (+))
93 primop_rule IntSubOp = two_lits (intOp2 (-))
94 primop_rule IntMulOp = two_lits (intOp2 (*))
95 primop_rule IntQuotOp = two_lits (intOp2Z quot)
96 primop_rule IntRemOp = two_lits (intOp2Z rem)
97 primop_rule IntNegOp = one_lit negOp
98 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
99 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
100 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
103 primop_rule WordAddOp = two_lits (wordOp2 (+))
104 primop_rule WordSubOp = two_lits (wordOp2 (-))
105 primop_rule WordMulOp = two_lits (wordOp2 (*))
106 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
107 primop_rule WordRemOp = two_lits (wordOp2Z rem)
108 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
109 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
110 primop_rule XorOp = two_lits (wordBitOp2 xor)
111 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
112 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
115 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
116 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
117 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
118 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
119 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
120 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
121 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
122 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
123 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
124 primop_rule ChrOp = one_lit (litCoerce int2CharLit)
125 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
126 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
127 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
128 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
129 -- SUP: Not sure what the standard says about precision in the following 2 cases
130 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
131 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
134 primop_rule FloatAddOp = two_lits (floatOp2 (+))
135 primop_rule FloatSubOp = two_lits (floatOp2 (-))
136 primop_rule FloatMulOp = two_lits (floatOp2 (*))
137 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
138 primop_rule FloatNegOp = one_lit negOp
141 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
142 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
143 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
144 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
145 primop_rule DoubleNegOp = one_lit negOp
147 -- Relational operators
148 primop_rule IntEqOp = relop (==) ++ litEq op_name True
149 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
150 primop_rule CharEqOp = relop (==) ++ litEq op_name True
151 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
153 primop_rule IntGtOp = relop (>)
154 primop_rule IntGeOp = relop (>=)
155 primop_rule IntLeOp = relop (<=)
156 primop_rule IntLtOp = relop (<)
158 primop_rule CharGtOp = relop (>)
159 primop_rule CharGeOp = relop (>=)
160 primop_rule CharLeOp = relop (<=)
161 primop_rule CharLtOp = relop (<)
163 primop_rule FloatGtOp = relop (>)
164 primop_rule FloatGeOp = relop (>=)
165 primop_rule FloatLeOp = relop (<=)
166 primop_rule FloatLtOp = relop (<)
167 primop_rule FloatEqOp = relop (==)
168 primop_rule FloatNeOp = relop (/=)
170 primop_rule DoubleGtOp = relop (>)
171 primop_rule DoubleGeOp = relop (>=)
172 primop_rule DoubleLeOp = relop (<=)
173 primop_rule DoubleLtOp = relop (<)
174 primop_rule DoubleEqOp = relop (==)
175 primop_rule DoubleNeOp = relop (/=)
177 primop_rule WordGtOp = relop (>)
178 primop_rule WordGeOp = relop (>=)
179 primop_rule WordLeOp = relop (<=)
180 primop_rule WordLtOp = relop (<)
181 primop_rule WordEqOp = relop (==)
182 primop_rule WordNeOp = relop (/=)
184 primop_rule other = []
189 %************************************************************************
191 \subsection{Doing the business}
193 %************************************************************************
195 ToDo: the reason these all return Nothing is because there used to be
196 the possibility of an argument being a litlit. Litlits are now gone,
197 so this could be cleaned up.
200 --------------------------
201 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
202 litCoerce fn lit = Just (Lit (fn lit))
204 --------------------------
205 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
209 done res | cmp res = Just trueVal
210 | otherwise = Just falseVal
212 -- These compares are at different types
213 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
214 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
215 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
216 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
217 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
218 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
219 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
222 --------------------------
224 negOp :: Literal -> Maybe CoreExpr -- Negate
225 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
226 negOp (MachFloat f) = Just (mkFloatVal (-f))
227 negOp (MachDouble 0.0) = Nothing
228 negOp (MachDouble d) = Just (mkDoubleVal (-d))
229 negOp (MachInt i) = intResult (-i)
232 --------------------------
233 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
234 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
235 intOp2 op l1 l2 = Nothing -- Could find LitLit
237 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
238 -- Like intOp2, but Nothing if i2=0
239 intOp2Z op (MachInt i1) (MachInt i2)
240 | i2 /= 0 = intResult (i1 `op` i2)
241 intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
243 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
244 -- Shifts take an Int; hence second arg of op is Int
245 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
246 intShiftOp2 op l1 l2 = Nothing
248 shiftRightLogical :: Integer -> Int -> Integer
249 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
250 -- Do this by converting to Word and back. Obviously this won't work for big
251 -- values, but its ok as we use it here
252 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
255 --------------------------
256 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
257 wordOp2 op (MachWord w1) (MachWord w2)
258 = wordResult (w1 `op` w2)
259 wordOp2 op l1 l2 = Nothing -- Could find LitLit
261 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
262 wordOp2Z op (MachWord w1) (MachWord w2)
263 | w2 /= 0 = wordResult (w1 `op` w2)
264 wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
266 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
267 = wordResult (w1 `op` w2)
268 wordBitOp2 op l1 l2 = Nothing -- Could find LitLit
270 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
271 -- Shifts take an Int; hence second arg of op is Int
272 wordShiftOp2 op (MachWord x) (MachInt n)
273 = wordResult (x `op` fromInteger n)
274 -- Do the shift at type Integer
275 wordShiftOp2 op l1 l2 = Nothing
277 --------------------------
278 floatOp2 op (MachFloat f1) (MachFloat f2)
279 = Just (mkFloatVal (f1 `op` f2))
280 floatOp2 op l1 l2 = Nothing
282 floatOp2Z op (MachFloat f1) (MachFloat f2)
283 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
284 floatOp2Z op l1 l2 = Nothing
286 --------------------------
287 doubleOp2 op (MachDouble f1) (MachDouble f2)
288 = Just (mkDoubleVal (f1 `op` f2))
289 doubleOp2 op l1 l2 = Nothing
291 doubleOp2Z op (MachDouble f1) (MachDouble f2)
292 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
293 doubleOp2Z op l1 l2 = Nothing
296 --------------------------
304 -- This is a Good Thing, because it allows case-of case things
305 -- to happen, and case-default absorption to happen. For
308 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
314 -- (modulo the usual precautions to avoid duplicating e1)
317 -> Bool -- True <=> equality, False <=> inequality
320 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
321 `appendFS` FSLIT("->case"),
323 ru_nargs = 2, ru_try = rule_fn }]
325 rule_fn [Lit lit, expr] = do_lit_eq lit expr
326 rule_fn [expr, Lit lit] = do_lit_eq lit expr
327 rule_fn other = Nothing
330 = Just (Case expr (mkWildId (literalType lit)) boolTy
331 [(DEFAULT, [], val_if_neq),
332 (LitAlt lit, [], val_if_eq)])
333 val_if_eq | is_eq = trueVal
334 | otherwise = falseVal
335 val_if_neq | is_eq = falseVal
336 | otherwise = trueVal
338 -- Note that we *don't* warn the user about overflow. It's not done at
339 -- runtime either, and compilation of completely harmless things like
340 -- ((124076834 :: Word32) + (2147483647 :: Word32))
341 -- would yield a warning. Instead we simply squash the value into the
342 -- Int range, but not in a way suitable for cross-compiling... :-(
343 intResult :: Integer -> Maybe CoreExpr
345 = Just (mkIntVal (toInteger (fromInteger result :: Int)))
347 wordResult :: Integer -> Maybe CoreExpr
349 = Just (mkWordVal (toInteger (fromInteger result :: Word)))
353 %************************************************************************
355 \subsection{Vaguely generic functions
357 %************************************************************************
360 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
361 -- Gives the Rule the same name as the primop itself
362 mkBasicRule op_name n_args rule_fn
363 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
365 ru_nargs = n_args, ru_try = rule_fn }]
367 oneLit :: Name -> (Literal -> Maybe CoreExpr)
370 = mkBasicRule op_name 1 rule_fn
372 rule_fn [Lit l1] = test (convFloating l1)
375 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
378 = mkBasicRule op_name 2 rule_fn
380 rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
383 -- When excess precision is not requested, cut down the precision of the
384 -- Rational value to that of Float/Double. We confuse host architecture
385 -- and target architecture here, but it's convenient (and wrong :-).
386 convFloating :: Literal -> Literal
387 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
388 MachFloat (toRational ((fromRational f) :: Float ))
389 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
390 MachDouble (toRational ((fromRational d) :: Double))
393 trueVal = Var trueDataConId
394 falseVal = Var falseDataConId
395 mkIntVal i = Lit (mkMachInt i)
396 mkWordVal w = Lit (mkMachWord w)
397 mkFloatVal f = Lit (convFloating (MachFloat f))
398 mkDoubleVal d = Lit (convFloating (MachDouble d))
402 %************************************************************************
404 \subsection{Special rules for seq, tagToEnum, dataToTag}
406 %************************************************************************
409 tagToEnumRule [Type ty, Lit (MachInt i)]
410 = ASSERT( isEnumerationTyCon tycon )
411 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
414 [] -> Nothing -- Abstract type
415 (dc:rest) -> ASSERT( null rest )
416 Just (Var (dataConWorkId dc))
418 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
420 tycon = tyConAppTyCon ty
422 tagToEnumRule other = Nothing
425 For dataToTag#, we can reduce if either
427 (a) the argument is a constructor
428 (b) the argument is a variable whose unfolding is a known constructor
431 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
432 | tag_to_enum `hasKey` tagToEnumKey
433 , ty1 `coreEqType` ty2
434 = Just tag -- dataToTag (tagToEnum x) ==> x
436 dataToTagRule [_, val_arg]
437 | Just (dc,_) <- exprIsConApp_maybe val_arg
438 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
439 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
441 dataToTagRule other = Nothing
444 %************************************************************************
446 \subsection{Built in rules}
448 %************************************************************************
451 builtinRules :: [CoreRule]
452 -- Rules for non-primops that can't be expressed using a RULE pragma
454 = [ BuiltinRule { ru_name = FSLIT("AppendLitString"), ru_fn = unpackCStringFoldrName,
455 ru_nargs = 4, ru_try = match_append_lit },
456 BuiltinRule { ru_name = FSLIT("EqString"), ru_fn = eqStringName,
457 ru_nargs = 2, ru_try = match_eq_string },
458 BuiltinRule { ru_name = FSLIT("Inline"), ru_fn = inlineIdName,
459 ru_nargs = 2, ru_try = match_inline }
463 ---------------------------------------------------
465 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
467 match_append_lit [Type ty1,
470 Var unpk `App` Type ty2
471 `App` Lit (MachStr s2)
475 | unpk `hasKey` unpackCStringFoldrIdKey &&
477 = ASSERT( ty1 `coreEqType` ty2 )
478 Just (Var unpk `App` Type ty1
479 `App` Lit (MachStr (s1 `appendFS` s2))
483 match_append_lit other = Nothing
485 ---------------------------------------------------
487 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
489 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
490 Var unpk2 `App` Lit (MachStr s2)]
491 | unpk1 `hasKey` unpackCStringIdKey,
492 unpk2 `hasKey` unpackCStringIdKey
493 = Just (if s1 == s2 then trueVal else falseVal)
495 match_eq_string other = Nothing
498 ---------------------------------------------------
500 -- inline f_ty (f a b c) = <f's unfolding> a b c
501 -- (if f has an unfolding)
503 -- It's important to allow the argument to 'inline' to have args itself
504 -- (a) because its more forgiving to allow the programmer to write
506 -- or inline (f a b c)
507 -- (b) because a polymorphic f wll get a type argument that the
508 -- programmer can't avoid
510 -- Also, don't forget about 'inline's type argument!
511 match_inline (Type _ : e : _)
512 | (Var f, args1) <- collectArgs e,
513 Just unf <- maybeUnfoldingTemplate (idUnfolding f)
514 = Just (mkApps unf args1)
516 match_inline other = Nothing