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