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