Built-in Natural literals in Core
[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 (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2)
375 go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
376 go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
377 | nt1 /= nt2 = Nothing
378 | otherwise = done (i1 `cmp` i2)
379 go _ _ = Nothing
380
381 --------------------------
382
383 negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate
384 negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
385 negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f))
386 negOp _ (MachDouble 0.0) = Nothing
387 negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d))
388 negOp dflags (LitNumber nt i t)
389 | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))
390 negOp _ _ = Nothing
391
392 complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement
393 complementOp dflags (LitNumber nt i t) =
394 Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
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 (LitNumber LitNumInt i1 _) (LitNumber LitNumInt 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 (LitNumber LitNumInt i1 _) (LitNumber LitNumInt 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 (LitNumber LitNumWord w1 _) (LitNumber LitNumWord 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 (LitNumber LitNumWord w1 _) (LitNumber LitNumWord 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 (LitNumber LitNumInt 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 (LitNumber nt x t)
467 -> let op = shift_op dflags
468 y = x `op` fromInteger shift_len
469 in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
470
471 _ -> mzero }
472
473 wordSizeInBits :: DynFlags -> Integer
474 wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
475
476 --------------------------
477 floatOp2 :: (Rational -> Rational -> Rational)
478 -> DynFlags -> Literal -> Literal
479 -> Maybe (Expr CoreBndr)
480 floatOp2 op dflags (MachFloat f1) (MachFloat f2)
481 = Just (mkFloatVal dflags (f1 `op` f2))
482 floatOp2 _ _ _ _ = Nothing
483
484 --------------------------
485 doubleOp2 :: (Rational -> Rational -> Rational)
486 -> DynFlags -> Literal -> Literal
487 -> Maybe (Expr CoreBndr)
488 doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
489 = Just (mkDoubleVal dflags (f1 `op` f2))
490 doubleOp2 _ _ _ _ = Nothing
491
492 --------------------------
493 {- Note [The litEq rule: converting equality to case]
494 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
495 This stuff turns
496 n ==# 3#
497 into
498 case n of
499 3# -> True
500 m -> False
501
502 This is a Good Thing, because it allows case-of case things
503 to happen, and case-default absorption to happen. For
504 example:
505
506 if (n ==# 3#) || (n ==# 4#) then e1 else e2
507 will transform to
508 case n of
509 3# -> e1
510 4# -> e1
511 m -> e2
512 (modulo the usual precautions to avoid duplicating e1)
513 -}
514
515 litEq :: Bool -- True <=> equality, False <=> inequality
516 -> RuleM CoreExpr
517 litEq is_eq = msum
518 [ do [Lit lit, expr] <- getArgs
519 dflags <- getDynFlags
520 do_lit_eq dflags lit expr
521 , do [expr, Lit lit] <- getArgs
522 dflags <- getDynFlags
523 do_lit_eq dflags lit expr ]
524 where
525 do_lit_eq dflags lit expr = do
526 guard (not (litIsLifted lit))
527 return (mkWildCase expr (literalType lit) intPrimTy
528 [(DEFAULT, [], val_if_neq),
529 (LitAlt lit, [], val_if_eq)])
530 where
531 val_if_eq | is_eq = trueValInt dflags
532 | otherwise = falseValInt dflags
533 val_if_neq | is_eq = falseValInt dflags
534 | otherwise = trueValInt dflags
535
536
537 -- | Check if there is comparison with minBound or maxBound, that is
538 -- always true or false. For instance, an Int cannot be smaller than its
539 -- minBound, so we can replace such comparison with False.
540 boundsCmp :: Comparison -> RuleM CoreExpr
541 boundsCmp op = do
542 dflags <- getDynFlags
543 [a, b] <- getArgs
544 liftMaybe $ mkRuleFn dflags op a b
545
546 data Comparison = Gt | Ge | Lt | Le
547
548 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
549 mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
550 mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
551 mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
552 mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
553 mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
554 mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
555 mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
556 mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
557 mkRuleFn _ _ _ _ = Nothing
558
559 isMinBound :: DynFlags -> Literal -> Bool
560 isMinBound _ (MachChar c) = c == minBound
561 isMinBound dflags (LitNumber nt i _) = case nt of
562 LitNumInt -> i == tARGET_MIN_INT dflags
563 LitNumInt64 -> i == toInteger (minBound :: Int64)
564 LitNumWord -> i == 0
565 LitNumWord64 -> i == 0
566 LitNumNatural -> i == 0
567 LitNumInteger -> False
568 isMinBound _ _ = False
569
570 isMaxBound :: DynFlags -> Literal -> Bool
571 isMaxBound _ (MachChar c) = c == maxBound
572 isMaxBound dflags (LitNumber nt i _) = case nt of
573 LitNumInt -> i == tARGET_MAX_INT dflags
574 LitNumInt64 -> i == toInteger (maxBound :: Int64)
575 LitNumWord -> i == tARGET_MAX_WORD dflags
576 LitNumWord64 -> i == toInteger (maxBound :: Word64)
577 LitNumNatural -> False
578 LitNumInteger -> False
579 isMaxBound _ _ = False
580
581 -- | Create an Int literal expression while ensuring the given Integer is in the
582 -- target Int range
583 intResult :: DynFlags -> Integer -> Maybe CoreExpr
584 intResult dflags result = Just (Lit (mkMachIntWrap dflags result))
585
586 -- | Create an unboxed pair of an Int literal expression, ensuring the given
587 -- Integer is in the target Int range and the corresponding overflow flag
588 -- (@0#@/@1#@) if it wasn't.
589 intCResult :: DynFlags -> Integer -> Maybe CoreExpr
590 intCResult dflags result = Just (mkPair [Lit lit, Lit c])
591 where
592 mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
593 (lit, b) = mkMachIntWrapC dflags result
594 c = if b then onei dflags else zeroi dflags
595
596 -- | Create a Word literal expression while ensuring the given Integer is in the
597 -- target Word range
598 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
599 wordResult dflags result = Just (Lit (mkMachWordWrap dflags result))
600
601 -- | Create an unboxed pair of a Word literal expression, ensuring the given
602 -- Integer is in the target Word range and the corresponding carry flag
603 -- (@0#@/@1#@) if it wasn't.
604 wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
605 wordCResult dflags result = Just (mkPair [Lit lit, Lit c])
606 where
607 mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
608 (lit, b) = mkMachWordWrapC dflags result
609 c = if b then onei dflags else zeroi dflags
610
611 inversePrimOp :: PrimOp -> RuleM CoreExpr
612 inversePrimOp primop = do
613 [Var primop_id `App` e] <- getArgs
614 matchPrimOpId primop primop_id
615 return e
616
617 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
618 this `subsumesPrimOp` that = do
619 [Var primop_id `App` e] <- getArgs
620 matchPrimOpId that primop_id
621 return (Var (mkPrimOpId this) `App` e)
622
623 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
624 subsumedByPrimOp primop = do
625 [e@(Var primop_id `App` _)] <- getArgs
626 matchPrimOpId primop primop_id
627 return e
628
629 idempotent :: RuleM CoreExpr
630 idempotent = do [e1, e2] <- getArgs
631 guard $ cheapEqExpr e1 e2
632 return e1
633
634 {-
635 Note [Guarding against silly shifts]
636 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
637 Consider this code:
638
639 import Data.Bits( (.|.), shiftL )
640 chunkToBitmap :: [Bool] -> Word32
641 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
642
643 This optimises to:
644 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
645 case w1_sCT of _ {
646 [] -> 0##;
647 : x_aAW xs_aAX ->
648 case x_aAW of _ {
649 GHC.Types.False ->
650 case w_sCS of wild2_Xh {
651 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
652 9223372036854775807 -> 0## };
653 GHC.Types.True ->
654 case GHC.Prim.>=# w_sCS 64 of _ {
655 GHC.Types.False ->
656 case w_sCS of wild3_Xh {
657 __DEFAULT ->
658 case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
659 GHC.Prim.or# (GHC.Prim.narrow32Word#
660 (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
661 ww_sCW
662 };
663 9223372036854775807 ->
664 GHC.Prim.narrow32Word#
665 !!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
666 };
667 GHC.Types.True ->
668 case w_sCS of wild3_Xh {
669 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
670 9223372036854775807 -> 0##
671 } } } }
672
673 Note the massive shift on line "!!!!". It can't happen, because we've checked
674 that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
675 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
676 can't constant fold it, but if it gets to the assember we get
677 Error: operand type mismatch for `shl'
678
679 So the best thing to do is to rewrite the shift with a call to error,
680 when the second arg is stupid.
681
682 ************************************************************************
683 * *
684 \subsection{Vaguely generic functions}
685 * *
686 ************************************************************************
687 -}
688
689 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
690 -- Gives the Rule the same name as the primop itself
691 mkBasicRule op_name n_args rm
692 = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
693 ru_fn = op_name,
694 ru_nargs = n_args,
695 ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
696
697 newtype RuleM r = RuleM
698 { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
699
700 instance Functor RuleM where
701 fmap = liftM
702
703 instance Applicative RuleM where
704 pure x = RuleM $ \_ _ _ -> Just x
705 (<*>) = ap
706
707 instance Monad RuleM where
708 RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
709 Nothing -> Nothing
710 Just r -> runRuleM (g r) dflags iu e
711 fail = MonadFail.fail
712
713 instance MonadFail.MonadFail RuleM where
714 fail _ = mzero
715
716 instance Alternative RuleM where
717 empty = RuleM $ \_ _ _ -> Nothing
718 RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
719 f1 dflags iu args <|> f2 dflags iu args
720
721 instance MonadPlus RuleM
722
723 instance HasDynFlags RuleM where
724 getDynFlags = RuleM $ \dflags _ _ -> Just dflags
725
726 liftMaybe :: Maybe a -> RuleM a
727 liftMaybe Nothing = mzero
728 liftMaybe (Just x) = return x
729
730 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
731 liftLit f = liftLitDynFlags (const f)
732
733 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
734 liftLitDynFlags f = do
735 dflags <- getDynFlags
736 [Lit lit] <- getArgs
737 return $ Lit (f dflags lit)
738
739 removeOp32 :: RuleM CoreExpr
740 removeOp32 = do
741 dflags <- getDynFlags
742 if wordSizeInBits dflags == 32
743 then do
744 [e] <- getArgs
745 return e
746 else mzero
747
748 getArgs :: RuleM [CoreExpr]
749 getArgs = RuleM $ \_ _ args -> Just args
750
751 getInScopeEnv :: RuleM InScopeEnv
752 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
753
754 -- return the n-th argument of this rule, if it is a literal
755 -- argument indices start from 0
756 getLiteral :: Int -> RuleM Literal
757 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
758 (Lit l:_) -> Just l
759 _ -> Nothing
760
761 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
762 unaryLit op = do
763 dflags <- getDynFlags
764 [Lit l] <- getArgs
765 liftMaybe $ op dflags (convFloating dflags l)
766
767 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
768 binaryLit op = do
769 dflags <- getDynFlags
770 [Lit l1, Lit l2] <- getArgs
771 liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
772
773 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
774 binaryCmpLit op = do
775 dflags <- getDynFlags
776 binaryLit (\_ -> cmpOp dflags op)
777
778 leftIdentity :: Literal -> RuleM CoreExpr
779 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
780
781 rightIdentity :: Literal -> RuleM CoreExpr
782 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
783
784 identity :: Literal -> RuleM CoreExpr
785 identity lit = leftIdentity lit `mplus` rightIdentity lit
786
787 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
788 leftIdentityDynFlags id_lit = do
789 dflags <- getDynFlags
790 [Lit l1, e2] <- getArgs
791 guard $ l1 == id_lit dflags
792 return e2
793
794 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
795 -- addition to the result, we have to indicate that no carry/overflow occured.
796 leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
797 leftIdentityCDynFlags id_lit = do
798 dflags <- getDynFlags
799 [Lit l1, e2] <- getArgs
800 guard $ l1 == id_lit dflags
801 let no_c = Lit (zeroi dflags)
802 return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
803
804 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
805 rightIdentityDynFlags id_lit = do
806 dflags <- getDynFlags
807 [e1, Lit l2] <- getArgs
808 guard $ l2 == id_lit dflags
809 return e1
810
811 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
812 -- addition to the result, we have to indicate that no carry/overflow occured.
813 rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
814 rightIdentityCDynFlags id_lit = do
815 dflags <- getDynFlags
816 [e1, Lit l2] <- getArgs
817 guard $ l2 == id_lit dflags
818 let no_c = Lit (zeroi dflags)
819 return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
820
821 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
822 identityDynFlags lit =
823 leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
824
825 -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
826 -- to the result, we have to indicate that no carry/overflow occured.
827 identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
828 identityCDynFlags lit =
829 leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit
830
831 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
832 leftZero zero = do
833 dflags <- getDynFlags
834 [Lit l1, _] <- getArgs
835 guard $ l1 == zero dflags
836 return $ Lit l1
837
838 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
839 rightZero zero = do
840 dflags <- getDynFlags
841 [_, Lit l2] <- getArgs
842 guard $ l2 == zero dflags
843 return $ Lit l2
844
845 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
846 zeroElem lit = leftZero lit `mplus` rightZero lit
847
848 equalArgs :: RuleM ()
849 equalArgs = do
850 [e1, e2] <- getArgs
851 guard $ e1 `cheapEqExpr` e2
852
853 nonZeroLit :: Int -> RuleM ()
854 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
855
856 -- When excess precision is not requested, cut down the precision of the
857 -- Rational value to that of Float/Double. We confuse host architecture
858 -- and target architecture here, but it's convenient (and wrong :-).
859 convFloating :: DynFlags -> Literal -> Literal
860 convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) =
861 MachFloat (toRational (fromRational f :: Float ))
862 convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
863 MachDouble (toRational (fromRational d :: Double))
864 convFloating _ l = l
865
866 guardFloatDiv :: RuleM ()
867 guardFloatDiv = do
868 [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
869 guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
870 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
871
872 guardDoubleDiv :: RuleM ()
873 guardDoubleDiv = do
874 [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
875 guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
876 && d2 /= 0 -- avoid NaN and Infinity/-Infinity
877 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
878 -- zero, but we might want to preserve the negative zero here which
879 -- is representable in Float/Double but not in (normalised)
880 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
881
882 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
883 strengthReduction two_lit add_op = do -- Note [Strength reduction]
884 arg <- msum [ do [arg, Lit mult_lit] <- getArgs
885 guard (mult_lit == two_lit)
886 return arg
887 , do [Lit mult_lit, arg] <- getArgs
888 guard (mult_lit == two_lit)
889 return arg ]
890 return $ Var (mkPrimOpId add_op) `App` arg `App` arg
891
892 -- Note [Strength reduction]
893 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
894 --
895 -- This rule turns floating point multiplications of the form 2.0 * x and
896 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
897 -- See #7116
898
899 -- Note [What's true and false]
900 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
901 --
902 -- trueValInt and falseValInt represent true and false values returned by
903 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
904 -- True is represented as an unboxed 1# literal, while false is represented
905 -- as 0# literal.
906 -- We still need Bool data constructors (True and False) to use in a rule
907 -- for constant folding of equal Strings
908
909 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
910 trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
911 falseValInt dflags = Lit $ zeroi dflags
912
913 trueValBool, falseValBool :: Expr CoreBndr
914 trueValBool = Var trueDataConId -- see Note [What's true and false]
915 falseValBool = Var falseDataConId
916
917 ltVal, eqVal, gtVal :: Expr CoreBndr
918 ltVal = Var ltDataConId
919 eqVal = Var eqDataConId
920 gtVal = Var gtDataConId
921
922 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
923 mkIntVal dflags i = Lit (mkMachInt dflags i)
924 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
925 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f))
926 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
927 mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
928
929 matchPrimOpId :: PrimOp -> Id -> RuleM ()
930 matchPrimOpId op id = do
931 op' <- liftMaybe $ isPrimOpId_maybe id
932 guard $ op == op'
933
934 {-
935 ************************************************************************
936 * *
937 \subsection{Special rules for seq, tagToEnum, dataToTag}
938 * *
939 ************************************************************************
940
941 Note [tagToEnum#]
942 ~~~~~~~~~~~~~~~~~
943 Nasty check to ensure that tagToEnum# is applied to a type that is an
944 enumeration TyCon. Unification may refine the type later, but this
945 check won't see that, alas. It's crude but it works.
946
947 Here's are two cases that should fail
948 f :: forall a. a
949 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
950
951 g :: Int
952 g = tagToEnum# 0 -- Int is not an enumeration
953
954 We used to make this check in the type inference engine, but it's quite
955 ugly to do so, because the delayed constraint solving means that we don't
956 really know what's going on until the end. It's very much a corner case
957 because we don't expect the user to call tagToEnum# at all; we merely
958 generate calls in derived instances of Enum. So we compromise: a
959 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
960 and emits a warning.
961 -}
962
963 tagToEnumRule :: RuleM CoreExpr
964 -- If data T a = A | B | C
965 -- then tag2Enum# (T ty) 2# --> B ty
966 tagToEnumRule = do
967 [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
968 case splitTyConApp_maybe ty of
969 Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
970 let tag = fromInteger i
971 correct_tag dc = (dataConTagZ dc) == tag
972 (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
973 ASSERT(null rest) return ()
974 return $ mkTyApps (Var (dataConWorkId dc)) tc_args
975
976 -- See Note [tagToEnum#]
977 _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
978 return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
979
980 ------------------------------
981 dataToTagRule :: RuleM CoreExpr
982 -- Rules for dataToTag#
983 dataToTagRule = a `mplus` b
984 where
985 -- dataToTag (tagToEnum x) ==> x
986 a = do
987 [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
988 guard $ tag_to_enum `hasKey` tagToEnumKey
989 guard $ ty1 `eqType` ty2
990 return tag
991
992 -- Why don't we simplify tagToEnum# (dataToTag# x) to x? We would
993 -- like to, but it seems tricky. See #14282. The trouble is that
994 -- we never actually see tagToEnum# (dataToTag# x). Because dataToTag#
995 -- is can_fail, this expression is immediately transformed into
996 --
997 -- case dataToTag# @T x of wild
998 -- { __DEFAULT -> tagToEnum# @T wild }
999 --
1000 -- and wild has no unfolding. Simon Peyton Jones speculates one way around
1001 -- might be to arrange to give unfoldings to case binders of CONLIKE
1002 -- applications and mark dataToTag# CONLIKE, but he doubts it's really
1003 -- worth the trouble.
1004
1005 -- dataToTag (K e1 e2) ==> tag-of K
1006 -- This also works (via exprIsConApp_maybe) for
1007 -- dataToTag x
1008 -- where x's unfolding is a constructor application
1009 b = do
1010 dflags <- getDynFlags
1011 [_, val_arg] <- getArgs
1012 in_scope <- getInScopeEnv
1013 (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
1014 ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
1015 return $ mkIntVal dflags (toInteger (dataConTagZ dc))
1016
1017 {-
1018 ************************************************************************
1019 * *
1020 \subsection{Rules for seq# and spark#}
1021 * *
1022 ************************************************************************
1023 -}
1024
1025 {- Note [seq# magic]
1026 ~~~~~~~~~~~~~~~~~~~~
1027 The primop
1028 seq# :: forall a s . a -> State# s -> (# State# s, a #)
1029
1030 is /not/ the same as the Prelude function seq :: a -> b -> b
1031 as you can see from its type. In fact, seq# is the implementation
1032 mechanism for 'evaluate'
1033
1034 evaluate :: a -> IO a
1035 evaluate a = IO $ \s -> seq# a s
1036
1037 The semantics of seq# is
1038 * evaluate its first argument
1039 * and return it
1040
1041 Things to note
1042
1043 * Why do we need a primop at all? That is, instead of
1044 case seq# x s of (# x, s #) -> blah
1045 why not instead say this?
1046 case x of { DEFAULT -> blah)
1047
1048 Reason (see Trac #5129): if we saw
1049 catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
1050
1051 then we'd drop the 'case x' because the body of the case is bottom
1052 anyway. But we don't want to do that; the whole /point/ of
1053 seq#/evaluate is to evaluate 'x' first in the IO monad.
1054
1055 In short, we /always/ evaluate the first argument and never
1056 just discard it.
1057
1058 * Why return the value? So that we can control sharing of seq'd
1059 values: in
1060 let x = e in x `seq` ... x ...
1061 We don't want to inline x, so better to represent it as
1062 let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
1063 also it matches the type of rseq in the Eval monad.
1064
1065 Implementing seq#. The compiler has magic for SeqOp in
1066
1067 - PrelRules.seqRule: eliminate (seq# <whnf> s)
1068
1069 - StgCmmExpr.cgExpr, and cgCase: special case for seq#
1070
1071 - CoreUtils.exprOkForSpeculation;
1072 see Note [seq# and expr_ok] in CoreUtils
1073
1074 - Simplify.addEvals records evaluated-ness for the result; see
1075 Note [Adding evaluatedness info to pattern-bound variables]
1076 in Simplify
1077 -}
1078
1079 seqRule :: RuleM CoreExpr
1080 seqRule = do
1081 [Type ty_a, Type _ty_s, a, s] <- getArgs
1082 guard $ exprIsHNF a
1083 return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
1084
1085 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
1086 sparkRule :: RuleM CoreExpr
1087 sparkRule = seqRule -- reduce on HNF, just the same
1088 -- XXX perhaps we shouldn't do this, because a spark eliminated by
1089 -- this rule won't be counted as a dud at runtime?
1090
1091 {-
1092 ************************************************************************
1093 * *
1094 \subsection{Built in rules}
1095 * *
1096 ************************************************************************
1097
1098 Note [Scoping for Builtin rules]
1099 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1100 When compiling a (base-package) module that defines one of the
1101 functions mentioned in the RHS of a built-in rule, there's a danger
1102 that we'll see
1103
1104 f = ...(eq String x)....
1105
1106 ....and lower down...
1107
1108 eqString = ...
1109
1110 Then a rewrite would give
1111
1112 f = ...(eqString x)...
1113 ....and lower down...
1114 eqString = ...
1115
1116 and lo, eqString is not in scope. This only really matters when we get to code
1117 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
1118 set of bindings, which sorts out the dependency. Without -O we don't do any rule
1119 rewriting so again we are fine.
1120
1121 (This whole thing doesn't show up for non-built-in rules because their dependencies
1122 are explicit.)
1123 -}
1124
1125 builtinRules :: [CoreRule]
1126 -- Rules for non-primops that can't be expressed using a RULE pragma
1127 builtinRules
1128 = [BuiltinRule { ru_name = fsLit "AppendLitString",
1129 ru_fn = unpackCStringFoldrName,
1130 ru_nargs = 4, ru_try = match_append_lit },
1131 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
1132 ru_nargs = 2, ru_try = match_eq_string },
1133 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
1134 ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
1135 BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
1136 ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
1137 mkBasicRule divIntName 2 $ msum
1138 [ nonZeroLit 1 >> binaryLit (intOp2 div)
1139 , leftZero zeroi
1140 , do
1141 [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
1142 Just n <- return $ exactLog2 d
1143 dflags <- getDynFlags
1144 return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
1145 ],
1146 mkBasicRule modIntName 2 $ msum
1147 [ nonZeroLit 1 >> binaryLit (intOp2 mod)
1148 , leftZero zeroi
1149 , do
1150 [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
1151 Just _ <- return $ exactLog2 d
1152 dflags <- getDynFlags
1153 return $ Var (mkPrimOpId AndIOp)
1154 `App` arg `App` mkIntVal dflags (d - 1)
1155 ]
1156 ]
1157 ++ builtinIntegerRules
1158 ++ builtinNaturalRules
1159 {-# NOINLINE builtinRules #-}
1160 -- there is no benefit to inlining these yet, despite this, GHC produces
1161 -- unfoldings for this regardless since the floated list entries look small.
1162
1163 builtinIntegerRules :: [CoreRule]
1164 builtinIntegerRules =
1165 [rule_IntToInteger "smallInteger" smallIntegerName,
1166 rule_WordToInteger "wordToInteger" wordToIntegerName,
1167 rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
1168 rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
1169 rule_convert "integerToWord" integerToWordName mkWordLitWord,
1170 rule_convert "integerToInt" integerToIntName mkIntLitInt,
1171 rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64),
1172 rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64),
1173 rule_binop "plusInteger" plusIntegerName (+),
1174 rule_binop "minusInteger" minusIntegerName (-),
1175 rule_binop "timesInteger" timesIntegerName (*),
1176 rule_unop "negateInteger" negateIntegerName negate,
1177 rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
1178 rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
1179 rule_unop "absInteger" absIntegerName abs,
1180 rule_unop "signumInteger" signumIntegerName signum,
1181 rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
1182 rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
1183 rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
1184 rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
1185 rule_binop_Ordering "compareInteger" compareIntegerName compare,
1186 rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
1187 rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
1188 rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
1189 rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
1190 rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
1191 rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
1192 rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
1193 rule_binop "gcdInteger" gcdIntegerName gcd,
1194 rule_binop "lcmInteger" lcmIntegerName lcm,
1195 rule_binop "andInteger" andIntegerName (.&.),
1196 rule_binop "orInteger" orIntegerName (.|.),
1197 rule_binop "xorInteger" xorIntegerName xor,
1198 rule_unop "complementInteger" complementIntegerName complement,
1199 rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
1200 rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
1201 rule_bitInteger "bitInteger" bitIntegerName,
1202 -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
1203 rule_divop_one "quotInteger" quotIntegerName quot,
1204 rule_divop_one "remInteger" remIntegerName rem,
1205 rule_divop_one "divInteger" divIntegerName div,
1206 rule_divop_one "modInteger" modIntegerName mod,
1207 rule_divop_both "divModInteger" divModIntegerName divMod,
1208 rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
1209 -- These rules below don't actually have to be built in, but if we
1210 -- put them in the Haskell source then we'd have to duplicate them
1211 -- between all Integer implementations
1212 rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName,
1213 rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName,
1214 rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName,
1215 rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
1216 rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp,
1217 rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp,
1218 rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
1219 ]
1220 where rule_convert str name convert
1221 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1222 ru_try = match_Integer_convert convert }
1223 rule_IntToInteger str name
1224 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1225 ru_try = match_IntToInteger }
1226 rule_WordToInteger str name
1227 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1228 ru_try = match_WordToInteger }
1229 rule_Int64ToInteger str name
1230 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1231 ru_try = match_Int64ToInteger }
1232 rule_Word64ToInteger str name
1233 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1234 ru_try = match_Word64ToInteger }
1235 rule_unop str name op
1236 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1237 ru_try = match_Integer_unop op }
1238 rule_bitInteger str name
1239 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1240 ru_try = match_bitInteger }
1241 rule_binop str name op
1242 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1243 ru_try = match_Integer_binop op }
1244 rule_divop_both str name op
1245 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1246 ru_try = match_Integer_divop_both op }
1247 rule_divop_one str name op
1248 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1249 ru_try = match_Integer_divop_one op }
1250 rule_Int_binop str name op
1251 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1252 ru_try = match_Integer_Int_binop op }
1253 rule_binop_Prim str name op
1254 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1255 ru_try = match_Integer_binop_Prim op }
1256 rule_binop_Ordering str name op
1257 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1258 ru_try = match_Integer_binop_Ordering op }
1259 rule_encodeFloat str name op
1260 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1261 ru_try = match_Integer_Int_encodeFloat op }
1262 rule_decodeDouble str name
1263 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1264 ru_try = match_decodeDouble }
1265 rule_XToIntegerToX str name toIntegerName
1266 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1267 ru_try = match_XToIntegerToX toIntegerName }
1268 rule_smallIntegerTo str name primOp
1269 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1270 ru_try = match_smallIntegerTo primOp }
1271 rule_rationalTo str name mkLit
1272 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1273 ru_try = match_rationalTo mkLit }
1274
1275 builtinNaturalRules :: [CoreRule]
1276 builtinNaturalRules =
1277 [rule_binop "plusNatural" plusNaturalName (+)
1278 ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing)
1279 ,rule_binop "timesNatural" timesNaturalName (*)
1280 ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
1281 ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName
1282 ,rule_WordToNatural "wordToNatural" wordToNaturalName
1283 ]
1284 where rule_binop str name op
1285 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1286 ru_try = match_Natural_binop op }
1287 rule_partial_binop str name op
1288 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1289 ru_try = match_Natural_partial_binop op }
1290 rule_NaturalToInteger str name
1291 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1292 ru_try = match_NaturalToInteger }
1293 rule_NaturalFromInteger str name
1294 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1295 ru_try = match_NaturalFromInteger }
1296 rule_WordToNatural str name
1297 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1298 ru_try = match_WordToNatural }
1299
1300 ---------------------------------------------------
1301 -- The rule is this:
1302 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1303 -- = unpackFoldrCString# "foobaz" c n
1304
1305 match_append_lit :: RuleFun
1306 match_append_lit _ id_unf _
1307 [ Type ty1
1308 , lit1
1309 , c1
1310 , Var unpk `App` Type ty2
1311 `App` lit2
1312 `App` c2
1313 `App` n
1314 ]
1315 | unpk `hasKey` unpackCStringFoldrIdKey &&
1316 c1 `cheapEqExpr` c2
1317 , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
1318 , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
1319 = ASSERT( ty1 `eqType` ty2 )
1320 Just (Var unpk `App` Type ty1
1321 `App` Lit (MachStr (s1 `BS.append` s2))
1322 `App` c1
1323 `App` n)
1324
1325 match_append_lit _ _ _ _ = Nothing
1326
1327 ---------------------------------------------------
1328 -- The rule is this:
1329 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
1330
1331 match_eq_string :: RuleFun
1332 match_eq_string _ id_unf _
1333 [Var unpk1 `App` lit1, Var unpk2 `App` lit2]
1334 | unpk1 `hasKey` unpackCStringIdKey
1335 , unpk2 `hasKey` unpackCStringIdKey
1336 , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
1337 , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
1338 = Just (if s1 == s2 then trueValBool else falseValBool)
1339
1340 match_eq_string _ _ _ _ = Nothing
1341
1342
1343 ---------------------------------------------------
1344 -- The rule is this:
1345 -- inline f_ty (f a b c) = <f's unfolding> a b c
1346 -- (if f has an unfolding, EVEN if it's a loop breaker)
1347 --
1348 -- It's important to allow the argument to 'inline' to have args itself
1349 -- (a) because its more forgiving to allow the programmer to write
1350 -- inline f a b c
1351 -- or inline (f a b c)
1352 -- (b) because a polymorphic f wll get a type argument that the
1353 -- programmer can't avoid
1354 --
1355 -- Also, don't forget about 'inline's type argument!
1356 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1357 match_inline (Type _ : e : _)
1358 | (Var f, args1) <- collectArgs e,
1359 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1360 -- Ignore the IdUnfoldingFun here!
1361 = Just (mkApps unf args1)
1362
1363 match_inline _ = Nothing
1364
1365
1366 -- See Note [magicDictId magic] in `basicTypes/MkId.hs`
1367 -- for a description of what is going on here.
1368 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1369 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1370 | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
1371 , Just (dictTy, _) <- splitFunTy_maybe fieldTy
1372 , Just dictTc <- tyConAppTyCon_maybe dictTy
1373 , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
1374 = Just
1375 $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
1376 `App` y
1377
1378 match_magicDict _ = Nothing
1379
1380 -------------------------------------------------
1381 -- Integer rules
1382 -- smallInteger (79::Int#) = 79::Integer
1383 -- wordToInteger (79::Word#) = 79::Integer
1384 -- Similarly Int64, Word64
1385
1386 match_IntToInteger :: RuleFun
1387 match_IntToInteger = match_IntToInteger_unop id
1388
1389 match_WordToInteger :: RuleFun
1390 match_WordToInteger _ id_unf id [xl]
1391 | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
1392 = case splitFunTy_maybe (idType id) of
1393 Just (_, integerTy) ->
1394 Just (Lit (mkLitInteger x integerTy))
1395 _ ->
1396 panic "match_WordToInteger: Id has the wrong type"
1397 match_WordToInteger _ _ _ _ = Nothing
1398
1399 match_Int64ToInteger :: RuleFun
1400 match_Int64ToInteger _ id_unf id [xl]
1401 | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
1402 = case splitFunTy_maybe (idType id) of
1403 Just (_, integerTy) ->
1404 Just (Lit (mkLitInteger x integerTy))
1405 _ ->
1406 panic "match_Int64ToInteger: Id has the wrong type"
1407 match_Int64ToInteger _ _ _ _ = Nothing
1408
1409 match_Word64ToInteger :: RuleFun
1410 match_Word64ToInteger _ id_unf id [xl]
1411 | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
1412 = case splitFunTy_maybe (idType id) of
1413 Just (_, integerTy) ->
1414 Just (Lit (mkLitInteger x integerTy))
1415 _ ->
1416 panic "match_Word64ToInteger: Id has the wrong type"
1417 match_Word64ToInteger _ _ _ _ = Nothing
1418
1419 match_NaturalToInteger :: RuleFun
1420 match_NaturalToInteger _ id_unf id [xl]
1421 | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
1422 = case splitFunTy_maybe (idType id) of
1423 Just (_, naturalTy) ->
1424 Just (Lit (LitNumber LitNumInteger x naturalTy))
1425 _ ->
1426 panic "match_NaturalToInteger: Id has the wrong type"
1427 match_NaturalToInteger _ _ _ _ = Nothing
1428
1429 match_NaturalFromInteger :: RuleFun
1430 match_NaturalFromInteger _ id_unf id [xl]
1431 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1432 , x >= 0
1433 = case splitFunTy_maybe (idType id) of
1434 Just (_, naturalTy) ->
1435 Just (Lit (LitNumber LitNumNatural x naturalTy))
1436 _ ->
1437 panic "match_NaturalFromInteger: Id has the wrong type"
1438 match_NaturalFromInteger _ _ _ _ = Nothing
1439
1440 match_WordToNatural :: RuleFun
1441 match_WordToNatural _ id_unf id [xl]
1442 | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
1443 = case splitFunTy_maybe (idType id) of
1444 Just (_, naturalTy) ->
1445 Just (Lit (LitNumber LitNumNatural x naturalTy))
1446 _ ->
1447 panic "match_WordToNatural: Id has the wrong type"
1448 match_WordToNatural _ _ _ _ = Nothing
1449
1450 -------------------------------------------------
1451 {- Note [Rewriting bitInteger]
1452 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1453 For most types the bitInteger operation can be implemented in terms of shifts.
1454 The integer-gmp package, however, can do substantially better than this if
1455 allowed to provide its own implementation. However, in so doing it previously lost
1456 constant-folding (see Trac #8832). The bitInteger rule above provides constant folding
1457 specifically for this function.
1458
1459 There is, however, a bit of trickiness here when it comes to ranges. While the
1460 AST encodes all integers as Integers, `bit` expects the bit
1461 index to be given as an Int. Hence we coerce to an Int in the rule definition.
1462 This will behave a bit funny for constants larger than the word size, but the user
1463 should expect some funniness given that they will have at very least ignored a
1464 warning in this case.
1465 -}
1466
1467 match_bitInteger :: RuleFun
1468 -- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
1469 match_bitInteger dflags id_unf fn [arg]
1470 | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
1471 , x >= 0
1472 , x <= (wordSizeInBits dflags - 1)
1473 -- Make sure x is small enough to yield a decently small iteger
1474 -- Attempting to construct the Integer for
1475 -- (bitInteger 9223372036854775807#)
1476 -- would be a bad idea (Trac #14959)
1477 , let x_int = fromIntegral x :: Int
1478 = case splitFunTy_maybe (idType fn) of
1479 Just (_, integerTy)
1480 -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
1481 _ -> panic "match_IntToInteger_unop: Id has the wrong type"
1482
1483 match_bitInteger _ _ _ _ = Nothing
1484
1485
1486 -------------------------------------------------
1487 match_Integer_convert :: Num a
1488 => (DynFlags -> a -> Expr CoreBndr)
1489 -> RuleFun
1490 match_Integer_convert convert dflags id_unf _ [xl]
1491 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1492 = Just (convert dflags (fromInteger x))
1493 match_Integer_convert _ _ _ _ _ = Nothing
1494
1495 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1496 match_Integer_unop unop _ id_unf _ [xl]
1497 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1498 = Just (Lit (LitNumber LitNumInteger (unop x) i))
1499 match_Integer_unop _ _ _ _ _ = Nothing
1500
1501 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
1502 match_IntToInteger_unop unop _ id_unf fn [xl]
1503 | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
1504 = case splitFunTy_maybe (idType fn) of
1505 Just (_, integerTy) ->
1506 Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
1507 _ ->
1508 panic "match_IntToInteger_unop: Id has the wrong type"
1509 match_IntToInteger_unop _ _ _ _ _ = Nothing
1510
1511 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1512 match_Integer_binop binop _ id_unf _ [xl,yl]
1513 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1514 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1515 = Just (Lit (mkLitInteger (x `binop` y) i))
1516 match_Integer_binop _ _ _ _ _ = Nothing
1517
1518 match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
1519 match_Natural_binop binop _ id_unf _ [xl,yl]
1520 | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
1521 , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
1522 = Just (Lit (mkLitNatural (x `binop` y) i))
1523 match_Natural_binop _ _ _ _ _ = Nothing
1524
1525 match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
1526 match_Natural_partial_binop binop _ id_unf _ [xl,yl]
1527 | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
1528 , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
1529 , Just z <- x `binop` y
1530 = Just (Lit (mkLitNatural z i))
1531 match_Natural_partial_binop _ _ _ _ _ = Nothing
1532
1533 -- This helper is used for the quotRem and divMod functions
1534 match_Integer_divop_both
1535 :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1536 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1537 | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
1538 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1539 , y /= 0
1540 , (r,s) <- x `divop` y
1541 = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
1542 match_Integer_divop_both _ _ _ _ _ = Nothing
1543
1544 -- This helper is used for the quot and rem functions
1545 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1546 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1547 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1548 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1549 , y /= 0
1550 = Just (Lit (mkLitInteger (x `divop` y) i))
1551 match_Integer_divop_one _ _ _ _ _ = Nothing
1552
1553 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
1554 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
1555 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1556 , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
1557 = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
1558 match_Integer_Int_binop _ _ _ _ _ = Nothing
1559
1560 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1561 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1562 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1563 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1564 = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1565 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1566
1567 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1568 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1569 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1570 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1571 = Just $ case x `binop` y of
1572 LT -> ltVal
1573 EQ -> eqVal
1574 GT -> gtVal
1575 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1576
1577 match_Integer_Int_encodeFloat :: RealFloat a
1578 => (a -> Expr CoreBndr)
1579 -> RuleFun
1580 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1581 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1582 , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
1583 = Just (mkLit $ encodeFloat x (fromInteger y))
1584 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1585
1586 ---------------------------------------------------
1587 -- constant folding for Float/Double
1588 --
1589 -- This turns
1590 -- rationalToFloat n d
1591 -- into a literal Float, and similarly for Doubles.
1592 --
1593 -- it's important to not match d == 0, because that may represent a
1594 -- literal "0/0" or similar, and we can't produce a literal value for
1595 -- NaN or +-Inf
1596 match_rationalTo :: RealFloat a
1597 => (a -> Expr CoreBndr)
1598 -> RuleFun
1599 match_rationalTo mkLit _ id_unf _ [xl, yl]
1600 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1601 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1602 , y /= 0
1603 = Just (mkLit (fromRational (x % y)))
1604 match_rationalTo _ _ _ _ _ = Nothing
1605
1606 match_decodeDouble :: RuleFun
1607 match_decodeDouble dflags id_unf fn [xl]
1608 | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1609 = case splitFunTy_maybe (idType fn) of
1610 Just (_, res)
1611 | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res
1612 -> case decodeFloat (fromRational x :: Double) of
1613 (y, z) ->
1614 Just $ mkCoreUbxTup [integerTy, intHashTy]
1615 [Lit (mkLitInteger y integerTy),
1616 Lit (mkMachInt dflags (toInteger z))]
1617 _ ->
1618 pprPanic "match_decodeDouble: Id has the wrong type"
1619 (ppr fn <+> dcolon <+> ppr (idType fn))
1620 match_decodeDouble _ _ _ _ = Nothing
1621
1622 match_XToIntegerToX :: Name -> RuleFun
1623 match_XToIntegerToX n _ _ _ [App (Var x) y]
1624 | idName x == n
1625 = Just y
1626 match_XToIntegerToX _ _ _ _ _ = Nothing
1627
1628 match_smallIntegerTo :: PrimOp -> RuleFun
1629 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1630 | idName x == smallIntegerName
1631 = Just $ App (Var (mkPrimOpId primOp)) y
1632 match_smallIntegerTo _ _ _ _ _ = Nothing
1633
1634
1635
1636 --------------------------------------------------------
1637 -- Constant folding through case-expressions
1638 --
1639 -- cf Scrutinee Constant Folding in simplCore/SimplUtils
1640 --------------------------------------------------------
1641
1642 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
1643 -- function to apply to each literal alternative.
1644 caseRules :: DynFlags
1645 -> CoreExpr -- Scrutinee
1646 -> Maybe ( CoreExpr -- New scrutinee
1647 , AltCon -> AltCon -- How to fix up the alt pattern
1648 , Id -> CoreExpr) -- How to reconstruct the original scrutinee
1649 -- from the new case-binder
1650 -- e.g case e of b {
1651 -- ...;
1652 -- con bs -> rhs;
1653 -- ... }
1654 -- ==>
1655 -- case e' of b' {
1656 -- ...;
1657 -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
1658 -- ... }
1659
1660 caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x#
1661 | Just op <- isPrimOpId_maybe f
1662 , Just x <- isLitValue_maybe l
1663 , Just adjust_lit <- adjustDyadicRight op x
1664 = Just (v, tx_lit_con dflags adjust_lit
1665 , \v -> (App (App (Var f) (Var v)) (Lit l)))
1666
1667 caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v
1668 | Just op <- isPrimOpId_maybe f
1669 , Just x <- isLitValue_maybe l
1670 , Just adjust_lit <- adjustDyadicLeft x op
1671 = Just (v, tx_lit_con dflags adjust_lit
1672 , \v -> (App (App (Var f) (Lit l)) (Var v)))
1673
1674
1675 caseRules dflags (App (Var f) v ) -- op v
1676 | Just op <- isPrimOpId_maybe f
1677 , Just adjust_lit <- adjustUnary op
1678 = Just (v, tx_lit_con dflags adjust_lit
1679 , \v -> App (Var f) (Var v))
1680
1681 -- See Note [caseRules for tagToEnum]
1682 caseRules dflags (App (App (Var f) type_arg) v)
1683 | Just TagToEnumOp <- isPrimOpId_maybe f
1684 = Just (v, tx_con_tte dflags
1685 , \v -> (App (App (Var f) type_arg) (Var v)))
1686
1687 -- See Note [caseRules for dataToTag]
1688 caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x
1689 | Just DataToTagOp <- isPrimOpId_maybe f
1690 , Just (tc, _) <- tcSplitTyConApp_maybe ty
1691 , isAlgTyCon tc
1692 = Just (v, tx_con_dtt ty
1693 , \v -> App (App (Var f) (Type ty)) (Var v))
1694
1695 caseRules _ _ = Nothing
1696
1697
1698 tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> AltCon
1699 tx_lit_con _ _ DEFAULT = DEFAULT
1700 tx_lit_con dflags adjust (LitAlt l) = LitAlt (mapLitValue dflags adjust l)
1701 tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt)
1702 -- NB: mapLitValue uses mkMachIntWrap etc, to ensure that the
1703 -- literal alternatives remain in Word/Int target ranges
1704 -- (See Note [Word/Int underflow/overflow] in Literal and #13172).
1705
1706 adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
1707 -- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x
1708 adjustDyadicRight op lit
1709 = case op of
1710 WordAddOp -> Just (\y -> y-lit )
1711 IntAddOp -> Just (\y -> y-lit )
1712 WordSubOp -> Just (\y -> y+lit )
1713 IntSubOp -> Just (\y -> y+lit )
1714 XorOp -> Just (\y -> y `xor` lit)
1715 XorIOp -> Just (\y -> y `xor` lit)
1716 _ -> Nothing
1717
1718 adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
1719 -- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x
1720 adjustDyadicLeft lit op
1721 = case op of
1722 WordAddOp -> Just (\y -> y-lit )
1723 IntAddOp -> Just (\y -> y-lit )
1724 WordSubOp -> Just (\y -> lit-y )
1725 IntSubOp -> Just (\y -> lit-y )
1726 XorOp -> Just (\y -> y `xor` lit)
1727 XorIOp -> Just (\y -> y `xor` lit)
1728 _ -> Nothing
1729
1730
1731 adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
1732 -- Given (op x) return a function 'f' s.t. f (op x) = x
1733 adjustUnary op
1734 = case op of
1735 NotOp -> Just (\y -> complement y)
1736 NotIOp -> Just (\y -> complement y)
1737 IntNegOp -> Just (\y -> negate y )
1738 _ -> Nothing
1739
1740 tx_con_tte :: DynFlags -> AltCon -> AltCon
1741 tx_con_tte _ DEFAULT = DEFAULT
1742 tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
1743 tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum]
1744 = LitAlt $ mkMachInt dflags $ toInteger $ dataConTagZ dc
1745
1746 tx_con_dtt :: Type -> AltCon -> AltCon
1747 tx_con_dtt _ DEFAULT = DEFAULT
1748 tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
1749 = DataAlt (get_con ty (fromInteger i))
1750 tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
1751
1752 get_con :: Type -> ConTagZ -> DataCon
1753 get_con ty tag = tyConDataCons (tyConAppTyCon ty) !! tag
1754
1755 {- Note [caseRules for tagToEnum]
1756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1757 We want to transform
1758 case tagToEnum x of
1759 False -> e1
1760 True -> e2
1761 into
1762 case x of
1763 0# -> e1
1764 1# -> e2
1765
1766 This rule eliminates a lot of boilerplate. For
1767 if (x>y) then e2 else e1
1768 we generate
1769 case tagToEnum (x ># y) of
1770 False -> e1
1771 True -> e2
1772 and it is nice to then get rid of the tagToEnum.
1773
1774 Beware (Trac #14768): avoid the temptation to map constructor 0 to
1775 DEFAULT, in the hope of getting this
1776 case (x ># y) of
1777 DEFAULT -> e1
1778 1# -> e2
1779 That fails utterly in the case of
1780 data Colour = Red | Green | Blue
1781 case tagToEnum x of
1782 DEFAULT -> e1
1783 Red -> e2
1784
1785 We don't want to get this!
1786 case x of
1787 DEFAULT -> e1
1788 DEFAULT -> e2
1789
1790 Instead, we deal with turning one branch into DEFAULT in SimplUtils
1791 (add_default in mkCase3).
1792
1793 Note [caseRules for dataToTag]
1794 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1795 We want to transform
1796 case dataToTag x of
1797 DEFAULT -> e1
1798 1# -> e2
1799 into
1800 case x of
1801 DEFAULT -> e1
1802 (:) _ _ -> e2
1803
1804 Note the need for some wildcard binders in
1805 the 'cons' case.
1806
1807 For the time, we only apply this transformation when the type of `x` is a type
1808 headed by a normal tycon. In particular, we do not apply this in the case of a
1809 data family tycon, since that would require carefully applying coercion(s)
1810 between the data family and the data family instance's representation type,
1811 which caseRules isn't currently engineered to handle (#14680).
1812 -}