Fix order of PrelRule
[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 CoreOpt ( exprIsLiteral_maybe )
35 import PrimOp ( PrimOp(..), tagToEnumKey )
36 import TysWiredIn
37 import TysPrim
38 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon
39 , unwrapNewTyCon_maybe, tyConDataCons )
40 import DataCon ( DataCon, dataConTagZ, dataConTyCon, dataConWorkId )
41 import CoreUtils ( cheapEqExpr, exprIsHNF )
42 import CoreUnfold ( exprIsConApp_maybe )
43 import Type
44 import OccName ( occNameFS )
45 import PrelNames
46 import Maybes ( orElse )
47 import Name ( Name, nameOccName )
48 import Outputable
49 import FastString
50 import BasicTypes
51 import DynFlags
52 import Platform
53 import Util
54 import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
55
56 import Control.Applicative ( Alternative(..) )
57
58 import Control.Monad
59 #if __GLASGOW_HASKELL__ > 710
60 import qualified Control.Monad.Fail as MonadFail
61 #endif
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 [ binaryLit (intOp2 Bits.shiftL)
126 , rightIdentityDynFlags zeroi ]
127 primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
128 , rightIdentityDynFlags zeroi ]
129 primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' 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 [ wordShiftRule (const Bits.shiftL) ]
161 primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule 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 wordShiftRule :: (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 wordShiftRule 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 Lit (MachWord x)
435 -> let op = shift_op dflags
436 in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
437 -- Do the shift at type Integer, but shift length is Int
438 _ -> mzero }
439
440 wordSizeInBits :: DynFlags -> Integer
441 wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
442
443 --------------------------
444 floatOp2 :: (Rational -> Rational -> Rational)
445 -> DynFlags -> Literal -> Literal
446 -> Maybe (Expr CoreBndr)
447 floatOp2 op dflags (MachFloat f1) (MachFloat f2)
448 = Just (mkFloatVal dflags (f1 `op` f2))
449 floatOp2 _ _ _ _ = Nothing
450
451 --------------------------
452 doubleOp2 :: (Rational -> Rational -> Rational)
453 -> DynFlags -> Literal -> Literal
454 -> Maybe (Expr CoreBndr)
455 doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
456 = Just (mkDoubleVal dflags (f1 `op` f2))
457 doubleOp2 _ _ _ _ = Nothing
458
459 --------------------------
460 {- Note [The litEq rule: converting equality to case]
461 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
462 This stuff turns
463 n ==# 3#
464 into
465 case n of
466 3# -> True
467 m -> False
468
469 This is a Good Thing, because it allows case-of case things
470 to happen, and case-default absorption to happen. For
471 example:
472
473 if (n ==# 3#) || (n ==# 4#) then e1 else e2
474 will transform to
475 case n of
476 3# -> e1
477 4# -> e1
478 m -> e2
479 (modulo the usual precautions to avoid duplicating e1)
480 -}
481
482 litEq :: Bool -- True <=> equality, False <=> inequality
483 -> RuleM CoreExpr
484 litEq is_eq = msum
485 [ do [Lit lit, expr] <- getArgs
486 dflags <- getDynFlags
487 do_lit_eq dflags lit expr
488 , do [expr, Lit lit] <- getArgs
489 dflags <- getDynFlags
490 do_lit_eq dflags lit expr ]
491 where
492 do_lit_eq dflags lit expr = do
493 guard (not (litIsLifted lit))
494 return (mkWildCase expr (literalType lit) intPrimTy
495 [(DEFAULT, [], val_if_neq),
496 (LitAlt lit, [], val_if_eq)])
497 where
498 val_if_eq | is_eq = trueValInt dflags
499 | otherwise = falseValInt dflags
500 val_if_neq | is_eq = falseValInt dflags
501 | otherwise = trueValInt dflags
502
503
504 -- | Check if there is comparison with minBound or maxBound, that is
505 -- always true or false. For instance, an Int cannot be smaller than its
506 -- minBound, so we can replace such comparison with False.
507 boundsCmp :: Comparison -> RuleM CoreExpr
508 boundsCmp op = do
509 dflags <- getDynFlags
510 [a, b] <- getArgs
511 liftMaybe $ mkRuleFn dflags op a b
512
513 data Comparison = Gt | Ge | Lt | Le
514
515 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
516 mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
517 mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
518 mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
519 mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
520 mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
521 mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
522 mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
523 mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
524 mkRuleFn _ _ _ _ = Nothing
525
526 isMinBound :: DynFlags -> Literal -> Bool
527 isMinBound _ (MachChar c) = c == minBound
528 isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags
529 isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64)
530 isMinBound _ (MachWord i) = i == 0
531 isMinBound _ (MachWord64 i) = i == 0
532 isMinBound _ _ = False
533
534 isMaxBound :: DynFlags -> Literal -> Bool
535 isMaxBound _ (MachChar c) = c == maxBound
536 isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags
537 isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64)
538 isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags
539 isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64)
540 isMaxBound _ _ = False
541
542 -- | Create an Int literal expression while ensuring the given Integer is in the
543 -- target Int range
544 intResult :: DynFlags -> Integer -> Maybe CoreExpr
545 intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
546
547 -- | Create a Word literal expression while ensuring the given Integer is in the
548 -- target Word range
549 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
550 wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
551
552 inversePrimOp :: PrimOp -> RuleM CoreExpr
553 inversePrimOp primop = do
554 [Var primop_id `App` e] <- getArgs
555 matchPrimOpId primop primop_id
556 return e
557
558 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
559 this `subsumesPrimOp` that = do
560 [Var primop_id `App` e] <- getArgs
561 matchPrimOpId that primop_id
562 return (Var (mkPrimOpId this) `App` e)
563
564 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
565 subsumedByPrimOp primop = do
566 [e@(Var primop_id `App` _)] <- getArgs
567 matchPrimOpId primop primop_id
568 return e
569
570 idempotent :: RuleM CoreExpr
571 idempotent = do [e1, e2] <- getArgs
572 guard $ cheapEqExpr e1 e2
573 return e1
574
575 {-
576 Note [Guarding against silly shifts]
577 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
578 Consider this code:
579
580 import Data.Bits( (.|.), shiftL )
581 chunkToBitmap :: [Bool] -> Word32
582 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
583
584 This optimises to:
585 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
586 case w1_sCT of _ {
587 [] -> 0##;
588 : x_aAW xs_aAX ->
589 case x_aAW of _ {
590 GHC.Types.False ->
591 case w_sCS of wild2_Xh {
592 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
593 9223372036854775807 -> 0## };
594 GHC.Types.True ->
595 case GHC.Prim.>=# w_sCS 64 of _ {
596 GHC.Types.False ->
597 case w_sCS of wild3_Xh {
598 __DEFAULT ->
599 case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
600 GHC.Prim.or# (GHC.Prim.narrow32Word#
601 (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
602 ww_sCW
603 };
604 9223372036854775807 ->
605 GHC.Prim.narrow32Word#
606 !!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
607 };
608 GHC.Types.True ->
609 case w_sCS of wild3_Xh {
610 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
611 9223372036854775807 -> 0##
612 } } } }
613
614 Note the massive shift on line "!!!!". It can't happen, because we've checked
615 that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
616 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
617 can't constant fold it, but if it gets to the assember we get
618 Error: operand type mismatch for `shl'
619
620 So the best thing to do is to rewrite the shift with a call to error,
621 when the second arg is stupid.
622
623 ************************************************************************
624 * *
625 \subsection{Vaguely generic functions}
626 * *
627 ************************************************************************
628 -}
629
630 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
631 -- Gives the Rule the same name as the primop itself
632 mkBasicRule op_name n_args rm
633 = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
634 ru_fn = op_name,
635 ru_nargs = n_args,
636 ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
637
638 newtype RuleM r = RuleM
639 { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
640
641 instance Functor RuleM where
642 fmap = liftM
643
644 instance Applicative RuleM where
645 pure x = RuleM $ \_ _ _ -> Just x
646 (<*>) = ap
647
648 instance Monad RuleM where
649 RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
650 Nothing -> Nothing
651 Just r -> runRuleM (g r) dflags iu e
652 fail _ = mzero
653
654 #if __GLASGOW_HASKELL__ > 710
655 instance MonadFail.MonadFail RuleM where
656 fail _ = mzero
657 #endif
658
659 instance Alternative RuleM where
660 empty = RuleM $ \_ _ _ -> Nothing
661 RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
662 f1 dflags iu args <|> f2 dflags iu args
663
664 instance MonadPlus RuleM
665
666 instance HasDynFlags RuleM where
667 getDynFlags = RuleM $ \dflags _ _ -> Just dflags
668
669 liftMaybe :: Maybe a -> RuleM a
670 liftMaybe Nothing = mzero
671 liftMaybe (Just x) = return x
672
673 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
674 liftLit f = liftLitDynFlags (const f)
675
676 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
677 liftLitDynFlags f = do
678 dflags <- getDynFlags
679 [Lit lit] <- getArgs
680 return $ Lit (f dflags lit)
681
682 removeOp32 :: RuleM CoreExpr
683 removeOp32 = do
684 dflags <- getDynFlags
685 if wordSizeInBits dflags == 32
686 then do
687 [e] <- getArgs
688 return e
689 else mzero
690
691 getArgs :: RuleM [CoreExpr]
692 getArgs = RuleM $ \_ _ args -> Just args
693
694 getInScopeEnv :: RuleM InScopeEnv
695 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
696
697 -- return the n-th argument of this rule, if it is a literal
698 -- argument indices start from 0
699 getLiteral :: Int -> RuleM Literal
700 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
701 (Lit l:_) -> Just l
702 _ -> Nothing
703
704 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
705 unaryLit op = do
706 dflags <- getDynFlags
707 [Lit l] <- getArgs
708 liftMaybe $ op dflags (convFloating dflags l)
709
710 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
711 binaryLit op = do
712 dflags <- getDynFlags
713 [Lit l1, Lit l2] <- getArgs
714 liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
715
716 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
717 binaryCmpLit op = do
718 dflags <- getDynFlags
719 binaryLit (\_ -> cmpOp dflags op)
720
721 leftIdentity :: Literal -> RuleM CoreExpr
722 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
723
724 rightIdentity :: Literal -> RuleM CoreExpr
725 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
726
727 identity :: Literal -> RuleM CoreExpr
728 identity lit = leftIdentity lit `mplus` rightIdentity lit
729
730 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
731 leftIdentityDynFlags id_lit = do
732 dflags <- getDynFlags
733 [Lit l1, e2] <- getArgs
734 guard $ l1 == id_lit dflags
735 return e2
736
737 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
738 rightIdentityDynFlags id_lit = do
739 dflags <- getDynFlags
740 [e1, Lit l2] <- getArgs
741 guard $ l2 == id_lit dflags
742 return e1
743
744 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
745 identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
746
747 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
748 leftZero zero = do
749 dflags <- getDynFlags
750 [Lit l1, _] <- getArgs
751 guard $ l1 == zero dflags
752 return $ Lit l1
753
754 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
755 rightZero zero = do
756 dflags <- getDynFlags
757 [_, Lit l2] <- getArgs
758 guard $ l2 == zero dflags
759 return $ Lit l2
760
761 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
762 zeroElem lit = leftZero lit `mplus` rightZero lit
763
764 equalArgs :: RuleM ()
765 equalArgs = do
766 [e1, e2] <- getArgs
767 guard $ e1 `cheapEqExpr` e2
768
769 nonZeroLit :: Int -> RuleM ()
770 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
771
772 -- When excess precision is not requested, cut down the precision of the
773 -- Rational value to that of Float/Double. We confuse host architecture
774 -- and target architecture here, but it's convenient (and wrong :-).
775 convFloating :: DynFlags -> Literal -> Literal
776 convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) =
777 MachFloat (toRational (fromRational f :: Float ))
778 convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
779 MachDouble (toRational (fromRational d :: Double))
780 convFloating _ l = l
781
782 guardFloatDiv :: RuleM ()
783 guardFloatDiv = do
784 [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
785 guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
786 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
787
788 guardDoubleDiv :: RuleM ()
789 guardDoubleDiv = do
790 [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
791 guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
792 && d2 /= 0 -- avoid NaN and Infinity/-Infinity
793 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
794 -- zero, but we might want to preserve the negative zero here which
795 -- is representable in Float/Double but not in (normalised)
796 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
797
798 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
799 strengthReduction two_lit add_op = do -- Note [Strength reduction]
800 arg <- msum [ do [arg, Lit mult_lit] <- getArgs
801 guard (mult_lit == two_lit)
802 return arg
803 , do [Lit mult_lit, arg] <- getArgs
804 guard (mult_lit == two_lit)
805 return arg ]
806 return $ Var (mkPrimOpId add_op) `App` arg `App` arg
807
808 -- Note [Strength reduction]
809 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
810 --
811 -- This rule turns floating point multiplications of the form 2.0 * x and
812 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
813 -- See #7116
814
815 -- Note [What's true and false]
816 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
817 --
818 -- trueValInt and falseValInt represent true and false values returned by
819 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
820 -- True is represented as an unboxed 1# literal, while false is represented
821 -- as 0# literal.
822 -- We still need Bool data constructors (True and False) to use in a rule
823 -- for constant folding of equal Strings
824
825 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
826 trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
827 falseValInt dflags = Lit $ zeroi dflags
828
829 trueValBool, falseValBool :: Expr CoreBndr
830 trueValBool = Var trueDataConId -- see Note [What's true and false]
831 falseValBool = Var falseDataConId
832
833 ltVal, eqVal, gtVal :: Expr CoreBndr
834 ltVal = Var ltDataConId
835 eqVal = Var eqDataConId
836 gtVal = Var gtDataConId
837
838 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
839 mkIntVal dflags i = Lit (mkMachInt dflags i)
840 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
841 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f))
842 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
843 mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
844
845 matchPrimOpId :: PrimOp -> Id -> RuleM ()
846 matchPrimOpId op id = do
847 op' <- liftMaybe $ isPrimOpId_maybe id
848 guard $ op == op'
849
850 {-
851 ************************************************************************
852 * *
853 \subsection{Special rules for seq, tagToEnum, dataToTag}
854 * *
855 ************************************************************************
856
857 Note [tagToEnum#]
858 ~~~~~~~~~~~~~~~~~
859 Nasty check to ensure that tagToEnum# is applied to a type that is an
860 enumeration TyCon. Unification may refine the type later, but this
861 check won't see that, alas. It's crude but it works.
862
863 Here's are two cases that should fail
864 f :: forall a. a
865 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
866
867 g :: Int
868 g = tagToEnum# 0 -- Int is not an enumeration
869
870 We used to make this check in the type inference engine, but it's quite
871 ugly to do so, because the delayed constraint solving means that we don't
872 really know what's going on until the end. It's very much a corner case
873 because we don't expect the user to call tagToEnum# at all; we merely
874 generate calls in derived instances of Enum. So we compromise: a
875 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
876 and emits a warning.
877 -}
878
879 tagToEnumRule :: RuleM CoreExpr
880 -- If data T a = A | B | C
881 -- then tag2Enum# (T ty) 2# --> B ty
882 tagToEnumRule = do
883 [Type ty, Lit (MachInt i)] <- getArgs
884 case splitTyConApp_maybe ty of
885 Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
886 let tag = fromInteger i
887 correct_tag dc = (dataConTagZ dc) == tag
888 (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
889 ASSERT(null rest) return ()
890 return $ mkTyApps (Var (dataConWorkId dc)) tc_args
891
892 -- See Note [tagToEnum#]
893 _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
894 return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
895
896 {-
897 For dataToTag#, we can reduce if either
898
899 (a) the argument is a constructor
900 (b) the argument is a variable whose unfolding is a known constructor
901 -}
902
903 dataToTagRule :: RuleM CoreExpr
904 dataToTagRule = a `mplus` b
905 where
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 -- dataToTag (tagToEnum x) ==> x
911 b = do
912 dflags <- getDynFlags
913 [_, val_arg] <- getArgs
914 in_scope <- getInScopeEnv
915 (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
916 ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
917 return $ mkIntVal dflags (toInteger (dataConTagZ dc))
918
919 {-
920 ************************************************************************
921 * *
922 \subsection{Rules for seq# and spark#}
923 * *
924 ************************************************************************
925 -}
926
927 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
928 seqRule :: RuleM CoreExpr
929 seqRule = do
930 [Type ty_a, Type ty_s, a, s] <- getArgs
931 guard $ exprIsHNF a
932 return $ mkCoreUbxTup [mkStatePrimTy ty_s, ty_a] [s, a]
933
934 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
935 sparkRule :: RuleM CoreExpr
936 sparkRule = seqRule -- reduce on HNF, just the same
937 -- XXX perhaps we shouldn't do this, because a spark eliminated by
938 -- this rule won't be counted as a dud at runtime?
939
940 {-
941 ************************************************************************
942 * *
943 \subsection{Built in rules}
944 * *
945 ************************************************************************
946
947 Note [Scoping for Builtin rules]
948 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
949 When compiling a (base-package) module that defines one of the
950 functions mentioned in the RHS of a built-in rule, there's a danger
951 that we'll see
952
953 f = ...(eq String x)....
954
955 ....and lower down...
956
957 eqString = ...
958
959 Then a rewrite would give
960
961 f = ...(eqString x)...
962 ....and lower down...
963 eqString = ...
964
965 and lo, eqString is not in scope. This only really matters when we get to code
966 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
967 set of bindings, which sorts out the dependency. Without -O we don't do any rule
968 rewriting so again we are fine.
969
970 (This whole thing doesn't show up for non-built-in rules because their dependencies
971 are explicit.)
972 -}
973
974 builtinRules :: [CoreRule]
975 -- Rules for non-primops that can't be expressed using a RULE pragma
976 builtinRules
977 = [BuiltinRule { ru_name = fsLit "AppendLitString",
978 ru_fn = unpackCStringFoldrName,
979 ru_nargs = 4, ru_try = match_append_lit },
980 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
981 ru_nargs = 2, ru_try = match_eq_string },
982 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
983 ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
984 BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
985 ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
986 mkBasicRule divIntName 2 $ msum
987 [ nonZeroLit 1 >> binaryLit (intOp2 div)
988 , leftZero zeroi
989 , do
990 [arg, Lit (MachInt d)] <- getArgs
991 Just n <- return $ exactLog2 d
992 dflags <- getDynFlags
993 return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
994 ],
995 mkBasicRule modIntName 2 $ msum
996 [ nonZeroLit 1 >> binaryLit (intOp2 mod)
997 , leftZero zeroi
998 , do
999 [arg, Lit (MachInt d)] <- getArgs
1000 Just _ <- return $ exactLog2 d
1001 dflags <- getDynFlags
1002 return $ Var (mkPrimOpId AndIOp)
1003 `App` arg `App` mkIntVal dflags (d - 1)
1004 ]
1005 ]
1006 ++ builtinIntegerRules
1007
1008 builtinIntegerRules :: [CoreRule]
1009 builtinIntegerRules =
1010 [rule_IntToInteger "smallInteger" smallIntegerName,
1011 rule_WordToInteger "wordToInteger" wordToIntegerName,
1012 rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
1013 rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
1014 rule_convert "integerToWord" integerToWordName mkWordLitWord,
1015 rule_convert "integerToInt" integerToIntName mkIntLitInt,
1016 rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64),
1017 rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64),
1018 rule_binop "plusInteger" plusIntegerName (+),
1019 rule_binop "minusInteger" minusIntegerName (-),
1020 rule_binop "timesInteger" timesIntegerName (*),
1021 rule_unop "negateInteger" negateIntegerName negate,
1022 rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
1023 rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
1024 rule_unop "absInteger" absIntegerName abs,
1025 rule_unop "signumInteger" signumIntegerName signum,
1026 rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
1027 rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
1028 rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
1029 rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
1030 rule_binop_Ordering "compareInteger" compareIntegerName compare,
1031 rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
1032 rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
1033 rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
1034 rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
1035 rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
1036 rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
1037 rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
1038 rule_binop "gcdInteger" gcdIntegerName gcd,
1039 rule_binop "lcmInteger" lcmIntegerName lcm,
1040 rule_binop "andInteger" andIntegerName (.&.),
1041 rule_binop "orInteger" orIntegerName (.|.),
1042 rule_binop "xorInteger" xorIntegerName xor,
1043 rule_unop "complementInteger" complementIntegerName complement,
1044 rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
1045 rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
1046 rule_bitInteger "bitInteger" bitIntegerName,
1047 -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
1048 rule_divop_one "quotInteger" quotIntegerName quot,
1049 rule_divop_one "remInteger" remIntegerName rem,
1050 rule_divop_one "divInteger" divIntegerName div,
1051 rule_divop_one "modInteger" modIntegerName mod,
1052 rule_divop_both "divModInteger" divModIntegerName divMod,
1053 rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
1054 -- These rules below don't actually have to be built in, but if we
1055 -- put them in the Haskell source then we'd have to duplicate them
1056 -- between all Integer implementations
1057 rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName,
1058 rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName,
1059 rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName,
1060 rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
1061 rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp,
1062 rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp,
1063 rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
1064 ]
1065 where rule_convert str name convert
1066 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1067 ru_try = match_Integer_convert convert }
1068 rule_IntToInteger str name
1069 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1070 ru_try = match_IntToInteger }
1071 rule_WordToInteger str name
1072 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1073 ru_try = match_WordToInteger }
1074 rule_Int64ToInteger str name
1075 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1076 ru_try = match_Int64ToInteger }
1077 rule_Word64ToInteger str name
1078 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1079 ru_try = match_Word64ToInteger }
1080 rule_unop str name op
1081 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1082 ru_try = match_Integer_unop op }
1083 rule_bitInteger str name
1084 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1085 ru_try = match_IntToInteger_unop (bit . fromIntegral) }
1086 rule_binop str name op
1087 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1088 ru_try = match_Integer_binop op }
1089 rule_divop_both str name op
1090 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1091 ru_try = match_Integer_divop_both op }
1092 rule_divop_one str name op
1093 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1094 ru_try = match_Integer_divop_one op }
1095 rule_Int_binop str name op
1096 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1097 ru_try = match_Integer_Int_binop op }
1098 rule_binop_Prim str name op
1099 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1100 ru_try = match_Integer_binop_Prim op }
1101 rule_binop_Ordering str name op
1102 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1103 ru_try = match_Integer_binop_Ordering op }
1104 rule_encodeFloat str name op
1105 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1106 ru_try = match_Integer_Int_encodeFloat op }
1107 rule_decodeDouble str name
1108 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1109 ru_try = match_decodeDouble }
1110 rule_XToIntegerToX str name toIntegerName
1111 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1112 ru_try = match_XToIntegerToX toIntegerName }
1113 rule_smallIntegerTo str name primOp
1114 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1115 ru_try = match_smallIntegerTo primOp }
1116 rule_rationalTo str name mkLit
1117 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1118 ru_try = match_rationalTo mkLit }
1119
1120 ---------------------------------------------------
1121 -- The rule is this:
1122 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1123 -- = unpackFoldrCString# "foobaz" c n
1124
1125 match_append_lit :: RuleFun
1126 match_append_lit _ id_unf _
1127 [ Type ty1
1128 , lit1
1129 , c1
1130 , Var unpk `App` Type ty2
1131 `App` lit2
1132 `App` c2
1133 `App` n
1134 ]
1135 | unpk `hasKey` unpackCStringFoldrIdKey &&
1136 c1 `cheapEqExpr` c2
1137 , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
1138 , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
1139 = ASSERT( ty1 `eqType` ty2 )
1140 Just (Var unpk `App` Type ty1
1141 `App` Lit (MachStr (s1 `BS.append` s2))
1142 `App` c1
1143 `App` n)
1144
1145 match_append_lit _ _ _ _ = Nothing
1146
1147 ---------------------------------------------------
1148 -- The rule is this:
1149 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
1150
1151 match_eq_string :: RuleFun
1152 match_eq_string _ id_unf _
1153 [Var unpk1 `App` lit1, Var unpk2 `App` lit2]
1154 | unpk1 `hasKey` unpackCStringIdKey
1155 , unpk2 `hasKey` unpackCStringIdKey
1156 , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
1157 , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
1158 = Just (if s1 == s2 then trueValBool else falseValBool)
1159
1160 match_eq_string _ _ _ _ = Nothing
1161
1162
1163 ---------------------------------------------------
1164 -- The rule is this:
1165 -- inline f_ty (f a b c) = <f's unfolding> a b c
1166 -- (if f has an unfolding, EVEN if it's a loop breaker)
1167 --
1168 -- It's important to allow the argument to 'inline' to have args itself
1169 -- (a) because its more forgiving to allow the programmer to write
1170 -- inline f a b c
1171 -- or inline (f a b c)
1172 -- (b) because a polymorphic f wll get a type argument that the
1173 -- programmer can't avoid
1174 --
1175 -- Also, don't forget about 'inline's type argument!
1176 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1177 match_inline (Type _ : e : _)
1178 | (Var f, args1) <- collectArgs e,
1179 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1180 -- Ignore the IdUnfoldingFun here!
1181 = Just (mkApps unf args1)
1182
1183 match_inline _ = Nothing
1184
1185
1186 -- See Note [magicDictId magic] in `basicTypes/MkId.hs`
1187 -- for a description of what is going on here.
1188 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1189 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1190 | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
1191 , Just (dictTy, _) <- splitFunTy_maybe fieldTy
1192 , Just dictTc <- tyConAppTyCon_maybe dictTy
1193 , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
1194 = Just
1195 $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
1196 `App` y
1197
1198 match_magicDict _ = Nothing
1199
1200 -------------------------------------------------
1201 -- Integer rules
1202 -- smallInteger (79::Int#) = 79::Integer
1203 -- wordToInteger (79::Word#) = 79::Integer
1204 -- Similarly Int64, Word64
1205
1206 match_IntToInteger :: RuleFun
1207 match_IntToInteger = match_IntToInteger_unop id
1208
1209 match_WordToInteger :: RuleFun
1210 match_WordToInteger _ id_unf id [xl]
1211 | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
1212 = case splitFunTy_maybe (idType id) of
1213 Just (_, integerTy) ->
1214 Just (Lit (LitInteger x integerTy))
1215 _ ->
1216 panic "match_WordToInteger: Id has the wrong type"
1217 match_WordToInteger _ _ _ _ = Nothing
1218
1219 match_Int64ToInteger :: RuleFun
1220 match_Int64ToInteger _ id_unf id [xl]
1221 | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
1222 = case splitFunTy_maybe (idType id) of
1223 Just (_, integerTy) ->
1224 Just (Lit (LitInteger x integerTy))
1225 _ ->
1226 panic "match_Int64ToInteger: Id has the wrong type"
1227 match_Int64ToInteger _ _ _ _ = Nothing
1228
1229 match_Word64ToInteger :: RuleFun
1230 match_Word64ToInteger _ id_unf id [xl]
1231 | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
1232 = case splitFunTy_maybe (idType id) of
1233 Just (_, integerTy) ->
1234 Just (Lit (LitInteger x integerTy))
1235 _ ->
1236 panic "match_Word64ToInteger: Id has the wrong type"
1237 match_Word64ToInteger _ _ _ _ = Nothing
1238
1239 -------------------------------------------------
1240 match_Integer_convert :: Num a
1241 => (DynFlags -> a -> Expr CoreBndr)
1242 -> RuleFun
1243 match_Integer_convert convert dflags id_unf _ [xl]
1244 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1245 = Just (convert dflags (fromInteger x))
1246 match_Integer_convert _ _ _ _ _ = Nothing
1247
1248 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1249 match_Integer_unop unop _ id_unf _ [xl]
1250 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1251 = Just (Lit (LitInteger (unop x) i))
1252 match_Integer_unop _ _ _ _ _ = Nothing
1253
1254 {- Note [Rewriting bitInteger]
1255
1256 For most types the bitInteger operation can be implemented in terms of shifts.
1257 The integer-gmp package, however, can do substantially better than this if
1258 allowed to provide its own implementation. However, in so doing it previously lost
1259 constant-folding (see Trac #8832). The bitInteger rule above provides constant folding
1260 specifically for this function.
1261
1262 There is, however, a bit of trickiness here when it comes to ranges. While the
1263 AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
1264 index to be given as an Int. Hence we coerce to an Int in the rule definition.
1265 This will behave a bit funny for constants larger than the word size, but the user
1266 should expect some funniness given that they will have at very least ignored a
1267 warning in this case.
1268 -}
1269
1270 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
1271 match_IntToInteger_unop unop _ id_unf fn [xl]
1272 | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
1273 = case splitFunTy_maybe (idType fn) of
1274 Just (_, integerTy) ->
1275 Just (Lit (LitInteger (unop x) integerTy))
1276 _ ->
1277 panic "match_IntToInteger_unop: Id has the wrong type"
1278 match_IntToInteger_unop _ _ _ _ _ = Nothing
1279
1280 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1281 match_Integer_binop binop _ id_unf _ [xl,yl]
1282 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1283 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1284 = Just (Lit (LitInteger (x `binop` y) i))
1285 match_Integer_binop _ _ _ _ _ = Nothing
1286
1287 -- This helper is used for the quotRem and divMod functions
1288 match_Integer_divop_both
1289 :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1290 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1291 | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
1292 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1293 , y /= 0
1294 , (r,s) <- x `divop` y
1295 = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
1296 match_Integer_divop_both _ _ _ _ _ = Nothing
1297
1298 -- This helper is used for the quot and rem functions
1299 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1300 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1301 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1302 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1303 , y /= 0
1304 = Just (Lit (LitInteger (x `divop` y) i))
1305 match_Integer_divop_one _ _ _ _ _ = Nothing
1306
1307 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
1308 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
1309 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1310 , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
1311 = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1312 match_Integer_Int_binop _ _ _ _ _ = Nothing
1313
1314 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1315 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1316 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1317 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1318 = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1319 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1320
1321 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1322 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1323 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1324 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1325 = Just $ case x `binop` y of
1326 LT -> ltVal
1327 EQ -> eqVal
1328 GT -> gtVal
1329 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1330
1331 match_Integer_Int_encodeFloat :: RealFloat a
1332 => (a -> Expr CoreBndr)
1333 -> RuleFun
1334 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1335 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1336 , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
1337 = Just (mkLit $ encodeFloat x (fromInteger y))
1338 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1339
1340 ---------------------------------------------------
1341 -- constant folding for Float/Double
1342 --
1343 -- This turns
1344 -- rationalToFloat n d
1345 -- into a literal Float, and similarly for Doubles.
1346 --
1347 -- it's important to not match d == 0, because that may represent a
1348 -- literal "0/0" or similar, and we can't produce a literal value for
1349 -- NaN or +-Inf
1350 match_rationalTo :: RealFloat a
1351 => (a -> Expr CoreBndr)
1352 -> RuleFun
1353 match_rationalTo mkLit _ id_unf _ [xl, yl]
1354 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1355 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1356 , y /= 0
1357 = Just (mkLit (fromRational (x % y)))
1358 match_rationalTo _ _ _ _ _ = Nothing
1359
1360 match_decodeDouble :: RuleFun
1361 match_decodeDouble _ id_unf fn [xl]
1362 | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1363 = case splitFunTy_maybe (idType fn) of
1364 Just (_, res)
1365 | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res
1366 -> case decodeFloat (fromRational x :: Double) of
1367 (y, z) ->
1368 Just $ mkCoreUbxTup [integerTy, intHashTy]
1369 [Lit (LitInteger y integerTy),
1370 Lit (MachInt (toInteger z))]
1371 _ ->
1372 pprPanic "match_decodeDouble: Id has the wrong type"
1373 (ppr fn <+> dcolon <+> ppr (idType fn))
1374 match_decodeDouble _ _ _ _ = Nothing
1375
1376 match_XToIntegerToX :: Name -> RuleFun
1377 match_XToIntegerToX n _ _ _ [App (Var x) y]
1378 | idName x == n
1379 = Just y
1380 match_XToIntegerToX _ _ _ _ _ = Nothing
1381
1382 match_smallIntegerTo :: PrimOp -> RuleFun
1383 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1384 | idName x == smallIntegerName
1385 = Just $ App (Var (mkPrimOpId primOp)) y
1386 match_smallIntegerTo _ _ _ _ _ = Nothing
1387
1388
1389
1390 --------------------------------------------------------
1391 -- Constant folding through case-expressions
1392 --
1393 -- cf Scrutinee Constant Folding in simplCore/SimplUtils
1394 --------------------------------------------------------
1395
1396 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
1397 -- function to apply to each literal alternative.
1398 caseRules :: DynFlags
1399 -> CoreExpr -- Scrutinee
1400 -> Maybe ( CoreExpr -- New scrutinee
1401 , AltCon -> AltCon -- How to fix up the alt pattern
1402 , Id -> CoreExpr) -- How to reconstruct the original scrutinee
1403 -- from the new case-binder
1404 -- e.g case e of b {
1405 -- ...;
1406 -- con bs -> rhs;
1407 -- ... }
1408 -- ==>
1409 -- case e' of b' {
1410 -- ...;
1411 -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
1412 -- ... }
1413
1414 caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x#
1415 | Just op <- isPrimOpId_maybe f
1416 , Just x <- isLitValue_maybe l
1417 , Just adjust_lit <- adjustDyadicRight op x
1418 = Just (v, tx_lit_con dflags adjust_lit
1419 , \v -> (App (App (Var f) (Var v)) (Lit l)))
1420
1421 caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v
1422 | Just op <- isPrimOpId_maybe f
1423 , Just x <- isLitValue_maybe l
1424 , Just adjust_lit <- adjustDyadicLeft x op
1425 = Just (v, tx_lit_con dflags adjust_lit
1426 , \v -> (App (App (Var f) (Lit l)) (Var v)))
1427
1428
1429 caseRules dflags (App (Var f) v ) -- op v
1430 | Just op <- isPrimOpId_maybe f
1431 , Just adjust_lit <- adjustUnary op
1432 = Just (v, tx_lit_con dflags adjust_lit
1433 , \v -> App (Var f) (Var v))
1434
1435 -- See Note [caseRules for tagToEnum]
1436 caseRules dflags (App (App (Var f) type_arg) v)
1437 | Just TagToEnumOp <- isPrimOpId_maybe f
1438 = Just (v, tx_con_tte dflags
1439 , \v -> (App (App (Var f) type_arg) (Var v)))
1440
1441 -- See Note [caseRules for dataToTag]
1442 caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x
1443 | Just DataToTagOp <- isPrimOpId_maybe f
1444 = Just (v, tx_con_dtt ty
1445 , \v -> App (App (Var f) (Type ty)) (Var v))
1446
1447 caseRules _ _ = Nothing
1448
1449
1450 tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon
1451 tx_lit_con _ _ DEFAULT = DEFAULT
1452 tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l)
1453 tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt)
1454 -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the
1455 -- literal alternatives remain in Word/Int target ranges
1456 -- (See Note [Word/Int underflow/overflow] in Literal and #13172).
1457
1458 adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
1459 -- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x
1460 adjustDyadicRight op lit
1461 = case op of
1462 WordAddOp -> Just (\y -> y-lit )
1463 IntAddOp -> Just (\y -> y-lit )
1464 WordSubOp -> Just (\y -> y+lit )
1465 IntSubOp -> Just (\y -> y+lit )
1466 XorOp -> Just (\y -> y `xor` lit)
1467 XorIOp -> Just (\y -> y `xor` lit)
1468 _ -> Nothing
1469
1470 adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
1471 -- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x
1472 adjustDyadicLeft lit op
1473 = case op of
1474 WordAddOp -> Just (\y -> y-lit )
1475 IntAddOp -> Just (\y -> y-lit )
1476 WordSubOp -> Just (\y -> lit-y )
1477 IntSubOp -> Just (\y -> lit-y )
1478 XorOp -> Just (\y -> y `xor` lit)
1479 XorIOp -> Just (\y -> y `xor` lit)
1480 _ -> Nothing
1481
1482
1483 adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
1484 -- Given (op x) return a function 'f' s.t. f (op x) = x
1485 adjustUnary op
1486 = case op of
1487 NotOp -> Just (\y -> complement y)
1488 NotIOp -> Just (\y -> complement y)
1489 IntNegOp -> Just (\y -> negate y )
1490 _ -> Nothing
1491
1492 tx_con_tte :: DynFlags -> AltCon -> AltCon
1493 tx_con_tte _ DEFAULT = DEFAULT
1494 tx_con_tte dflags (DataAlt dc)
1495 | tag == 0 = DEFAULT -- See Note [caseRules for tagToEnum]
1496 | otherwise = LitAlt (mkMachInt dflags (toInteger tag))
1497 where
1498 tag = dataConTagZ dc
1499 tx_con_tte _ alt = pprPanic "caseRules" (ppr alt)
1500
1501 tx_con_dtt :: Type -> AltCon -> AltCon
1502 tx_con_dtt _ DEFAULT = DEFAULT
1503 tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i))
1504 tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
1505
1506 get_con :: Type -> ConTagZ -> DataCon
1507 get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag
1508
1509 {- Note [caseRules for tagToEnum]
1510 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1511 We want to transform
1512 case tagToEnum x of
1513 False -> e1
1514 True -> e2
1515 into
1516 case x of
1517 0# -> e1
1518 1# -> e1
1519
1520 This rule eliminates a lot of boilerplate. For
1521 if (x>y) then e1 else e2
1522 we generate
1523 case tagToEnum (x ># y) of
1524 False -> e2
1525 True -> e1
1526 and it is nice to then get rid of the tagToEnum.
1527
1528 NB: in SimplUtils, where we invoke caseRules,
1529 we convert that 0# to DEFAULT
1530
1531 Note [caseRules for dataToTag]
1532 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1533 We want to transform
1534 case dataToTag x of
1535 DEFAULT -> e1
1536 1# -> e2
1537 into
1538 case x of
1539 DEFAULT -> e1
1540 (:) _ _ -> e2
1541
1542 Note the need for some wildcard binders in
1543 the 'cons' case.
1544 -}