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.
15 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
17 module PrelRules ( primOpRules, builtinRules ) where
19 #include "HsVersions.h"
25 import PrimOp ( PrimOp(..), tagToEnumKey )
27 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
28 import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
29 import CoreUtils ( cheapEqExpr )
30 import CoreUnfold ( exprIsConApp_maybe )
32 import OccName ( occNameFS )
34 import Maybes ( orElse )
35 import Name ( Name, nameOccName )
38 import StaticFlags ( opt_SimplExcessPrecision )
41 import Data.Bits as Bits
42 import Data.Word ( Word )
46 Note [Constant folding]
47 ~~~~~~~~~~~~~~~~~~~~~~~
48 primOpRules generates the rewrite rules for each primop
49 These rules do what is often called "constant folding"
50 E.g. the rules for +# might say
52 Well, of course you'd need a lot of rules if you did it
53 like that, so we use a BuiltinRule instead, so that we
54 can match in any two literal values. So the rule is really
56 (Lit 4) +# (Lit y) = Lit (x+#y)
57 where the (+#) on the rhs is done at compile time
59 That is why these rules are built in here. Other rules
60 which don't need to be built in are in GHC.Base. For
66 primOpRules :: PrimOp -> Name -> [CoreRule]
67 primOpRules op op_name = primop_rule op
70 one_lit = oneLit op_name
71 two_lits = twoLits op_name
72 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
73 -- Cunning. cmpOp compares the values to give an Ordering.
74 -- It applies its argument to that ordering value to turn
75 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
77 -- ToDo: something for integer-shift ops?
80 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
81 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
84 primop_rule IntAddOp = two_lits (intOp2 (+))
85 primop_rule IntSubOp = two_lits (intOp2 (-))
86 primop_rule IntMulOp = two_lits (intOp2 (*))
87 primop_rule IntQuotOp = two_lits (intOp2Z quot)
88 primop_rule IntRemOp = two_lits (intOp2Z rem)
89 primop_rule IntNegOp = one_lit negOp
90 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
91 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
92 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
95 primop_rule WordAddOp = two_lits (wordOp2 (+))
96 primop_rule WordSubOp = two_lits (wordOp2 (-))
97 primop_rule WordMulOp = two_lits (wordOp2 (*))
98 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
99 primop_rule WordRemOp = two_lits (wordOp2Z rem)
100 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
101 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
102 primop_rule XorOp = two_lits (wordBitOp2 xor)
103 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
104 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
107 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
108 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
109 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
110 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
111 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
112 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
113 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
114 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
115 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
116 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
117 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
118 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
119 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
120 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
121 -- SUP: Not sure what the standard says about precision in the following 2 cases
122 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
123 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
126 primop_rule FloatAddOp = two_lits (floatOp2 (+))
127 primop_rule FloatSubOp = two_lits (floatOp2 (-))
128 primop_rule FloatMulOp = two_lits (floatOp2 (*))
129 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
130 primop_rule FloatNegOp = one_lit negOp
133 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
134 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
135 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
136 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
137 primop_rule DoubleNegOp = one_lit negOp
139 -- Relational operators
140 primop_rule IntEqOp = relop (==) ++ litEq op_name True
141 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
142 primop_rule CharEqOp = relop (==) ++ litEq op_name True
143 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
145 primop_rule IntGtOp = relop (>)
146 primop_rule IntGeOp = relop (>=)
147 primop_rule IntLeOp = relop (<=)
148 primop_rule IntLtOp = relop (<)
150 primop_rule CharGtOp = relop (>)
151 primop_rule CharGeOp = relop (>=)
152 primop_rule CharLeOp = relop (<=)
153 primop_rule CharLtOp = relop (<)
155 primop_rule FloatGtOp = relop (>)
156 primop_rule FloatGeOp = relop (>=)
157 primop_rule FloatLeOp = relop (<=)
158 primop_rule FloatLtOp = relop (<)
159 primop_rule FloatEqOp = relop (==)
160 primop_rule FloatNeOp = relop (/=)
162 primop_rule DoubleGtOp = relop (>)
163 primop_rule DoubleGeOp = relop (>=)
164 primop_rule DoubleLeOp = relop (<=)
165 primop_rule DoubleLtOp = relop (<)
166 primop_rule DoubleEqOp = relop (==)
167 primop_rule DoubleNeOp = relop (/=)
169 primop_rule WordGtOp = relop (>)
170 primop_rule WordGeOp = relop (>=)
171 primop_rule WordLeOp = relop (<=)
172 primop_rule WordLtOp = relop (<)
173 primop_rule WordEqOp = relop (==)
174 primop_rule WordNeOp = relop (/=)
181 %************************************************************************
183 \subsection{Doing the business}
185 %************************************************************************
187 ToDo: the reason these all return Nothing is because there used to be
188 the possibility of an argument being a litlit. Litlits are now gone,
189 so this could be cleaned up.
192 --------------------------
193 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
194 litCoerce fn lit = Just (Lit (fn lit))
196 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
197 predLitCoerce p fn lit
198 | p lit = Just (Lit (fn lit))
199 | otherwise = Nothing
201 --------------------------
202 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
206 done res | cmp res = Just trueVal
207 | otherwise = Just falseVal
209 -- These compares are at different types
210 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
211 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
212 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
213 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
214 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
215 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
216 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
219 --------------------------
221 negOp :: Literal -> Maybe CoreExpr -- Negate
222 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
223 negOp (MachFloat f) = Just (mkFloatVal (-f))
224 negOp (MachDouble 0.0) = Nothing
225 negOp (MachDouble d) = Just (mkDoubleVal (-d))
226 negOp (MachInt i) = intResult (-i)
229 --------------------------
230 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
231 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
232 intOp2 _ _ _ = Nothing -- Could find LitLit
234 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
235 -- Like intOp2, but Nothing if i2=0
236 intOp2Z op (MachInt i1) (MachInt i2)
237 | i2 /= 0 = intResult (i1 `op` i2)
238 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
240 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
241 -- Shifts take an Int; hence second arg of op is Int
242 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
243 intShiftOp2 _ _ _ = Nothing
245 shiftRightLogical :: Integer -> Int -> Integer
246 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
247 -- Do this by converting to Word and back. Obviously this won't work for big
248 -- values, but its ok as we use it here
249 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
252 --------------------------
253 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
254 wordOp2 op (MachWord w1) (MachWord w2)
255 = wordResult (w1 `op` w2)
256 wordOp2 _ _ _ = Nothing -- Could find LitLit
258 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
259 wordOp2Z op (MachWord w1) (MachWord w2)
260 | w2 /= 0 = wordResult (w1 `op` w2)
261 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
263 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
265 wordBitOp2 op (MachWord w1) (MachWord w2)
266 = wordResult (w1 `op` w2)
267 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
269 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
270 -- Shifts take an Int; hence second arg of op is Int
271 wordShiftOp2 op (MachWord x) (MachInt n)
272 = wordResult (x `op` fromInteger n)
273 -- Do the shift at type Integer
274 wordShiftOp2 _ _ _ = Nothing
276 --------------------------
277 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
278 -> Maybe (Expr CoreBndr)
279 floatOp2 op (MachFloat f1) (MachFloat f2)
280 = Just (mkFloatVal (f1 `op` f2))
281 floatOp2 _ _ _ = Nothing
283 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
284 -> Maybe (Expr CoreBndr)
285 floatOp2Z op (MachFloat f1) (MachFloat f2)
286 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
287 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
288 = Just (mkFloatVal (f1 `op` f2))
289 floatOp2Z _ _ _ = Nothing
291 --------------------------
292 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
293 -> Maybe (Expr CoreBndr)
294 doubleOp2 op (MachDouble f1) (MachDouble f2)
295 = Just (mkDoubleVal (f1 `op` f2))
296 doubleOp2 _ _ _ = Nothing
298 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
299 -> Maybe (Expr CoreBndr)
300 doubleOp2Z op (MachDouble f1) (MachDouble f2)
301 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
302 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
303 = Just (mkDoubleVal (f1 `op` f2))
304 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
305 -- zero, but we might want to preserve the negative zero here which
306 -- is representable in Float/Double but not in (normalised)
307 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
308 doubleOp2Z _ _ _ = Nothing
311 --------------------------
319 -- This is a Good Thing, because it allows case-of case things
320 -- to happen, and case-default absorption to happen. For
323 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
329 -- (modulo the usual precautions to avoid duplicating e1)
332 -> Bool -- True <=> equality, False <=> inequality
335 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
336 `appendFS` (fsLit "->case"),
338 ru_nargs = 2, ru_try = rule_fn }]
340 rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
341 rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
342 rule_fn _ _ = Nothing
345 = Just (mkWildCase expr (literalType lit) boolTy
346 [(DEFAULT, [], val_if_neq),
347 (LitAlt lit, [], val_if_eq)])
348 val_if_eq | is_eq = trueVal
349 | otherwise = falseVal
350 val_if_neq | is_eq = falseVal
351 | otherwise = trueVal
353 -- Note that we *don't* warn the user about overflow. It's not done at
354 -- runtime either, and compilation of completely harmless things like
355 -- ((124076834 :: Word32) + (2147483647 :: Word32))
356 -- would yield a warning. Instead we simply squash the value into the
357 -- *target* Int/Word range.
358 intResult :: Integer -> Maybe CoreExpr
360 = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
362 wordResult :: Integer -> Maybe CoreExpr
364 = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
368 %************************************************************************
370 \subsection{Vaguely generic functions
372 %************************************************************************
375 mkBasicRule :: Name -> Int
376 -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
378 -- Gives the Rule the same name as the primop itself
379 mkBasicRule op_name n_args rule_fn
380 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
382 ru_nargs = n_args, ru_try = rule_fn }]
384 oneLit :: Name -> (Literal -> Maybe CoreExpr)
387 = mkBasicRule op_name 1 rule_fn
389 rule_fn _ [Lit l1] = test (convFloating l1)
390 rule_fn _ _ = Nothing
392 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
395 = mkBasicRule op_name 2 rule_fn
397 rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
398 rule_fn _ _ = Nothing
400 -- When excess precision is not requested, cut down the precision of the
401 -- Rational value to that of Float/Double. We confuse host architecture
402 -- and target architecture here, but it's convenient (and wrong :-).
403 convFloating :: Literal -> Literal
404 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
405 MachFloat (toRational ((fromRational f) :: Float ))
406 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
407 MachDouble (toRational ((fromRational d) :: Double))
410 trueVal, falseVal :: Expr CoreBndr
411 trueVal = Var trueDataConId
412 falseVal = Var falseDataConId
413 mkIntVal :: Integer -> Expr CoreBndr
414 mkIntVal i = Lit (mkMachInt i)
415 mkWordVal :: Integer -> Expr CoreBndr
416 mkWordVal w = Lit (mkMachWord w)
417 mkFloatVal :: Rational -> Expr CoreBndr
418 mkFloatVal f = Lit (convFloating (MachFloat f))
419 mkDoubleVal :: Rational -> Expr CoreBndr
420 mkDoubleVal d = Lit (convFloating (MachDouble d))
424 %************************************************************************
426 \subsection{Special rules for seq, tagToEnum, dataToTag}
428 %************************************************************************
432 Nasty check to ensure that tagToEnum# is applied to a type that is an
433 enumeration TyCon. Unification may refine the type later, but this
434 check won't see that, alas. It's crude but it works.
436 Here's are two cases that should fail
438 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
441 g = tagToEnum# 0 -- Int is not an enumeration
443 We used to make this check in the type inference engine, but it's quite
444 ugly to do so, because the delayed constraint solving means that we don't
445 really know what's going on until the end. It's very much a corner case
446 because we don't expect the user to call tagToEnum# at all; we merely
447 generate calls in derived instances of Enum. So we compromise: a
448 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
452 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
453 -- If data T a = A | B | C
454 -- then tag2Enum# (T ty) 2# --> B ty
455 tagToEnumRule _ [Type ty, Lit (MachInt i)]
456 | Just (tycon, tc_args) <- splitTyConApp_maybe ty
457 , isEnumerationTyCon tycon
458 = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
459 [] -> Nothing -- Abstract type
460 (dc:rest) -> ASSERT( null rest )
461 Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
462 | otherwise -- See Note [tagToEnum#]
463 = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
464 Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
466 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
469 tagToEnumRule _ _ = Nothing
473 For dataToTag#, we can reduce if either
475 (a) the argument is a constructor
476 (b) the argument is a variable whose unfolding is a known constructor
479 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
480 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
481 | tag_to_enum `hasKey` tagToEnumKey
482 , ty1 `coreEqType` ty2
483 = Just tag -- dataToTag (tagToEnum x) ==> x
485 dataToTagRule id_unf [_, val_arg]
486 | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
487 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
488 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
490 dataToTagRule _ _ = Nothing
493 %************************************************************************
495 \subsection{Built in rules}
497 %************************************************************************
499 Note [Scoping for Builtin rules]
500 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 When compiling a (base-package) module that defines one of the
502 functions mentioned in the RHS of a built-in rule, there's a danger
505 f = ...(eq String x)....
507 ....and lower down...
511 Then a rewrite would give
513 f = ...(eqString x)...
514 ....and lower down...
517 and lo, eqString is not in scope. This only really matters when we get to code
518 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
519 set of bindings, which sorts out the dependency. Without -O we don't do any rule
520 rewriting so again we are fine.
522 (This whole thing doesn't show up for non-built-in rules because their dependencies
527 builtinRules :: [CoreRule]
528 -- Rules for non-primops that can't be expressed using a RULE pragma
530 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
531 ru_nargs = 4, ru_try = match_append_lit },
532 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
533 ru_nargs = 2, ru_try = match_eq_string },
534 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
535 ru_nargs = 2, ru_try = match_inline }
539 ---------------------------------------------------
541 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
542 -- = unpackFoldrCString# "foobaz" c n
544 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
545 match_append_lit _ [Type ty1,
548 Var unpk `App` Type ty2
549 `App` Lit (MachStr s2)
553 | unpk `hasKey` unpackCStringFoldrIdKey &&
555 = ASSERT( ty1 `coreEqType` ty2 )
556 Just (Var unpk `App` Type ty1
557 `App` Lit (MachStr (s1 `appendFS` s2))
561 match_append_lit _ _ = Nothing
563 ---------------------------------------------------
565 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
567 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
568 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
569 Var unpk2 `App` Lit (MachStr s2)]
570 | unpk1 `hasKey` unpackCStringIdKey,
571 unpk2 `hasKey` unpackCStringIdKey
572 = Just (if s1 == s2 then trueVal else falseVal)
574 match_eq_string _ _ = Nothing
577 ---------------------------------------------------
579 -- inline f_ty (f a b c) = <f's unfolding> a b c
580 -- (if f has an unfolding, EVEN if it's a loop breaker)
582 -- It's important to allow the argument to 'inline' to have args itself
583 -- (a) because its more forgiving to allow the programmer to write
585 -- or inline (f a b c)
586 -- (b) because a polymorphic f wll get a type argument that the
587 -- programmer can't avoid
589 -- Also, don't forget about 'inline's type argument!
590 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
591 match_inline _ (Type _ : e : _)
592 | (Var f, args1) <- collectArgs e,
593 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
594 -- Ignore the IdUnfoldingFun here!
595 = Just (mkApps unf args1)
597 match_inline _ _ = Nothing