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(..), primOpOcc, 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 )
46 import StaticFlags ( opt_SimplExcessPrecision )
48 import Data.Bits ( Bits(..) )
49 #if __GLASGOW_HASKELL__ >= 500
50 import Data.Word ( Word )
52 import Data.Word ( Word64 )
57 Note [Constant folding]
58 ~~~~~~~~~~~~~~~~~~~~~~~
59 primOpRules generates the rewrite rules for each primop
60 These rules do what is often called "constant folding"
61 E.g. the rules for +# might say
63 Well, of course you'd need a lot of rules if you did it
64 like that, so we use a BuiltinRule instead, so that we
65 can match in any two literal values. So the rule is really
67 (Lit 4) +# (Lit y) = Lit (x+#y)
68 where the (+#) on the rhs is done at compile time
70 That is why these rules are built in here. Other rules
71 which don't need to be built in are in GHC.Base. For
77 primOpRules :: PrimOp -> Name -> [CoreRule]
78 primOpRules op op_name = primop_rule op
80 rule_name = occNameFS (primOpOcc op)
81 rule_name_case = rule_name `appendFS` FSLIT("->case")
84 one_rule rule_fn = [BuiltinRule { ru_name = rule_name,
87 case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case,
91 -- ToDo: something for integer-shift ops?
94 primop_rule TagToEnumOp = one_rule tagToEnumRule
95 primop_rule DataToTagOp = one_rule dataToTagRule
98 primop_rule IntAddOp = one_rule (twoLits (intOp2 (+)))
99 primop_rule IntSubOp = one_rule (twoLits (intOp2 (-)))
100 primop_rule IntMulOp = one_rule (twoLits (intOp2 (*)))
101 primop_rule IntQuotOp = one_rule (twoLits (intOp2Z quot))
102 primop_rule IntRemOp = one_rule (twoLits (intOp2Z rem))
103 primop_rule IntNegOp = one_rule (oneLit negOp)
106 #if __GLASGOW_HASKELL__ >= 500
107 primop_rule WordAddOp = one_rule (twoLits (wordOp2 (+)))
108 primop_rule WordSubOp = one_rule (twoLits (wordOp2 (-)))
109 primop_rule WordMulOp = one_rule (twoLits (wordOp2 (*)))
111 primop_rule WordQuotOp = one_rule (twoLits (wordOp2Z quot))
112 primop_rule WordRemOp = one_rule (twoLits (wordOp2Z rem))
113 #if __GLASGOW_HASKELL__ >= 407
114 primop_rule AndOp = one_rule (twoLits (wordBitOp2 (.&.)))
115 primop_rule OrOp = one_rule (twoLits (wordBitOp2 (.|.)))
116 primop_rule XorOp = one_rule (twoLits (wordBitOp2 xor))
120 primop_rule Word2IntOp = one_rule (oneLit (litCoerce word2IntLit))
121 primop_rule Int2WordOp = one_rule (oneLit (litCoerce int2WordLit))
122 primop_rule Narrow8IntOp = one_rule (oneLit (litCoerce narrow8IntLit))
123 primop_rule Narrow16IntOp = one_rule (oneLit (litCoerce narrow16IntLit))
124 primop_rule Narrow32IntOp = one_rule (oneLit (litCoerce narrow32IntLit))
125 primop_rule Narrow8WordOp = one_rule (oneLit (litCoerce narrow8WordLit))
126 primop_rule Narrow16WordOp = one_rule (oneLit (litCoerce narrow16WordLit))
127 primop_rule Narrow32WordOp = one_rule (oneLit (litCoerce narrow32WordLit))
128 primop_rule OrdOp = one_rule (oneLit (litCoerce char2IntLit))
129 primop_rule ChrOp = one_rule (oneLit (litCoerce int2CharLit))
130 primop_rule Float2IntOp = one_rule (oneLit (litCoerce float2IntLit))
131 primop_rule Int2FloatOp = one_rule (oneLit (litCoerce int2FloatLit))
132 primop_rule Double2IntOp = one_rule (oneLit (litCoerce double2IntLit))
133 primop_rule Int2DoubleOp = one_rule (oneLit (litCoerce int2DoubleLit))
134 -- SUP: Not sure what the standard says about precision in the following 2 cases
135 primop_rule Float2DoubleOp = one_rule (oneLit (litCoerce float2DoubleLit))
136 primop_rule Double2FloatOp = one_rule (oneLit (litCoerce double2FloatLit))
139 primop_rule FloatAddOp = one_rule (twoLits (floatOp2 (+)))
140 primop_rule FloatSubOp = one_rule (twoLits (floatOp2 (-)))
141 primop_rule FloatMulOp = one_rule (twoLits (floatOp2 (*)))
142 primop_rule FloatDivOp = one_rule (twoLits (floatOp2Z (/)))
143 primop_rule FloatNegOp = one_rule (oneLit negOp)
146 primop_rule DoubleAddOp = one_rule (twoLits (doubleOp2 (+)))
147 primop_rule DoubleSubOp = one_rule (twoLits (doubleOp2 (-)))
148 primop_rule DoubleMulOp = one_rule (twoLits (doubleOp2 (*)))
149 primop_rule DoubleDivOp = one_rule (twoLits (doubleOp2Z (/)))
150 primop_rule DoubleNegOp = one_rule (oneLit negOp)
152 -- Relational operators
153 primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True)
154 primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False)
155 primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True)
156 primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False)
158 primop_rule IntGtOp = one_rule (relop (>))
159 primop_rule IntGeOp = one_rule (relop (>=))
160 primop_rule IntLeOp = one_rule (relop (<=))
161 primop_rule IntLtOp = one_rule (relop (<))
163 primop_rule CharGtOp = one_rule (relop (>))
164 primop_rule CharGeOp = one_rule (relop (>=))
165 primop_rule CharLeOp = one_rule (relop (<=))
166 primop_rule CharLtOp = one_rule (relop (<))
168 primop_rule FloatGtOp = one_rule (relop (>))
169 primop_rule FloatGeOp = one_rule (relop (>=))
170 primop_rule FloatLeOp = one_rule (relop (<=))
171 primop_rule FloatLtOp = one_rule (relop (<))
172 primop_rule FloatEqOp = one_rule (relop (==))
173 primop_rule FloatNeOp = one_rule (relop (/=))
175 primop_rule DoubleGtOp = one_rule (relop (>))
176 primop_rule DoubleGeOp = one_rule (relop (>=))
177 primop_rule DoubleLeOp = one_rule (relop (<=))
178 primop_rule DoubleLtOp = one_rule (relop (<))
179 primop_rule DoubleEqOp = one_rule (relop (==))
180 primop_rule DoubleNeOp = one_rule (relop (/=))
182 primop_rule WordGtOp = one_rule (relop (>))
183 primop_rule WordGeOp = one_rule (relop (>=))
184 primop_rule WordLeOp = one_rule (relop (<=))
185 primop_rule WordLtOp = one_rule (relop (<))
186 primop_rule WordEqOp = one_rule (relop (==))
187 primop_rule WordNeOp = one_rule (relop (/=))
189 primop_rule other = []
192 relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ))
193 -- Cunning. cmpOp compares the values to give an Ordering.
194 -- It applies its argument to that ordering value to turn
195 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
198 %************************************************************************
200 \subsection{Doing the business}
202 %************************************************************************
204 ToDo: the reason these all return Nothing is because there used to be
205 the possibility of an argument being a litlit. Litlits are now gone,
206 so this could be cleaned up.
209 --------------------------
210 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
211 litCoerce fn lit = Just (Lit (fn lit))
213 --------------------------
214 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
218 done res | cmp res = Just trueVal
219 | otherwise = Just falseVal
221 -- These compares are at different types
222 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
223 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
224 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
225 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
226 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
227 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
228 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
231 --------------------------
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 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
242 intOp2 op l1 l2 = Nothing -- Could find LitLit
244 intOp2Z op (MachInt i1) (MachInt i2)
245 | i2 /= 0 = Just (mkIntVal (i1 `op` i2))
246 intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
248 --------------------------
249 #if __GLASGOW_HASKELL__ >= 500
250 wordOp2 op (MachWord w1) (MachWord w2)
251 = wordResult (w1 `op` w2)
252 wordOp2 op l1 l2 = Nothing -- Could find LitLit
255 wordOp2Z op (MachWord w1) (MachWord w2)
256 | w2 /= 0 = Just (mkWordVal (w1 `op` w2))
257 wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
259 #if __GLASGOW_HASKELL__ >= 500
260 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
261 = Just (mkWordVal (w1 `op` w2))
263 -- Integer is not an instance of Bits, so we operate on Word64
264 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
265 = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
267 wordBitOp2 op l1 l2 = Nothing -- Could find LitLit
269 --------------------------
270 floatOp2 op (MachFloat f1) (MachFloat f2)
271 = Just (mkFloatVal (f1 `op` f2))
272 floatOp2 op l1 l2 = Nothing
274 floatOp2Z op (MachFloat f1) (MachFloat f2)
275 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
276 floatOp2Z op l1 l2 = Nothing
278 --------------------------
279 doubleOp2 op (MachDouble f1) (MachDouble f2)
280 = Just (mkDoubleVal (f1 `op` f2))
281 doubleOp2 op l1 l2 = Nothing
283 doubleOp2Z op (MachDouble f1) (MachDouble f2)
284 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
285 doubleOp2Z op l1 l2 = Nothing
288 --------------------------
296 -- This is a Good Thing, because it allows case-of case things
297 -- to happen, and case-default absorption to happen. For
300 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
306 -- (modulo the usual precautions to avoid duplicating e1)
308 litEq :: Bool -- True <=> equality, False <=> inequality
310 litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr
311 litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr
312 litEq is_eq other = Nothing
314 do_lit_eq is_eq lit expr
315 = Just (Case expr (mkWildId (literalType lit)) boolTy
316 [(DEFAULT, [], val_if_neq),
317 (LitAlt lit, [], val_if_eq)])
319 val_if_eq | is_eq = trueVal
320 | otherwise = falseVal
321 val_if_neq | is_eq = falseVal
322 | otherwise = trueVal
324 -- Note that we *don't* warn the user about overflow. It's not done at
325 -- runtime either, and compilation of completely harmless things like
326 -- ((124076834 :: Word32) + (2147483647 :: Word32))
327 -- would yield a warning. Instead we simply squash the value into the
328 -- Int range, but not in a way suitable for cross-compiling... :-(
329 intResult :: Integer -> Maybe CoreExpr
331 = Just (mkIntVal (toInteger (fromInteger result :: Int)))
333 #if __GLASGOW_HASKELL__ >= 500
334 wordResult :: Integer -> Maybe CoreExpr
336 = Just (mkWordVal (toInteger (fromInteger result :: Word)))
341 %************************************************************************
343 \subsection{Vaguely generic functions
345 %************************************************************************
348 type RuleFun = [CoreExpr] -> Maybe CoreExpr
350 twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun
351 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
352 twoLits rule _ = Nothing
354 oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun
355 oneLit rule [Lit l1] = rule (convFloating l1)
356 oneLit rule _ = Nothing
358 -- When excess precision is not requested, cut down the precision of the
359 -- Rational value to that of Float/Double. We confuse host architecture
360 -- and target architecture here, but it's convenient (and wrong :-).
361 convFloating :: Literal -> Literal
362 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
363 MachFloat (toRational ((fromRational f) :: Float ))
364 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
365 MachDouble (toRational ((fromRational d) :: Double))
369 trueVal = Var trueDataConId
370 falseVal = Var falseDataConId
371 mkIntVal i = Lit (mkMachInt i)
372 mkWordVal w = Lit (mkMachWord w)
373 mkFloatVal f = Lit (convFloating (MachFloat f))
374 mkDoubleVal d = Lit (convFloating (MachDouble d))
378 %************************************************************************
380 \subsection{Special rules for seq, tagToEnum, dataToTag}
382 %************************************************************************
385 tagToEnumRule [Type ty, Lit (MachInt i)]
386 = ASSERT( isEnumerationTyCon tycon )
387 case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
390 [] -> Nothing -- Abstract type
391 (dc:rest) -> ASSERT( null rest )
392 Just (Var (dataConWorkId dc))
394 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
396 tycon = tyConAppTyCon ty
398 tagToEnumRule other = Nothing
401 For dataToTag#, we can reduce if either
403 (a) the argument is a constructor
404 (b) the argument is a variable whose unfolding is a known constructor
407 dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
408 | tag_to_enum `hasKey` tagToEnumKey
409 , ty1 `coreEqType` ty2
410 = Just tag -- dataToTag (tagToEnum x) ==> x
412 dataToTagRule [_, val_arg]
413 | Just (dc,_) <- exprIsConApp_maybe val_arg
414 = ASSERT( not (isNewTyCon (dataConTyCon dc)) )
415 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
417 dataToTagRule other = Nothing
420 %************************************************************************
422 \subsection{Built in rules}
424 %************************************************************************
427 builtinRules :: [CoreRule]
428 -- Rules for non-primops that can't be expressed using a RULE pragma
430 = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit,
431 BuiltinRule FSLIT("EqString") eqStringName match_eq_string,
432 BuiltinRule FSLIT("Inline") inlineIdName match_inline
436 ---------------------------------------------------
438 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
440 match_append_lit [Type ty1,
443 Var unpk `App` Type ty2
444 `App` Lit (MachStr s2)
448 | unpk `hasKey` unpackCStringFoldrIdKey &&
450 = ASSERT( ty1 `coreEqType` ty2 )
451 Just (Var unpk `App` Type ty1
452 `App` Lit (MachStr (s1 `appendFS` s2))
456 match_append_lit other = Nothing
458 ---------------------------------------------------
460 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
462 match_eq_string [Var unpk1 `App` Lit (MachStr s1),
463 Var unpk2 `App` Lit (MachStr s2)]
464 | unpk1 `hasKey` unpackCStringIdKey,
465 unpk2 `hasKey` unpackCStringIdKey
466 = Just (if s1 == s2 then trueVal else falseVal)
468 match_eq_string other = Nothing
471 ---------------------------------------------------
473 -- inline (f a b c) = <f's unfolding> a b c
474 -- (if f has an unfolding)
475 match_inline (e:args2)
476 | (Var f, args1) <- collectArgs e,
477 Just unf <- maybeUnfoldingTemplate (idUnfolding f)
478 = Just (mkApps (mkApps unf args1) args2)
480 match_inline other = Nothing