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 ( idUnfolding )
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, exprIsConApp_maybe )
39 import Type ( tyConAppTyCon, coreEqType )
40 import OccName ( occNameFS )
41 import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
42 eqStringName, unpackCStringIdKey, inlineIdName )
43 import Maybes ( orElse )
44 import Name ( Name, nameOccName )
47 import StaticFlags ( opt_SimplExcessPrecision )
50 import Data.Bits as Bits
51 import Data.Word ( Word )
55 Note [Constant folding]
56 ~~~~~~~~~~~~~~~~~~~~~~~
57 primOpRules generates the rewrite rules for each primop
58 These rules do what is often called "constant folding"
59 E.g. the rules for +# might say
61 Well, of course you'd need a lot of rules if you did it
62 like that, so we use a BuiltinRule instead, so that we
63 can match in any two literal values. So the rule is really
65 (Lit 4) +# (Lit y) = Lit (x+#y)
66 where the (+#) on the rhs is done at compile time
68 That is why these rules are built in here. Other rules
69 which don't need to be built in are in GHC.Base. For
75 primOpRules :: PrimOp -> Name -> [CoreRule]
76 primOpRules op op_name = primop_rule op
79 one_lit = oneLit op_name
80 two_lits = twoLits op_name
81 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
82 -- Cunning. cmpOp compares the values to give an Ordering.
83 -- It applies its argument to that ordering value to turn
84 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
86 -- ToDo: something for integer-shift ops?
89 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
90 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
93 primop_rule IntAddOp = two_lits (intOp2 (+))
94 primop_rule IntSubOp = two_lits (intOp2 (-))
95 primop_rule IntMulOp = two_lits (intOp2 (*))
96 primop_rule IntQuotOp = two_lits (intOp2Z quot)
97 primop_rule IntRemOp = two_lits (intOp2Z rem)
98 primop_rule IntNegOp = one_lit negOp
99 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
100 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
101 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
104 primop_rule WordAddOp = two_lits (wordOp2 (+))
105 primop_rule WordSubOp = two_lits (wordOp2 (-))
106 primop_rule WordMulOp = two_lits (wordOp2 (*))
107 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
108 primop_rule WordRemOp = two_lits (wordOp2Z rem)
109 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
110 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
111 primop_rule XorOp = two_lits (wordBitOp2 xor)
112 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
113 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
116 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
117 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
118 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
119 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
120 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
121 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
122 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
123 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
124 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
125 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
126 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
127 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
128 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
129 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
130 -- SUP: Not sure what the standard says about precision in the following 2 cases
131 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
132 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
135 primop_rule FloatAddOp = two_lits (floatOp2 (+))
136 primop_rule FloatSubOp = two_lits (floatOp2 (-))
137 primop_rule FloatMulOp = two_lits (floatOp2 (*))
138 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
139 primop_rule FloatNegOp = one_lit negOp
142 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
143 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
144 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
145 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
146 primop_rule DoubleNegOp = one_lit negOp
148 -- Relational operators
149 primop_rule IntEqOp = relop (==) ++ litEq op_name True
150 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
151 primop_rule CharEqOp = relop (==) ++ litEq op_name True
152 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
154 primop_rule IntGtOp = relop (>)
155 primop_rule IntGeOp = relop (>=)
156 primop_rule IntLeOp = relop (<=)
157 primop_rule IntLtOp = relop (<)
159 primop_rule CharGtOp = relop (>)
160 primop_rule CharGeOp = relop (>=)
161 primop_rule CharLeOp = relop (<=)
162 primop_rule CharLtOp = relop (<)
164 primop_rule FloatGtOp = relop (>)
165 primop_rule FloatGeOp = relop (>=)
166 primop_rule FloatLeOp = relop (<=)
167 primop_rule FloatLtOp = relop (<)
168 primop_rule FloatEqOp = relop (==)
169 primop_rule FloatNeOp = relop (/=)
171 primop_rule DoubleGtOp = relop (>)
172 primop_rule DoubleGeOp = relop (>=)
173 primop_rule DoubleLeOp = relop (<=)
174 primop_rule DoubleLtOp = relop (<)
175 primop_rule DoubleEqOp = relop (==)
176 primop_rule DoubleNeOp = relop (/=)
178 primop_rule WordGtOp = relop (>)
179 primop_rule WordGeOp = relop (>=)
180 primop_rule WordLeOp = relop (<=)
181 primop_rule WordLtOp = relop (<)
182 primop_rule WordEqOp = relop (==)
183 primop_rule WordNeOp = relop (/=)
190 %************************************************************************
192 \subsection{Doing the business}
194 %************************************************************************
196 ToDo: the reason these all return Nothing is because there used to be
197 the possibility of an argument being a litlit. Litlits are now gone,
198 so this could be cleaned up.
201 --------------------------
202 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
203 litCoerce fn lit = Just (Lit (fn lit))
205 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
206 predLitCoerce p fn lit
207 | p lit = Just (Lit (fn lit))
208 | otherwise = Nothing
210 --------------------------
211 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
215 done res | cmp res = Just trueVal
216 | otherwise = Just falseVal
218 -- These compares are at different types
219 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
220 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
221 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
222 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
223 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
224 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
225 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
228 --------------------------
230 negOp :: Literal -> Maybe CoreExpr -- Negate
231 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
232 negOp (MachFloat f) = Just (mkFloatVal (-f))
233 negOp (MachDouble 0.0) = Nothing
234 negOp (MachDouble d) = Just (mkDoubleVal (-d))
235 negOp (MachInt i) = intResult (-i)
238 --------------------------
239 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
240 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
241 intOp2 _ _ _ = Nothing -- Could find LitLit
243 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
244 -- Like intOp2, but Nothing if i2=0
245 intOp2Z op (MachInt i1) (MachInt i2)
246 | i2 /= 0 = intResult (i1 `op` i2)
247 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
249 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
250 -- Shifts take an Int; hence second arg of op is Int
251 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
252 intShiftOp2 _ _ _ = Nothing
254 shiftRightLogical :: Integer -> Int -> Integer
255 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
256 -- Do this by converting to Word and back. Obviously this won't work for big
257 -- values, but its ok as we use it here
258 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
261 --------------------------
262 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
263 wordOp2 op (MachWord w1) (MachWord w2)
264 = wordResult (w1 `op` w2)
265 wordOp2 _ _ _ = Nothing -- Could find LitLit
267 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
268 wordOp2Z op (MachWord w1) (MachWord w2)
269 | w2 /= 0 = wordResult (w1 `op` w2)
270 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
272 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
274 wordBitOp2 op (MachWord w1) (MachWord w2)
275 = wordResult (w1 `op` w2)
276 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
278 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
279 -- Shifts take an Int; hence second arg of op is Int
280 wordShiftOp2 op (MachWord x) (MachInt n)
281 = wordResult (x `op` fromInteger n)
282 -- Do the shift at type Integer
283 wordShiftOp2 _ _ _ = Nothing
285 --------------------------
286 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
287 -> Maybe (Expr CoreBndr)
288 floatOp2 op (MachFloat f1) (MachFloat f2)
289 = Just (mkFloatVal (f1 `op` f2))
290 floatOp2 _ _ _ = Nothing
292 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
293 -> Maybe (Expr CoreBndr)
294 floatOp2Z op (MachFloat f1) (MachFloat f2)
295 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
296 floatOp2Z _ _ _ = Nothing
298 --------------------------
299 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
300 -> Maybe (Expr CoreBndr)
301 doubleOp2 op (MachDouble f1) (MachDouble f2)
302 = Just (mkDoubleVal (f1 `op` f2))
303 doubleOp2 _ _ _ = Nothing
305 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
306 -> Maybe (Expr CoreBndr)
307 doubleOp2Z op (MachDouble f1) (MachDouble f2)
308 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
309 doubleOp2Z _ _ _ = Nothing
312 --------------------------
320 -- This is a Good Thing, because it allows case-of case things
321 -- to happen, and case-default absorption to happen. For
324 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
330 -- (modulo the usual precautions to avoid duplicating e1)
333 -> Bool -- True <=> equality, False <=> inequality
336 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
337 `appendFS` (fsLit "->case"),
339 ru_nargs = 2, ru_try = rule_fn }]
341 rule_fn [Lit lit, expr] = do_lit_eq lit expr
342 rule_fn [expr, Lit lit] = do_lit_eq lit expr
346 = Just (mkWildCase expr (literalType lit) boolTy
347 [(DEFAULT, [], val_if_neq),
348 (LitAlt lit, [], val_if_eq)])
349 val_if_eq | is_eq = trueVal
350 | otherwise = falseVal
351 val_if_neq | is_eq = falseVal
352 | otherwise = trueVal
354 -- Note that we *don't* warn the user about overflow. It's not done at
355 -- runtime either, and compilation of completely harmless things like
356 -- ((124076834 :: Word32) + (2147483647 :: Word32))
357 -- would yield a warning. Instead we simply squash the value into the
358 -- *target* Int/Word range.
359 intResult :: Integer -> Maybe CoreExpr
361 = Just (mkIntVal (toInteger (fromInteger result :: TargetInt)))
363 wordResult :: Integer -> Maybe CoreExpr
365 = Just (mkWordVal (toInteger (fromInteger result :: TargetWord)))
369 %************************************************************************
371 \subsection{Vaguely generic functions
373 %************************************************************************
376 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
377 -- Gives the Rule the same name as the primop itself
378 mkBasicRule op_name n_args rule_fn
379 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
381 ru_nargs = n_args, ru_try = rule_fn }]
383 oneLit :: Name -> (Literal -> Maybe CoreExpr)
386 = mkBasicRule op_name 1 rule_fn
388 rule_fn [Lit l1] = test (convFloating l1)
391 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
394 = mkBasicRule op_name 2 rule_fn
396 rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
399 -- When excess precision is not requested, cut down the precision of the
400 -- Rational value to that of Float/Double. We confuse host architecture
401 -- and target architecture here, but it's convenient (and wrong :-).
402 convFloating :: Literal -> Literal
403 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
404 MachFloat (toRational ((fromRational f) :: Float ))
405 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
406 MachDouble (toRational ((fromRational d) :: Double))
409 trueVal, falseVal :: Expr CoreBndr
410 trueVal = Var trueDataConId
411 falseVal = Var falseDataConId
412 mkIntVal :: Integer -> Expr CoreBndr
413 mkIntVal i = Lit (mkMachInt i)
414 mkWordVal :: Integer -> Expr CoreBndr
415 mkWordVal w = Lit (mkMachWord w)
416 mkFloatVal :: Rational -> Expr CoreBndr
417 mkFloatVal f = Lit (convFloating (MachFloat f))
418 mkDoubleVal :: Rational -> Expr CoreBndr
419 mkDoubleVal d = Lit (convFloating (MachDouble d))
423 %************************************************************************
425 \subsection{Special rules for seq, tagToEnum, dataToTag}
427 %************************************************************************
430 tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
431 tagToEnumRule [Type ty, Lit (MachInt i)]
432 = ASSERT( isEnumerationTyCon tycon )
433 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
436 [] -> Nothing -- Abstract type
437 (dc:rest) -> ASSERT( null rest )
438 Just (Var (dataConWorkId dc))
440 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
442 tycon = tyConAppTyCon ty
444 tagToEnumRule _ = Nothing
447 For dataToTag#, we can reduce if either
449 (a) the argument is a constructor
450 (b) the argument is a variable whose unfolding is a known constructor
453 dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr)
454 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
455 | tag_to_enum `hasKey` tagToEnumKey
456 , ty1 `coreEqType` ty2
457 = Just tag -- dataToTag (tagToEnum x) ==> x
459 dataToTagRule [_, val_arg]
460 | Just (dc,_) <- exprIsConApp_maybe val_arg
461 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
462 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
464 dataToTagRule _ = Nothing
467 %************************************************************************
469 \subsection{Built in rules}
471 %************************************************************************
473 Note [Scoping for Builtin rules]
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
475 When compiling a (base-package) module that defines one of the
476 functions mentioned in the RHS of a built-in rule, there's a danger
479 f = ...(eq String x)....
481 ....and lower down...
485 Then a rewrite would give
487 f = ...(eqString x)...
488 ....and lower down...
491 and lo, eqString is not in scope. This only really matters when we get to code
492 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
493 set of bindings, which sorts out the dependency. Without -O we don't do any rule
494 rewriting so again we are fine.
496 (This whole thing doesn't show up for non-built-in rules because their dependencies
501 builtinRules :: [CoreRule]
502 -- Rules for non-primops that can't be expressed using a RULE pragma
504 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
505 ru_nargs = 4, ru_try = match_append_lit },
506 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
507 ru_nargs = 2, ru_try = match_eq_string },
508 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
509 ru_nargs = 2, ru_try = match_inline }
513 ---------------------------------------------------
515 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
517 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
518 match_append_lit [Type ty1,
521 Var unpk `App` Type ty2
522 `App` Lit (MachStr s2)
526 | unpk `hasKey` unpackCStringFoldrIdKey &&
528 = ASSERT( ty1 `coreEqType` ty2 )
529 Just (Var unpk `App` Type ty1
530 `App` Lit (MachStr (s1 `appendFS` s2))
534 match_append_lit _ = Nothing
536 ---------------------------------------------------
538 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
540 match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
541 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
542 Var unpk2 `App` Lit (MachStr s2)]
543 | unpk1 `hasKey` unpackCStringIdKey,
544 unpk2 `hasKey` unpackCStringIdKey
545 = Just (if s1 == s2 then trueVal else falseVal)
547 match_eq_string _ = Nothing
550 ---------------------------------------------------
552 -- inline f_ty (f a b c) = <f's unfolding> a b c
553 -- (if f has an unfolding)
555 -- It's important to allow the argument to 'inline' to have args itself
556 -- (a) because its more forgiving to allow the programmer to write
558 -- or inline (f a b c)
559 -- (b) because a polymorphic f wll get a type argument that the
560 -- programmer can't avoid
562 -- Also, don't forget about 'inline's type argument!
563 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
564 match_inline (Type _ : e : _)
565 | (Var f, args1) <- collectArgs e,
566 Just unf <- maybeUnfoldingTemplate (idUnfolding f)
567 = Just (mkApps unf args1)
569 match_inline _ = Nothing