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