Drop pre-AMP compatibility CPP conditionals
[ghc.git] / compiler / prelude / PrelRules.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[ConFold]{Constant Folder}
5
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...
9
10 ToDo:
11 check boundaries before folding, e.g. we can fold the Float addition
12 (i1 + i2) only if it results in a valid Float.
13 -}
14
15 {-# LANGUAGE CPP, RankNTypes #-}
16 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
17
18 module PrelRules ( primOpRules, builtinRules ) where
19
20 #include "HsVersions.h"
21 #include "../includes/MachDeps.h"
22
23 import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
24
25 import CoreSyn
26 import MkCore
27 import Id
28 import Literal
29 import CoreSubst ( exprIsLiteral_maybe )
30 import PrimOp ( PrimOp(..), tagToEnumKey )
31 import TysWiredIn
32 import TysPrim
33 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
34 import DataCon ( dataConTag, dataConTyCon, dataConWorkId )
35 import CoreUtils ( cheapEqExpr, exprIsHNF )
36 import CoreUnfold ( exprIsConApp_maybe )
37 import Type
38 import OccName ( occNameFS )
39 import PrelNames
40 import Maybes ( orElse )
41 import Name ( Name, nameOccName )
42 import Outputable
43 import FastString
44 import BasicTypes
45 import DynFlags
46 import Platform
47 import Util
48 import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
49
50 import Control.Applicative ( Alternative(..) )
51
52 import Control.Monad
53 #if __GLASGOW_HASKELL__ > 710
54 import qualified Control.Monad.Fail as MonadFail
55 #endif
56 import Data.Bits as Bits
57 import qualified Data.ByteString as BS
58 import Data.Int
59 import Data.Ratio
60 import Data.Word
61
62 {-
63 Note [Constant folding]
64 ~~~~~~~~~~~~~~~~~~~~~~~
65 primOpRules generates a rewrite rule for each primop
66 These rules do what is often called "constant folding"
67 E.g. the rules for +# might say
68 4 +# 5 = 9
69 Well, of course you'd need a lot of rules if you did it
70 like that, so we use a BuiltinRule instead, so that we
71 can match in any two literal values. So the rule is really
72 more like
73 (Lit x) +# (Lit y) = Lit (x+#y)
74 where the (+#) on the rhs is done at compile time
75
76 That is why these rules are built in here.
77 -}
78
79 primOpRules :: Name -> PrimOp -> Maybe CoreRule
80 -- ToDo: something for integer-shift ops?
81 -- NotOp
82 primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
83 primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
84
85 -- Int operations
86 primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
87 , identityDynFlags zeroi ]
88 primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
89 , rightIdentityDynFlags zeroi
90 , equalArgs >> retLit zeroi ]
91 primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
92 , zeroElem zeroi
93 , identityDynFlags onei ]
94 primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
95 , leftZero zeroi
96 , rightIdentityDynFlags onei
97 , equalArgs >> retLit onei ]
98 primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
99 , leftZero zeroi
100 , do l <- getLiteral 1
101 dflags <- getDynFlags
102 guard (l == onei dflags)
103 retLit zeroi
104 , equalArgs >> retLit zeroi
105 , equalArgs >> retLit zeroi ]
106 primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
107 , idempotent
108 , zeroElem zeroi ]
109 primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
110 , idempotent
111 , identityDynFlags zeroi ]
112 primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
113 , identityDynFlags zeroi
114 , equalArgs >> retLit zeroi ]
115 primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp
116 , inversePrimOp NotIOp ]
117 primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
118 , inversePrimOp IntNegOp ]
119 primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
120 , rightIdentityDynFlags zeroi ]
121 primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
122 , rightIdentityDynFlags zeroi ]
123 primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
124 , rightIdentityDynFlags zeroi ]
125
126 -- Word operations
127 primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
128 , identityDynFlags zerow ]
129 primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
130 , rightIdentityDynFlags zerow
131 , equalArgs >> retLit zerow ]
132 primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
133 , identityDynFlags onew ]
134 primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
135 , rightIdentityDynFlags onew ]
136 primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
137 , rightIdentityDynFlags onew ]
138 primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
139 , idempotent
140 , zeroElem zerow ]
141 primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
142 , idempotent
143 , identityDynFlags zerow ]
144 primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
145 , identityDynFlags zerow
146 , equalArgs >> retLit zerow ]
147 primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp
148 , inversePrimOp NotOp ]
149 primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
150 primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
151
152 -- coercions
153 primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
154 , inversePrimOp Int2WordOp ]
155 primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
156 , inversePrimOp Word2IntOp ]
157 primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
158 , subsumedByPrimOp Narrow8IntOp
159 , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
160 , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
161 primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
162 , subsumedByPrimOp Narrow8IntOp
163 , subsumedByPrimOp Narrow16IntOp
164 , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
165 primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
166 , subsumedByPrimOp Narrow8IntOp
167 , subsumedByPrimOp Narrow16IntOp
168 , subsumedByPrimOp Narrow32IntOp
169 , removeOp32 ]
170 primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
171 , subsumedByPrimOp Narrow8WordOp
172 , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
173 , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
174 primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
175 , subsumedByPrimOp Narrow8WordOp
176 , subsumedByPrimOp Narrow16WordOp
177 , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
178 primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
179 , subsumedByPrimOp Narrow8WordOp
180 , subsumedByPrimOp Narrow16WordOp
181 , subsumedByPrimOp Narrow32WordOp
182 , removeOp32 ]
183 primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit
184 , inversePrimOp ChrOp ]
185 primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
186 guard (litFitsInChar lit)
187 liftLit int2CharLit
188 , inversePrimOp OrdOp ]
189 primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
190 primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
191 primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
192 primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
193 -- SUP: Not sure what the standard says about precision in the following 2 cases
194 primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
195 primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
196
197 -- Float
198 primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
199 , identity zerof ]
200 primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
201 , rightIdentity zerof ]
202 primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
203 , identity onef
204 , strengthReduction twof FloatAddOp ]
205 -- zeroElem zerof doesn't hold because of NaN
206 primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
207 , rightIdentity onef ]
208 primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
209 , inversePrimOp FloatNegOp ]
210
211 -- Double
212 primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
213 , identity zerod ]
214 primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
215 , rightIdentity zerod ]
216 primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
217 , identity oned
218 , strengthReduction twod DoubleAddOp ]
219 -- zeroElem zerod doesn't hold because of NaN
220 primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
221 , rightIdentity oned ]
222 primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
223 , inversePrimOp DoubleNegOp ]
224
225 -- Relational operators
226
227 primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ]
228 primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ]
229 primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ]
230 primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ]
231
232 primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
233 primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
234 primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
235 primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
236
237 primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
238 primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
239 primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
240 primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
241
242 primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>)
243 primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=)
244 primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=)
245 primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<)
246 primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==)
247 primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=)
248
249 primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)
250 primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)
251 primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)
252 primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)
253 primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)
254 primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
255
256 primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
257 primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
258 primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
259 primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
260 primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ]
261 primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ]
262
263 primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]
264
265 primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ]
266 primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ]
267
268 primOpRules _ _ = Nothing
269
270 {-
271 ************************************************************************
272 * *
273 \subsection{Doing the business}
274 * *
275 ************************************************************************
276 -}
277
278 -- useful shorthands
279 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
280 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
281
282 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
283 -> [RuleM CoreExpr] -> Maybe CoreRule
284 mkRelOpRule nm cmp extra
285 = mkPrimOpRule nm 2 $
286 binaryCmpLit cmp : equal_rule : extra
287 where
288 -- x `cmp` x does not depend on x, so
289 -- compute it for the arbitrary value 'True'
290 -- and use that result
291 equal_rule = do { equalArgs
292 ; dflags <- getDynFlags
293 ; return (if cmp True True
294 then trueValInt dflags
295 else falseValInt dflags) }
296
297 {- Note [Rules for floating-point comparisons]
298 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
299 We need different rules for floating-point values because for floats
300 it is not true that x = x (for NaNs); so we do not want the equal_rule
301 rule that mkRelOpRule uses.
302
303 Note also that, in the case of equality/inequality, we do /not/
304 want to switch to a case-expression. For example, we do not want
305 to convert
306 case (eqFloat# x 3.8#) of
307 True -> this
308 False -> that
309 to
310 case x of
311 3.8#::Float# -> this
312 _ -> that
313 See Trac #9238. Reason: comparing floating-point values for equality
314 delicate, and we don't want to implement that delicacy in the code for
315 case expressions. So we make it an invariant of Core that a case
316 expression never scrutinises a Float# or Double#.
317
318 This transformation is what the litEq rule does;
319 see Note [The litEq rule: converting equality to case].
320 So we /refrain/ from using litEq for mkFloatingRelOpRule.
321 -}
322
323 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
324 -> Maybe CoreRule
325 -- See Note [Rules for floating-point comparisons]
326 mkFloatingRelOpRule nm cmp
327 = mkPrimOpRule nm 2 [binaryCmpLit cmp]
328
329 -- common constants
330 zeroi, onei, zerow, onew :: DynFlags -> Literal
331 zeroi dflags = mkMachInt dflags 0
332 onei dflags = mkMachInt dflags 1
333 zerow dflags = mkMachWord dflags 0
334 onew dflags = mkMachWord dflags 1
335
336 zerof, onef, twof, zerod, oned, twod :: Literal
337 zerof = mkMachFloat 0.0
338 onef = mkMachFloat 1.0
339 twof = mkMachFloat 2.0
340 zerod = mkMachDouble 0.0
341 oned = mkMachDouble 1.0
342 twod = mkMachDouble 2.0
343
344 cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
345 -> Literal -> Literal -> Maybe CoreExpr
346 cmpOp dflags cmp = go
347 where
348 done True = Just $ trueValInt dflags
349 done False = Just $ falseValInt dflags
350
351 -- These compares are at different types
352 go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
353 go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2)
354 go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2)
355 go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2)
356 go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
357 go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2)
358 go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
359 go _ _ = Nothing
360
361 --------------------------
362
363 negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate
364 negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
365 negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f))
366 negOp _ (MachDouble 0.0) = Nothing
367 negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d))
368 negOp dflags (MachInt i) = intResult dflags (-i)
369 negOp _ _ = Nothing
370
371 complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement
372 complementOp dflags (MachWord i) = wordResult dflags (complement i)
373 complementOp dflags (MachInt i) = intResult dflags (complement i)
374 complementOp _ _ = Nothing
375
376 --------------------------
377 intOp2 :: (Integral a, Integral b)
378 => (a -> b -> Integer)
379 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
380 intOp2 = intOp2' . const
381
382 intOp2' :: (Integral a, Integral b)
383 => (DynFlags -> a -> b -> Integer)
384 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
385 intOp2' op dflags (MachInt i1) (MachInt i2) =
386 let o = op dflags
387 in intResult dflags (fromInteger i1 `o` fromInteger i2)
388 intOp2' _ _ _ _ = Nothing -- Could find LitLit
389
390 shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
391 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
392 -- Do this by converting to Word and back. Obviously this won't work for big
393 -- values, but its ok as we use it here
394 shiftRightLogical dflags x n
395 | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)
396 | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)
397 | otherwise = panic "shiftRightLogical: unsupported word size"
398
399 --------------------------
400 retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
401 retLit l = do dflags <- getDynFlags
402 return $ Lit $ l dflags
403
404 wordOp2 :: (Integral a, Integral b)
405 => (a -> b -> Integer)
406 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
407 wordOp2 op dflags (MachWord w1) (MachWord w2)
408 = wordResult dflags (fromInteger w1 `op` fromInteger w2)
409 wordOp2 _ _ _ _ = Nothing -- Could find LitLit
410
411 wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
412 -- Shifts take an Int; hence third arg of op is Int
413 -- See Note [Guarding against silly shifts]
414 wordShiftRule shift_op
415 = do { dflags <- getDynFlags
416 ; [e1, Lit (MachInt shift_len)] <- getArgs
417 ; case e1 of
418 _ | shift_len == 0
419 -> return e1
420 | shift_len < 0 || wordSizeInBits dflags < shift_len
421 -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
422 ("Bad shift length" ++ show shift_len))
423 Lit (MachWord x)
424 -> let op = shift_op dflags
425 in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
426 -- Do the shift at type Integer, but shift length is Int
427 _ -> mzero }
428
429 wordSizeInBits :: DynFlags -> Integer
430 wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
431
432 --------------------------
433 floatOp2 :: (Rational -> Rational -> Rational)
434 -> DynFlags -> Literal -> Literal
435 -> Maybe (Expr CoreBndr)
436 floatOp2 op dflags (MachFloat f1) (MachFloat f2)
437 = Just (mkFloatVal dflags (f1 `op` f2))
438 floatOp2 _ _ _ _ = Nothing
439
440 --------------------------
441 doubleOp2 :: (Rational -> Rational -> Rational)
442 -> DynFlags -> Literal -> Literal
443 -> Maybe (Expr CoreBndr)
444 doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
445 = Just (mkDoubleVal dflags (f1 `op` f2))
446 doubleOp2 _ _ _ _ = Nothing
447
448 --------------------------
449 {- Note [The litEq rule: converting equality to case]
450 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
451 This stuff turns
452 n ==# 3#
453 into
454 case n of
455 3# -> True
456 m -> False
457
458 This is a Good Thing, because it allows case-of case things
459 to happen, and case-default absorption to happen. For
460 example:
461
462 if (n ==# 3#) || (n ==# 4#) then e1 else e2
463 will transform to
464 case n of
465 3# -> e1
466 4# -> e1
467 m -> e2
468 (modulo the usual precautions to avoid duplicating e1)
469 -}
470
471 litEq :: Bool -- True <=> equality, False <=> inequality
472 -> RuleM CoreExpr
473 litEq is_eq = msum
474 [ do [Lit lit, expr] <- getArgs
475 dflags <- getDynFlags
476 do_lit_eq dflags lit expr
477 , do [expr, Lit lit] <- getArgs
478 dflags <- getDynFlags
479 do_lit_eq dflags lit expr ]
480 where
481 do_lit_eq dflags lit expr = do
482 guard (not (litIsLifted lit))
483 return (mkWildCase expr (literalType lit) intPrimTy
484 [(DEFAULT, [], val_if_neq),
485 (LitAlt lit, [], val_if_eq)])
486 where
487 val_if_eq | is_eq = trueValInt dflags
488 | otherwise = falseValInt dflags
489 val_if_neq | is_eq = falseValInt dflags
490 | otherwise = trueValInt dflags
491
492
493 -- | Check if there is comparison with minBound or maxBound, that is
494 -- always true or false. For instance, an Int cannot be smaller than its
495 -- minBound, so we can replace such comparison with False.
496 boundsCmp :: Comparison -> RuleM CoreExpr
497 boundsCmp op = do
498 dflags <- getDynFlags
499 [a, b] <- getArgs
500 liftMaybe $ mkRuleFn dflags op a b
501
502 data Comparison = Gt | Ge | Lt | Le
503
504 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
505 mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
506 mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
507 mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
508 mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
509 mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
510 mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
511 mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
512 mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
513 mkRuleFn _ _ _ _ = Nothing
514
515 isMinBound :: DynFlags -> Literal -> Bool
516 isMinBound _ (MachChar c) = c == minBound
517 isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags
518 isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64)
519 isMinBound _ (MachWord i) = i == 0
520 isMinBound _ (MachWord64 i) = i == 0
521 isMinBound _ _ = False
522
523 isMaxBound :: DynFlags -> Literal -> Bool
524 isMaxBound _ (MachChar c) = c == maxBound
525 isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags
526 isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64)
527 isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags
528 isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64)
529 isMaxBound _ _ = False
530
531
532 -- Note that we *don't* warn the user about overflow. It's not done at
533 -- runtime either, and compilation of completely harmless things like
534 -- ((124076834 :: Word32) + (2147483647 :: Word32))
535 -- would yield a warning. Instead we simply squash the value into the
536 -- *target* Int/Word range.
537 intResult :: DynFlags -> Integer -> Maybe CoreExpr
538 intResult dflags result = Just (mkIntVal dflags result')
539 where result' = case platformWordSize (targetPlatform dflags) of
540 4 -> toInteger (fromInteger result :: Int32)
541 8 -> toInteger (fromInteger result :: Int64)
542 w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
543
544 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
545 wordResult dflags result = Just (mkWordVal dflags result')
546 where result' = case platformWordSize (targetPlatform dflags) of
547 4 -> toInteger (fromInteger result :: Word32)
548 8 -> toInteger (fromInteger result :: Word64)
549 w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
550
551 inversePrimOp :: PrimOp -> RuleM CoreExpr
552 inversePrimOp primop = do
553 [Var primop_id `App` e] <- getArgs
554 matchPrimOpId primop primop_id
555 return e
556
557 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
558 this `subsumesPrimOp` that = do
559 [Var primop_id `App` e] <- getArgs
560 matchPrimOpId that primop_id
561 return (Var (mkPrimOpId this) `App` e)
562
563 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
564 subsumedByPrimOp primop = do
565 [e@(Var primop_id `App` _)] <- getArgs
566 matchPrimOpId primop primop_id
567 return e
568
569 idempotent :: RuleM CoreExpr
570 idempotent = do [e1, e2] <- getArgs
571 guard $ cheapEqExpr e1 e2
572 return e1
573
574 {-
575 Note [Guarding against silly shifts]
576 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
577 Consider this code:
578
579 import Data.Bits( (.|.), shiftL )
580 chunkToBitmap :: [Bool] -> Word32
581 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
582
583 This optimises to:
584 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
585 case w1_sCT of _ {
586 [] -> 0##;
587 : x_aAW xs_aAX ->
588 case x_aAW of _ {
589 GHC.Types.False ->
590 case w_sCS of wild2_Xh {
591 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
592 9223372036854775807 -> 0## };
593 GHC.Types.True ->
594 case GHC.Prim.>=# w_sCS 64 of _ {
595 GHC.Types.False ->
596 case w_sCS of wild3_Xh {
597 __DEFAULT ->
598 case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
599 GHC.Prim.or# (GHC.Prim.narrow32Word#
600 (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
601 ww_sCW
602 };
603 9223372036854775807 ->
604 GHC.Prim.narrow32Word#
605 !!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
606 };
607 GHC.Types.True ->
608 case w_sCS of wild3_Xh {
609 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
610 9223372036854775807 -> 0##
611 } } } }
612
613 Note the massive shift on line "!!!!". It can't happen, because we've checked
614 that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
615 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
616 can't constant fold it, but if it gets to the assember we get
617 Error: operand type mismatch for `shl'
618
619 So the best thing to do is to rewrite the shift with a call to error,
620 when the second arg is stupid.
621
622 ************************************************************************
623 * *
624 \subsection{Vaguely generic functions}
625 * *
626 ************************************************************************
627 -}
628
629 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
630 -- Gives the Rule the same name as the primop itself
631 mkBasicRule op_name n_args rm
632 = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
633 ru_fn = op_name,
634 ru_nargs = n_args,
635 ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
636
637 newtype RuleM r = RuleM
638 { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
639
640 instance Functor RuleM where
641 fmap = liftM
642
643 instance Applicative RuleM where
644 pure x = RuleM $ \_ _ _ -> Just x
645 (<*>) = ap
646
647 instance Monad RuleM where
648 return = pure
649 RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
650 Nothing -> Nothing
651 Just r -> runRuleM (g r) dflags iu e
652 fail _ = mzero
653
654 #if __GLASGOW_HASKELL__ > 710
655 instance MonadFail.MonadFail RuleM where
656 fail _ = mzero
657 #endif
658
659 instance Alternative RuleM where
660 empty = mzero
661 (<|>) = mplus
662
663 instance MonadPlus RuleM where
664 mzero = RuleM $ \_ _ _ -> Nothing
665 mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
666 f1 dflags iu args `mplus` f2 dflags iu args
667
668 instance HasDynFlags RuleM where
669 getDynFlags = RuleM $ \dflags _ _ -> Just dflags
670
671 liftMaybe :: Maybe a -> RuleM a
672 liftMaybe Nothing = mzero
673 liftMaybe (Just x) = return x
674
675 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
676 liftLit f = liftLitDynFlags (const f)
677
678 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
679 liftLitDynFlags f = do
680 dflags <- getDynFlags
681 [Lit lit] <- getArgs
682 return $ Lit (f dflags lit)
683
684 removeOp32 :: RuleM CoreExpr
685 removeOp32 = do
686 dflags <- getDynFlags
687 if wordSizeInBits dflags == 32
688 then do
689 [e] <- getArgs
690 return e
691 else mzero
692
693 getArgs :: RuleM [CoreExpr]
694 getArgs = RuleM $ \_ _ args -> Just args
695
696 getInScopeEnv :: RuleM InScopeEnv
697 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
698
699 -- return the n-th argument of this rule, if it is a literal
700 -- argument indices start from 0
701 getLiteral :: Int -> RuleM Literal
702 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
703 (Lit l:_) -> Just l
704 _ -> Nothing
705
706 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
707 unaryLit op = do
708 dflags <- getDynFlags
709 [Lit l] <- getArgs
710 liftMaybe $ op dflags (convFloating dflags l)
711
712 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
713 binaryLit op = do
714 dflags <- getDynFlags
715 [Lit l1, Lit l2] <- getArgs
716 liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
717
718 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
719 binaryCmpLit op = do
720 dflags <- getDynFlags
721 binaryLit (\_ -> cmpOp dflags op)
722
723 leftIdentity :: Literal -> RuleM CoreExpr
724 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
725
726 rightIdentity :: Literal -> RuleM CoreExpr
727 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
728
729 identity :: Literal -> RuleM CoreExpr
730 identity lit = leftIdentity lit `mplus` rightIdentity lit
731
732 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
733 leftIdentityDynFlags id_lit = do
734 dflags <- getDynFlags
735 [Lit l1, e2] <- getArgs
736 guard $ l1 == id_lit dflags
737 return e2
738
739 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
740 rightIdentityDynFlags id_lit = do
741 dflags <- getDynFlags
742 [e1, Lit l2] <- getArgs
743 guard $ l2 == id_lit dflags
744 return e1
745
746 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
747 identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
748
749 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
750 leftZero zero = do
751 dflags <- getDynFlags
752 [Lit l1, _] <- getArgs
753 guard $ l1 == zero dflags
754 return $ Lit l1
755
756 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
757 rightZero zero = do
758 dflags <- getDynFlags
759 [_, Lit l2] <- getArgs
760 guard $ l2 == zero dflags
761 return $ Lit l2
762
763 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
764 zeroElem lit = leftZero lit `mplus` rightZero lit
765
766 equalArgs :: RuleM ()
767 equalArgs = do
768 [e1, e2] <- getArgs
769 guard $ e1 `cheapEqExpr` e2
770
771 nonZeroLit :: Int -> RuleM ()
772 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
773
774 -- When excess precision is not requested, cut down the precision of the
775 -- Rational value to that of Float/Double. We confuse host architecture
776 -- and target architecture here, but it's convenient (and wrong :-).
777 convFloating :: DynFlags -> Literal -> Literal
778 convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) =
779 MachFloat (toRational (fromRational f :: Float ))
780 convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
781 MachDouble (toRational (fromRational d :: Double))
782 convFloating _ l = l
783
784 guardFloatDiv :: RuleM ()
785 guardFloatDiv = do
786 [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
787 guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
788 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
789
790 guardDoubleDiv :: RuleM ()
791 guardDoubleDiv = do
792 [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
793 guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
794 && d2 /= 0 -- avoid NaN and Infinity/-Infinity
795 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
796 -- zero, but we might want to preserve the negative zero here which
797 -- is representable in Float/Double but not in (normalised)
798 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
799
800 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
801 strengthReduction two_lit add_op = do -- Note [Strength reduction]
802 arg <- msum [ do [arg, Lit mult_lit] <- getArgs
803 guard (mult_lit == two_lit)
804 return arg
805 , do [Lit mult_lit, arg] <- getArgs
806 guard (mult_lit == two_lit)
807 return arg ]
808 return $ Var (mkPrimOpId add_op) `App` arg `App` arg
809
810 -- Note [Strength reduction]
811 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
812 --
813 -- This rule turns floating point multiplications of the form 2.0 * x and
814 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
815 -- See #7116
816
817 -- Note [What's true and false]
818 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
819 --
820 -- trueValInt and falseValInt represent true and false values returned by
821 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
822 -- True is represented as an unboxed 1# literal, while false is represented
823 -- as 0# literal.
824 -- We still need Bool data constructors (True and False) to use in a rule
825 -- for constant folding of equal Strings
826
827 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
828 trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
829 falseValInt dflags = Lit $ zeroi dflags
830
831 trueValBool, falseValBool :: Expr CoreBndr
832 trueValBool = Var trueDataConId -- see Note [What's true and false]
833 falseValBool = Var falseDataConId
834
835 ltVal, eqVal, gtVal :: Expr CoreBndr
836 ltVal = Var ltDataConId
837 eqVal = Var eqDataConId
838 gtVal = Var gtDataConId
839
840 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
841 mkIntVal dflags i = Lit (mkMachInt dflags i)
842 mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
843 mkWordVal dflags w = Lit (mkMachWord dflags w)
844 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
845 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f))
846 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
847 mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
848
849 matchPrimOpId :: PrimOp -> Id -> RuleM ()
850 matchPrimOpId op id = do
851 op' <- liftMaybe $ isPrimOpId_maybe id
852 guard $ op == op'
853
854 {-
855 ************************************************************************
856 * *
857 \subsection{Special rules for seq, tagToEnum, dataToTag}
858 * *
859 ************************************************************************
860
861 Note [tagToEnum#]
862 ~~~~~~~~~~~~~~~~~
863 Nasty check to ensure that tagToEnum# is applied to a type that is an
864 enumeration TyCon. Unification may refine the type later, but this
865 check won't see that, alas. It's crude but it works.
866
867 Here's are two cases that should fail
868 f :: forall a. a
869 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
870
871 g :: Int
872 g = tagToEnum# 0 -- Int is not an enumeration
873
874 We used to make this check in the type inference engine, but it's quite
875 ugly to do so, because the delayed constraint solving means that we don't
876 really know what's going on until the end. It's very much a corner case
877 because we don't expect the user to call tagToEnum# at all; we merely
878 generate calls in derived instances of Enum. So we compromise: a
879 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
880 and emits a warning.
881 -}
882
883 tagToEnumRule :: RuleM CoreExpr
884 -- If data T a = A | B | C
885 -- then tag2Enum# (T ty) 2# --> B ty
886 tagToEnumRule = do
887 [Type ty, Lit (MachInt i)] <- getArgs
888 case splitTyConApp_maybe ty of
889 Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
890 let tag = fromInteger i
891 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
892 (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
893 ASSERT(null rest) return ()
894 return $ mkTyApps (Var (dataConWorkId dc)) tc_args
895
896 -- See Note [tagToEnum#]
897 _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
898 return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
899
900 {-
901 For dataToTag#, we can reduce if either
902
903 (a) the argument is a constructor
904 (b) the argument is a variable whose unfolding is a known constructor
905 -}
906
907 dataToTagRule :: RuleM CoreExpr
908 dataToTagRule = a `mplus` b
909 where
910 a = do
911 [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
912 guard $ tag_to_enum `hasKey` tagToEnumKey
913 guard $ ty1 `eqType` ty2
914 return tag -- dataToTag (tagToEnum x) ==> x
915 b = do
916 dflags <- getDynFlags
917 [_, val_arg] <- getArgs
918 in_scope <- getInScopeEnv
919 (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
920 ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
921 return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
922
923 {-
924 ************************************************************************
925 * *
926 \subsection{Rules for seq# and spark#}
927 * *
928 ************************************************************************
929 -}
930
931 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
932 seqRule :: RuleM CoreExpr
933 seqRule = do
934 [Type ty_a, Type ty_s, a, s] <- getArgs
935 guard $ exprIsHNF a
936 return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]
937
938 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
939 sparkRule :: RuleM CoreExpr
940 sparkRule = seqRule -- reduce on HNF, just the same
941 -- XXX perhaps we shouldn't do this, because a spark eliminated by
942 -- this rule won't be counted as a dud at runtime?
943
944 {-
945 ************************************************************************
946 * *
947 \subsection{Built in rules}
948 * *
949 ************************************************************************
950
951 Note [Scoping for Builtin rules]
952 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
953 When compiling a (base-package) module that defines one of the
954 functions mentioned in the RHS of a built-in rule, there's a danger
955 that we'll see
956
957 f = ...(eq String x)....
958
959 ....and lower down...
960
961 eqString = ...
962
963 Then a rewrite would give
964
965 f = ...(eqString x)...
966 ....and lower down...
967 eqString = ...
968
969 and lo, eqString is not in scope. This only really matters when we get to code
970 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
971 set of bindings, which sorts out the dependency. Without -O we don't do any rule
972 rewriting so again we are fine.
973
974 (This whole thing doesn't show up for non-built-in rules because their dependencies
975 are explicit.)
976 -}
977
978 builtinRules :: [CoreRule]
979 -- Rules for non-primops that can't be expressed using a RULE pragma
980 builtinRules
981 = [BuiltinRule { ru_name = fsLit "AppendLitString",
982 ru_fn = unpackCStringFoldrName,
983 ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
984 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
985 ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
986 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
987 ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
988 BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
989 ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }
990 ]
991 ++ builtinIntegerRules
992
993 builtinIntegerRules :: [CoreRule]
994 builtinIntegerRules =
995 [rule_IntToInteger "smallInteger" smallIntegerName,
996 rule_WordToInteger "wordToInteger" wordToIntegerName,
997 rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
998 rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
999 rule_convert "integerToWord" integerToWordName mkWordLitWord,
1000 rule_convert "integerToInt" integerToIntName mkIntLitInt,
1001 rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64),
1002 rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64),
1003 rule_binop "plusInteger" plusIntegerName (+),
1004 rule_binop "minusInteger" minusIntegerName (-),
1005 rule_binop "timesInteger" timesIntegerName (*),
1006 rule_unop "negateInteger" negateIntegerName negate,
1007 rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
1008 rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
1009 rule_unop "absInteger" absIntegerName abs,
1010 rule_unop "signumInteger" signumIntegerName signum,
1011 rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
1012 rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
1013 rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
1014 rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
1015 rule_binop_Ordering "compareInteger" compareIntegerName compare,
1016 rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
1017 rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
1018 rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
1019 rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
1020 rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
1021 rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
1022 rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
1023 rule_binop "gcdInteger" gcdIntegerName gcd,
1024 rule_binop "lcmInteger" lcmIntegerName lcm,
1025 rule_binop "andInteger" andIntegerName (.&.),
1026 rule_binop "orInteger" orIntegerName (.|.),
1027 rule_binop "xorInteger" xorIntegerName xor,
1028 rule_unop "complementInteger" complementIntegerName complement,
1029 rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
1030 rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
1031 rule_bitInteger "bitInteger" bitIntegerName,
1032 -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
1033 rule_divop_one "quotInteger" quotIntegerName quot,
1034 rule_divop_one "remInteger" remIntegerName rem,
1035 rule_divop_one "divInteger" divIntegerName div,
1036 rule_divop_one "modInteger" modIntegerName mod,
1037 rule_divop_both "divModInteger" divModIntegerName divMod,
1038 rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
1039 -- These rules below don't actually have to be built in, but if we
1040 -- put them in the Haskell source then we'd have to duplicate them
1041 -- between all Integer implementations
1042 rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName,
1043 rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName,
1044 rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName,
1045 rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
1046 rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp,
1047 rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp,
1048 rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
1049 ]
1050 where rule_convert str name convert
1051 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1052 ru_try = match_Integer_convert convert }
1053 rule_IntToInteger str name
1054 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1055 ru_try = match_IntToInteger }
1056 rule_WordToInteger str name
1057 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1058 ru_try = match_WordToInteger }
1059 rule_Int64ToInteger str name
1060 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1061 ru_try = match_Int64ToInteger }
1062 rule_Word64ToInteger str name
1063 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1064 ru_try = match_Word64ToInteger }
1065 rule_unop str name op
1066 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1067 ru_try = match_Integer_unop op }
1068 rule_bitInteger str name
1069 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1070 ru_try = match_IntToInteger_unop (bit . fromIntegral) }
1071 rule_binop str name op
1072 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1073 ru_try = match_Integer_binop op }
1074 rule_divop_both str name op
1075 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1076 ru_try = match_Integer_divop_both op }
1077 rule_divop_one str name op
1078 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1079 ru_try = match_Integer_divop_one op }
1080 rule_Int_binop str name op
1081 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1082 ru_try = match_Integer_Int_binop op }
1083 rule_binop_Prim str name op
1084 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1085 ru_try = match_Integer_binop_Prim op }
1086 rule_binop_Ordering str name op
1087 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1088 ru_try = match_Integer_binop_Ordering op }
1089 rule_encodeFloat str name op
1090 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1091 ru_try = match_Integer_Int_encodeFloat op }
1092 rule_decodeDouble str name
1093 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1094 ru_try = match_decodeDouble }
1095 rule_XToIntegerToX str name toIntegerName
1096 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1097 ru_try = match_XToIntegerToX toIntegerName }
1098 rule_smallIntegerTo str name primOp
1099 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1100 ru_try = match_smallIntegerTo primOp }
1101 rule_rationalTo str name mkLit
1102 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1103 ru_try = match_rationalTo mkLit }
1104
1105 ---------------------------------------------------
1106 -- The rule is this:
1107 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1108 -- = unpackFoldrCString# "foobaz" c n
1109
1110 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1111 match_append_lit [Type ty1,
1112 Lit (MachStr s1),
1113 c1,
1114 Var unpk `App` Type ty2
1115 `App` Lit (MachStr s2)
1116 `App` c2
1117 `App` n
1118 ]
1119 | unpk `hasKey` unpackCStringFoldrIdKey &&
1120 c1 `cheapEqExpr` c2
1121 = ASSERT( ty1 `eqType` ty2 )
1122 Just (Var unpk `App` Type ty1
1123 `App` Lit (MachStr (s1 `BS.append` s2))
1124 `App` c1
1125 `App` n)
1126
1127 match_append_lit _ = Nothing
1128
1129 ---------------------------------------------------
1130 -- The rule is this:
1131 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
1132
1133 match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1134 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
1135 Var unpk2 `App` Lit (MachStr s2)]
1136 | unpk1 `hasKey` unpackCStringIdKey,
1137 unpk2 `hasKey` unpackCStringIdKey
1138 = Just (if s1 == s2 then trueValBool else falseValBool)
1139
1140 match_eq_string _ _ = Nothing
1141
1142
1143 ---------------------------------------------------
1144 -- The rule is this:
1145 -- inline f_ty (f a b c) = <f's unfolding> a b c
1146 -- (if f has an unfolding, EVEN if it's a loop breaker)
1147 --
1148 -- It's important to allow the argument to 'inline' to have args itself
1149 -- (a) because its more forgiving to allow the programmer to write
1150 -- inline f a b c
1151 -- or inline (f a b c)
1152 -- (b) because a polymorphic f wll get a type argument that the
1153 -- programmer can't avoid
1154 --
1155 -- Also, don't forget about 'inline's type argument!
1156 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1157 match_inline (Type _ : e : _)
1158 | (Var f, args1) <- collectArgs e,
1159 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1160 -- Ignore the IdUnfoldingFun here!
1161 = Just (mkApps unf args1)
1162
1163 match_inline _ = Nothing
1164
1165
1166 -- See Note [magicDictId magic] in `basicTypes/MkId.hs`
1167 -- for a description of what is going on here.
1168 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1169 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1170 | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
1171 , Just (dictTy, _) <- splitFunTy_maybe fieldTy
1172 , Just dictTc <- tyConAppTyCon_maybe dictTy
1173 , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
1174 = Just
1175 $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
1176 `App` y
1177
1178 match_magicDict _ = Nothing
1179
1180 -------------------------------------------------
1181 -- Integer rules
1182 -- smallInteger (79::Int#) = 79::Integer
1183 -- wordToInteger (79::Word#) = 79::Integer
1184 -- Similarly Int64, Word64
1185
1186 match_IntToInteger :: RuleFun
1187 match_IntToInteger = match_IntToInteger_unop id
1188
1189 match_WordToInteger :: RuleFun
1190 match_WordToInteger _ id_unf id [xl]
1191 | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
1192 = case splitFunTy_maybe (idType id) of
1193 Just (_, integerTy) ->
1194 Just (Lit (LitInteger x integerTy))
1195 _ ->
1196 panic "match_WordToInteger: Id has the wrong type"
1197 match_WordToInteger _ _ _ _ = Nothing
1198
1199 match_Int64ToInteger :: RuleFun
1200 match_Int64ToInteger _ id_unf id [xl]
1201 | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
1202 = case splitFunTy_maybe (idType id) of
1203 Just (_, integerTy) ->
1204 Just (Lit (LitInteger x integerTy))
1205 _ ->
1206 panic "match_Int64ToInteger: Id has the wrong type"
1207 match_Int64ToInteger _ _ _ _ = Nothing
1208
1209 match_Word64ToInteger :: RuleFun
1210 match_Word64ToInteger _ id_unf id [xl]
1211 | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
1212 = case splitFunTy_maybe (idType id) of
1213 Just (_, integerTy) ->
1214 Just (Lit (LitInteger x integerTy))
1215 _ ->
1216 panic "match_Word64ToInteger: Id has the wrong type"
1217 match_Word64ToInteger _ _ _ _ = Nothing
1218
1219 -------------------------------------------------
1220 match_Integer_convert :: Num a
1221 => (DynFlags -> a -> Expr CoreBndr)
1222 -> RuleFun
1223 match_Integer_convert convert dflags id_unf _ [xl]
1224 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1225 = Just (convert dflags (fromInteger x))
1226 match_Integer_convert _ _ _ _ _ = Nothing
1227
1228 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1229 match_Integer_unop unop _ id_unf _ [xl]
1230 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1231 = Just (Lit (LitInteger (unop x) i))
1232 match_Integer_unop _ _ _ _ _ = Nothing
1233
1234 {- Note [Rewriting bitInteger]
1235
1236 For most types the bitInteger operation can be implemented in terms of shifts.
1237 The integer-gmp package, however, can do substantially better than this if
1238 allowed to provide its own implementation. However, in so doing it previously lost
1239 constant-folding (see Trac #8832). The bitInteger rule above provides constant folding
1240 specifically for this function.
1241
1242 There is, however, a bit of trickiness here when it comes to ranges. While the
1243 AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
1244 index to be given as an Int. Hence we coerce to an Int in the rule definition.
1245 This will behave a bit funny for constants larger than the word size, but the user
1246 should expect some funniness given that they will have at very least ignored a
1247 warning in this case.
1248 -}
1249
1250 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
1251 match_IntToInteger_unop unop _ id_unf fn [xl]
1252 | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
1253 = case splitFunTy_maybe (idType fn) of
1254 Just (_, integerTy) ->
1255 Just (Lit (LitInteger (unop x) integerTy))
1256 _ ->
1257 panic "match_IntToInteger_unop: Id has the wrong type"
1258 match_IntToInteger_unop _ _ _ _ _ = Nothing
1259
1260 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1261 match_Integer_binop binop _ id_unf _ [xl,yl]
1262 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1263 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1264 = Just (Lit (LitInteger (x `binop` y) i))
1265 match_Integer_binop _ _ _ _ _ = Nothing
1266
1267 -- This helper is used for the quotRem and divMod functions
1268 match_Integer_divop_both
1269 :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1270 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1271 | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
1272 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1273 , y /= 0
1274 , (r,s) <- x `divop` y
1275 = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
1276 match_Integer_divop_both _ _ _ _ _ = Nothing
1277
1278 -- This helper is used for the quot and rem functions
1279 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1280 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1281 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1282 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1283 , y /= 0
1284 = Just (Lit (LitInteger (x `divop` y) i))
1285 match_Integer_divop_one _ _ _ _ _ = Nothing
1286
1287 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
1288 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
1289 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1290 , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
1291 = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1292 match_Integer_Int_binop _ _ _ _ _ = Nothing
1293
1294 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1295 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1296 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1297 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1298 = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1299 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1300
1301 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1302 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1303 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1304 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1305 = Just $ case x `binop` y of
1306 LT -> ltVal
1307 EQ -> eqVal
1308 GT -> gtVal
1309 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1310
1311 match_Integer_Int_encodeFloat :: RealFloat a
1312 => (a -> Expr CoreBndr)
1313 -> RuleFun
1314 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1315 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1316 , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
1317 = Just (mkLit $ encodeFloat x (fromInteger y))
1318 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1319
1320 ---------------------------------------------------
1321 -- constant folding for Float/Double
1322 --
1323 -- This turns
1324 -- rationalToFloat n d
1325 -- into a literal Float, and similarly for Doubles.
1326 --
1327 -- it's important to not match d == 0, because that may represent a
1328 -- literal "0/0" or similar, and we can't produce a literal value for
1329 -- NaN or +-Inf
1330 match_rationalTo :: RealFloat a
1331 => (a -> Expr CoreBndr)
1332 -> RuleFun
1333 match_rationalTo mkLit _ id_unf _ [xl, yl]
1334 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1335 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1336 , y /= 0
1337 = Just (mkLit (fromRational (x % y)))
1338 match_rationalTo _ _ _ _ _ = Nothing
1339
1340 match_decodeDouble :: RuleFun
1341 match_decodeDouble _ id_unf fn [xl]
1342 | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1343 = case splitFunTy_maybe (idType fn) of
1344 Just (_, res)
1345 | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res
1346 -> case decodeFloat (fromRational x :: Double) of
1347 (y, z) ->
1348 Just $ mkCoreUbxTup [integerTy, intHashTy]
1349 [Lit (LitInteger y integerTy),
1350 Lit (MachInt (toInteger z))]
1351 _ ->
1352 pprPanic "match_decodeDouble: Id has the wrong type"
1353 (ppr fn <+> dcolon <+> ppr (idType fn))
1354 match_decodeDouble _ _ _ _ = Nothing
1355
1356 match_XToIntegerToX :: Name -> RuleFun
1357 match_XToIntegerToX n _ _ _ [App (Var x) y]
1358 | idName x == n
1359 = Just y
1360 match_XToIntegerToX _ _ _ _ _ = Nothing
1361
1362 match_smallIntegerTo :: PrimOp -> RuleFun
1363 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1364 | idName x == smallIntegerName
1365 = Just $ App (Var (mkPrimOpId primOp)) y
1366 match_smallIntegerTo _ _ _ _ _ = Nothing