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 MkCore ( mkWildCase )
24 import Id ( realIdUnfolding )
25 import Literal ( Literal(..), mkMachInt, mkMachWord
27 , word2IntLit, int2WordLit
28 , narrow8IntLit, narrow16IntLit, narrow32IntLit
29 , narrow8WordLit, narrow16WordLit, narrow32WordLit
30 , char2IntLit, int2CharLit
31 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
32 , float2DoubleLit, double2FloatLit, litFitsInChar
34 import PrimOp ( PrimOp(..), tagToEnumKey )
35 import TysWiredIn ( boolTy, trueDataConId, falseDataConId )
36 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
37 import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
38 import CoreUtils ( cheapEqExpr )
39 import CoreUnfold ( exprIsConApp_maybe )
40 import Type ( tyConAppTyCon, coreEqType )
41 import OccName ( occNameFS )
42 import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
43 eqStringName, unpackCStringIdKey, inlineIdName )
44 import Maybes ( orElse )
45 import Name ( Name, nameOccName )
48 import StaticFlags ( opt_SimplExcessPrecision )
51 import Data.Bits as Bits
52 import Data.Word ( Word )
56 Note [Constant folding]
57 ~~~~~~~~~~~~~~~~~~~~~~~
58 primOpRules generates the rewrite rules for each primop
59 These rules do what is often called "constant folding"
60 E.g. the rules for +# might say
62 Well, of course you'd need a lot of rules if you did it
63 like that, so we use a BuiltinRule instead, so that we
64 can match in any two literal values. So the rule is really
66 (Lit 4) +# (Lit y) = Lit (x+#y)
67 where the (+#) on the rhs is done at compile time
69 That is why these rules are built in here. Other rules
70 which don't need to be built in are in GHC.Base. For
76 primOpRules :: PrimOp -> Name -> [CoreRule]
77 primOpRules op op_name = primop_rule op
80 one_lit = oneLit op_name
81 two_lits = twoLits op_name
82 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
83 -- Cunning. cmpOp compares the values to give an Ordering.
84 -- It applies its argument to that ordering value to turn
85 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
87 -- ToDo: something for integer-shift ops?
90 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
91 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
94 primop_rule IntAddOp = two_lits (intOp2 (+))
95 primop_rule IntSubOp = two_lits (intOp2 (-))
96 primop_rule IntMulOp = two_lits (intOp2 (*))
97 primop_rule IntQuotOp = two_lits (intOp2Z quot)
98 primop_rule IntRemOp = two_lits (intOp2Z rem)
99 primop_rule IntNegOp = one_lit negOp
100 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
101 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
102 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
105 primop_rule WordAddOp = two_lits (wordOp2 (+))
106 primop_rule WordSubOp = two_lits (wordOp2 (-))
107 primop_rule WordMulOp = two_lits (wordOp2 (*))
108 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
109 primop_rule WordRemOp = two_lits (wordOp2Z rem)
110 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
111 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
112 primop_rule XorOp = two_lits (wordBitOp2 xor)
113 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
114 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
117 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
118 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
119 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
120 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
121 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
122 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
123 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
124 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
125 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
126 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
127 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
128 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
129 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
130 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
131 -- SUP: Not sure what the standard says about precision in the following 2 cases
132 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
133 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
136 primop_rule FloatAddOp = two_lits (floatOp2 (+))
137 primop_rule FloatSubOp = two_lits (floatOp2 (-))
138 primop_rule FloatMulOp = two_lits (floatOp2 (*))
139 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
140 primop_rule FloatNegOp = one_lit negOp
143 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
144 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
145 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
146 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
147 primop_rule DoubleNegOp = one_lit negOp
149 -- Relational operators
150 primop_rule IntEqOp = relop (==) ++ litEq op_name True
151 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
152 primop_rule CharEqOp = relop (==) ++ litEq op_name True
153 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
155 primop_rule IntGtOp = relop (>)
156 primop_rule IntGeOp = relop (>=)
157 primop_rule IntLeOp = relop (<=)
158 primop_rule IntLtOp = relop (<)
160 primop_rule CharGtOp = relop (>)
161 primop_rule CharGeOp = relop (>=)
162 primop_rule CharLeOp = relop (<=)
163 primop_rule CharLtOp = relop (<)
165 primop_rule FloatGtOp = relop (>)
166 primop_rule FloatGeOp = relop (>=)
167 primop_rule FloatLeOp = relop (<=)
168 primop_rule FloatLtOp = relop (<)
169 primop_rule FloatEqOp = relop (==)
170 primop_rule FloatNeOp = relop (/=)
172 primop_rule DoubleGtOp = relop (>)
173 primop_rule DoubleGeOp = relop (>=)
174 primop_rule DoubleLeOp = relop (<=)
175 primop_rule DoubleLtOp = relop (<)
176 primop_rule DoubleEqOp = relop (==)
177 primop_rule DoubleNeOp = relop (/=)
179 primop_rule WordGtOp = relop (>)
180 primop_rule WordGeOp = relop (>=)
181 primop_rule WordLeOp = relop (<=)
182 primop_rule WordLtOp = relop (<)
183 primop_rule WordEqOp = relop (==)
184 primop_rule WordNeOp = relop (/=)
191 %************************************************************************
193 \subsection{Doing the business}
195 %************************************************************************
197 ToDo: the reason these all return Nothing is because there used to be
198 the possibility of an argument being a litlit. Litlits are now gone,
199 so this could be cleaned up.
202 --------------------------
203 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
204 litCoerce fn lit = Just (Lit (fn lit))
206 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
207 predLitCoerce p fn lit
208 | p lit = Just (Lit (fn lit))
209 | otherwise = Nothing
211 --------------------------
212 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
216 done res | cmp res = Just trueVal
217 | otherwise = Just falseVal
219 -- These compares are at different types
220 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
221 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
222 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
223 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
224 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
225 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
226 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
229 --------------------------
231 negOp :: Literal -> Maybe CoreExpr -- Negate
232 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
233 negOp (MachFloat f) = Just (mkFloatVal (-f))
234 negOp (MachDouble 0.0) = Nothing
235 negOp (MachDouble d) = Just (mkDoubleVal (-d))
236 negOp (MachInt i) = intResult (-i)
239 --------------------------
240 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
241 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
242 intOp2 _ _ _ = Nothing -- Could find LitLit
244 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
245 -- Like intOp2, but Nothing if i2=0
246 intOp2Z op (MachInt i1) (MachInt i2)
247 | i2 /= 0 = intResult (i1 `op` i2)
248 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
250 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
251 -- Shifts take an Int; hence second arg of op is Int
252 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
253 intShiftOp2 _ _ _ = Nothing
255 shiftRightLogical :: Integer -> Int -> Integer
256 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
257 -- Do this by converting to Word and back. Obviously this won't work for big
258 -- values, but its ok as we use it here
259 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
262 --------------------------
263 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
264 wordOp2 op (MachWord w1) (MachWord w2)
265 = wordResult (w1 `op` w2)
266 wordOp2 _ _ _ = Nothing -- Could find LitLit
268 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
269 wordOp2Z op (MachWord w1) (MachWord w2)
270 | w2 /= 0 = wordResult (w1 `op` w2)
271 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
273 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
275 wordBitOp2 op (MachWord w1) (MachWord w2)
276 = wordResult (w1 `op` w2)
277 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
279 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
280 -- Shifts take an Int; hence second arg of op is Int
281 wordShiftOp2 op (MachWord x) (MachInt n)
282 = wordResult (x `op` fromInteger n)
283 -- Do the shift at type Integer
284 wordShiftOp2 _ _ _ = Nothing
286 --------------------------
287 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
288 -> Maybe (Expr CoreBndr)
289 floatOp2 op (MachFloat f1) (MachFloat f2)
290 = Just (mkFloatVal (f1 `op` f2))
291 floatOp2 _ _ _ = Nothing
293 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
294 -> Maybe (Expr CoreBndr)
295 floatOp2Z op (MachFloat f1) (MachFloat f2)
296 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
297 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
298 = Just (mkFloatVal (f1 `op` f2))
299 floatOp2Z _ _ _ = Nothing
301 --------------------------
302 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
303 -> Maybe (Expr CoreBndr)
304 doubleOp2 op (MachDouble f1) (MachDouble f2)
305 = Just (mkDoubleVal (f1 `op` f2))
306 doubleOp2 _ _ _ = Nothing
308 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
309 -> Maybe (Expr CoreBndr)
310 doubleOp2Z op (MachDouble f1) (MachDouble f2)
311 | (f1 /= 0 || f2 > 0) -- see Note [negative zero]
312 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
313 = Just (mkDoubleVal (f1 `op` f2))
314 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
315 -- zero, but we might want to preserve the negative zero here which
316 -- is representable in Float/Double but not in (normalised)
317 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
318 doubleOp2Z _ _ _ = Nothing
321 --------------------------
329 -- This is a Good Thing, because it allows case-of case things
330 -- to happen, and case-default absorption to happen. For
333 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
339 -- (modulo the usual precautions to avoid duplicating e1)
342 -> Bool -- True <=> equality, False <=> inequality
345 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
346 `appendFS` (fsLit "->case"),
348 ru_nargs = 2, ru_try = rule_fn }]
350 rule_fn _ [Lit lit, expr] = do_lit_eq lit expr
351 rule_fn _ [expr, Lit lit] = do_lit_eq lit expr
352 rule_fn _ _ = Nothing
355 = Just (mkWildCase expr (literalType lit) boolTy
356 [(DEFAULT, [], val_if_neq),
357 (LitAlt lit, [], val_if_eq)])
358 val_if_eq | is_eq = trueVal
359 | otherwise = falseVal
360 val_if_neq | is_eq = falseVal
361 | otherwise = trueVal
363 -- Note that we *don't* warn the user about overflow. It's not done at
364 -- runtime either, and compilation of completely harmless things like
365 -- ((124076834 :: Word32) + (2147483647 :: Word32))
366 -- would yield a warning. Instead we simply squash the value into the
367 -- *target* Int/Word range.
368 intResult :: Integer -> Maybe CoreExpr
370 = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
372 wordResult :: Integer -> Maybe CoreExpr
374 = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
378 %************************************************************************
380 \subsection{Vaguely generic functions
382 %************************************************************************
385 mkBasicRule :: Name -> Int
386 -> (IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr)
388 -- Gives the Rule the same name as the primop itself
389 mkBasicRule op_name n_args rule_fn
390 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
392 ru_nargs = n_args, ru_try = rule_fn }]
394 oneLit :: Name -> (Literal -> Maybe CoreExpr)
397 = mkBasicRule op_name 1 rule_fn
399 rule_fn _ [Lit l1] = test (convFloating l1)
400 rule_fn _ _ = Nothing
402 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
405 = mkBasicRule op_name 2 rule_fn
407 rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
408 rule_fn _ _ = Nothing
410 -- When excess precision is not requested, cut down the precision of the
411 -- Rational value to that of Float/Double. We confuse host architecture
412 -- and target architecture here, but it's convenient (and wrong :-).
413 convFloating :: Literal -> Literal
414 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
415 MachFloat (toRational ((fromRational f) :: Float ))
416 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
417 MachDouble (toRational ((fromRational d) :: Double))
420 trueVal, falseVal :: Expr CoreBndr
421 trueVal = Var trueDataConId
422 falseVal = Var falseDataConId
423 mkIntVal :: Integer -> Expr CoreBndr
424 mkIntVal i = Lit (mkMachInt i)
425 mkWordVal :: Integer -> Expr CoreBndr
426 mkWordVal w = Lit (mkMachWord w)
427 mkFloatVal :: Rational -> Expr CoreBndr
428 mkFloatVal f = Lit (convFloating (MachFloat f))
429 mkDoubleVal :: Rational -> Expr CoreBndr
430 mkDoubleVal d = Lit (convFloating (MachDouble d))
434 %************************************************************************
436 \subsection{Special rules for seq, tagToEnum, dataToTag}
438 %************************************************************************
441 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
442 tagToEnumRule _ [Type ty, Lit (MachInt i)]
443 = ASSERT( isEnumerationTyCon tycon )
444 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
447 [] -> Nothing -- Abstract type
448 (dc:rest) -> ASSERT( null rest )
449 Just (Var (dataConWorkId dc))
451 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
453 tycon = tyConAppTyCon ty
455 tagToEnumRule _ _ = Nothing
458 For dataToTag#, we can reduce if either
460 (a) the argument is a constructor
461 (b) the argument is a variable whose unfolding is a known constructor
464 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
465 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
466 | tag_to_enum `hasKey` tagToEnumKey
467 , ty1 `coreEqType` ty2
468 = Just tag -- dataToTag (tagToEnum x) ==> x
470 dataToTagRule id_unf [_, val_arg]
471 | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg
472 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
473 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
475 dataToTagRule _ _ = Nothing
478 %************************************************************************
480 \subsection{Built in rules}
482 %************************************************************************
484 Note [Scoping for Builtin rules]
485 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
486 When compiling a (base-package) module that defines one of the
487 functions mentioned in the RHS of a built-in rule, there's a danger
490 f = ...(eq String x)....
492 ....and lower down...
496 Then a rewrite would give
498 f = ...(eqString x)...
499 ....and lower down...
502 and lo, eqString is not in scope. This only really matters when we get to code
503 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
504 set of bindings, which sorts out the dependency. Without -O we don't do any rule
505 rewriting so again we are fine.
507 (This whole thing doesn't show up for non-built-in rules because their dependencies
512 builtinRules :: [CoreRule]
513 -- Rules for non-primops that can't be expressed using a RULE pragma
515 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
516 ru_nargs = 4, ru_try = match_append_lit },
517 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
518 ru_nargs = 2, ru_try = match_eq_string },
519 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
520 ru_nargs = 2, ru_try = match_inline }
524 ---------------------------------------------------
526 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
528 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
529 match_append_lit _ [Type ty1,
532 Var unpk `App` Type ty2
533 `App` Lit (MachStr s2)
537 | unpk `hasKey` unpackCStringFoldrIdKey &&
539 = ASSERT( ty1 `coreEqType` ty2 )
540 Just (Var unpk `App` Type ty1
541 `App` Lit (MachStr (s1 `appendFS` s2))
545 match_append_lit _ _ = Nothing
547 ---------------------------------------------------
549 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
551 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
552 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
553 Var unpk2 `App` Lit (MachStr s2)]
554 | unpk1 `hasKey` unpackCStringIdKey,
555 unpk2 `hasKey` unpackCStringIdKey
556 = Just (if s1 == s2 then trueVal else falseVal)
558 match_eq_string _ _ = Nothing
561 ---------------------------------------------------
563 -- inline f_ty (f a b c) = <f's unfolding> a b c
564 -- (if f has an unfolding, EVEN if it's a loop breaker)
566 -- It's important to allow the argument to 'inline' to have args itself
567 -- (a) because its more forgiving to allow the programmer to write
569 -- or inline (f a b c)
570 -- (b) because a polymorphic f wll get a type argument that the
571 -- programmer can't avoid
573 -- Also, don't forget about 'inline's type argument!
574 match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
575 match_inline _ (Type _ : e : _)
576 | (Var f, args1) <- collectArgs e,
577 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
578 -- Ignore the IdUnfoldingFun here!
579 = Just (mkApps unf args1)
581 match_inline _ _ = Nothing