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