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
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 )
48 import Data.Bits as Bits ( Bits(..), shiftL, shiftR )
49 -- shiftL and shiftR were not always methods of Bits
50 #if __GLASGOW_HASKELL__ >= 500
51 import Data.Word ( Word )
53 import Data.Word ( Word64 )
58 Note [Constant folding]
59 ~~~~~~~~~~~~~~~~~~~~~~~
60 primOpRules generates the rewrite rules for each primop
61 These rules do what is often called "constant folding"
62 E.g. the rules for +# might say
64 Well, of course you'd need a lot of rules if you did it
65 like that, so we use a BuiltinRule instead, so that we
66 can match in any two literal values. So the rule is really
68 (Lit 4) +# (Lit y) = Lit (x+#y)
69 where the (+#) on the rhs is done at compile time
71 That is why these rules are built in here. Other rules
72 which don't need to be built in are in GHC.Base. For
78 primOpRules :: PrimOp -> Name -> [CoreRule]
79 primOpRules op op_name = primop_rule op
82 one_lit = oneLit op_name
83 two_lits = twoLits op_name
84 relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ))
85 -- Cunning. cmpOp compares the values to give an Ordering.
86 -- It applies its argument to that ordering value to turn
87 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
89 -- ToDo: something for integer-shift ops?
92 primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule
93 primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule
96 primop_rule IntAddOp = two_lits (intOp2 (+))
97 primop_rule IntSubOp = two_lits (intOp2 (-))
98 primop_rule IntMulOp = two_lits (intOp2 (*))
99 primop_rule IntQuotOp = two_lits (intOp2Z quot)
100 primop_rule IntRemOp = two_lits (intOp2Z rem)
101 primop_rule IntNegOp = one_lit negOp
102 primop_rule ISllOp = two_lits (intShiftOp2 Bits.shiftL)
103 primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR)
104 primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical)
107 #if __GLASGOW_HASKELL__ >= 500
108 primop_rule WordAddOp = two_lits (wordOp2 (+))
109 primop_rule WordSubOp = two_lits (wordOp2 (-))
110 primop_rule WordMulOp = two_lits (wordOp2 (*))
112 primop_rule WordQuotOp = two_lits (wordOp2Z quot)
113 primop_rule WordRemOp = two_lits (wordOp2Z rem)
114 #if __GLASGOW_HASKELL__ >= 407
115 primop_rule AndOp = two_lits (wordBitOp2 (.&.))
116 primop_rule OrOp = two_lits (wordBitOp2 (.|.))
117 primop_rule XorOp = two_lits (wordBitOp2 xor)
119 primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL)
120 primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical)
123 primop_rule Word2IntOp = one_lit (litCoerce word2IntLit)
124 primop_rule Int2WordOp = one_lit (litCoerce int2WordLit)
125 primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit)
126 primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit)
127 primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit)
128 primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit)
129 primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit)
130 primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit)
131 primop_rule OrdOp = one_lit (litCoerce char2IntLit)
132 primop_rule ChrOp = one_lit (litCoerce int2CharLit)
133 primop_rule Float2IntOp = one_lit (litCoerce float2IntLit)
134 primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit)
135 primop_rule Double2IntOp = one_lit (litCoerce double2IntLit)
136 primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit)
137 -- SUP: Not sure what the standard says about precision in the following 2 cases
138 primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit)
139 primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit)
142 primop_rule FloatAddOp = two_lits (floatOp2 (+))
143 primop_rule FloatSubOp = two_lits (floatOp2 (-))
144 primop_rule FloatMulOp = two_lits (floatOp2 (*))
145 primop_rule FloatDivOp = two_lits (floatOp2Z (/))
146 primop_rule FloatNegOp = one_lit negOp
149 primop_rule DoubleAddOp = two_lits (doubleOp2 (+))
150 primop_rule DoubleSubOp = two_lits (doubleOp2 (-))
151 primop_rule DoubleMulOp = two_lits (doubleOp2 (*))
152 primop_rule DoubleDivOp = two_lits (doubleOp2Z (/))
153 primop_rule DoubleNegOp = one_lit negOp
155 -- Relational operators
156 primop_rule IntEqOp = relop (==) ++ litEq op_name True
157 primop_rule IntNeOp = relop (/=) ++ litEq op_name False
158 primop_rule CharEqOp = relop (==) ++ litEq op_name True
159 primop_rule CharNeOp = relop (/=) ++ litEq op_name False
161 primop_rule IntGtOp = relop (>)
162 primop_rule IntGeOp = relop (>=)
163 primop_rule IntLeOp = relop (<=)
164 primop_rule IntLtOp = relop (<)
166 primop_rule CharGtOp = relop (>)
167 primop_rule CharGeOp = relop (>=)
168 primop_rule CharLeOp = relop (<=)
169 primop_rule CharLtOp = relop (<)
171 primop_rule FloatGtOp = relop (>)
172 primop_rule FloatGeOp = relop (>=)
173 primop_rule FloatLeOp = relop (<=)
174 primop_rule FloatLtOp = relop (<)
175 primop_rule FloatEqOp = relop (==)
176 primop_rule FloatNeOp = relop (/=)
178 primop_rule DoubleGtOp = relop (>)
179 primop_rule DoubleGeOp = relop (>=)
180 primop_rule DoubleLeOp = relop (<=)
181 primop_rule DoubleLtOp = relop (<)
182 primop_rule DoubleEqOp = relop (==)
183 primop_rule DoubleNeOp = relop (/=)
185 primop_rule WordGtOp = relop (>)
186 primop_rule WordGeOp = relop (>=)
187 primop_rule WordLeOp = relop (<=)
188 primop_rule WordLtOp = relop (<)
189 primop_rule WordEqOp = relop (==)
190 primop_rule WordNeOp = relop (/=)
192 primop_rule other = []
197 %************************************************************************
199 \subsection{Doing the business}
201 %************************************************************************
203 ToDo: the reason these all return Nothing is because there used to be
204 the possibility of an argument being a litlit. Litlits are now gone,
205 so this could be cleaned up.
208 --------------------------
209 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
210 litCoerce fn lit = Just (Lit (fn lit))
212 --------------------------
213 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
217 done res | cmp res = Just trueVal
218 | otherwise = Just falseVal
220 -- These compares are at different types
221 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
222 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
223 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
224 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
225 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
226 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
227 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
230 --------------------------
232 negOp :: Literal -> Maybe CoreExpr -- Negate
233 negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
234 negOp (MachFloat f) = Just (mkFloatVal (-f))
235 negOp (MachDouble 0.0) = Nothing
236 negOp (MachDouble d) = Just (mkDoubleVal (-d))
237 negOp (MachInt i) = intResult (-i)
240 --------------------------
241 intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
242 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
243 intOp2 op l1 l2 = Nothing -- Could find LitLit
245 intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
246 -- Like intOp2, but Nothing if i2=0
247 intOp2Z op (MachInt i1) (MachInt i2)
248 | i2 /= 0 = intResult (i1 `op` i2)
249 intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
251 intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
252 -- Shifts take an Int; hence second arg of op is Int
253 intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2)
254 intShiftOp2 op l1 l2 = Nothing
256 shiftRightLogical :: Integer -> Int -> Integer
257 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
258 -- Do this by converting to Word and back. Obviously this won't work for big
259 -- values, but its ok as we use it here
260 shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word)
263 --------------------------
264 #if __GLASGOW_HASKELL__ >= 500
265 wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
266 wordOp2 op (MachWord w1) (MachWord w2)
267 = wordResult (w1 `op` w2)
268 wordOp2 op l1 l2 = Nothing -- Could find LitLit
271 wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr
272 wordOp2Z op (MachWord w1) (MachWord w2)
273 | w2 /= 0 = wordResult (w1 `op` w2)
274 wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
276 #if __GLASGOW_HASKELL__ >= 500
277 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
278 = wordResult (w1 `op` w2)
280 -- Integer is not an instance of Bits, so we operate on Word64
281 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
282 = wordResult ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2))
284 wordBitOp2 op l1 l2 = Nothing -- Could find LitLit
286 wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr
287 -- Shifts take an Int; hence second arg of op is Int
288 wordShiftOp2 op (MachWord x) (MachInt n)
289 = wordResult (x `op` fromInteger n)
290 -- Do the shift at type Integer
291 wordShiftOp2 op l1 l2 = Nothing
293 --------------------------
294 floatOp2 op (MachFloat f1) (MachFloat f2)
295 = Just (mkFloatVal (f1 `op` f2))
296 floatOp2 op l1 l2 = Nothing
298 floatOp2Z op (MachFloat f1) (MachFloat f2)
299 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
300 floatOp2Z op l1 l2 = Nothing
302 --------------------------
303 doubleOp2 op (MachDouble f1) (MachDouble f2)
304 = Just (mkDoubleVal (f1 `op` f2))
305 doubleOp2 op l1 l2 = Nothing
307 doubleOp2Z op (MachDouble f1) (MachDouble f2)
308 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
309 doubleOp2Z op l1 l2 = 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
343 rule_fn other = Nothing
346 = Just (Case expr (mkWildId (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 -- Int range, but not in a way suitable for cross-compiling... :-(
359 intResult :: Integer -> Maybe CoreExpr
361 = Just (mkIntVal (toInteger (fromInteger result :: Int)))
363 #if __GLASGOW_HASKELL__ >= 500
364 wordResult :: Integer -> Maybe CoreExpr
366 = Just (mkWordVal (toInteger (fromInteger result :: Word)))
371 %************************************************************************
373 \subsection{Vaguely generic functions
375 %************************************************************************
378 mkBasicRule :: Name -> Int -> ([CoreExpr] -> Maybe CoreExpr) -> [CoreRule]
379 -- Gives the Rule the same name as the primop itself
380 mkBasicRule op_name n_args rule_fn
381 = [BuiltinRule { ru_name = occNameFS (nameOccName op_name),
383 ru_nargs = n_args, ru_try = rule_fn }]
385 oneLit :: Name -> (Literal -> Maybe CoreExpr)
388 = mkBasicRule op_name 1 rule_fn
390 rule_fn [Lit l1] = test (convFloating l1)
393 twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr)
396 = mkBasicRule op_name 2 rule_fn
398 rule_fn [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2)
401 -- When excess precision is not requested, cut down the precision of the
402 -- Rational value to that of Float/Double. We confuse host architecture
403 -- and target architecture here, but it's convenient (and wrong :-).
404 convFloating :: Literal -> Literal
405 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
406 MachFloat (toRational ((fromRational f) :: Float ))
407 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
408 MachDouble (toRational ((fromRational d) :: Double))
411 trueVal = Var trueDataConId
412 falseVal = Var falseDataConId
413 mkIntVal i = Lit (mkMachInt i)
414 mkWordVal w = Lit (mkMachWord w)
415 mkFloatVal f = Lit (convFloating (MachFloat f))
416 mkDoubleVal d = Lit (convFloating (MachDouble d))
420 %************************************************************************
422 \subsection{Special rules for seq, tagToEnum, dataToTag}
424 %************************************************************************
427 tagToEnumRule [Type ty, Lit (MachInt i)]
428 = ASSERT( isEnumerationTyCon tycon )
429 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
432 [] -> Nothing -- Abstract type
433 (dc:rest) -> ASSERT( null rest )
434 Just (Var (dataConWorkId dc))
436 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
438 tycon = tyConAppTyCon ty
440 tagToEnumRule other = Nothing
443 For dataToTag#, we can reduce if either
445 (a) the argument is a constructor
446 (b) the argument is a variable whose unfolding is a known constructor
449 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
450 | tag_to_enum `hasKey` tagToEnumKey
451 , ty1 `coreEqType` ty2
452 = Just tag -- dataToTag (tagToEnum x) ==> x
454 dataToTagRule [_, val_arg]
455 | Just (dc,_) <- exprIsConApp_maybe val_arg
456 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
457 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
459 dataToTagRule other = Nothing
462 %************************************************************************
464 \subsection{Built in rules}
466 %************************************************************************
469 builtinRules :: [CoreRule]
470 -- Rules for non-primops that can't be expressed using a RULE pragma
472 = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName 4 match_append_lit,
473 BuiltinRule FSLIT("EqString") eqStringName 2 match_eq_string,
474 BuiltinRule FSLIT("Inline") inlineIdName 1 match_inline
478 ---------------------------------------------------
480 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
482 match_append_lit [Type ty1,
485 Var unpk `App` Type ty2
486 `App` Lit (MachStr s2)
490 | unpk `hasKey` unpackCStringFoldrIdKey &&
492 = ASSERT( ty1 `coreEqType` ty2 )
493 Just (Var unpk `App` Type ty1
494 `App` Lit (MachStr (s1 `appendFS` s2))
498 match_append_lit other = Nothing
500 ---------------------------------------------------
502 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
504 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
505 Var unpk2 `App` Lit (MachStr s2)]
506 | unpk1 `hasKey` unpackCStringIdKey,
507 unpk2 `hasKey` unpackCStringIdKey
508 = Just (if s1 == s2 then trueVal else falseVal)
510 match_eq_string other = Nothing
513 ---------------------------------------------------
515 -- inline (f a b c) = <f's unfolding> a b c
516 -- (if f has an unfolding)
518 | (Var f, args1) <- collectArgs e,
519 Just unf <- maybeUnfoldingTemplate (idUnfolding f)
520 = Just (mkApps unf args1)
522 match_inline other = Nothing