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