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 )
24 import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
26 , word2IntLit, int2WordLit
27 , narrow8IntLit, narrow16IntLit, narrow32IntLit
28 , narrow8WordLit, narrow16WordLit, narrow32WordLit
29 , char2IntLit, int2CharLit
30 , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
31 , nullAddrLit, float2DoubleLit, double2FloatLit
33 import PrimOp ( PrimOp(..), primOpOcc )
34 import TysWiredIn ( trueDataConId, falseDataConId )
35 import TyCon ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
36 import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
37 import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
38 import Type ( tyConAppTyCon, eqType )
39 import OccName ( occNameUserString)
40 import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
42 import Bits ( Bits(..) )
43 #if __GLASGOW_HASKELL__ >= 500
46 import Word ( Word64 )
49 import CmdLineOpts ( opt_SimplExcessPrecision )
54 primOpRules :: PrimOp -> [CoreRule]
55 primOpRules op = primop_rule op
57 op_name = _PK_ (occNameUserString (primOpOcc op))
58 op_name_case = op_name _APPEND_ SLIT("->case")
61 one_rule rule_fn = [BuiltinRule op_name rule_fn]
63 -- ToDo: something for integer-shift ops?
66 primop_rule AddrNullOp = one_rule nullAddrRule
67 primop_rule SeqOp = one_rule seqRule
68 primop_rule TagToEnumOp = one_rule tagToEnumRule
69 primop_rule DataToTagOp = one_rule dataToTagRule
72 primop_rule IntAddOp = one_rule (twoLits (intOp2 (+)))
73 primop_rule IntSubOp = one_rule (twoLits (intOp2 (-)))
74 primop_rule IntMulOp = one_rule (twoLits (intOp2 (*)))
75 primop_rule IntQuotOp = one_rule (twoLits (intOp2Z quot))
76 primop_rule IntRemOp = one_rule (twoLits (intOp2Z rem))
77 primop_rule IntNegOp = one_rule (oneLit negOp)
80 #if __GLASGOW_HASKELL__ >= 500
81 primop_rule WordAddOp = one_rule (twoLits (wordOp2 (+)))
82 primop_rule WordSubOp = one_rule (twoLits (wordOp2 (-)))
83 primop_rule WordMulOp = one_rule (twoLits (wordOp2 (*)))
85 primop_rule WordQuotOp = one_rule (twoLits (wordOp2Z quot))
86 primop_rule WordRemOp = one_rule (twoLits (wordOp2Z rem))
87 #if __GLASGOW_HASKELL__ >= 407
88 primop_rule AndOp = one_rule (twoLits (wordBitOp2 (.&.)))
89 primop_rule OrOp = one_rule (twoLits (wordBitOp2 (.|.)))
90 primop_rule XorOp = one_rule (twoLits (wordBitOp2 xor))
94 primop_rule Word2IntOp = one_rule (oneLit (litCoerce word2IntLit))
95 primop_rule Int2WordOp = one_rule (oneLit (litCoerce int2WordLit))
96 primop_rule Narrow8IntOp = one_rule (oneLit (litCoerce narrow8IntLit))
97 primop_rule Narrow16IntOp = one_rule (oneLit (litCoerce narrow16IntLit))
98 primop_rule Narrow32IntOp = one_rule (oneLit (litCoerce narrow32IntLit))
99 primop_rule Narrow8WordOp = one_rule (oneLit (litCoerce narrow8WordLit))
100 primop_rule Narrow16WordOp = one_rule (oneLit (litCoerce narrow16WordLit))
101 primop_rule Narrow32WordOp = one_rule (oneLit (litCoerce narrow32WordLit))
102 primop_rule OrdOp = one_rule (oneLit (litCoerce char2IntLit))
103 primop_rule ChrOp = one_rule (oneLit (litCoerce int2CharLit))
104 primop_rule Float2IntOp = one_rule (oneLit (litCoerce float2IntLit))
105 primop_rule Int2FloatOp = one_rule (oneLit (litCoerce int2FloatLit))
106 primop_rule Double2IntOp = one_rule (oneLit (litCoerce double2IntLit))
107 primop_rule Int2DoubleOp = one_rule (oneLit (litCoerce int2DoubleLit))
108 -- SUP: Not sure what the standard says about precision in the following 2 cases
109 primop_rule Float2DoubleOp = one_rule (oneLit (litCoerce float2DoubleLit))
110 primop_rule Double2FloatOp = one_rule (oneLit (litCoerce double2FloatLit))
113 primop_rule FloatAddOp = one_rule (twoLits (floatOp2 (+)))
114 primop_rule FloatSubOp = one_rule (twoLits (floatOp2 (-)))
115 primop_rule FloatMulOp = one_rule (twoLits (floatOp2 (*)))
116 primop_rule FloatDivOp = one_rule (twoLits (floatOp2Z (/)))
117 primop_rule FloatNegOp = one_rule (oneLit negOp)
120 primop_rule DoubleAddOp = one_rule (twoLits (doubleOp2 (+)))
121 primop_rule DoubleSubOp = one_rule (twoLits (doubleOp2 (-)))
122 primop_rule DoubleMulOp = one_rule (twoLits (doubleOp2 (*)))
123 primop_rule DoubleDivOp = one_rule (twoLits (doubleOp2Z (/)))
124 primop_rule DoubleNegOp = one_rule (oneLit negOp)
126 -- Relational operators
127 primop_rule IntEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
128 primop_rule IntNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
129 primop_rule CharEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)]
130 primop_rule CharNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)]
132 primop_rule IntGtOp = one_rule (relop (>))
133 primop_rule IntGeOp = one_rule (relop (>=))
134 primop_rule IntLeOp = one_rule (relop (<=))
135 primop_rule IntLtOp = one_rule (relop (<))
137 primop_rule CharGtOp = one_rule (relop (>))
138 primop_rule CharGeOp = one_rule (relop (>=))
139 primop_rule CharLeOp = one_rule (relop (<=))
140 primop_rule CharLtOp = one_rule (relop (<))
142 primop_rule FloatGtOp = one_rule (relop (>))
143 primop_rule FloatGeOp = one_rule (relop (>=))
144 primop_rule FloatLeOp = one_rule (relop (<=))
145 primop_rule FloatLtOp = one_rule (relop (<))
146 primop_rule FloatEqOp = one_rule (relop (==))
147 primop_rule FloatNeOp = one_rule (relop (/=))
149 primop_rule DoubleGtOp = one_rule (relop (>))
150 primop_rule DoubleGeOp = one_rule (relop (>=))
151 primop_rule DoubleLeOp = one_rule (relop (<=))
152 primop_rule DoubleLtOp = one_rule (relop (<))
153 primop_rule DoubleEqOp = one_rule (relop (==))
154 primop_rule DoubleNeOp = one_rule (relop (/=))
156 primop_rule WordGtOp = one_rule (relop (>))
157 primop_rule WordGeOp = one_rule (relop (>=))
158 primop_rule WordLeOp = one_rule (relop (<=))
159 primop_rule WordLtOp = one_rule (relop (<))
160 primop_rule WordEqOp = one_rule (relop (==))
161 primop_rule WordNeOp = one_rule (relop (/=))
163 primop_rule other = []
166 relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ))
167 -- Cunning. cmpOp compares the values to give an Ordering.
168 -- It applies its argument to that ordering value to turn
169 -- the ordering into a boolean value. (`cmp` EQ) is just the job.
172 %************************************************************************
174 \subsection{Doing the business}
176 %************************************************************************
180 In all these operations we might find a LitLit as an operand; that's
181 why we have the catch-all Nothing case.
184 --------------------------
185 litCoerce :: (Literal -> Literal) -> Literal -> Maybe CoreExpr
186 litCoerce fn lit | isLitLitLit lit = Nothing
187 | otherwise = Just (Lit (fn lit))
189 --------------------------
190 cmpOp :: (Ordering -> Bool) -> Literal -> Literal -> Maybe CoreExpr
194 done res | cmp res = Just trueVal
195 | otherwise = Just falseVal
197 -- These compares are at different types
198 go (MachChar i1) (MachChar i2) = done (i1 `compare` i2)
199 go (MachInt i1) (MachInt i2) = done (i1 `compare` i2)
200 go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2)
201 go (MachWord i1) (MachWord i2) = done (i1 `compare` i2)
202 go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
203 go (MachFloat i1) (MachFloat i2) = done (i1 `compare` i2)
204 go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
207 --------------------------
209 negOp (MachFloat f) = Just (mkFloatVal (-f))
210 negOp (MachDouble d) = Just (mkDoubleVal (-d))
211 negOp (MachInt i) = intResult (-i)
214 --------------------------
215 intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2)
216 intOp2 op l1 l2 = Nothing -- Could find LitLit
218 intOp2Z op (MachInt i1) (MachInt i2)
219 | i2 /= 0 = Just (mkIntVal (i1 `op` i2))
220 intOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
222 --------------------------
223 #if __GLASGOW_HASKELL__ >= 500
224 wordOp2 op (MachWord w1) (MachWord w2)
225 = wordResult (w1 `op` w2)
226 wordOp2 op l1 l2 = Nothing -- Could find LitLit
229 wordOp2Z op (MachWord w1) (MachWord w2)
230 | w2 /= 0 = Just (mkWordVal (w1 `op` w2))
231 wordOp2Z op l1 l2 = Nothing -- LitLit or zero dividend
233 #if __GLASGOW_HASKELL__ >= 500
234 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
235 = Just (mkWordVal (w1 `op` w2))
237 -- Integer is not an instance of Bits, so we operate on Word64
238 wordBitOp2 op l1@(MachWord w1) l2@(MachWord w2)
239 = Just (mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
241 wordBitOp2 op l1 l2 = Nothing -- Could find LitLit
243 --------------------------
244 floatOp2 op (MachFloat f1) (MachFloat f2)
245 = Just (mkFloatVal (f1 `op` f2))
246 floatOp2 op l1 l2 = Nothing
248 floatOp2Z op (MachFloat f1) (MachFloat f2)
249 | f2 /= 0 = Just (mkFloatVal (f1 `op` f2))
250 floatOp2Z op l1 l2 = Nothing
252 --------------------------
253 doubleOp2 op (MachDouble f1) (MachDouble f2)
254 = Just (mkDoubleVal (f1 `op` f2))
255 doubleOp2 op l1 l2 = Nothing
257 doubleOp2Z op (MachDouble f1) (MachDouble f2)
258 | f2 /= 0 = Just (mkDoubleVal (f1 `op` f2))
259 doubleOp2Z op l1 l2 = Nothing
262 --------------------------
270 -- This is a Good Thing, because it allows case-of case things
271 -- to happen, and case-default absorption to happen. For
274 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
280 -- (modulo the usual precautions to avoid duplicating e1)
282 litEq :: Bool -- True <=> equality, False <=> inequality
284 litEq is_eq [Lit lit, expr] = do_lit_eq is_eq lit expr
285 litEq is_eq [expr, Lit lit] = do_lit_eq is_eq lit expr
286 litEq is_eq other = Nothing
288 do_lit_eq is_eq lit expr
289 = Just (Case expr (mkWildId (literalType lit))
290 [(DEFAULT, [], val_if_neq),
291 (LitAlt lit, [], val_if_eq)])
293 val_if_eq | is_eq = trueVal
294 | otherwise = falseVal
295 val_if_neq | is_eq = falseVal
296 | otherwise = trueVal
298 -- Note that we *don't* warn the user about overflow. It's not done at
299 -- runtime either, and compilation of completely harmless things like
300 -- ((124076834 :: Word32) + (2147483647 :: Word32))
301 -- would yield a warning. Instead we simply squash the value into the
302 -- Int range, but not in a way suitable for cross-compiling... :-(
303 intResult :: Integer -> Maybe CoreExpr
305 = Just (mkIntVal (toInteger (fromInteger result :: Int)))
307 #if __GLASGOW_HASKELL__ >= 500
308 wordResult :: Integer -> Maybe CoreExpr
310 = Just (mkWordVal (toInteger (fromInteger result :: Word)))
315 %************************************************************************
317 \subsection{Vaguely generic functions
319 %************************************************************************
322 type RuleFun = [CoreExpr] -> Maybe CoreExpr
324 twoLits :: (Literal -> Literal -> Maybe CoreExpr) -> RuleFun
325 twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
326 twoLits rule _ = Nothing
328 oneLit :: (Literal -> Maybe CoreExpr) -> RuleFun
329 oneLit rule [Lit l1] = rule (convFloating l1)
330 oneLit rule _ = Nothing
332 -- When excess precision is not requested, cut down the precision of the
333 -- Rational value to that of Float/Double. We confuse host architecture
334 -- and target architecture here, but it's convenient (and wrong :-).
335 convFloating :: Literal -> Literal
336 convFloating (MachFloat f) | not opt_SimplExcessPrecision =
337 MachFloat (toRational ((fromRational f) :: Float ))
338 convFloating (MachDouble d) | not opt_SimplExcessPrecision =
339 MachDouble (toRational ((fromRational d) :: Double))
343 trueVal = Var trueDataConId
344 falseVal = Var falseDataConId
345 mkIntVal i = Lit (mkMachInt i)
346 mkWordVal w = Lit (mkMachWord w)
347 mkFloatVal f = Lit (convFloating (MachFloat f))
348 mkDoubleVal d = Lit (convFloating (MachDouble d))
352 nullAddrRule _ = Just(Lit nullAddrLit)
356 %************************************************************************
358 \subsection{Special rules for seq, tagToEnum, dataToTag}
360 %************************************************************************
362 In the parallel world, we use _seq_ to control the order in which
363 certain expressions will be evaluated. Operationally, the expression
364 ``_seq_ a b'' evaluates a and then evaluates b. We have an inlining
365 for _seq_ which translates _seq_ to:
367 _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }
369 Now, we know that the seq# primitive will never return 0#, but we
370 don't let the simplifier know that. We also use a special error
371 value, parError#, which is *not* a bottoming Id, so as far as the
372 simplifier is concerned, we have to evaluate seq# a before we know
373 whether or not y will be evaluated.
375 If we didn't have the extra case, then after inlining the compiler might
377 f p q = case seq# p of { _ -> p+q }
379 If it sees that, it can see that f is strict in q, and hence it might
380 evaluate q before p! The "0# ->" case prevents this happening.
381 By having the parError# branch we make sure that anything in the
382 other branch stays there!
384 This is fine, but we'd like to get rid of the extraneous code. Hence,
385 we *do* let the simplifier know that seq# is strict in its argument.
386 As a result, we hope that `a' will be evaluated before seq# is called.
387 At this point, we have a very special and magical simpification which
388 says that ``seq# a'' can be immediately simplified to `1#' if we
389 know that `a' is already evaluated.
391 NB: If we ever do case-floating, we have an extra worry:
394 a' -> let b' = case seq# a of { True -> b; False -> parError# }
400 a' -> let b' = case True of { True -> b; False -> parError# }
414 The second case must never be floated outside of the first!
417 seqRule [Type ty, arg] | exprIsValue arg = Just (mkIntVal 1)
418 seqRule other = Nothing
423 tagToEnumRule [Type ty, Lit (MachInt i)]
424 = ASSERT( isEnumerationTyCon tycon )
425 case filter correct_tag (tyConDataConsIfAvailable tycon) of
428 [] -> Nothing -- Abstract type
429 (dc:rest) -> ASSERT( null rest )
430 Just (Var (dataConId dc))
432 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
434 tycon = tyConAppTyCon ty
436 tagToEnumRule other = Nothing
439 For dataToTag#, we can reduce if either
441 (a) the argument is a constructor
442 (b) the argument is a variable whose unfolding is a known constructor
445 dataToTagRule [_, val_arg]
446 = case exprIsConApp_maybe val_arg of
447 Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
448 Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))
452 dataToTagRule other = Nothing
455 %************************************************************************
457 \subsection{Built in rules}
459 %************************************************************************
462 builtinRules :: [(Name, CoreRule)]
463 -- Rules for non-primops that can't be expressed using a RULE pragma
465 = [ (unpackCStringFoldrName, BuiltinRule SLIT("AppendLitString") match_append_lit_str)
470 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) = unpackFoldrCString# "foobaz" c n
472 match_append_lit_str [Type ty1,
475 Var unpk `App` Type ty2
476 `App` Lit (MachStr s2)
480 | unpk `hasKey` unpackCStringFoldrIdKey &&
482 = ASSERT( ty1 `eqType` ty2 )
483 Just (Var unpk `App` Type ty1
484 `App` Lit (MachStr (s1 _APPEND_ s2))
488 match_append_lit_str other = Nothing