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