3a0b1f7b9f34a047ad38cc97f3231200abc96437
[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, PatternSynonyms, ViewPatterns, RecordWildCards #-}
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 , tyConFamilySize )
43 import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId )
44 import CoreUtils ( cheapEqExpr, exprIsHNF, exprType )
45 import CoreUnfold ( exprIsConApp_maybe )
46 import Type
47 import OccName ( occNameFS )
48 import PrelNames
49 import Maybes ( orElse )
50 import Name ( Name, nameOccName )
51 import Outputable
52 import FastString
53 import BasicTypes
54 import DynFlags
55 import Platform
56 import Util
57 import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
58
59 import Control.Applicative ( Alternative(..) )
60
61 import Control.Monad
62 import qualified Control.Monad.Fail as MonadFail
63 import Data.Bits as Bits
64 import qualified Data.ByteString as BS
65 import Data.Int
66 import Data.Ratio
67 import Data.Word
68
69 {-
70 Note [Constant folding]
71 ~~~~~~~~~~~~~~~~~~~~~~~
72 primOpRules generates a rewrite rule for each primop
73 These rules do what is often called "constant folding"
74 E.g. the rules for +# might say
75 4 +# 5 = 9
76 Well, of course you'd need a lot of rules if you did it
77 like that, so we use a BuiltinRule instead, so that we
78 can match in any two literal values. So the rule is really
79 more like
80 (Lit x) +# (Lit y) = Lit (x+#y)
81 where the (+#) on the rhs is done at compile time
82
83 That is why these rules are built in here.
84 -}
85
86 primOpRules :: Name -> PrimOp -> Maybe CoreRule
87 -- ToDo: something for integer-shift ops?
88 -- NotOp
89 primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
90 primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
91
92 -- Int operations
93 primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
94 , identityDynFlags zeroi
95 , numFoldingRules IntAddOp intPrimOps
96 ]
97 primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
98 , rightIdentityDynFlags zeroi
99 , equalArgs >> retLit zeroi
100 , numFoldingRules IntSubOp intPrimOps
101 ]
102 primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))
103 , identityCDynFlags zeroi ]
104 primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))
105 , rightIdentityCDynFlags zeroi
106 , equalArgs >> retLitNoC zeroi ]
107 primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
108 , zeroElem zeroi
109 , identityDynFlags onei
110 , numFoldingRules IntMulOp intPrimOps
111 ]
112 primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
113 , leftZero zeroi
114 , rightIdentityDynFlags onei
115 , equalArgs >> retLit onei ]
116 primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
117 , leftZero zeroi
118 , do l <- getLiteral 1
119 dflags <- getDynFlags
120 guard (l == onei dflags)
121 retLit zeroi
122 , equalArgs >> retLit zeroi
123 , equalArgs >> retLit zeroi ]
124 primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
125 , idempotent
126 , zeroElem zeroi ]
127 primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
128 , idempotent
129 , identityDynFlags zeroi ]
130 primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
131 , identityDynFlags zeroi
132 , equalArgs >> retLit zeroi ]
133 primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp
134 , inversePrimOp NotIOp ]
135 primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
136 , inversePrimOp IntNegOp ]
137 primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL)
138 , rightIdentityDynFlags zeroi ]
139 primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR)
140 , rightIdentityDynFlags zeroi ]
141 primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical
142 , rightIdentityDynFlags zeroi ]
143
144 -- Word operations
145 primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
146 , identityDynFlags zerow
147 , numFoldingRules WordAddOp wordPrimOps
148 ]
149 primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
150 , rightIdentityDynFlags zerow
151 , equalArgs >> retLit zerow
152 , numFoldingRules WordSubOp wordPrimOps
153 ]
154 primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))
155 , identityCDynFlags zerow ]
156 primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))
157 , rightIdentityCDynFlags zerow
158 , equalArgs >> retLitNoC zerow ]
159 primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
160 , identityDynFlags onew
161 , numFoldingRules WordMulOp wordPrimOps
162 ]
163 primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
164 , rightIdentityDynFlags onew ]
165 primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
166 , leftZero zerow
167 , do l <- getLiteral 1
168 dflags <- getDynFlags
169 guard (l == onew dflags)
170 retLit zerow
171 , equalArgs >> retLit zerow ]
172 primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
173 , idempotent
174 , zeroElem zerow ]
175 primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
176 , idempotent
177 , identityDynFlags zerow ]
178 primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
179 , identityDynFlags zerow
180 , equalArgs >> retLit zerow ]
181 primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp
182 , inversePrimOp NotOp ]
183 primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ]
184 primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ]
185
186 -- coercions
187 primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
188 , inversePrimOp Int2WordOp ]
189 primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
190 , inversePrimOp Word2IntOp ]
191 primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
192 , subsumedByPrimOp Narrow8IntOp
193 , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
194 , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
195 primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
196 , subsumedByPrimOp Narrow8IntOp
197 , subsumedByPrimOp Narrow16IntOp
198 , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
199 primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
200 , subsumedByPrimOp Narrow8IntOp
201 , subsumedByPrimOp Narrow16IntOp
202 , subsumedByPrimOp Narrow32IntOp
203 , removeOp32 ]
204 primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
205 , subsumedByPrimOp Narrow8WordOp
206 , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
207 , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
208 primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
209 , subsumedByPrimOp Narrow8WordOp
210 , subsumedByPrimOp Narrow16WordOp
211 , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
212 primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
213 , subsumedByPrimOp Narrow8WordOp
214 , subsumedByPrimOp Narrow16WordOp
215 , subsumedByPrimOp Narrow32WordOp
216 , removeOp32 ]
217 primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit
218 , inversePrimOp ChrOp ]
219 primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
220 guard (litFitsInChar lit)
221 liftLit int2CharLit
222 , inversePrimOp OrdOp ]
223 primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
224 primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
225 primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
226 primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
227 -- SUP: Not sure what the standard says about precision in the following 2 cases
228 primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
229 primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
230
231 -- Float
232 primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
233 , identity zerof ]
234 primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
235 , rightIdentity zerof ]
236 primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
237 , identity onef
238 , strengthReduction twof FloatAddOp ]
239 -- zeroElem zerof doesn't hold because of NaN
240 primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
241 , rightIdentity onef ]
242 primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
243 , inversePrimOp FloatNegOp ]
244
245 -- Double
246 primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
247 , identity zerod ]
248 primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
249 , rightIdentity zerod ]
250 primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
251 , identity oned
252 , strengthReduction twod DoubleAddOp ]
253 -- zeroElem zerod doesn't hold because of NaN
254 primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
255 , rightIdentity oned ]
256 primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
257 , inversePrimOp DoubleNegOp ]
258
259 -- Relational operators
260
261 primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ]
262 primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ]
263 primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ]
264 primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ]
265
266 primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
267 primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
268 primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
269 primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
270
271 primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
272 primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
273 primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
274 primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
275
276 primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>)
277 primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=)
278 primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=)
279 primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<)
280 primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==)
281 primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=)
282
283 primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)
284 primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)
285 primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)
286 primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)
287 primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)
288 primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
289
290 primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
291 primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
292 primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
293 primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
294 primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ]
295 primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ]
296
297 primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]
298
299 primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ]
300 primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ]
301
302 primOpRules _ _ = Nothing
303
304 {-
305 ************************************************************************
306 * *
307 \subsection{Doing the business}
308 * *
309 ************************************************************************
310 -}
311
312 -- useful shorthands
313 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
314 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
315
316 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
317 -> [RuleM CoreExpr] -> Maybe CoreRule
318 mkRelOpRule nm cmp extra
319 = mkPrimOpRule nm 2 $
320 binaryCmpLit cmp : equal_rule : extra
321 where
322 -- x `cmp` x does not depend on x, so
323 -- compute it for the arbitrary value 'True'
324 -- and use that result
325 equal_rule = do { equalArgs
326 ; dflags <- getDynFlags
327 ; return (if cmp True True
328 then trueValInt dflags
329 else falseValInt dflags) }
330
331 {- Note [Rules for floating-point comparisons]
332 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 We need different rules for floating-point values because for floats
334 it is not true that x = x (for NaNs); so we do not want the equal_rule
335 rule that mkRelOpRule uses.
336
337 Note also that, in the case of equality/inequality, we do /not/
338 want to switch to a case-expression. For example, we do not want
339 to convert
340 case (eqFloat# x 3.8#) of
341 True -> this
342 False -> that
343 to
344 case x of
345 3.8#::Float# -> this
346 _ -> that
347 See Trac #9238. Reason: comparing floating-point values for equality
348 delicate, and we don't want to implement that delicacy in the code for
349 case expressions. So we make it an invariant of Core that a case
350 expression never scrutinises a Float# or Double#.
351
352 This transformation is what the litEq rule does;
353 see Note [The litEq rule: converting equality to case].
354 So we /refrain/ from using litEq for mkFloatingRelOpRule.
355 -}
356
357 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
358 -> Maybe CoreRule
359 -- See Note [Rules for floating-point comparisons]
360 mkFloatingRelOpRule nm cmp
361 = mkPrimOpRule nm 2 [binaryCmpLit cmp]
362
363 -- common constants
364 zeroi, onei, zerow, onew :: DynFlags -> Literal
365 zeroi dflags = mkLitInt dflags 0
366 onei dflags = mkLitInt dflags 1
367 zerow dflags = mkLitWord dflags 0
368 onew dflags = mkLitWord dflags 1
369
370 zerof, onef, twof, zerod, oned, twod :: Literal
371 zerof = mkLitFloat 0.0
372 onef = mkLitFloat 1.0
373 twof = mkLitFloat 2.0
374 zerod = mkLitDouble 0.0
375 oned = mkLitDouble 1.0
376 twod = mkLitDouble 2.0
377
378 cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
379 -> Literal -> Literal -> Maybe CoreExpr
380 cmpOp dflags cmp = go
381 where
382 done True = Just $ trueValInt dflags
383 done False = Just $ falseValInt dflags
384
385 -- These compares are at different types
386 go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2)
387 go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2)
388 go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)
389 go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
390 | nt1 /= nt2 = Nothing
391 | otherwise = done (i1 `cmp` i2)
392 go _ _ = Nothing
393
394 --------------------------
395
396 negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate
397 negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
398 negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f))
399 negOp _ (LitDouble 0.0) = Nothing
400 negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d))
401 negOp dflags (LitNumber nt i t)
402 | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))
403 negOp _ _ = Nothing
404
405 complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement
406 complementOp dflags (LitNumber nt i t) =
407 Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
408 complementOp _ _ = Nothing
409
410 --------------------------
411 intOp2 :: (Integral a, Integral b)
412 => (a -> b -> Integer)
413 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
414 intOp2 = intOp2' . const
415
416 intOp2' :: (Integral a, Integral b)
417 => (DynFlags -> a -> b -> Integer)
418 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
419 intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =
420 let o = op dflags
421 in intResult dflags (fromInteger i1 `o` fromInteger i2)
422 intOp2' _ _ _ _ = Nothing -- Could find LitLit
423
424 intOpC2 :: (Integral a, Integral b)
425 => (a -> b -> Integer)
426 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
427 intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do
428 intCResult dflags (fromInteger i1 `op` fromInteger i2)
429 intOpC2 _ _ _ _ = Nothing -- Could find LitLit
430
431 shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
432 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
433 -- Do this by converting to Word and back. Obviously this won't work for big
434 -- values, but its ok as we use it here
435 shiftRightLogical dflags x n
436 | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)
437 | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)
438 | otherwise = panic "shiftRightLogical: unsupported word size"
439
440 --------------------------
441 retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
442 retLit l = do dflags <- getDynFlags
443 return $ Lit $ l dflags
444
445 retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr
446 retLitNoC l = do dflags <- getDynFlags
447 let lit = l dflags
448 let ty = literalType lit
449 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)]
450
451 wordOp2 :: (Integral a, Integral b)
452 => (a -> b -> Integer)
453 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
454 wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)
455 = wordResult dflags (fromInteger w1 `op` fromInteger w2)
456 wordOp2 _ _ _ _ = Nothing -- Could find LitLit
457
458 wordOpC2 :: (Integral a, Integral b)
459 => (a -> b -> Integer)
460 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
461 wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
462 wordCResult dflags (fromInteger w1 `op` fromInteger w2)
463 wordOpC2 _ _ _ _ = Nothing -- Could find LitLit
464
465 shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
466 -- Shifts take an Int; hence third arg of op is Int
467 -- Used for shift primops
468 -- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word#
469 -- SllOp, SrlOp :: Word# -> Int# -> Word#
470 -- See Note [Guarding against silly shifts]
471 shiftRule shift_op
472 = do { dflags <- getDynFlags
473 ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
474 ; case e1 of
475 _ | shift_len == 0
476 -> return e1
477
478 -- Do the shift at type Integer, but shift length is Int
479 Lit (LitNumber nt x t)
480 | 0 < shift_len
481 , shift_len <= wordSizeInBits dflags
482 -> let op = shift_op dflags
483 y = x `op` fromInteger shift_len
484 in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
485
486 _ -> mzero }
487
488 wordSizeInBits :: DynFlags -> Integer
489 wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
490
491 --------------------------
492 floatOp2 :: (Rational -> Rational -> Rational)
493 -> DynFlags -> Literal -> Literal
494 -> Maybe (Expr CoreBndr)
495 floatOp2 op dflags (LitFloat f1) (LitFloat f2)
496 = Just (mkFloatVal dflags (f1 `op` f2))
497 floatOp2 _ _ _ _ = Nothing
498
499 --------------------------
500 doubleOp2 :: (Rational -> Rational -> Rational)
501 -> DynFlags -> Literal -> Literal
502 -> Maybe (Expr CoreBndr)
503 doubleOp2 op dflags (LitDouble f1) (LitDouble f2)
504 = Just (mkDoubleVal dflags (f1 `op` f2))
505 doubleOp2 _ _ _ _ = Nothing
506
507 --------------------------
508 {- Note [The litEq rule: converting equality to case]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 This stuff turns
511 n ==# 3#
512 into
513 case n of
514 3# -> True
515 m -> False
516
517 This is a Good Thing, because it allows case-of case things
518 to happen, and case-default absorption to happen. For
519 example:
520
521 if (n ==# 3#) || (n ==# 4#) then e1 else e2
522 will transform to
523 case n of
524 3# -> e1
525 4# -> e1
526 m -> e2
527 (modulo the usual precautions to avoid duplicating e1)
528 -}
529
530 litEq :: Bool -- True <=> equality, False <=> inequality
531 -> RuleM CoreExpr
532 litEq is_eq = msum
533 [ do [Lit lit, expr] <- getArgs
534 dflags <- getDynFlags
535 do_lit_eq dflags lit expr
536 , do [expr, Lit lit] <- getArgs
537 dflags <- getDynFlags
538 do_lit_eq dflags lit expr ]
539 where
540 do_lit_eq dflags lit expr = do
541 guard (not (litIsLifted lit))
542 return (mkWildCase expr (literalType lit) intPrimTy
543 [(DEFAULT, [], val_if_neq),
544 (LitAlt lit, [], val_if_eq)])
545 where
546 val_if_eq | is_eq = trueValInt dflags
547 | otherwise = falseValInt dflags
548 val_if_neq | is_eq = falseValInt dflags
549 | otherwise = trueValInt dflags
550
551
552 -- | Check if there is comparison with minBound or maxBound, that is
553 -- always true or false. For instance, an Int cannot be smaller than its
554 -- minBound, so we can replace such comparison with False.
555 boundsCmp :: Comparison -> RuleM CoreExpr
556 boundsCmp op = do
557 dflags <- getDynFlags
558 [a, b] <- getArgs
559 liftMaybe $ mkRuleFn dflags op a b
560
561 data Comparison = Gt | Ge | Lt | Le
562
563 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
564 mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
565 mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
566 mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
567 mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
568 mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
569 mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
570 mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
571 mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
572 mkRuleFn _ _ _ _ = Nothing
573
574 isMinBound :: DynFlags -> Literal -> Bool
575 isMinBound _ (LitChar c) = c == minBound
576 isMinBound dflags (LitNumber nt i _) = case nt of
577 LitNumInt -> i == tARGET_MIN_INT dflags
578 LitNumInt64 -> i == toInteger (minBound :: Int64)
579 LitNumWord -> i == 0
580 LitNumWord64 -> i == 0
581 LitNumNatural -> i == 0
582 LitNumInteger -> False
583 isMinBound _ _ = False
584
585 isMaxBound :: DynFlags -> Literal -> Bool
586 isMaxBound _ (LitChar c) = c == maxBound
587 isMaxBound dflags (LitNumber nt i _) = case nt of
588 LitNumInt -> i == tARGET_MAX_INT dflags
589 LitNumInt64 -> i == toInteger (maxBound :: Int64)
590 LitNumWord -> i == tARGET_MAX_WORD dflags
591 LitNumWord64 -> i == toInteger (maxBound :: Word64)
592 LitNumNatural -> False
593 LitNumInteger -> False
594 isMaxBound _ _ = False
595
596 -- | Create an Int literal expression while ensuring the given Integer is in the
597 -- target Int range
598 intResult :: DynFlags -> Integer -> Maybe CoreExpr
599 intResult dflags result = Just (intResult' dflags result)
600
601 intResult' :: DynFlags -> Integer -> CoreExpr
602 intResult' dflags result = Lit (mkLitIntWrap dflags result)
603
604 -- | Create an unboxed pair of an Int literal expression, ensuring the given
605 -- Integer is in the target Int range and the corresponding overflow flag
606 -- (@0#@/@1#@) if it wasn't.
607 intCResult :: DynFlags -> Integer -> Maybe CoreExpr
608 intCResult dflags result = Just (mkPair [Lit lit, Lit c])
609 where
610 mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]
611 (lit, b) = mkLitIntWrapC dflags result
612 c = if b then onei dflags else zeroi dflags
613
614 -- | Create a Word literal expression while ensuring the given Integer is in the
615 -- target Word range
616 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
617 wordResult dflags result = Just (wordResult' dflags result)
618
619 wordResult' :: DynFlags -> Integer -> CoreExpr
620 wordResult' dflags result = Lit (mkLitWordWrap dflags result)
621
622 -- | Create an unboxed pair of a Word literal expression, ensuring the given
623 -- Integer is in the target Word range and the corresponding carry flag
624 -- (@0#@/@1#@) if it wasn't.
625 wordCResult :: DynFlags -> Integer -> Maybe CoreExpr
626 wordCResult dflags result = Just (mkPair [Lit lit, Lit c])
627 where
628 mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]
629 (lit, b) = mkLitWordWrapC dflags result
630 c = if b then onei dflags else zeroi dflags
631
632 inversePrimOp :: PrimOp -> RuleM CoreExpr
633 inversePrimOp primop = do
634 [Var primop_id `App` e] <- getArgs
635 matchPrimOpId primop primop_id
636 return e
637
638 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
639 this `subsumesPrimOp` that = do
640 [Var primop_id `App` e] <- getArgs
641 matchPrimOpId that primop_id
642 return (Var (mkPrimOpId this) `App` e)
643
644 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
645 subsumedByPrimOp primop = do
646 [e@(Var primop_id `App` _)] <- getArgs
647 matchPrimOpId primop primop_id
648 return e
649
650 idempotent :: RuleM CoreExpr
651 idempotent = do [e1, e2] <- getArgs
652 guard $ cheapEqExpr e1 e2
653 return e1
654
655 {-
656 Note [Guarding against silly shifts]
657 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
658 Consider this code:
659
660 import Data.Bits( (.|.), shiftL )
661 chunkToBitmap :: [Bool] -> Word32
662 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
663
664 This optimises to:
665 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
666 case w1_sCT of _ {
667 [] -> 0##;
668 : x_aAW xs_aAX ->
669 case x_aAW of _ {
670 GHC.Types.False ->
671 case w_sCS of wild2_Xh {
672 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
673 9223372036854775807 -> 0## };
674 GHC.Types.True ->
675 case GHC.Prim.>=# w_sCS 64 of _ {
676 GHC.Types.False ->
677 case w_sCS of wild3_Xh {
678 __DEFAULT ->
679 case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
680 GHC.Prim.or# (GHC.Prim.narrow32Word#
681 (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))
682 ww_sCW
683 };
684 9223372036854775807 ->
685 GHC.Prim.narrow32Word#
686 !!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)
687 };
688 GHC.Types.True ->
689 case w_sCS of wild3_Xh {
690 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
691 9223372036854775807 -> 0##
692 } } } }
693
694 Note the massive shift on line "!!!!". It can't happen, because we've checked
695 that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!
696 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
697 can't constant fold it, but if it gets to the assember we get
698 Error: operand type mismatch for `shl'
699
700 So the best thing to do is to rewrite the shift with a call to error,
701 when the second arg is stupid.
702
703 There are two cases:
704
705 - Shifting fixed-width things: the primops ISll, Sll, etc
706 These are handled by shiftRule.
707
708 We are happy to shift by any amount up to wordSize but no more.
709
710 - Shifting Integers: the function shiftLInteger, shiftRInteger
711 from the 'integer' library. These are handled by rule_shift_op,
712 and match_Integer_shift_op.
713
714 Here we could in principle shift by any amount, but we arbitary
715 limit the shift to 4 bits; in particualr we do not want shift by a
716 huge amount, which can happen in code like that above.
717
718 The two cases are more different in their code paths that is comfortable,
719 but that is only a historical accident.
720
721
722 ************************************************************************
723 * *
724 \subsection{Vaguely generic functions}
725 * *
726 ************************************************************************
727 -}
728
729 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
730 -- Gives the Rule the same name as the primop itself
731 mkBasicRule op_name n_args rm
732 = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
733 ru_fn = op_name,
734 ru_nargs = n_args,
735 ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
736
737 newtype RuleM r = RuleM
738 { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
739
740 instance Functor RuleM where
741 fmap = liftM
742
743 instance Applicative RuleM where
744 pure x = RuleM $ \_ _ _ -> Just x
745 (<*>) = ap
746
747 instance Monad RuleM where
748 RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
749 Nothing -> Nothing
750 Just r -> runRuleM (g r) dflags iu e
751 #if !MIN_VERSION_base(4,13,0)
752 fail = MonadFail.fail
753 #endif
754
755 instance MonadFail.MonadFail RuleM where
756 fail _ = mzero
757
758 instance Alternative RuleM where
759 empty = RuleM $ \_ _ _ -> Nothing
760 RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args ->
761 f1 dflags iu args <|> f2 dflags iu args
762
763 instance MonadPlus RuleM
764
765 instance HasDynFlags RuleM where
766 getDynFlags = RuleM $ \dflags _ _ -> Just dflags
767
768 liftMaybe :: Maybe a -> RuleM a
769 liftMaybe Nothing = mzero
770 liftMaybe (Just x) = return x
771
772 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
773 liftLit f = liftLitDynFlags (const f)
774
775 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
776 liftLitDynFlags f = do
777 dflags <- getDynFlags
778 [Lit lit] <- getArgs
779 return $ Lit (f dflags lit)
780
781 removeOp32 :: RuleM CoreExpr
782 removeOp32 = do
783 dflags <- getDynFlags
784 if wordSizeInBits dflags == 32
785 then do
786 [e] <- getArgs
787 return e
788 else mzero
789
790 getArgs :: RuleM [CoreExpr]
791 getArgs = RuleM $ \_ _ args -> Just args
792
793 getInScopeEnv :: RuleM InScopeEnv
794 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
795
796 -- return the n-th argument of this rule, if it is a literal
797 -- argument indices start from 0
798 getLiteral :: Int -> RuleM Literal
799 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
800 (Lit l:_) -> Just l
801 _ -> Nothing
802
803 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
804 unaryLit op = do
805 dflags <- getDynFlags
806 [Lit l] <- getArgs
807 liftMaybe $ op dflags (convFloating dflags l)
808
809 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
810 binaryLit op = do
811 dflags <- getDynFlags
812 [Lit l1, Lit l2] <- getArgs
813 liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
814
815 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
816 binaryCmpLit op = do
817 dflags <- getDynFlags
818 binaryLit (\_ -> cmpOp dflags op)
819
820 leftIdentity :: Literal -> RuleM CoreExpr
821 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
822
823 rightIdentity :: Literal -> RuleM CoreExpr
824 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
825
826 identity :: Literal -> RuleM CoreExpr
827 identity lit = leftIdentity lit `mplus` rightIdentity lit
828
829 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
830 leftIdentityDynFlags id_lit = do
831 dflags <- getDynFlags
832 [Lit l1, e2] <- getArgs
833 guard $ l1 == id_lit dflags
834 return e2
835
836 -- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in
837 -- addition to the result, we have to indicate that no carry/overflow occured.
838 leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
839 leftIdentityCDynFlags id_lit = do
840 dflags <- getDynFlags
841 [Lit l1, e2] <- getArgs
842 guard $ l1 == id_lit dflags
843 let no_c = Lit (zeroi dflags)
844 return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])
845
846 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
847 rightIdentityDynFlags id_lit = do
848 dflags <- getDynFlags
849 [e1, Lit l2] <- getArgs
850 guard $ l2 == id_lit dflags
851 return e1
852
853 -- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in
854 -- addition to the result, we have to indicate that no carry/overflow occured.
855 rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
856 rightIdentityCDynFlags id_lit = do
857 dflags <- getDynFlags
858 [e1, Lit l2] <- getArgs
859 guard $ l2 == id_lit dflags
860 let no_c = Lit (zeroi dflags)
861 return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])
862
863 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
864 identityDynFlags lit =
865 leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
866
867 -- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition
868 -- to the result, we have to indicate that no carry/overflow occured.
869 identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
870 identityCDynFlags lit =
871 leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit
872
873 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
874 leftZero zero = do
875 dflags <- getDynFlags
876 [Lit l1, _] <- getArgs
877 guard $ l1 == zero dflags
878 return $ Lit l1
879
880 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
881 rightZero zero = do
882 dflags <- getDynFlags
883 [_, Lit l2] <- getArgs
884 guard $ l2 == zero dflags
885 return $ Lit l2
886
887 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
888 zeroElem lit = leftZero lit `mplus` rightZero lit
889
890 equalArgs :: RuleM ()
891 equalArgs = do
892 [e1, e2] <- getArgs
893 guard $ e1 `cheapEqExpr` e2
894
895 nonZeroLit :: Int -> RuleM ()
896 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
897
898 -- When excess precision is not requested, cut down the precision of the
899 -- Rational value to that of Float/Double. We confuse host architecture
900 -- and target architecture here, but it's convenient (and wrong :-).
901 convFloating :: DynFlags -> Literal -> Literal
902 convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) =
903 LitFloat (toRational (fromRational f :: Float ))
904 convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) =
905 LitDouble (toRational (fromRational d :: Double))
906 convFloating _ l = l
907
908 guardFloatDiv :: RuleM ()
909 guardFloatDiv = do
910 [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs
911 guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
912 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
913
914 guardDoubleDiv :: RuleM ()
915 guardDoubleDiv = do
916 [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs
917 guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
918 && d2 /= 0 -- avoid NaN and Infinity/-Infinity
919 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
920 -- zero, but we might want to preserve the negative zero here which
921 -- is representable in Float/Double but not in (normalised)
922 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
923
924 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
925 strengthReduction two_lit add_op = do -- Note [Strength reduction]
926 arg <- msum [ do [arg, Lit mult_lit] <- getArgs
927 guard (mult_lit == two_lit)
928 return arg
929 , do [Lit mult_lit, arg] <- getArgs
930 guard (mult_lit == two_lit)
931 return arg ]
932 return $ Var (mkPrimOpId add_op) `App` arg `App` arg
933
934 -- Note [Strength reduction]
935 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
936 --
937 -- This rule turns floating point multiplications of the form 2.0 * x and
938 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
939 -- See #7116
940
941 -- Note [What's true and false]
942 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
943 --
944 -- trueValInt and falseValInt represent true and false values returned by
945 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
946 -- True is represented as an unboxed 1# literal, while false is represented
947 -- as 0# literal.
948 -- We still need Bool data constructors (True and False) to use in a rule
949 -- for constant folding of equal Strings
950
951 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
952 trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
953 falseValInt dflags = Lit $ zeroi dflags
954
955 trueValBool, falseValBool :: Expr CoreBndr
956 trueValBool = Var trueDataConId -- see Note [What's true and false]
957 falseValBool = Var falseDataConId
958
959 ltVal, eqVal, gtVal :: Expr CoreBndr
960 ltVal = Var ordLTDataConId
961 eqVal = Var ordEQDataConId
962 gtVal = Var ordGTDataConId
963
964 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
965 mkIntVal dflags i = Lit (mkLitInt dflags i)
966 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
967 mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f))
968 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
969 mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d))
970
971 matchPrimOpId :: PrimOp -> Id -> RuleM ()
972 matchPrimOpId op id = do
973 op' <- liftMaybe $ isPrimOpId_maybe id
974 guard $ op == op'
975
976 {-
977 ************************************************************************
978 * *
979 \subsection{Special rules for seq, tagToEnum, dataToTag}
980 * *
981 ************************************************************************
982
983 Note [tagToEnum#]
984 ~~~~~~~~~~~~~~~~~
985 Nasty check to ensure that tagToEnum# is applied to a type that is an
986 enumeration TyCon. Unification may refine the type later, but this
987 check won't see that, alas. It's crude but it works.
988
989 Here's are two cases that should fail
990 f :: forall a. a
991 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
992
993 g :: Int
994 g = tagToEnum# 0 -- Int is not an enumeration
995
996 We used to make this check in the type inference engine, but it's quite
997 ugly to do so, because the delayed constraint solving means that we don't
998 really know what's going on until the end. It's very much a corner case
999 because we don't expect the user to call tagToEnum# at all; we merely
1000 generate calls in derived instances of Enum. So we compromise: a
1001 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
1002 and emits a warning.
1003 -}
1004
1005 tagToEnumRule :: RuleM CoreExpr
1006 -- If data T a = A | B | C
1007 -- then tag2Enum# (T ty) 2# --> B ty
1008 tagToEnumRule = do
1009 [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
1010 case splitTyConApp_maybe ty of
1011 Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
1012 let tag = fromInteger i
1013 correct_tag dc = (dataConTagZ dc) == tag
1014 (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
1015 ASSERT(null rest) return ()
1016 return $ mkTyApps (Var (dataConWorkId dc)) tc_args
1017
1018 -- See Note [tagToEnum#]
1019 _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )
1020 return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
1021
1022 ------------------------------
1023 dataToTagRule :: RuleM CoreExpr
1024 -- See Note [dataToTag#] in primops.txt.pp
1025 dataToTagRule = a `mplus` b
1026 where
1027 -- dataToTag (tagToEnum x) ==> x
1028 a = do
1029 [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
1030 guard $ tag_to_enum `hasKey` tagToEnumKey
1031 guard $ ty1 `eqType` ty2
1032 return tag
1033
1034 -- dataToTag (K e1 e2) ==> tag-of K
1035 -- This also works (via exprIsConApp_maybe) for
1036 -- dataToTag x
1037 -- where x's unfolding is a constructor application
1038 b = do
1039 dflags <- getDynFlags
1040 [_, val_arg] <- getArgs
1041 in_scope <- getInScopeEnv
1042 (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
1043 ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
1044 return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))
1045
1046 {- Note [dataToTag# magic]
1047 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1048 The primop dataToTag# is unusual because it evaluates its argument.
1049 Only `SeqOp` shares that property. (Other primops do not do anything
1050 as fancy as argument evaluation.) The special handling for dataToTag#
1051 is:
1052
1053 * CoreUtils.exprOkForSpeculation has a special case for DataToTagOp,
1054 (actually in app_ok). Most primops with lifted arguments do not
1055 evaluate those arguments, but DataToTagOp and SeqOp are two
1056 exceptions. We say that they are /never/ ok-for-speculation,
1057 regardless of the evaluated-ness of their argument.
1058 See CoreUtils Note [exprOkForSpeculation and SeqOp/DataToTagOp]
1059
1060 * There is a special case for DataToTagOp in StgCmmExpr.cgExpr,
1061 that evaluates its argument and then extracts the tag from
1062 the returned value.
1063
1064 * An application like (dataToTag# (Just x)) is optimised by
1065 dataToTagRule in PrelRules.
1066
1067 * A case expression like
1068 case (dataToTag# e) of <alts>
1069 gets transformed t
1070 case e of <transformed alts>
1071 by PrelRules.caseRules; see Note [caseRules for dataToTag]
1072
1073 See Trac #15696 for a long saga.
1074
1075
1076 ************************************************************************
1077 * *
1078 \subsection{Rules for seq# and spark#}
1079 * *
1080 ************************************************************************
1081 -}
1082
1083 {- Note [seq# magic]
1084 ~~~~~~~~~~~~~~~~~~~~
1085 The primop
1086 seq# :: forall a s . a -> State# s -> (# State# s, a #)
1087
1088 is /not/ the same as the Prelude function seq :: a -> b -> b
1089 as you can see from its type. In fact, seq# is the implementation
1090 mechanism for 'evaluate'
1091
1092 evaluate :: a -> IO a
1093 evaluate a = IO $ \s -> seq# a s
1094
1095 The semantics of seq# is
1096 * evaluate its first argument
1097 * and return it
1098
1099 Things to note
1100
1101 * Why do we need a primop at all? That is, instead of
1102 case seq# x s of (# x, s #) -> blah
1103 why not instead say this?
1104 case x of { DEFAULT -> blah)
1105
1106 Reason (see Trac #5129): if we saw
1107 catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler
1108
1109 then we'd drop the 'case x' because the body of the case is bottom
1110 anyway. But we don't want to do that; the whole /point/ of
1111 seq#/evaluate is to evaluate 'x' first in the IO monad.
1112
1113 In short, we /always/ evaluate the first argument and never
1114 just discard it.
1115
1116 * Why return the value? So that we can control sharing of seq'd
1117 values: in
1118 let x = e in x `seq` ... x ...
1119 We don't want to inline x, so better to represent it as
1120 let x = e in case seq# x RW of (# _, x' #) -> ... x' ...
1121 also it matches the type of rseq in the Eval monad.
1122
1123 Implementing seq#. The compiler has magic for SeqOp in
1124
1125 - PrelRules.seqRule: eliminate (seq# <whnf> s)
1126
1127 - StgCmmExpr.cgExpr, and cgCase: special case for seq#
1128
1129 - CoreUtils.exprOkForSpeculation;
1130 see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in CoreUtils
1131
1132 - Simplify.addEvals records evaluated-ness for the result; see
1133 Note [Adding evaluatedness info to pattern-bound variables]
1134 in Simplify
1135 -}
1136
1137 seqRule :: RuleM CoreExpr
1138 seqRule = do
1139 [Type ty_a, Type _ty_s, a, s] <- getArgs
1140 guard $ exprIsHNF a
1141 return $ mkCoreUbxTup [exprType s, ty_a] [s, a]
1142
1143 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
1144 sparkRule :: RuleM CoreExpr
1145 sparkRule = seqRule -- reduce on HNF, just the same
1146 -- XXX perhaps we shouldn't do this, because a spark eliminated by
1147 -- this rule won't be counted as a dud at runtime?
1148
1149 {-
1150 ************************************************************************
1151 * *
1152 \subsection{Built in rules}
1153 * *
1154 ************************************************************************
1155
1156 Note [Scoping for Builtin rules]
1157 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1158 When compiling a (base-package) module that defines one of the
1159 functions mentioned in the RHS of a built-in rule, there's a danger
1160 that we'll see
1161
1162 f = ...(eq String x)....
1163
1164 ....and lower down...
1165
1166 eqString = ...
1167
1168 Then a rewrite would give
1169
1170 f = ...(eqString x)...
1171 ....and lower down...
1172 eqString = ...
1173
1174 and lo, eqString is not in scope. This only really matters when we get to code
1175 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
1176 set of bindings, which sorts out the dependency. Without -O we don't do any rule
1177 rewriting so again we are fine.
1178
1179 (This whole thing doesn't show up for non-built-in rules because their dependencies
1180 are explicit.)
1181 -}
1182
1183 builtinRules :: [CoreRule]
1184 -- Rules for non-primops that can't be expressed using a RULE pragma
1185 builtinRules
1186 = [BuiltinRule { ru_name = fsLit "AppendLitString",
1187 ru_fn = unpackCStringFoldrName,
1188 ru_nargs = 4, ru_try = match_append_lit },
1189 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
1190 ru_nargs = 2, ru_try = match_eq_string },
1191 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
1192 ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
1193 BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
1194 ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },
1195 mkBasicRule divIntName 2 $ msum
1196 [ nonZeroLit 1 >> binaryLit (intOp2 div)
1197 , leftZero zeroi
1198 , do
1199 [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
1200 Just n <- return $ exactLog2 d
1201 dflags <- getDynFlags
1202 return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
1203 ],
1204 mkBasicRule modIntName 2 $ msum
1205 [ nonZeroLit 1 >> binaryLit (intOp2 mod)
1206 , leftZero zeroi
1207 , do
1208 [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
1209 Just _ <- return $ exactLog2 d
1210 dflags <- getDynFlags
1211 return $ Var (mkPrimOpId AndIOp)
1212 `App` arg `App` mkIntVal dflags (d - 1)
1213 ]
1214 ]
1215 ++ builtinIntegerRules
1216 ++ builtinNaturalRules
1217 {-# NOINLINE builtinRules #-}
1218 -- there is no benefit to inlining these yet, despite this, GHC produces
1219 -- unfoldings for this regardless since the floated list entries look small.
1220
1221 builtinIntegerRules :: [CoreRule]
1222 builtinIntegerRules =
1223 [rule_IntToInteger "smallInteger" smallIntegerName,
1224 rule_WordToInteger "wordToInteger" wordToIntegerName,
1225 rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
1226 rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
1227 rule_convert "integerToWord" integerToWordName mkWordLitWord,
1228 rule_convert "integerToInt" integerToIntName mkIntLitInt,
1229 rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64),
1230 rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64),
1231 rule_binop "plusInteger" plusIntegerName (+),
1232 rule_binop "minusInteger" minusIntegerName (-),
1233 rule_binop "timesInteger" timesIntegerName (*),
1234 rule_unop "negateInteger" negateIntegerName negate,
1235 rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
1236 rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
1237 rule_unop "absInteger" absIntegerName abs,
1238 rule_unop "signumInteger" signumIntegerName signum,
1239 rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
1240 rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
1241 rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
1242 rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
1243 rule_binop_Ordering "compareInteger" compareIntegerName compare,
1244 rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
1245 rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
1246 rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
1247 rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
1248 rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
1249 rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
1250 rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
1251 rule_binop "gcdInteger" gcdIntegerName gcd,
1252 rule_binop "lcmInteger" lcmIntegerName lcm,
1253 rule_binop "andInteger" andIntegerName (.&.),
1254 rule_binop "orInteger" orIntegerName (.|.),
1255 rule_binop "xorInteger" xorIntegerName xor,
1256 rule_unop "complementInteger" complementIntegerName complement,
1257 rule_shift_op "shiftLInteger" shiftLIntegerName shiftL,
1258 rule_shift_op "shiftRInteger" shiftRIntegerName shiftR,
1259 rule_bitInteger "bitInteger" bitIntegerName,
1260 -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
1261 rule_divop_one "quotInteger" quotIntegerName quot,
1262 rule_divop_one "remInteger" remIntegerName rem,
1263 rule_divop_one "divInteger" divIntegerName div,
1264 rule_divop_one "modInteger" modIntegerName mod,
1265 rule_divop_both "divModInteger" divModIntegerName divMod,
1266 rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
1267 -- These rules below don't actually have to be built in, but if we
1268 -- put them in the Haskell source then we'd have to duplicate them
1269 -- between all Integer implementations
1270 rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName,
1271 rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName,
1272 rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName,
1273 rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
1274 rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp,
1275 rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp,
1276 rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
1277 ]
1278 where rule_convert str name convert
1279 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1280 ru_try = match_Integer_convert convert }
1281 rule_IntToInteger str name
1282 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1283 ru_try = match_IntToInteger }
1284 rule_WordToInteger str name
1285 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1286 ru_try = match_WordToInteger }
1287 rule_Int64ToInteger str name
1288 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1289 ru_try = match_Int64ToInteger }
1290 rule_Word64ToInteger str name
1291 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1292 ru_try = match_Word64ToInteger }
1293 rule_unop str name op
1294 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1295 ru_try = match_Integer_unop op }
1296 rule_bitInteger str name
1297 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1298 ru_try = match_bitInteger }
1299 rule_binop str name op
1300 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1301 ru_try = match_Integer_binop op }
1302 rule_divop_both str name op
1303 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1304 ru_try = match_Integer_divop_both op }
1305 rule_divop_one str name op
1306 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1307 ru_try = match_Integer_divop_one op }
1308 rule_shift_op str name op
1309 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1310 ru_try = match_Integer_shift_op op }
1311 rule_binop_Prim str name op
1312 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1313 ru_try = match_Integer_binop_Prim op }
1314 rule_binop_Ordering str name op
1315 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1316 ru_try = match_Integer_binop_Ordering op }
1317 rule_encodeFloat str name op
1318 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1319 ru_try = match_Integer_Int_encodeFloat op }
1320 rule_decodeDouble str name
1321 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1322 ru_try = match_decodeDouble }
1323 rule_XToIntegerToX str name toIntegerName
1324 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1325 ru_try = match_XToIntegerToX toIntegerName }
1326 rule_smallIntegerTo str name primOp
1327 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1328 ru_try = match_smallIntegerTo primOp }
1329 rule_rationalTo str name mkLit
1330 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1331 ru_try = match_rationalTo mkLit }
1332
1333 builtinNaturalRules :: [CoreRule]
1334 builtinNaturalRules =
1335 [rule_binop "plusNatural" plusNaturalName (+)
1336 ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing)
1337 ,rule_binop "timesNatural" timesNaturalName (*)
1338 ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
1339 ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName
1340 ,rule_WordToNatural "wordToNatural" wordToNaturalName
1341 ]
1342 where rule_binop str name op
1343 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1344 ru_try = match_Natural_binop op }
1345 rule_partial_binop str name op
1346 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1347 ru_try = match_Natural_partial_binop op }
1348 rule_NaturalToInteger str name
1349 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1350 ru_try = match_NaturalToInteger }
1351 rule_NaturalFromInteger str name
1352 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1353 ru_try = match_NaturalFromInteger }
1354 rule_WordToNatural str name
1355 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1356 ru_try = match_WordToNatural }
1357
1358 ---------------------------------------------------
1359 -- The rule is this:
1360 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1361 -- = unpackFoldrCString# "foobaz" c n
1362
1363 match_append_lit :: RuleFun
1364 match_append_lit _ id_unf _
1365 [ Type ty1
1366 , lit1
1367 , c1
1368 , Var unpk `App` Type ty2
1369 `App` lit2
1370 `App` c2
1371 `App` n
1372 ]
1373 | unpk `hasKey` unpackCStringFoldrIdKey &&
1374 c1 `cheapEqExpr` c2
1375 , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1
1376 , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2
1377 = ASSERT( ty1 `eqType` ty2 )
1378 Just (Var unpk `App` Type ty1
1379 `App` Lit (LitString (s1 `BS.append` s2))
1380 `App` c1
1381 `App` n)
1382
1383 match_append_lit _ _ _ _ = Nothing
1384
1385 ---------------------------------------------------
1386 -- The rule is this:
1387 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2
1388
1389 match_eq_string :: RuleFun
1390 match_eq_string _ id_unf _
1391 [Var unpk1 `App` lit1, Var unpk2 `App` lit2]
1392 | unpk1 `hasKey` unpackCStringIdKey
1393 , unpk2 `hasKey` unpackCStringIdKey
1394 , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1
1395 , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2
1396 = Just (if s1 == s2 then trueValBool else falseValBool)
1397
1398 match_eq_string _ _ _ _ = Nothing
1399
1400
1401 ---------------------------------------------------
1402 -- The rule is this:
1403 -- inline f_ty (f a b c) = <f's unfolding> a b c
1404 -- (if f has an unfolding, EVEN if it's a loop breaker)
1405 --
1406 -- It's important to allow the argument to 'inline' to have args itself
1407 -- (a) because its more forgiving to allow the programmer to write
1408 -- inline f a b c
1409 -- or inline (f a b c)
1410 -- (b) because a polymorphic f wll get a type argument that the
1411 -- programmer can't avoid
1412 --
1413 -- Also, don't forget about 'inline's type argument!
1414 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1415 match_inline (Type _ : e : _)
1416 | (Var f, args1) <- collectArgs e,
1417 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1418 -- Ignore the IdUnfoldingFun here!
1419 = Just (mkApps unf args1)
1420
1421 match_inline _ = Nothing
1422
1423
1424 -- See Note [magicDictId magic] in `basicTypes/MkId.hs`
1425 -- for a description of what is going on here.
1426 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1427 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1428 | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
1429 , Just (dictTy, _) <- splitFunTy_maybe fieldTy
1430 , Just dictTc <- tyConAppTyCon_maybe dictTy
1431 , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
1432 = Just
1433 $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))
1434 `App` y
1435
1436 match_magicDict _ = Nothing
1437
1438 -------------------------------------------------
1439 -- Integer rules
1440 -- smallInteger (79::Int#) = 79::Integer
1441 -- wordToInteger (79::Word#) = 79::Integer
1442 -- Similarly Int64, Word64
1443
1444 match_IntToInteger :: RuleFun
1445 match_IntToInteger = match_IntToInteger_unop id
1446
1447 match_WordToInteger :: RuleFun
1448 match_WordToInteger _ id_unf id [xl]
1449 | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
1450 = case splitFunTy_maybe (idType id) of
1451 Just (_, integerTy) ->
1452 Just (Lit (mkLitInteger x integerTy))
1453 _ ->
1454 panic "match_WordToInteger: Id has the wrong type"
1455 match_WordToInteger _ _ _ _ = Nothing
1456
1457 match_Int64ToInteger :: RuleFun
1458 match_Int64ToInteger _ id_unf id [xl]
1459 | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
1460 = case splitFunTy_maybe (idType id) of
1461 Just (_, integerTy) ->
1462 Just (Lit (mkLitInteger x integerTy))
1463 _ ->
1464 panic "match_Int64ToInteger: Id has the wrong type"
1465 match_Int64ToInteger _ _ _ _ = Nothing
1466
1467 match_Word64ToInteger :: RuleFun
1468 match_Word64ToInteger _ id_unf id [xl]
1469 | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
1470 = case splitFunTy_maybe (idType id) of
1471 Just (_, integerTy) ->
1472 Just (Lit (mkLitInteger x integerTy))
1473 _ ->
1474 panic "match_Word64ToInteger: Id has the wrong type"
1475 match_Word64ToInteger _ _ _ _ = Nothing
1476
1477 match_NaturalToInteger :: RuleFun
1478 match_NaturalToInteger _ id_unf id [xl]
1479 | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
1480 = case splitFunTy_maybe (idType id) of
1481 Just (_, naturalTy) ->
1482 Just (Lit (LitNumber LitNumInteger x naturalTy))
1483 _ ->
1484 panic "match_NaturalToInteger: Id has the wrong type"
1485 match_NaturalToInteger _ _ _ _ = Nothing
1486
1487 match_NaturalFromInteger :: RuleFun
1488 match_NaturalFromInteger _ id_unf id [xl]
1489 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1490 , x >= 0
1491 = case splitFunTy_maybe (idType id) of
1492 Just (_, naturalTy) ->
1493 Just (Lit (LitNumber LitNumNatural x naturalTy))
1494 _ ->
1495 panic "match_NaturalFromInteger: Id has the wrong type"
1496 match_NaturalFromInteger _ _ _ _ = Nothing
1497
1498 match_WordToNatural :: RuleFun
1499 match_WordToNatural _ id_unf id [xl]
1500 | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
1501 = case splitFunTy_maybe (idType id) of
1502 Just (_, naturalTy) ->
1503 Just (Lit (LitNumber LitNumNatural x naturalTy))
1504 _ ->
1505 panic "match_WordToNatural: Id has the wrong type"
1506 match_WordToNatural _ _ _ _ = Nothing
1507
1508 -------------------------------------------------
1509 {- Note [Rewriting bitInteger]
1510 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1511 For most types the bitInteger operation can be implemented in terms of shifts.
1512 The integer-gmp package, however, can do substantially better than this if
1513 allowed to provide its own implementation. However, in so doing it previously lost
1514 constant-folding (see Trac #8832). The bitInteger rule above provides constant folding
1515 specifically for this function.
1516
1517 There is, however, a bit of trickiness here when it comes to ranges. While the
1518 AST encodes all integers as Integers, `bit` expects the bit
1519 index to be given as an Int. Hence we coerce to an Int in the rule definition.
1520 This will behave a bit funny for constants larger than the word size, but the user
1521 should expect some funniness given that they will have at very least ignored a
1522 warning in this case.
1523 -}
1524
1525 match_bitInteger :: RuleFun
1526 -- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
1527 match_bitInteger dflags id_unf fn [arg]
1528 | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
1529 , x >= 0
1530 , x <= (wordSizeInBits dflags - 1)
1531 -- Make sure x is small enough to yield a decently small iteger
1532 -- Attempting to construct the Integer for
1533 -- (bitInteger 9223372036854775807#)
1534 -- would be a bad idea (Trac #14959)
1535 , let x_int = fromIntegral x :: Int
1536 = case splitFunTy_maybe (idType fn) of
1537 Just (_, integerTy)
1538 -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
1539 _ -> panic "match_IntToInteger_unop: Id has the wrong type"
1540
1541 match_bitInteger _ _ _ _ = Nothing
1542
1543
1544 -------------------------------------------------
1545 match_Integer_convert :: Num a
1546 => (DynFlags -> a -> Expr CoreBndr)
1547 -> RuleFun
1548 match_Integer_convert convert dflags id_unf _ [xl]
1549 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1550 = Just (convert dflags (fromInteger x))
1551 match_Integer_convert _ _ _ _ _ = Nothing
1552
1553 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1554 match_Integer_unop unop _ id_unf _ [xl]
1555 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1556 = Just (Lit (LitNumber LitNumInteger (unop x) i))
1557 match_Integer_unop _ _ _ _ _ = Nothing
1558
1559 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
1560 match_IntToInteger_unop unop _ id_unf fn [xl]
1561 | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
1562 = case splitFunTy_maybe (idType fn) of
1563 Just (_, integerTy) ->
1564 Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
1565 _ ->
1566 panic "match_IntToInteger_unop: Id has the wrong type"
1567 match_IntToInteger_unop _ _ _ _ _ = Nothing
1568
1569 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1570 match_Integer_binop binop _ id_unf _ [xl,yl]
1571 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1572 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1573 = Just (Lit (mkLitInteger (x `binop` y) i))
1574 match_Integer_binop _ _ _ _ _ = Nothing
1575
1576 match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
1577 match_Natural_binop binop _ id_unf _ [xl,yl]
1578 | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
1579 , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
1580 = Just (Lit (mkLitNatural (x `binop` y) i))
1581 match_Natural_binop _ _ _ _ _ = Nothing
1582
1583 match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
1584 match_Natural_partial_binop binop _ id_unf _ [xl,yl]
1585 | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
1586 , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
1587 , Just z <- x `binop` y
1588 = Just (Lit (mkLitNatural z i))
1589 match_Natural_partial_binop _ _ _ _ _ = Nothing
1590
1591 -- This helper is used for the quotRem and divMod functions
1592 match_Integer_divop_both
1593 :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1594 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1595 | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
1596 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1597 , y /= 0
1598 , (r,s) <- x `divop` y
1599 = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
1600 match_Integer_divop_both _ _ _ _ _ = Nothing
1601
1602 -- This helper is used for the quot and rem functions
1603 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1604 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1605 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1606 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1607 , y /= 0
1608 = Just (Lit (mkLitInteger (x `divop` y) i))
1609 match_Integer_divop_one _ _ _ _ _ = Nothing
1610
1611 match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun
1612 -- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer
1613 -- See Note [Guarding against silly shifts]
1614 match_Integer_shift_op binop _ id_unf _ [xl,yl]
1615 | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
1616 , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
1617 , y >= 0
1618 , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat
1619 -- arbitrary. We can get huge shifts in inaccessible code
1620 -- (Trac #15673)
1621 = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
1622 match_Integer_shift_op _ _ _ _ _ = Nothing
1623
1624 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1625 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1626 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1627 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1628 = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1629 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1630
1631 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1632 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1633 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1634 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1635 = Just $ case x `binop` y of
1636 LT -> ltVal
1637 EQ -> eqVal
1638 GT -> gtVal
1639 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1640
1641 match_Integer_Int_encodeFloat :: RealFloat a
1642 => (a -> Expr CoreBndr)
1643 -> RuleFun
1644 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1645 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1646 , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl
1647 = Just (mkLit $ encodeFloat x (fromInteger y))
1648 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1649
1650 ---------------------------------------------------
1651 -- constant folding for Float/Double
1652 --
1653 -- This turns
1654 -- rationalToFloat n d
1655 -- into a literal Float, and similarly for Doubles.
1656 --
1657 -- it's important to not match d == 0, because that may represent a
1658 -- literal "0/0" or similar, and we can't produce a literal value for
1659 -- NaN or +-Inf
1660 match_rationalTo :: RealFloat a
1661 => (a -> Expr CoreBndr)
1662 -> RuleFun
1663 match_rationalTo mkLit _ id_unf _ [xl, yl]
1664 | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
1665 , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
1666 , y /= 0
1667 = Just (mkLit (fromRational (x % y)))
1668 match_rationalTo _ _ _ _ _ = Nothing
1669
1670 match_decodeDouble :: RuleFun
1671 match_decodeDouble dflags id_unf fn [xl]
1672 | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl
1673 = case splitFunTy_maybe (idType fn) of
1674 Just (_, res)
1675 | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res
1676 -> case decodeFloat (fromRational x :: Double) of
1677 (y, z) ->
1678 Just $ mkCoreUbxTup [integerTy, intHashTy]
1679 [Lit (mkLitInteger y integerTy),
1680 Lit (mkLitInt dflags (toInteger z))]
1681 _ ->
1682 pprPanic "match_decodeDouble: Id has the wrong type"
1683 (ppr fn <+> dcolon <+> ppr (idType fn))
1684 match_decodeDouble _ _ _ _ = Nothing
1685
1686 match_XToIntegerToX :: Name -> RuleFun
1687 match_XToIntegerToX n _ _ _ [App (Var x) y]
1688 | idName x == n
1689 = Just y
1690 match_XToIntegerToX _ _ _ _ _ = Nothing
1691
1692 match_smallIntegerTo :: PrimOp -> RuleFun
1693 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1694 | idName x == smallIntegerName
1695 = Just $ App (Var (mkPrimOpId primOp)) y
1696 match_smallIntegerTo _ _ _ _ _ = Nothing
1697
1698
1699
1700 --------------------------------------------------------
1701 -- Note [Constant folding through nested expressions]
1702 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1703 --
1704 -- We use rewrites rules to perform constant folding. It means that we don't
1705 -- have a global view of the expression we are trying to optimise. As a
1706 -- consequence we only perform local (small-step) transformations that either:
1707 -- 1) reduce the number of operations
1708 -- 2) rearrange the expression to increase the odds that other rules will
1709 -- match
1710 --
1711 -- We don't try to handle more complex expression optimisation cases that would
1712 -- require a global view. For example, rewriting expressions to increase
1713 -- sharing (e.g., Horner's method); optimisations that require local
1714 -- transformations increasing the number of operations; rearrangements to
1715 -- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).
1716 --
1717 -- We already have rules to perform constant folding on expressions with the
1718 -- following shape (where a and/or b are literals):
1719 --
1720 -- D) op
1721 -- /\
1722 -- / \
1723 -- / \
1724 -- a b
1725 --
1726 -- To support nested expressions, we match three other shapes of expression
1727 -- trees:
1728 --
1729 -- A) op1 B) op1 C) op1
1730 -- /\ /\ /\
1731 -- / \ / \ / \
1732 -- / \ / \ / \
1733 -- a op2 op2 c op2 op3
1734 -- /\ /\ /\ /\
1735 -- / \ / \ / \ / \
1736 -- b c a b a b c d
1737 --
1738 --
1739 -- R1) +/- simplification:
1740 -- ops = + or -, two literals (not siblings)
1741 --
1742 -- Examples:
1743 -- A: 5 + (10-x) ==> 15-x
1744 -- B: (10+x) + 5 ==> 15+x
1745 -- C: (5+a)-(5-b) ==> 0+(a+b)
1746 --
1747 -- R2) * simplification
1748 -- ops = *, two literals (not siblings)
1749 --
1750 -- Examples:
1751 -- A: 5 * (10*x) ==> 50*x
1752 -- B: (10*x) * 5 ==> 50*x
1753 -- C: (5*a)*(5*b) ==> 25*(a*b)
1754 --
1755 -- R3) * distribution over +/-
1756 -- op1 = *, op2 = + or -, two literals (not siblings)
1757 --
1758 -- This transformation doesn't reduce the number of operations but switches
1759 -- the outer and the inner operations so that the outer is (+) or (-) instead
1760 -- of (*). It increases the odds that other rules will match after this one.
1761 --
1762 -- Examples:
1763 -- A: 5 * (10-x) ==> 50 - (5*x)
1764 -- B: (10+x) * 5 ==> 50 + (5*x)
1765 -- C: Not supported as it would increase the number of operations:
1766 -- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b
1767 --
1768 -- R4) Simple factorization
1769 --
1770 -- op1 = + or -, op2/op3 = *,
1771 -- one literal for each innermost * operation (except in the D case),
1772 -- the two other terms are equals
1773 --
1774 -- Examples:
1775 -- A: x - (10*x) ==> (-9)*x
1776 -- B: (10*x) + x ==> 11*x
1777 -- C: (5*x)-(x*3) ==> 2*x
1778 -- D: x+x ==> 2*x
1779 --
1780 -- R5) +/- propagation
1781 --
1782 -- ops = + or -, one literal
1783 --
1784 -- This transformation doesn't reduce the number of operations but propagates
1785 -- the constant to the outer level. It increases the odds that other rules
1786 -- will match after this one.
1787 --
1788 -- Examples:
1789 -- A: x - (10-y) ==> (x+y) - 10
1790 -- B: (10+x) - y ==> 10 + (x-y)
1791 -- C: N/A (caught by the A and B cases)
1792 --
1793 --------------------------------------------------------
1794
1795 -- | Rules to perform constant folding into nested expressions
1796 --
1797 --See Note [Constant folding through nested expressions]
1798 numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr
1799 numFoldingRules op dict = do
1800 [e1,e2] <- getArgs
1801 dflags <- getDynFlags
1802 let PrimOps{..} = dict dflags
1803 if not (gopt Opt_NumConstantFolding dflags)
1804 then mzero
1805 else case BinOpApp e1 op e2 of
1806 -- R1) +/- simplification
1807 x :++: (y :++: v) -> return $ mkL (x+y) `add` v
1808 x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v
1809 x :++: (v :-: L y) -> return $ mkL (x-y) `add` v
1810 L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v
1811 L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v
1812 L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v
1813
1814 (y :++: v) :-: L x -> return $ mkL (y-x) `add` v
1815 (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v
1816 (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v
1817
1818 (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v)
1819 (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v)
1820 (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)
1821 (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v)
1822 (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w)
1823 (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v)
1824 (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w)
1825 (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v)
1826 (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w)
1827
1828 (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w)
1829 (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)
1830 (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w)
1831 (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v)
1832 (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v)
1833 (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v)
1834 (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w)
1835 (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w)
1836 (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w)
1837
1838 -- R2) * simplification
1839 x :**: (y :**: v) -> return $ mkL (x*y) `mul` v
1840 (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v)
1841
1842 -- R3) * distribution over +/-
1843 x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v)
1844 x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v)
1845 x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y)
1846
1847 -- R4) Simple factorization
1848 v :+: w
1849 | w `cheapEqExpr` v -> return $ mkL 2 `mul` v
1850 w :+: (y :**: v)
1851 | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v
1852 w :-: (y :**: v)
1853 | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v
1854 (y :**: v) :+: w
1855 | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v
1856 (y :**: v) :-: w
1857 | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v
1858 (x :**: w) :+: (y :**: v)
1859 | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v
1860 (x :**: w) :-: (y :**: v)
1861 | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v
1862
1863 -- R5) +/- propagation
1864 w :+: (y :++: v) -> return $ mkL y `add` (w `add` v)
1865 (y :++: v) :+: w -> return $ mkL y `add` (w `add` v)
1866 w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y
1867 (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w)
1868 w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y
1869 (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v)
1870 w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v)
1871 w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y
1872 (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v)
1873 (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y
1874
1875 _ -> mzero
1876
1877
1878
1879 -- | Match the application of a binary primop
1880 pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr
1881 pattern BinOpApp x op y = OpVal op `App` x `App` y
1882
1883 -- | Match a primop
1884 pattern OpVal :: PrimOp -> Arg CoreBndr
1885 pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where
1886 OpVal op = Var (mkPrimOpId op)
1887
1888
1889
1890 -- | Match a literal
1891 pattern L :: Integer -> Arg CoreBndr
1892 pattern L l <- Lit (isLitValue_maybe -> Just l)
1893
1894 -- | Match an addition
1895 pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
1896 pattern x :+: y <- BinOpApp x (isAddOp -> True) y
1897
1898 -- | Match an addition with a literal (handle commutativity)
1899 pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr
1900 pattern l :++: x <- (isAdd -> Just (l,x))
1901
1902 isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)
1903 isAdd e = case e of
1904 L l :+: x -> Just (l,x)
1905 x :+: L l -> Just (l,x)
1906 _ -> Nothing
1907
1908 -- | Match a multiplication
1909 pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
1910 pattern x :*: y <- BinOpApp x (isMulOp -> True) y
1911
1912 -- | Match a multiplication with a literal (handle commutativity)
1913 pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr
1914 pattern l :**: x <- (isMul -> Just (l,x))
1915
1916 isMul :: CoreExpr -> Maybe (Integer,CoreExpr)
1917 isMul e = case e of
1918 L l :*: x -> Just (l,x)
1919 x :*: L l -> Just (l,x)
1920 _ -> Nothing
1921
1922
1923 -- | Match a subtraction
1924 pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr
1925 pattern x :-: y <- BinOpApp x (isSubOp -> True) y
1926
1927 isSubOp :: PrimOp -> Bool
1928 isSubOp IntSubOp = True
1929 isSubOp WordSubOp = True
1930 isSubOp _ = False
1931
1932 isAddOp :: PrimOp -> Bool
1933 isAddOp IntAddOp = True
1934 isAddOp WordAddOp = True
1935 isAddOp _ = False
1936
1937 isMulOp :: PrimOp -> Bool
1938 isMulOp IntMulOp = True
1939 isMulOp WordMulOp = True
1940 isMulOp _ = False
1941
1942 -- | Explicit "type-class"-like dictionary for numeric primops
1943 --
1944 -- Depends on DynFlags because creating a literal value depends on DynFlags
1945 data PrimOps = PrimOps
1946 { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers
1947 , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers
1948 , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers
1949 , mkL :: Integer -> CoreExpr -- ^ Create a literal value
1950 }
1951
1952 intPrimOps :: DynFlags -> PrimOps
1953 intPrimOps dflags = PrimOps
1954 { add = \x y -> BinOpApp x IntAddOp y
1955 , sub = \x y -> BinOpApp x IntSubOp y
1956 , mul = \x y -> BinOpApp x IntMulOp y
1957 , mkL = intResult' dflags
1958 }
1959
1960 wordPrimOps :: DynFlags -> PrimOps
1961 wordPrimOps dflags = PrimOps
1962 { add = \x y -> BinOpApp x WordAddOp y
1963 , sub = \x y -> BinOpApp x WordSubOp y
1964 , mul = \x y -> BinOpApp x WordMulOp y
1965 , mkL = wordResult' dflags
1966 }
1967
1968
1969 --------------------------------------------------------
1970 -- Constant folding through case-expressions
1971 --
1972 -- cf Scrutinee Constant Folding in simplCore/SimplUtils
1973 --------------------------------------------------------
1974
1975 -- | Match the scrutinee of a case and potentially return a new scrutinee and a
1976 -- function to apply to each literal alternative.
1977 caseRules :: DynFlags
1978 -> CoreExpr -- Scrutinee
1979 -> Maybe ( CoreExpr -- New scrutinee
1980 , AltCon -> Maybe AltCon -- How to fix up the alt pattern
1981 -- Nothing <=> Unreachable
1982 -- See Note [Unreachable caseRules alternatives]
1983 , Id -> CoreExpr) -- How to reconstruct the original scrutinee
1984 -- from the new case-binder
1985 -- e.g case e of b {
1986 -- ...;
1987 -- con bs -> rhs;
1988 -- ... }
1989 -- ==>
1990 -- case e' of b' {
1991 -- ...;
1992 -- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;
1993 -- ... }
1994
1995 caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x#
1996 | Just op <- isPrimOpId_maybe f
1997 , Just x <- isLitValue_maybe l
1998 , Just adjust_lit <- adjustDyadicRight op x
1999 = Just (v, tx_lit_con dflags adjust_lit
2000 , \v -> (App (App (Var f) (Var v)) (Lit l)))
2001
2002 caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v
2003 | Just op <- isPrimOpId_maybe f
2004 , Just x <- isLitValue_maybe l
2005 , Just adjust_lit <- adjustDyadicLeft x op
2006 = Just (v, tx_lit_con dflags adjust_lit
2007 , \v -> (App (App (Var f) (Lit l)) (Var v)))
2008
2009
2010 caseRules dflags (App (Var f) v ) -- op v
2011 | Just op <- isPrimOpId_maybe f
2012 , Just adjust_lit <- adjustUnary op
2013 = Just (v, tx_lit_con dflags adjust_lit
2014 , \v -> App (Var f) (Var v))
2015
2016 -- See Note [caseRules for tagToEnum]
2017 caseRules dflags (App (App (Var f) type_arg) v)
2018 | Just TagToEnumOp <- isPrimOpId_maybe f
2019 = Just (v, tx_con_tte dflags
2020 , \v -> (App (App (Var f) type_arg) (Var v)))
2021
2022 -- See Note [caseRules for dataToTag]
2023 caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x
2024 | Just DataToTagOp <- isPrimOpId_maybe f
2025 , Just (tc, _) <- tcSplitTyConApp_maybe ty
2026 , isAlgTyCon tc
2027 = Just (v, tx_con_dtt ty
2028 , \v -> App (App (Var f) (Type ty)) (Var v))
2029
2030 caseRules _ _ = Nothing
2031
2032
2033 tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon
2034 tx_lit_con _ _ DEFAULT = Just DEFAULT
2035 tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l)
2036 tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt)
2037 -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the
2038 -- literal alternatives remain in Word/Int target ranges
2039 -- (See Note [Word/Int underflow/overflow] in Literal and #13172).
2040
2041 adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)
2042 -- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x
2043 adjustDyadicRight op lit
2044 = case op of
2045 WordAddOp -> Just (\y -> y-lit )
2046 IntAddOp -> Just (\y -> y-lit )
2047 WordSubOp -> Just (\y -> y+lit )
2048 IntSubOp -> Just (\y -> y+lit )
2049 XorOp -> Just (\y -> y `xor` lit)
2050 XorIOp -> Just (\y -> y `xor` lit)
2051 _ -> Nothing
2052
2053 adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)
2054 -- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x
2055 adjustDyadicLeft lit op
2056 = case op of
2057 WordAddOp -> Just (\y -> y-lit )
2058 IntAddOp -> Just (\y -> y-lit )
2059 WordSubOp -> Just (\y -> lit-y )
2060 IntSubOp -> Just (\y -> lit-y )
2061 XorOp -> Just (\y -> y `xor` lit)
2062 XorIOp -> Just (\y -> y `xor` lit)
2063 _ -> Nothing
2064
2065
2066 adjustUnary :: PrimOp -> Maybe (Integer -> Integer)
2067 -- Given (op x) return a function 'f' s.t. f (op x) = x
2068 adjustUnary op
2069 = case op of
2070 NotOp -> Just (\y -> complement y)
2071 NotIOp -> Just (\y -> complement y)
2072 IntNegOp -> Just (\y -> negate y )
2073 _ -> Nothing
2074
2075 tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon
2076 tx_con_tte _ DEFAULT = Just DEFAULT
2077 tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)
2078 tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum]
2079 = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc
2080
2081 tx_con_dtt :: Type -> AltCon -> Maybe AltCon
2082 tx_con_dtt _ DEFAULT = Just DEFAULT
2083 tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
2084 | tag >= 0
2085 , tag < n_data_cons
2086 = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!)
2087 | otherwise
2088 = Nothing
2089 where
2090 tag = fromInteger i :: ConTagZ
2091 tc = tyConAppTyCon ty
2092 n_data_cons = tyConFamilySize tc
2093 data_cons = tyConDataCons tc
2094
2095 tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)
2096
2097
2098 {- Note [caseRules for tagToEnum]
2099 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2100 We want to transform
2101 case tagToEnum x of
2102 False -> e1
2103 True -> e2
2104 into
2105 case x of
2106 0# -> e1
2107 1# -> e2
2108
2109 This rule eliminates a lot of boilerplate. For
2110 if (x>y) then e2 else e1
2111 we generate
2112 case tagToEnum (x ># y) of
2113 False -> e1
2114 True -> e2
2115 and it is nice to then get rid of the tagToEnum.
2116
2117 Beware (Trac #14768): avoid the temptation to map constructor 0 to
2118 DEFAULT, in the hope of getting this
2119 case (x ># y) of
2120 DEFAULT -> e1
2121 1# -> e2
2122 That fails utterly in the case of
2123 data Colour = Red | Green | Blue
2124 case tagToEnum x of
2125 DEFAULT -> e1
2126 Red -> e2
2127
2128 We don't want to get this!
2129 case x of
2130 DEFAULT -> e1
2131 DEFAULT -> e2
2132
2133 Instead, we deal with turning one branch into DEFAULT in SimplUtils
2134 (add_default in mkCase3).
2135
2136 Note [caseRules for dataToTag]
2137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2138 See also Note [dataToTag#] in primpops.txt.pp
2139
2140 We want to transform
2141 case dataToTag x of
2142 DEFAULT -> e1
2143 1# -> e2
2144 into
2145 case x of
2146 DEFAULT -> e1
2147 (:) _ _ -> e2
2148
2149 Note the need for some wildcard binders in
2150 the 'cons' case.
2151
2152 For the time, we only apply this transformation when the type of `x` is a type
2153 headed by a normal tycon. In particular, we do not apply this in the case of a
2154 data family tycon, since that would require carefully applying coercion(s)
2155 between the data family and the data family instance's representation type,
2156 which caseRules isn't currently engineered to handle (#14680).
2157
2158 Note [Unreachable caseRules alternatives]
2159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2160 Take care if we see something like
2161 case dataToTag x of
2162 DEFAULT -> e1
2163 -1# -> e2
2164 100 -> e3
2165 because there isn't a data constructor with tag -1 or 100. In this case the
2166 out-of-range alterantive is dead code -- we know the range of tags for x.
2167
2168 Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating
2169 an alternative that is unreachable.
2170
2171 You may wonder how this can happen: check out Trac #15436.
2172 -}