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, litFitsInChar
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 )
47 import Data.Bits as Bits
48 import Data.Word ( Word )
52 Note [Constant folding]
53 ~~~~~~~~~~~~~~~~~~~~~~~
54 primOpRules generates the rewrite rules for each primop
55 These rules do what is often called "constant folding"
56 E.g. the rules for +# might say
58 Well, of course you'd need a lot of rules if you did it
59 like that, so we use a BuiltinRule instead, so that we
60 can match in any two literal values. So the rule is really
62 (Lit 4) +# (Lit y) = Lit (x+#y)
63 where the (+#) on the rhs is done at compile time
65 That is why these rules are built in here. Other rules
66 which don't need to be built in are in GHC.Base. For
72 primOpRules :: PrimOp -> Name -> [CoreRule]
73 primOpRules op op_name = primop_rule op
76 one_lit = oneLit op_name
77 two_lits = twoLits op_name
78 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
79 -- Cunning. cmpOp compares the values to give an Ordering.
80 -- It applies its argument to that ordering value to turn
81 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
83 -- ToDo: something for integer-shift ops?
86 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
87 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
90 primop_rule IntAddOp = two_lits (intOp2 (+))
91 primop_rule IntSubOp = two_lits (intOp2 (-))
92 primop_rule IntMulOp = two_lits (intOp2 (*))
93 primop_rule IntQuotOp = two_lits (intOp2Z quot)
94 primop_rule IntRemOp = two_lits (intOp2Z rem)
95 primop_rule IntNegOp = one_lit negOp
96 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
97 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
98 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
101 primop_rule WordAddOp = two_lits (wordOp2 (+))
102 primop_rule WordSubOp = two_lits (wordOp2 (-))
103 primop_rule WordMulOp = two_lits (wordOp2 (*))
104 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
105 primop_rule WordRemOp = two_lits (wordOp2Z rem)
106 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
107 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
108 primop_rule XorOp = two_lits (wordBitOp2 xor)
109 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
110 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
113 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
114 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
115 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
116 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
117 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
118 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
119 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
120 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
121 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
122 primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit)
123 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
124 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
125 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
126 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
127 -- SUP: Not sure what the standard says about precision in the following 2 cases
128 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
129 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
132 primop_rule FloatAddOp = two_lits (floatOp2 (+))
133 primop_rule FloatSubOp = two_lits (floatOp2 (-))
134 primop_rule FloatMulOp = two_lits (floatOp2 (*))
135 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
136 primop_rule FloatNegOp = one_lit negOp
139 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
140 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
141 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
142 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
143 primop_rule DoubleNegOp = one_lit negOp
145 -- Relational operators
146 primop_rule IntEqOp = relop (==) ++ litEq op_name True
147 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
148 primop_rule CharEqOp = relop (==) ++ litEq op_name True
149 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
151 primop_rule IntGtOp = relop (>)
152 primop_rule IntGeOp = relop (>=)
153 primop_rule IntLeOp = relop (<=)
154 primop_rule IntLtOp = relop (<)
156 primop_rule CharGtOp = relop (>)
157 primop_rule CharGeOp = relop (>=)
158 primop_rule CharLeOp = relop (<=)
159 primop_rule CharLtOp = relop (<)
161 primop_rule FloatGtOp = relop (>)
162 primop_rule FloatGeOp = relop (>=)
163 primop_rule FloatLeOp = relop (<=)
164 primop_rule FloatLtOp = relop (<)
165 primop_rule FloatEqOp = relop (==)
166 primop_rule FloatNeOp = relop (/=)
168 primop_rule DoubleGtOp = relop (>)
169 primop_rule DoubleGeOp = relop (>=)
170 primop_rule DoubleLeOp = relop (<=)
171 primop_rule DoubleLtOp = relop (<)
172 primop_rule DoubleEqOp = relop (==)
173 primop_rule DoubleNeOp = relop (/=)
175 primop_rule WordGtOp = relop (>)
176 primop_rule WordGeOp = relop (>=)
177 primop_rule WordLeOp = relop (<=)
178 primop_rule WordLtOp = relop (<)
179 primop_rule WordEqOp = relop (==)
180 primop_rule WordNeOp = relop (/=)
187 %************************************************************************
189 \subsection{Doing the business}
191 %************************************************************************
193 ToDo: the reason these all return Nothing is because there used to be
194 the possibility of an argument being a litlit. Litlits are now gone,
195 so this could be cleaned up.
198 --------------------------
199 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
200 litCoerce fn lit = Just (Lit (fn lit))
202 predLitCoerce :: (Literal -> Bool) -> (Literal -> Literal) -> Literal -> Maybe CoreExpr
203 predLitCoerce p fn lit
204 | p lit = Just (Lit (fn lit))
205 | otherwise = Nothing
207 --------------------------
208 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
212 done res | cmp res = Just trueVal
213 | otherwise = Just falseVal
215 -- These compares are at different types
216 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
217 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
218 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
219 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
220 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
221 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
222 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
225 --------------------------
227 negOp :: Literal -> Maybe CoreExpr -- Negate
228 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
229 negOp (MachFloat f) = Just (mkFloatVal (-f))
230 negOp (MachDouble 0.0) = Nothing
231 negOp (MachDouble d) = Just (mkDoubleVal (-d))
232 negOp (MachInt i) = intResult (-i)
235 --------------------------
236 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
237 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
238 intOp2 _ _ _ = Nothing -- Could find LitLit
240 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
241 -- Like intOp2, but Nothing if i2=0
242 intOp2Z op (MachInt i1) (MachInt i2)
243 | i2 /= 0 = intResult (i1 `op` i2)
244 intOp2Z _ _ _ = Nothing -- LitLit or zero dividend
246 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
247 -- Shifts take an Int; hence second arg of op is Int
248 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
249 intShiftOp2 _ _ _ = Nothing
251 shiftRightLogical :: Integer -> Int -> Integer
252 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
253 -- Do this by converting to Word and back. Obviously this won't work for big
254 -- values, but its ok as we use it here
255 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
258 --------------------------
259 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
260 wordOp2 op (MachWord w1) (MachWord w2)
261 = wordResult (w1 `op` w2)
262 wordOp2 _ _ _ = Nothing -- Could find LitLit
264 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
265 wordOp2Z op (MachWord w1) (MachWord w2)
266 | w2 /= 0 = wordResult (w1 `op` w2)
267 wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend
269 wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal
271 wordBitOp2 op (MachWord w1) (MachWord w2)
272 = wordResult (w1 `op` w2)
273 wordBitOp2 _ _ _ = Nothing -- Could find LitLit
275 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
276 -- Shifts take an Int; hence second arg of op is Int
277 wordShiftOp2 op (MachWord x) (MachInt n)
278 = wordResult (x `op` fromInteger n)
279 -- Do the shift at type Integer
280 wordShiftOp2 _ _ _ = Nothing
282 --------------------------
283 floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
284 -> Maybe (Expr CoreBndr)
285 floatOp2 op (MachFloat f1) (MachFloat f2)
286 = Just (mkFloatVal (f1 `op` f2))
287 floatOp2 _ _ _ = Nothing
289 floatOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
290 -> Maybe (Expr CoreBndr)
291 floatOp2Z op (MachFloat f1) (MachFloat f2)
292 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
293 floatOp2Z _ _ _ = Nothing
295 --------------------------
296 doubleOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal
297 -> Maybe (Expr CoreBndr)
298 doubleOp2 op (MachDouble f1) (MachDouble f2)
299 = Just (mkDoubleVal (f1 `op` f2))
300 doubleOp2 _ _ _ = Nothing
302 doubleOp2Z :: (Rational -> Rational -> Rational) -> Literal -> Literal
303 -> Maybe (Expr CoreBndr)
304 doubleOp2Z op (MachDouble f1) (MachDouble f2)
305 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
306 doubleOp2Z _ _ _ = Nothing
309 --------------------------
317 -- This is a Good Thing, because it allows case-of case things
318 -- to happen, and case-default absorption to happen. For
321 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
327 -- (modulo the usual precautions to avoid duplicating e1)
330 -> Bool -- True <=> equality, False <=> inequality
333 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name)
334 `appendFS` (fsLit "->case"),
336 ru_nargs = 2, ru_try = rule_fn }]
338 rule_fn [Lit lit, expr] = do_lit_eq lit expr
339 rule_fn [expr, Lit lit] = do_lit_eq lit expr
343 = Just (Case expr (mkWildId (literalType lit)) boolTy
344 [(DEFAULT, [], val_if_neq),
345 (LitAlt lit, [], val_if_eq)])
346 val_if_eq | is_eq = trueVal
347 | otherwise = falseVal
348 val_if_neq | is_eq = falseVal
349 | otherwise = trueVal
351 -- Note that we *don't* warn the user about overflow. It's not done at
352 -- runtime either, and compilation of completely harmless things like
353 -- ((124076834 :: Word32) + (2147483647 :: Word32))
354 -- would yield a warning. Instead we simply squash the value into the
355 -- Int range, but not in a way suitable for cross-compiling... :-(
356 intResult :: Integer -> Maybe CoreExpr
358 = Just (mkIntVal (toInteger (fromInteger result :: Int)))
360 wordResult :: Integer -> Maybe CoreExpr
362 = Just (mkWordVal (toInteger (fromInteger result :: Word)))
366 %************************************************************************
368 \subsection{Vaguely generic functions
370 %************************************************************************
373 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
374 -- Gives the Rule the same name as the primop itself
375 mkBasicRule op_name n_args rule_fn
376 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
378 ru_nargs = n_args, ru_try = rule_fn }]
380 oneLit :: Name -> (Literal -> Maybe CoreExpr)
383 = mkBasicRule op_name 1 rule_fn
385 rule_fn [Lit l1] = test (convFloating l1)
388 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
391 = mkBasicRule op_name 2 rule_fn
393 rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
396 -- When excess precision is not requested, cut down the precision of the
397 -- Rational value to that of Float/Double. We confuse host architecture
398 -- and target architecture here, but it's convenient (and wrong :-).
399 convFloating :: Literal -> Literal
400 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
401 MachFloat (toRational ((fromRational f) :: Float ))
402 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
403 MachDouble (toRational ((fromRational d) :: Double))
406 trueVal, falseVal :: Expr CoreBndr
407 trueVal = Var trueDataConId
408 falseVal = Var falseDataConId
409 mkIntVal :: Integer -> Expr CoreBndr
410 mkIntVal i = Lit (mkMachInt i)
411 mkWordVal :: Integer -> Expr CoreBndr
412 mkWordVal w = Lit (mkMachWord w)
413 mkFloatVal :: Rational -> Expr CoreBndr
414 mkFloatVal f = Lit (convFloating (MachFloat f))
415 mkDoubleVal :: Rational -> Expr CoreBndr
416 mkDoubleVal d = Lit (convFloating (MachDouble d))
420 %************************************************************************
422 \subsection{Special rules for seq, tagToEnum, dataToTag}
424 %************************************************************************
427 tagToEnumRule :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
428 tagToEnumRule [Type ty, Lit (MachInt i)]
429 = ASSERT( isEnumerationTyCon tycon )
430 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
433 [] -> Nothing -- Abstract type
434 (dc:rest) -> ASSERT( null rest )
435 Just (Var (dataConWorkId dc))
437 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
439 tycon = tyConAppTyCon ty
441 tagToEnumRule _ = Nothing
444 For dataToTag#, we can reduce if either
446 (a) the argument is a constructor
447 (b) the argument is a variable whose unfolding is a known constructor
450 dataToTagRule :: [Expr CoreBndr] -> Maybe (Arg CoreBndr)
451 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
452 | tag_to_enum `hasKey` tagToEnumKey
453 , ty1 `coreEqType` ty2
454 = Just tag -- dataToTag (tagToEnum x) ==> x
456 dataToTagRule [_, val_arg]
457 | Just (dc,_) <- exprIsConApp_maybe val_arg
458 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
459 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
461 dataToTagRule _ = Nothing
464 %************************************************************************
466 \subsection{Built in rules}
468 %************************************************************************
470 Note [Scoping for Builtin rules]
471 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
472 When compiling a (base-package) module that defines one of the
473 functions mentioned in the RHS of a built-in rule, there's a danger
476 f = ...(eq String x)....
478 ....and lower down...
482 Then a rewrite would give
484 f = ...(eqString x)...
485 ....and lower down...
488 and lo, eqString is not in scope. This only really matters when we get to code
489 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
490 set of bindings, which sorts out the dependency. Without -O we don't do any rule
491 rewriting so again we are fine.
493 (This whole thing doesn't show up for non-built-in rules because their dependencies
498 builtinRules :: [CoreRule]
499 -- Rules for non-primops that can't be expressed using a RULE pragma
501 = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName,
502 ru_nargs = 4, ru_try = match_append_lit },
503 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
504 ru_nargs = 2, ru_try = match_eq_string },
505 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
506 ru_nargs = 2, ru_try = match_inline }
510 ---------------------------------------------------
512 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
514 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
515 match_append_lit [Type ty1,
518 Var unpk `App` Type ty2
519 `App` Lit (MachStr s2)
523 | unpk `hasKey` unpackCStringFoldrIdKey &&
525 = ASSERT( ty1 `coreEqType` ty2 )
526 Just (Var unpk `App` Type ty1
527 `App` Lit (MachStr (s1 `appendFS` s2))
531 match_append_lit _ = Nothing
533 ---------------------------------------------------
535 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
537 match_eq_string :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
538 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
539 Var unpk2 `App` Lit (MachStr s2)]
540 | unpk1 `hasKey` unpackCStringIdKey,
541 unpk2 `hasKey` unpackCStringIdKey
542 = Just (if s1 == s2 then trueVal else falseVal)
544 match_eq_string _ = Nothing
547 ---------------------------------------------------
549 -- inline f_ty (f a b c) = <f's unfolding> a b c
550 -- (if f has an unfolding)
552 -- It's important to allow the argument to 'inline' to have args itself
553 -- (a) because its more forgiving to allow the programmer to write
555 -- or inline (f a b c)
556 -- (b) because a polymorphic f wll get a type argument that the
557 -- programmer can't avoid
559 -- Also, don't forget about 'inline's type argument!
560 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
561 match_inline (Type _ : e : _)
562 | (Var f, args1) <- collectArgs e,
563 Just unf <- maybeUnfoldingTemplate (idUnfolding f)
564 = Just (mkApps unf args1)
566 match_inline _ = Nothing