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 )
48 import Data.Bits as Bits
49 import Data.Word ( Word )
53 Note [Constant folding]
54 ~~~~~~~~~~~~~~~~~~~~~~~
55 primOpRules generates the rewrite rules for each primop
56 These rules do what is often called "constant folding"
57 E.g. the rules for +# might say
59 Well, of course you'd need a lot of rules if you did it
60 like that, so we use a BuiltinRule instead, so that we
61 can match in any two literal values. So the rule is really
63 (Lit 4) +# (Lit y) = Lit (x+#y)
64 where the (+#) on the rhs is done at compile time
66 That is why these rules are built in here. Other rules
67 which don't need to be built in are in GHC.Base. For
73 primOpRules :: PrimOp -> Name -> [CoreRule]
74 primOpRules op op_name = primop_rule op
77 one_lit = oneLit op_name
78 two_lits = twoLits op_name
79 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
80 -- Cunning. cmpOp compares the values to give an Ordering.
81 -- It applies its argument to that ordering value to turn
82 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
84 -- ToDo: something for integer-shift ops?
87 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
88 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
91 primop_rule IntAddOp = two_lits (intOp2 (+))
92 primop_rule IntSubOp = two_lits (intOp2 (-))
93 primop_rule IntMulOp = two_lits (intOp2 (*))
94 primop_rule IntQuotOp = two_lits (intOp2Z quot)
95 primop_rule IntRemOp = two_lits (intOp2Z rem)
96 primop_rule IntNegOp = one_lit negOp
97 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
98 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
99 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
102 primop_rule WordAddOp = two_lits (wordOp2 (+))
103 primop_rule WordSubOp = two_lits (wordOp2 (-))
104 primop_rule WordMulOp = two_lits (wordOp2 (*))
105 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
106 primop_rule WordRemOp = two_lits (wordOp2Z rem)
107 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
108 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
109 primop_rule XorOp = two_lits (wordBitOp2 xor)
110 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
111 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
114 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
115 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
116 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
117 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
118 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
119 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
120 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
121 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
122 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
123 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
124 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
125 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
126 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
127 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
128 -- SUP: Not sure what the standard says about precision in the following 2 cases
129 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
130 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
133 primop_rule FloatAddOp = two_lits (floatOp2 (+))
134 primop_rule FloatSubOp = two_lits (floatOp2 (-))
135 primop_rule FloatMulOp = two_lits (floatOp2 (*))
136 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
137 primop_rule FloatNegOp = one_lit negOp
140 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
141 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
142 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
143 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
144 primop_rule DoubleNegOp = one_lit negOp
146 -- Relational operators
147 primop_rule IntEqOp = relop (==) ++ litEq op_name True
148 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
149 primop_rule CharEqOp = relop (==) ++ litEq op_name True
150 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
152 primop_rule IntGtOp = relop (>)
153 primop_rule IntGeOp = relop (>=)
154 primop_rule IntLeOp = relop (<=)
155 primop_rule IntLtOp = relop (<)
157 primop_rule CharGtOp = relop (>)
158 primop_rule CharGeOp = relop (>=)
159 primop_rule CharLeOp = relop (<=)
160 primop_rule CharLtOp = relop (<)
162 primop_rule FloatGtOp = relop (>)
163 primop_rule FloatGeOp = relop (>=)
164 primop_rule FloatLeOp = relop (<=)
165 primop_rule FloatLtOp = relop (<)
166 primop_rule FloatEqOp = relop (==)
167 primop_rule FloatNeOp = relop (/=)
169 primop_rule DoubleGtOp = relop (>)
170 primop_rule DoubleGeOp = relop (>=)
171 primop_rule DoubleLeOp = relop (<=)
172 primop_rule DoubleLtOp = relop (<)
173 primop_rule DoubleEqOp = relop (==)
174 primop_rule DoubleNeOp = relop (/=)
176 primop_rule WordGtOp = relop (>)
177 primop_rule WordGeOp = relop (>=)
178 primop_rule WordLeOp = relop (<=)
179 primop_rule WordLtOp = relop (<)
180 primop_rule WordEqOp = relop (==)
181 primop_rule WordNeOp = relop (/=)
188 %************************************************************************
190 \subsection{Doing the business}
192 %************************************************************************
194 ToDo: the reason these all return Nothing is because there used to be
195 the possibility of an argument being a litlit. Litlits are now gone,
196 so this could be cleaned up.
199 --------------------------
200 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
201 litCoerce fn lit = Just (Lit (fn lit))
203 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
204 predLitCoerce p fn lit
205 | p lit = Just (Lit (fn lit))
206 | otherwise = Nothing
208 --------------------------
209 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
213 done res | cmp res = Just trueVal
214 | otherwise = Just falseVal
216 -- These compares are at different types
217 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
218 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
219 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
220 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
221 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
222 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
223 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
226 --------------------------
228 negOp :: Literal -> Maybe CoreExpr -- Negate
229 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
230 negOp (MachFloat f) = Just (mkFloatVal (-f))
231 negOp (MachDouble 0.0) = Nothing
232 negOp (MachDouble d) = Just (mkDoubleVal (-d))
233 negOp (MachInt i) = intResult (-i)
236 --------------------------
237 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
238 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
239 intOp2 _ _ _ = Nothing -- Could find LitLit
241 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
242 -- Like intOp2, but Nothing if i2=0
243 intOp2Z op (MachInt i1) (MachInt i2)
244 | i2 /= 0 = intResult (i1 `op` i2)
245 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
247 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
248 -- Shifts take an Int; hence second arg of op is Int
249 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
250 intShiftOp2 _ _ _ = Nothing
252 shiftRightLogical :: Integer -> Int -> Integer
253 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
254 -- Do this by converting to Word and back. Obviously this won't work for big
255 -- values, but its ok as we use it here
256 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
259 --------------------------
260 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
261 wordOp2 op (MachWord w1) (MachWord w2)
262 = wordResult (w1 `op` w2)
263 wordOp2 _ _ _ = Nothing -- Could find LitLit
265 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
266 wordOp2Z op (MachWord w1) (MachWord w2)
267 | w2 /= 0 = wordResult (w1 `op` w2)
268 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
270 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
272 wordBitOp2 op (MachWord w1) (MachWord w2)
273 = wordResult (w1 `op` w2)
274 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
276 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
277 -- Shifts take an Int; hence second arg of op is Int
278 wordShiftOp2 op (MachWord x) (MachInt n)
279 = wordResult (x `op` fromInteger n)
280 -- Do the shift at type Integer
281 wordShiftOp2 _ _ _ = Nothing
283 --------------------------
284 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
285 -> Maybe (Expr CoreBndr)
286 floatOp2 op (MachFloat f1) (MachFloat f2)
287 = Just (mkFloatVal (f1 `op` f2))
288 floatOp2 _ _ _ = Nothing
290 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
291 -> Maybe (Expr CoreBndr)
292 floatOp2Z op (MachFloat f1) (MachFloat f2)
293 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
294 floatOp2Z _ _ _ = Nothing
296 --------------------------
297 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
298 -> Maybe (Expr CoreBndr)
299 doubleOp2 op (MachDouble f1) (MachDouble f2)
300 = Just (mkDoubleVal (f1 `op` f2))
301 doubleOp2 _ _ _ = Nothing
303 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
304 -> Maybe (Expr CoreBndr)
305 doubleOp2Z op (MachDouble f1) (MachDouble f2)
306 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
307 doubleOp2Z _ _ _ = Nothing
310 --------------------------
318 -- This is a Good Thing, because it allows case-of case things
319 -- to happen, and case-default absorption to happen. For
322 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
328 -- (modulo the usual precautions to avoid duplicating e1)
331 -> Bool -- True <=> equality, False <=> inequality
334 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
335 `appendFS` (fsLit "->case"),
337 ru_nargs = 2, ru_try = rule_fn }]
339 rule_fn [Lit lit, expr] = do_lit_eq lit expr
340 rule_fn [expr, Lit lit] = do_lit_eq lit expr
344 = Just (mkWildCase expr (literalType lit) boolTy
345 [(DEFAULT, [], val_if_neq),
346 (LitAlt lit, [], val_if_eq)])
347 val_if_eq | is_eq = trueVal
348 | otherwise = falseVal
349 val_if_neq | is_eq = falseVal
350 | otherwise = trueVal
352 -- Note that we *don't* warn the user about overflow. It's not done at
353 -- runtime either, and compilation of completely harmless things like
354 -- ((124076834 :: Word32) + (2147483647 :: Word32))
355 -- would yield a warning. Instead we simply squash the value into the
356 -- Int range, but not in a way suitable for cross-compiling... :-(
357 intResult :: Integer -> Maybe CoreExpr
359 = Just (mkIntVal (toInteger (fromInteger result :: Int)))
361 wordResult :: Integer -> Maybe CoreExpr
363 = Just (mkWordVal (toInteger (fromInteger result :: Word)))
367 %************************************************************************
369 \subsection{Vaguely generic functions
371 %************************************************************************
374 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
375 -- Gives the Rule the same name as the primop itself
376 mkBasicRule op_name n_args rule_fn
377 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
379 ru_nargs = n_args, ru_try = rule_fn }]
381 oneLit :: Name -> (Literal -> Maybe CoreExpr)
384 = mkBasicRule op_name 1 rule_fn
386 rule_fn [Lit l1] = test (convFloating l1)
389 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
392 = mkBasicRule op_name 2 rule_fn
394 rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
397 -- When excess precision is not requested, cut down the precision of the
398 -- Rational value to that of Float/Double. We confuse host architecture
399 -- and target architecture here, but it's convenient (and wrong :-).
400 convFloating :: Literal -> Literal
401 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
402 MachFloat (toRational ((fromRational f) :: Float ))
403 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
404 MachDouble (toRational ((fromRational d) :: Double))
407 trueVal, falseVal :: Expr CoreBndr
408 trueVal = Var trueDataConId
409 falseVal = Var falseDataConId
410 mkIntVal :: Integer -> Expr CoreBndr
411 mkIntVal i = Lit (mkMachInt i)
412 mkWordVal :: Integer -> Expr CoreBndr
413 mkWordVal w = Lit (mkMachWord w)
414 mkFloatVal :: Rational -> Expr CoreBndr
415 mkFloatVal f = Lit (convFloating (MachFloat f))
416 mkDoubleVal :: Rational -> Expr CoreBndr
417 mkDoubleVal d = Lit (convFloating (MachDouble d))
421 %************************************************************************
423 \subsection{Special rules for seq, tagToEnum, dataToTag}
425 %************************************************************************
428 tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
429 tagToEnumRule [Type ty, Lit (MachInt i)]
430 = ASSERT( isEnumerationTyCon tycon )
431 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
434 [] -> Nothing -- Abstract type
435 (dc:rest) -> ASSERT( null rest )
436 Just (Var (dataConWorkId dc))
438 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
440 tycon = tyConAppTyCon ty
442 tagToEnumRule _ = Nothing
445 For dataToTag#, we can reduce if either
447 (a) the argument is a constructor
448 (b) the argument is a variable whose unfolding is a known constructor
451 dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr)
452 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
453 | tag_to_enum `hasKey` tagToEnumKey
454 , ty1 `coreEqType` ty2
455 = Just tag -- dataToTag (tagToEnum x) ==> x
457 dataToTagRule [_, val_arg]
458 | Just (dc,_) <- exprIsConApp_maybe val_arg
459 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
460 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
462 dataToTagRule _ = Nothing
465 %************************************************************************
467 \subsection{Built in rules}
469 %************************************************************************
471 Note [Scoping for Builtin rules]
472 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
473 When compiling a (base-package) module that defines one of the
474 functions mentioned in the RHS of a built-in rule, there's a danger
477 f = ...(eq String x)....
479 ....and lower down...
483 Then a rewrite would give
485 f = ...(eqString x)...
486 ....and lower down...
489 and lo, eqString is not in scope. This only really matters when we get to code
490 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
491 set of bindings, which sorts out the dependency. Without -O we don't do any rule
492 rewriting so again we are fine.
494 (This whole thing doesn't show up for non-built-in rules because their dependencies
499 builtinRules :: [CoreRule]
500 -- Rules for non-primops that can't be expressed using a RULE pragma
502 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
503 ru_nargs = 4, ru_try = match_append_lit },
504 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
505 ru_nargs = 2, ru_try = match_eq_string },
506 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
507 ru_nargs = 2, ru_try = match_inline }
511 ---------------------------------------------------
513 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
515 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
516 match_append_lit [Type ty1,
519 Var unpk `App` Type ty2
520 `App` Lit (MachStr s2)
524 | unpk `hasKey` unpackCStringFoldrIdKey &&
526 = ASSERT( ty1 `coreEqType` ty2 )
527 Just (Var unpk `App` Type ty1
528 `App` Lit (MachStr (s1 `appendFS` s2))
532 match_append_lit _ = Nothing
534 ---------------------------------------------------
536 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
538 match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
539 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
540 Var unpk2 `App` Lit (MachStr s2)]
541 | unpk1 `hasKey` unpackCStringIdKey,
542 unpk2 `hasKey` unpackCStringIdKey
543 = Just (if s1 == s2 then trueVal else falseVal)
545 match_eq_string _ = Nothing
548 ---------------------------------------------------
550 -- inline f_ty (f a b c) = <f's unfolding> a b c
551 -- (if f has an unfolding)
553 -- It's important to allow the argument to 'inline' to have args itself
554 -- (a) because its more forgiving to allow the programmer to write
556 -- or inline (f a b c)
557 -- (b) because a polymorphic f wll get a type argument that the
558 -- programmer can't avoid
560 -- Also, don't forget about 'inline's type argument!
561 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
562 match_inline (Type _ : e : _)
563 | (Var f, args1) <- collectArgs e,
564 Just unf <- maybeUnfoldingTemplate (idUnfolding f)
565 = Just (mkApps unf args1)
567 match_inline _ = Nothing