Replace .lhs with .hs in compiler comments
[ghc.git] / compiler / prelude / PrelRules.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[ConFold]{Constant Folder}
5
6 Conceptually, constant folding should be parameterized with the kind
7 of target machine to get identical behaviour during compilation time
8 and runtime. We cheat a little bit here...
9
10 ToDo:
11 check boundaries before folding, e.g. we can fold the Float addition
12 (i1 + i2) only if it results in a valid Float.
13 -}
14
15 {-# LANGUAGE CPP, RankNTypes #-}
16 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
17
18 module PrelRules ( primOpRules, builtinRules ) where
19
20 #include "HsVersions.h"
21 #include "../includes/MachDeps.h"
22
23 import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId )
24
25 import CoreSyn
26 import MkCore
27 import Id
28 import Literal
29 import CoreSubst ( exprIsLiteral_maybe )
30 import PrimOp ( PrimOp(..), tagToEnumKey )
31 import TysWiredIn
32 import TysPrim
33 import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe )
34 import DataCon ( dataConTag, dataConTyCon, dataConWorkId )
35 import CoreUtils ( cheapEqExpr, exprIsHNF )
36 import CoreUnfold ( exprIsConApp_maybe )
37 import Type
38 import TypeRep
39 import OccName ( occNameFS )
40 import PrelNames
41 import Maybes ( orElse )
42 import Name ( Name, nameOccName )
43 import Outputable
44 import FastString
45 import BasicTypes
46 import DynFlags
47 import Platform
48 import Util
49 import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..))
50
51 #if __GLASGOW_HASKELL__ >= 709
52 import Control.Applicative ( Alternative(..) )
53 #else
54 import Control.Applicative ( Applicative(..), Alternative(..) )
55 #endif
56
57 import Control.Monad
58 import Data.Bits as Bits
59 import qualified Data.ByteString as BS
60 import Data.Int
61 import Data.Ratio
62 import Data.Word
63
64 {-
65 Note [Constant folding]
66 ~~~~~~~~~~~~~~~~~~~~~~~
67 primOpRules generates a rewrite rule for each primop
68 These rules do what is often called "constant folding"
69 E.g. the rules for +# might say
70 4 +# 5 = 9
71 Well, of course you'd need a lot of rules if you did it
72 like that, so we use a BuiltinRule instead, so that we
73 can match in any two literal values. So the rule is really
74 more like
75 (Lit x) +# (Lit y) = Lit (x+#y)
76 where the (+#) on the rhs is done at compile time
77
78 That is why these rules are built in here.
79 -}
80
81 primOpRules :: Name -> PrimOp -> Maybe CoreRule
82 -- ToDo: something for integer-shift ops?
83 -- NotOp
84 primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ]
85 primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
86
87 -- Int operations
88 primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
89 , identityDynFlags zeroi ]
90 primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
91 , rightIdentityDynFlags zeroi
92 , equalArgs >> retLit zeroi ]
93 primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
94 , zeroElem zeroi
95 , identityDynFlags onei ]
96 primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)
97 , leftZero zeroi
98 , rightIdentityDynFlags onei
99 , equalArgs >> retLit onei ]
100 primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)
101 , leftZero zeroi
102 , do l <- getLiteral 1
103 dflags <- getDynFlags
104 guard (l == onei dflags)
105 retLit zeroi
106 , equalArgs >> retLit zeroi
107 , equalArgs >> retLit zeroi ]
108 primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))
109 , idempotent
110 , zeroElem zeroi ]
111 primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))
112 , idempotent
113 , identityDynFlags zeroi ]
114 primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)
115 , identityDynFlags zeroi
116 , equalArgs >> retLit zeroi ]
117 primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp
118 , inversePrimOp NotIOp ]
119 primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
120 , inversePrimOp IntNegOp ]
121 primOpRules nm ISllOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftL)
122 , rightIdentityDynFlags zeroi ]
123 primOpRules nm ISraOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 Bits.shiftR)
124 , rightIdentityDynFlags zeroi ]
125 primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ binaryLit (intOp2' shiftRightLogical)
126 , rightIdentityDynFlags zeroi ]
127
128 -- Word operations
129 primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))
130 , identityDynFlags zerow ]
131 primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))
132 , rightIdentityDynFlags zerow
133 , equalArgs >> retLit zerow ]
134 primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))
135 , identityDynFlags onew ]
136 primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)
137 , rightIdentityDynFlags onew ]
138 primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)
139 , rightIdentityDynFlags onew ]
140 primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))
141 , idempotent
142 , zeroElem zerow ]
143 primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))
144 , idempotent
145 , identityDynFlags zerow ]
146 primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)
147 , identityDynFlags zerow
148 , equalArgs >> retLit zerow ]
149 primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp
150 , inversePrimOp NotOp ]
151 primOpRules nm SllOp = mkPrimOpRule nm 2 [ wordShiftRule (const Bits.shiftL) ]
152 primOpRules nm SrlOp = mkPrimOpRule nm 2 [ wordShiftRule shiftRightLogical ]
153
154 -- coercions
155 primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit
156 , inversePrimOp Int2WordOp ]
157 primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit
158 , inversePrimOp Word2IntOp ]
159 primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit
160 , subsumedByPrimOp Narrow8IntOp
161 , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp
162 , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ]
163 primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit
164 , subsumedByPrimOp Narrow8IntOp
165 , subsumedByPrimOp Narrow16IntOp
166 , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ]
167 primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit
168 , subsumedByPrimOp Narrow8IntOp
169 , subsumedByPrimOp Narrow16IntOp
170 , subsumedByPrimOp Narrow32IntOp
171 , removeOp32 ]
172 primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit
173 , subsumedByPrimOp Narrow8WordOp
174 , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp
175 , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ]
176 primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit
177 , subsumedByPrimOp Narrow8WordOp
178 , subsumedByPrimOp Narrow16WordOp
179 , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ]
180 primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit
181 , subsumedByPrimOp Narrow8WordOp
182 , subsumedByPrimOp Narrow16WordOp
183 , subsumedByPrimOp Narrow32WordOp
184 , removeOp32 ]
185 primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit
186 , inversePrimOp ChrOp ]
187 primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs
188 guard (litFitsInChar lit)
189 liftLit int2CharLit
190 , inversePrimOp OrdOp ]
191 primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ]
192 primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ]
193 primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ]
194 primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]
195 -- SUP: Not sure what the standard says about precision in the following 2 cases
196 primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]
197 primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ]
198
199 -- Float
200 primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))
201 , identity zerof ]
202 primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))
203 , rightIdentity zerof ]
204 primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))
205 , identity onef
206 , strengthReduction twof FloatAddOp ]
207 -- zeroElem zerof doesn't hold because of NaN
208 primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))
209 , rightIdentity onef ]
210 primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
211 , inversePrimOp FloatNegOp ]
212
213 -- Double
214 primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))
215 , identity zerod ]
216 primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))
217 , rightIdentity zerod ]
218 primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))
219 , identity oned
220 , strengthReduction twod DoubleAddOp ]
221 -- zeroElem zerod doesn't hold because of NaN
222 primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))
223 , rightIdentity oned ]
224 primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp
225 , inversePrimOp DoubleNegOp ]
226
227 -- Relational operators
228
229 primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ]
230 primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ]
231 primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ]
232 primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ]
233
234 primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
235 primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
236 primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
237 primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
238
239 primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
240 primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
241 primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
242 primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
243
244 primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) []
245 primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) []
246 primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) []
247 primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) []
248 primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
249 primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
250
251 primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) []
252 primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
253 primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
254 primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) []
255 primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
256 primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
257
258 primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
259 primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
260 primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
261 primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
262 primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ]
263 primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ]
264
265 primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ]
266
267 primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ]
268 primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ]
269
270 primOpRules _ _ = Nothing
271
272 {-
273 ************************************************************************
274 * *
275 \subsection{Doing the business}
276 * *
277 ************************************************************************
278 -}
279
280 -- useful shorthands
281 mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule
282 mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
283
284 mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
285 -> [RuleM CoreExpr] -> Maybe CoreRule
286 mkRelOpRule nm cmp extra
287 = mkPrimOpRule nm 2 $ rules ++ extra
288 where
289 rules = [ binaryCmpLit cmp
290 , do equalArgs
291 -- x `cmp` x does not depend on x, so
292 -- compute it for the arbitrary value 'True'
293 -- and use that result
294 dflags <- getDynFlags
295 return (if cmp True True
296 then trueValInt dflags
297 else falseValInt dflags) ]
298
299 -- Note [Rules for floating-point comparisons]
300 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
301 --
302 -- We need different rules for floating-point values because for floats
303 -- it is not true that x = x. The special case when this does not occur
304 -- are NaNs.
305
306 mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
307 -> [RuleM CoreExpr] -> Maybe CoreRule
308 mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
309 = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
310
311 -- common constants
312 zeroi, onei, zerow, onew :: DynFlags -> Literal
313 zeroi dflags = mkMachInt dflags 0
314 onei dflags = mkMachInt dflags 1
315 zerow dflags = mkMachWord dflags 0
316 onew dflags = mkMachWord dflags 1
317
318 zerof, onef, twof, zerod, oned, twod :: Literal
319 zerof = mkMachFloat 0.0
320 onef = mkMachFloat 1.0
321 twof = mkMachFloat 2.0
322 zerod = mkMachDouble 0.0
323 oned = mkMachDouble 1.0
324 twod = mkMachDouble 2.0
325
326 cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool)
327 -> Literal -> Literal -> Maybe CoreExpr
328 cmpOp dflags cmp = go
329 where
330 done True = Just $ trueValInt dflags
331 done False = Just $ falseValInt dflags
332
333 -- These compares are at different types
334 go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2)
335 go (MachInt i1) (MachInt i2) = done (i1 `cmp` i2)
336 go (MachInt64 i1) (MachInt64 i2) = done (i1 `cmp` i2)
337 go (MachWord i1) (MachWord i2) = done (i1 `cmp` i2)
338 go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
339 go (MachFloat i1) (MachFloat i2) = done (i1 `cmp` i2)
340 go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
341 go _ _ = Nothing
342
343 --------------------------
344
345 negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate
346 negOp _ (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational
347 negOp dflags (MachFloat f) = Just (mkFloatVal dflags (-f))
348 negOp _ (MachDouble 0.0) = Nothing
349 negOp dflags (MachDouble d) = Just (mkDoubleVal dflags (-d))
350 negOp dflags (MachInt i) = intResult dflags (-i)
351 negOp _ _ = Nothing
352
353 complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement
354 complementOp dflags (MachWord i) = wordResult dflags (complement i)
355 complementOp dflags (MachInt i) = intResult dflags (complement i)
356 complementOp _ _ = Nothing
357
358 --------------------------
359 intOp2 :: (Integral a, Integral b)
360 => (a -> b -> Integer)
361 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
362 intOp2 = intOp2' . const
363
364 intOp2' :: (Integral a, Integral b)
365 => (DynFlags -> a -> b -> Integer)
366 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
367 intOp2' op dflags (MachInt i1) (MachInt i2) =
368 let o = op dflags
369 in intResult dflags (fromInteger i1 `o` fromInteger i2)
370 intOp2' _ _ _ _ = Nothing -- Could find LitLit
371
372 shiftRightLogical :: DynFlags -> Integer -> Int -> Integer
373 -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do
374 -- Do this by converting to Word and back. Obviously this won't work for big
375 -- values, but its ok as we use it here
376 shiftRightLogical dflags x n
377 | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32)
378 | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64)
379 | otherwise = panic "shiftRightLogical: unsupported word size"
380
381 --------------------------
382 retLit :: (DynFlags -> Literal) -> RuleM CoreExpr
383 retLit l = do dflags <- getDynFlags
384 return $ Lit $ l dflags
385
386 wordOp2 :: (Integral a, Integral b)
387 => (a -> b -> Integer)
388 -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
389 wordOp2 op dflags (MachWord w1) (MachWord w2)
390 = wordResult dflags (fromInteger w1 `op` fromInteger w2)
391 wordOp2 _ _ _ _ = Nothing -- Could find LitLit
392
393 wordShiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
394 -- Shifts take an Int; hence third arg of op is Int
395 -- See Note [Guarding against silly shifts]
396 wordShiftRule shift_op
397 = do { dflags <- getDynFlags
398 ; [e1, Lit (MachInt shift_len)] <- getArgs
399 ; case e1 of
400 _ | shift_len == 0
401 -> return e1
402 | shift_len < 0 || wordSizeInBits dflags < shift_len
403 -> return (mkRuntimeErrorApp rUNTIME_ERROR_ID wordPrimTy
404 ("Bad shift length" ++ show shift_len))
405 Lit (MachWord x)
406 -> let op = shift_op dflags
407 in liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
408 -- Do the shift at type Integer, but shift length is Int
409 _ -> mzero }
410
411 wordSizeInBits :: DynFlags -> Integer
412 wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3)
413
414 --------------------------
415 floatOp2 :: (Rational -> Rational -> Rational)
416 -> DynFlags -> Literal -> Literal
417 -> Maybe (Expr CoreBndr)
418 floatOp2 op dflags (MachFloat f1) (MachFloat f2)
419 = Just (mkFloatVal dflags (f1 `op` f2))
420 floatOp2 _ _ _ _ = Nothing
421
422 --------------------------
423 doubleOp2 :: (Rational -> Rational -> Rational)
424 -> DynFlags -> Literal -> Literal
425 -> Maybe (Expr CoreBndr)
426 doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
427 = Just (mkDoubleVal dflags (f1 `op` f2))
428 doubleOp2 _ _ _ _ = Nothing
429
430 --------------------------
431 -- This stuff turns
432 -- n ==# 3#
433 -- into
434 -- case n of
435 -- 3# -> True
436 -- m -> False
437 --
438 -- This is a Good Thing, because it allows case-of case things
439 -- to happen, and case-default absorption to happen. For
440 -- example:
441 --
442 -- if (n ==# 3#) || (n ==# 4#) then e1 else e2
443 -- will transform to
444 -- case n of
445 -- 3# -> e1
446 -- 4# -> e1
447 -- m -> e2
448 -- (modulo the usual precautions to avoid duplicating e1)
449
450 litEq :: Bool -- True <=> equality, False <=> inequality
451 -> RuleM CoreExpr
452 litEq is_eq = msum
453 [ do [Lit lit, expr] <- getArgs
454 dflags <- getDynFlags
455 do_lit_eq dflags lit expr
456 , do [expr, Lit lit] <- getArgs
457 dflags <- getDynFlags
458 do_lit_eq dflags lit expr ]
459 where
460 do_lit_eq dflags lit expr = do
461 guard (not (litIsLifted lit))
462 return (mkWildCase expr (literalType lit) intPrimTy
463 [(DEFAULT, [], val_if_neq),
464 (LitAlt lit, [], val_if_eq)])
465 where
466 val_if_eq | is_eq = trueValInt dflags
467 | otherwise = falseValInt dflags
468 val_if_neq | is_eq = falseValInt dflags
469 | otherwise = trueValInt dflags
470
471
472 -- | Check if there is comparison with minBound or maxBound, that is
473 -- always true or false. For instance, an Int cannot be smaller than its
474 -- minBound, so we can replace such comparison with False.
475 boundsCmp :: Comparison -> RuleM CoreExpr
476 boundsCmp op = do
477 dflags <- getDynFlags
478 [a, b] <- getArgs
479 liftMaybe $ mkRuleFn dflags op a b
480
481 data Comparison = Gt | Ge | Lt | Le
482
483 mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr
484 mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags
485 mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags
486 mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags
487 mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags
488 mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags
489 mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags
490 mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags
491 mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags
492 mkRuleFn _ _ _ _ = Nothing
493
494 isMinBound :: DynFlags -> Literal -> Bool
495 isMinBound _ (MachChar c) = c == minBound
496 isMinBound dflags (MachInt i) = i == tARGET_MIN_INT dflags
497 isMinBound _ (MachInt64 i) = i == toInteger (minBound :: Int64)
498 isMinBound _ (MachWord i) = i == 0
499 isMinBound _ (MachWord64 i) = i == 0
500 isMinBound _ _ = False
501
502 isMaxBound :: DynFlags -> Literal -> Bool
503 isMaxBound _ (MachChar c) = c == maxBound
504 isMaxBound dflags (MachInt i) = i == tARGET_MAX_INT dflags
505 isMaxBound _ (MachInt64 i) = i == toInteger (maxBound :: Int64)
506 isMaxBound dflags (MachWord i) = i == tARGET_MAX_WORD dflags
507 isMaxBound _ (MachWord64 i) = i == toInteger (maxBound :: Word64)
508 isMaxBound _ _ = False
509
510
511 -- Note that we *don't* warn the user about overflow. It's not done at
512 -- runtime either, and compilation of completely harmless things like
513 -- ((124076834 :: Word32) + (2147483647 :: Word32))
514 -- would yield a warning. Instead we simply squash the value into the
515 -- *target* Int/Word range.
516 intResult :: DynFlags -> Integer -> Maybe CoreExpr
517 intResult dflags result = Just (mkIntVal dflags result')
518 where result' = case platformWordSize (targetPlatform dflags) of
519 4 -> toInteger (fromInteger result :: Int32)
520 8 -> toInteger (fromInteger result :: Int64)
521 w -> panic ("intResult: Unknown platformWordSize: " ++ show w)
522
523 wordResult :: DynFlags -> Integer -> Maybe CoreExpr
524 wordResult dflags result = Just (mkWordVal dflags result')
525 where result' = case platformWordSize (targetPlatform dflags) of
526 4 -> toInteger (fromInteger result :: Word32)
527 8 -> toInteger (fromInteger result :: Word64)
528 w -> panic ("wordResult: Unknown platformWordSize: " ++ show w)
529
530 inversePrimOp :: PrimOp -> RuleM CoreExpr
531 inversePrimOp primop = do
532 [Var primop_id `App` e] <- getArgs
533 matchPrimOpId primop primop_id
534 return e
535
536 subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr
537 this `subsumesPrimOp` that = do
538 [Var primop_id `App` e] <- getArgs
539 matchPrimOpId that primop_id
540 return (Var (mkPrimOpId this) `App` e)
541
542 subsumedByPrimOp :: PrimOp -> RuleM CoreExpr
543 subsumedByPrimOp primop = do
544 [e@(Var primop_id `App` _)] <- getArgs
545 matchPrimOpId primop primop_id
546 return e
547
548 idempotent :: RuleM CoreExpr
549 idempotent = do [e1, e2] <- getArgs
550 guard $ cheapEqExpr e1 e2
551 return e1
552
553 {-
554 Note [Guarding against silly shifts]
555 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
556 Consider this code:
557
558 import Data.Bits( (.|.), shiftL )
559 chunkToBitmap :: [Bool] -> Word32
560 chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
561
562 This optimises to:
563 Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->
564 case w1_sCT of _ {
565 [] -> __word 0;
566 : x_aAW xs_aAX ->
567 case x_aAW of _ {
568 GHC.Types.False ->
569 case w_sCS of wild2_Xh {
570 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;
571 9223372036854775807 -> __word 0 };
572 GHC.Types.True ->
573 case GHC.Prim.>=# w_sCS 64 of _ {
574 GHC.Types.False ->
575 case w_sCS of wild3_Xh {
576 __DEFAULT ->
577 case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->
578 GHC.Prim.or# (GHC.Prim.narrow32Word#
579 (GHC.Prim.uncheckedShiftL# (__word 1) wild3_Xh))
580 ww_sCW
581 };
582 9223372036854775807 ->
583 GHC.Prim.narrow32Word#
584 !!!!--> (GHC.Prim.uncheckedShiftL# (__word 1) 9223372036854775807)
585 };
586 GHC.Types.True ->
587 case w_sCS of wild3_Xh {
588 __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;
589 9223372036854775807 -> __word 0
590 } } } }
591
592 Note the massive shift on line "!!!!". It can't happen, because we've checked
593 that w < 64, but the optimiser didn't spot that. We DO NO want to constant-fold this!
594 Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we
595 can't constant fold it, but if it gets to the assember we get
596 Error: operand type mismatch for `shl'
597
598 So the best thing to do is to rewrite the shift with a call to error,
599 when the second arg is stupid.
600
601 ************************************************************************
602 * *
603 \subsection{Vaguely generic functions}
604 * *
605 ************************************************************************
606 -}
607
608 mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule
609 -- Gives the Rule the same name as the primop itself
610 mkBasicRule op_name n_args rm
611 = BuiltinRule { ru_name = occNameFS (nameOccName op_name),
612 ru_fn = op_name,
613 ru_nargs = n_args,
614 ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope }
615
616 newtype RuleM r = RuleM
617 { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r }
618
619 instance Functor RuleM where
620 fmap = liftM
621
622 instance Applicative RuleM where
623 pure = return
624 (<*>) = ap
625
626 instance Monad RuleM where
627 return x = RuleM $ \_ _ _ -> Just x
628 RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of
629 Nothing -> Nothing
630 Just r -> runRuleM (g r) dflags iu e
631 fail _ = mzero
632
633 instance Alternative RuleM where
634 empty = mzero
635 (<|>) = mplus
636
637 instance MonadPlus RuleM where
638 mzero = RuleM $ \_ _ _ -> Nothing
639 mplus (RuleM f1) (RuleM f2) = RuleM $ \dflags iu args ->
640 f1 dflags iu args `mplus` f2 dflags iu args
641
642 instance HasDynFlags RuleM where
643 getDynFlags = RuleM $ \dflags _ _ -> Just dflags
644
645 liftMaybe :: Maybe a -> RuleM a
646 liftMaybe Nothing = mzero
647 liftMaybe (Just x) = return x
648
649 liftLit :: (Literal -> Literal) -> RuleM CoreExpr
650 liftLit f = liftLitDynFlags (const f)
651
652 liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr
653 liftLitDynFlags f = do
654 dflags <- getDynFlags
655 [Lit lit] <- getArgs
656 return $ Lit (f dflags lit)
657
658 removeOp32 :: RuleM CoreExpr
659 removeOp32 = do
660 dflags <- getDynFlags
661 if wordSizeInBits dflags == 32
662 then do
663 [e] <- getArgs
664 return e
665 else mzero
666
667 getArgs :: RuleM [CoreExpr]
668 getArgs = RuleM $ \_ _ args -> Just args
669
670 getInScopeEnv :: RuleM InScopeEnv
671 getInScopeEnv = RuleM $ \_ iu _ -> Just iu
672
673 -- return the n-th argument of this rule, if it is a literal
674 -- argument indices start from 0
675 getLiteral :: Int -> RuleM Literal
676 getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of
677 (Lit l:_) -> Just l
678 _ -> Nothing
679
680 unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
681 unaryLit op = do
682 dflags <- getDynFlags
683 [Lit l] <- getArgs
684 liftMaybe $ op dflags (convFloating dflags l)
685
686 binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
687 binaryLit op = do
688 dflags <- getDynFlags
689 [Lit l1, Lit l2] <- getArgs
690 liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
691
692 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
693 binaryCmpLit op = do
694 dflags <- getDynFlags
695 binaryLit (\_ -> cmpOp dflags op)
696
697 leftIdentity :: Literal -> RuleM CoreExpr
698 leftIdentity id_lit = leftIdentityDynFlags (const id_lit)
699
700 rightIdentity :: Literal -> RuleM CoreExpr
701 rightIdentity id_lit = rightIdentityDynFlags (const id_lit)
702
703 identity :: Literal -> RuleM CoreExpr
704 identity lit = leftIdentity lit `mplus` rightIdentity lit
705
706 leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
707 leftIdentityDynFlags id_lit = do
708 dflags <- getDynFlags
709 [Lit l1, e2] <- getArgs
710 guard $ l1 == id_lit dflags
711 return e2
712
713 rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
714 rightIdentityDynFlags id_lit = do
715 dflags <- getDynFlags
716 [e1, Lit l2] <- getArgs
717 guard $ l2 == id_lit dflags
718 return e1
719
720 identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr
721 identityDynFlags lit = leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit
722
723 leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr
724 leftZero zero = do
725 dflags <- getDynFlags
726 [Lit l1, _] <- getArgs
727 guard $ l1 == zero dflags
728 return $ Lit l1
729
730 rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr
731 rightZero zero = do
732 dflags <- getDynFlags
733 [_, Lit l2] <- getArgs
734 guard $ l2 == zero dflags
735 return $ Lit l2
736
737 zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr
738 zeroElem lit = leftZero lit `mplus` rightZero lit
739
740 equalArgs :: RuleM ()
741 equalArgs = do
742 [e1, e2] <- getArgs
743 guard $ e1 `cheapEqExpr` e2
744
745 nonZeroLit :: Int -> RuleM ()
746 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
747
748 -- When excess precision is not requested, cut down the precision of the
749 -- Rational value to that of Float/Double. We confuse host architecture
750 -- and target architecture here, but it's convenient (and wrong :-).
751 convFloating :: DynFlags -> Literal -> Literal
752 convFloating dflags (MachFloat f) | not (gopt Opt_ExcessPrecision dflags) =
753 MachFloat (toRational (fromRational f :: Float ))
754 convFloating dflags (MachDouble d) | not (gopt Opt_ExcessPrecision dflags) =
755 MachDouble (toRational (fromRational d :: Double))
756 convFloating _ l = l
757
758 guardFloatDiv :: RuleM ()
759 guardFloatDiv = do
760 [Lit (MachFloat f1), Lit (MachFloat f2)] <- getArgs
761 guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]
762 && f2 /= 0 -- avoid NaN and Infinity/-Infinity
763
764 guardDoubleDiv :: RuleM ()
765 guardDoubleDiv = do
766 [Lit (MachDouble d1), Lit (MachDouble d2)] <- getArgs
767 guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]
768 && d2 /= 0 -- avoid NaN and Infinity/-Infinity
769 -- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to
770 -- zero, but we might want to preserve the negative zero here which
771 -- is representable in Float/Double but not in (normalised)
772 -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?
773
774 strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr
775 strengthReduction two_lit add_op = do -- Note [Strength reduction]
776 arg <- msum [ do [arg, Lit mult_lit] <- getArgs
777 guard (mult_lit == two_lit)
778 return arg
779 , do [Lit mult_lit, arg] <- getArgs
780 guard (mult_lit == two_lit)
781 return arg ]
782 return $ Var (mkPrimOpId add_op) `App` arg `App` arg
783
784 -- Note [Strength reduction]
785 -- ~~~~~~~~~~~~~~~~~~~~~~~~~
786 --
787 -- This rule turns floating point multiplications of the form 2.0 * x and
788 -- x * 2.0 into x + x addition, because addition costs less than multiplication.
789 -- See #7116
790
791 -- Note [What's true and false]
792 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
793 --
794 -- trueValInt and falseValInt represent true and false values returned by
795 -- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.
796 -- True is represented as an unboxed 1# literal, while false is represented
797 -- as 0# literal.
798 -- We still need Bool data constructors (True and False) to use in a rule
799 -- for constant folding of equal Strings
800
801 trueValInt, falseValInt :: DynFlags -> Expr CoreBndr
802 trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false]
803 falseValInt dflags = Lit $ zeroi dflags
804
805 trueValBool, falseValBool :: Expr CoreBndr
806 trueValBool = Var trueDataConId -- see Note [What's true and false]
807 falseValBool = Var falseDataConId
808
809 ltVal, eqVal, gtVal :: Expr CoreBndr
810 ltVal = Var ltDataConId
811 eqVal = Var eqDataConId
812 gtVal = Var gtDataConId
813
814 mkIntVal :: DynFlags -> Integer -> Expr CoreBndr
815 mkIntVal dflags i = Lit (mkMachInt dflags i)
816 mkWordVal :: DynFlags -> Integer -> Expr CoreBndr
817 mkWordVal dflags w = Lit (mkMachWord dflags w)
818 mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr
819 mkFloatVal dflags f = Lit (convFloating dflags (MachFloat f))
820 mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr
821 mkDoubleVal dflags d = Lit (convFloating dflags (MachDouble d))
822
823 matchPrimOpId :: PrimOp -> Id -> RuleM ()
824 matchPrimOpId op id = do
825 op' <- liftMaybe $ isPrimOpId_maybe id
826 guard $ op == op'
827
828 {-
829 ************************************************************************
830 * *
831 \subsection{Special rules for seq, tagToEnum, dataToTag}
832 * *
833 ************************************************************************
834
835 Note [tagToEnum#]
836 ~~~~~~~~~~~~~~~~~
837 Nasty check to ensure that tagToEnum# is applied to a type that is an
838 enumeration TyCon. Unification may refine the type later, but this
839 check won't see that, alas. It's crude but it works.
840
841 Here's are two cases that should fail
842 f :: forall a. a
843 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
844
845 g :: Int
846 g = tagToEnum# 0 -- Int is not an enumeration
847
848 We used to make this check in the type inference engine, but it's quite
849 ugly to do so, because the delayed constraint solving means that we don't
850 really know what's going on until the end. It's very much a corner case
851 because we don't expect the user to call tagToEnum# at all; we merely
852 generate calls in derived instances of Enum. So we compromise: a
853 rewrite rule rewrites a bad instance of tagToEnum# to an error call,
854 and emits a warning.
855 -}
856
857 tagToEnumRule :: RuleM CoreExpr
858 -- If data T a = A | B | C
859 -- then tag2Enum# (T ty) 2# --> B ty
860 tagToEnumRule = do
861 [Type ty, Lit (MachInt i)] <- getArgs
862 case splitTyConApp_maybe ty of
863 Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
864 let tag = fromInteger i
865 correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
866 (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
867 ASSERT(null rest) return ()
868 return $ mkTyApps (Var (dataConWorkId dc)) tc_args
869
870 -- See Note [tagToEnum#]
871 _ -> WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
872 return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
873
874 {-
875 For dataToTag#, we can reduce if either
876
877 (a) the argument is a constructor
878 (b) the argument is a variable whose unfolding is a known constructor
879 -}
880
881 dataToTagRule :: RuleM CoreExpr
882 dataToTagRule = a `mplus` b
883 where
884 a = do
885 [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs
886 guard $ tag_to_enum `hasKey` tagToEnumKey
887 guard $ ty1 `eqType` ty2
888 return tag -- dataToTag (tagToEnum x) ==> x
889 b = do
890 dflags <- getDynFlags
891 [_, val_arg] <- getArgs
892 in_scope <- getInScopeEnv
893 (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg
894 ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()
895 return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG))
896
897 {-
898 ************************************************************************
899 * *
900 \subsection{Rules for seq# and spark#}
901 * *
902 ************************************************************************
903 -}
904
905 -- seq# :: forall a s . a -> State# s -> (# State# s, a #)
906 seqRule :: RuleM CoreExpr
907 seqRule = do
908 [ty_a, Type ty_s, a, s] <- getArgs
909 guard $ exprIsHNF a
910 return $ mkConApp (tupleCon UnboxedTuple 2)
911 [Type (mkStatePrimTy ty_s), ty_a, s, a]
912
913 -- spark# :: forall a s . a -> State# s -> (# State# s, a #)
914 sparkRule :: RuleM CoreExpr
915 sparkRule = seqRule -- reduce on HNF, just the same
916 -- XXX perhaps we shouldn't do this, because a spark eliminated by
917 -- this rule won't be counted as a dud at runtime?
918
919 {-
920 ************************************************************************
921 * *
922 \subsection{Built in rules}
923 * *
924 ************************************************************************
925
926 Note [Scoping for Builtin rules]
927 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
928 When compiling a (base-package) module that defines one of the
929 functions mentioned in the RHS of a built-in rule, there's a danger
930 that we'll see
931
932 f = ...(eq String x)....
933
934 ....and lower down...
935
936 eqString = ...
937
938 Then a rewrite would give
939
940 f = ...(eqString x)...
941 ....and lower down...
942 eqString = ...
943
944 and lo, eqString is not in scope. This only really matters when we get to code
945 generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole
946 set of bindings, which sorts out the dependency. Without -O we don't do any rule
947 rewriting so again we are fine.
948
949 (This whole thing doesn't show up for non-built-in rules because their dependencies
950 are explicit.)
951 -}
952
953 builtinRules :: [CoreRule]
954 -- Rules for non-primops that can't be expressed using a RULE pragma
955 builtinRules
956 = [BuiltinRule { ru_name = fsLit "AppendLitString",
957 ru_fn = unpackCStringFoldrName,
958 ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
959 BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
960 ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
961 BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
962 ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
963 BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
964 ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }
965 ]
966 ++ builtinIntegerRules
967
968 builtinIntegerRules :: [CoreRule]
969 builtinIntegerRules =
970 [rule_IntToInteger "smallInteger" smallIntegerName,
971 rule_WordToInteger "wordToInteger" wordToIntegerName,
972 rule_Int64ToInteger "int64ToInteger" int64ToIntegerName,
973 rule_Word64ToInteger "word64ToInteger" word64ToIntegerName,
974 rule_convert "integerToWord" integerToWordName mkWordLitWord,
975 rule_convert "integerToInt" integerToIntName mkIntLitInt,
976 rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64),
977 rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64),
978 rule_binop "plusInteger" plusIntegerName (+),
979 rule_binop "minusInteger" minusIntegerName (-),
980 rule_binop "timesInteger" timesIntegerName (*),
981 rule_unop "negateInteger" negateIntegerName negate,
982 rule_binop_Prim "eqInteger#" eqIntegerPrimName (==),
983 rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=),
984 rule_unop "absInteger" absIntegerName abs,
985 rule_unop "signumInteger" signumIntegerName signum,
986 rule_binop_Prim "leInteger#" leIntegerPrimName (<=),
987 rule_binop_Prim "gtInteger#" gtIntegerPrimName (>),
988 rule_binop_Prim "ltInteger#" ltIntegerPrimName (<),
989 rule_binop_Prim "geInteger#" geIntegerPrimName (>=),
990 rule_binop_Ordering "compareInteger" compareIntegerName compare,
991 rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat,
992 rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat),
993 rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble,
994 rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName,
995 rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble),
996 rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr,
997 rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr,
998 rule_binop "gcdInteger" gcdIntegerName gcd,
999 rule_binop "lcmInteger" lcmIntegerName lcm,
1000 rule_binop "andInteger" andIntegerName (.&.),
1001 rule_binop "orInteger" orIntegerName (.|.),
1002 rule_binop "xorInteger" xorIntegerName xor,
1003 rule_unop "complementInteger" complementIntegerName complement,
1004 rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL,
1005 rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR,
1006 -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs
1007 rule_divop_one "quotInteger" quotIntegerName quot,
1008 rule_divop_one "remInteger" remIntegerName rem,
1009 rule_divop_one "divInteger" divIntegerName div,
1010 rule_divop_one "modInteger" modIntegerName mod,
1011 rule_divop_both "divModInteger" divModIntegerName divMod,
1012 rule_divop_both "quotRemInteger" quotRemIntegerName quotRem,
1013 -- These rules below don't actually have to be built in, but if we
1014 -- put them in the Haskell source then we'd have to duplicate them
1015 -- between all Integer implementations
1016 rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName,
1017 rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName,
1018 rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName,
1019 rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName,
1020 rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp,
1021 rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp,
1022 rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp
1023 ]
1024 where rule_convert str name convert
1025 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1026 ru_try = match_Integer_convert convert }
1027 rule_IntToInteger str name
1028 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1029 ru_try = match_IntToInteger }
1030 rule_WordToInteger str name
1031 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1032 ru_try = match_WordToInteger }
1033 rule_Int64ToInteger str name
1034 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1035 ru_try = match_Int64ToInteger }
1036 rule_Word64ToInteger str name
1037 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1038 ru_try = match_Word64ToInteger }
1039 rule_unop str name op
1040 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1041 ru_try = match_Integer_unop op }
1042 rule_binop str name op
1043 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1044 ru_try = match_Integer_binop op }
1045 rule_divop_both str name op
1046 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1047 ru_try = match_Integer_divop_both op }
1048 rule_divop_one str name op
1049 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1050 ru_try = match_Integer_divop_one op }
1051 rule_Int_binop str name op
1052 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1053 ru_try = match_Integer_Int_binop op }
1054 rule_binop_Prim str name op
1055 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1056 ru_try = match_Integer_binop_Prim op }
1057 rule_binop_Ordering str name op
1058 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1059 ru_try = match_Integer_binop_Ordering op }
1060 rule_encodeFloat str name op
1061 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1062 ru_try = match_Integer_Int_encodeFloat op }
1063 rule_decodeDouble str name
1064 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1065 ru_try = match_decodeDouble }
1066 rule_XToIntegerToX str name toIntegerName
1067 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1068 ru_try = match_XToIntegerToX toIntegerName }
1069 rule_smallIntegerTo str name primOp
1070 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
1071 ru_try = match_smallIntegerTo primOp }
1072 rule_rationalTo str name mkLit
1073 = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
1074 ru_try = match_rationalTo mkLit }
1075
1076 ---------------------------------------------------
1077 -- The rule is this:
1078 -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
1079 -- = unpackFoldrCString# "foobaz" c n
1080
1081 match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1082 match_append_lit [Type ty1,
1083 Lit (MachStr s1),
1084 c1,
1085 Var unpk `App` Type ty2
1086 `App` Lit (MachStr s2)
1087 `App` c2
1088 `App` n
1089 ]
1090 | unpk `hasKey` unpackCStringFoldrIdKey &&
1091 c1 `cheapEqExpr` c2
1092 = ASSERT( ty1 `eqType` ty2 )
1093 Just (Var unpk `App` Type ty1
1094 `App` Lit (MachStr (s1 `BS.append` s2))
1095 `App` c1
1096 `App` n)
1097
1098 match_append_lit _ = Nothing
1099
1100 ---------------------------------------------------
1101 -- The rule is this:
1102 -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
1103
1104 match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1105 match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
1106 Var unpk2 `App` Lit (MachStr s2)]
1107 | unpk1 `hasKey` unpackCStringIdKey,
1108 unpk2 `hasKey` unpackCStringIdKey
1109 = Just (if s1 == s2 then trueValBool else falseValBool)
1110
1111 match_eq_string _ _ = Nothing
1112
1113
1114 ---------------------------------------------------
1115 -- The rule is this:
1116 -- inline f_ty (f a b c) = <f's unfolding> a b c
1117 -- (if f has an unfolding, EVEN if it's a loop breaker)
1118 --
1119 -- It's important to allow the argument to 'inline' to have args itself
1120 -- (a) because its more forgiving to allow the programmer to write
1121 -- inline f a b c
1122 -- or inline (f a b c)
1123 -- (b) because a polymorphic f wll get a type argument that the
1124 -- programmer can't avoid
1125 --
1126 -- Also, don't forget about 'inline's type argument!
1127 match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1128 match_inline (Type _ : e : _)
1129 | (Var f, args1) <- collectArgs e,
1130 Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)
1131 -- Ignore the IdUnfoldingFun here!
1132 = Just (mkApps unf args1)
1133
1134 match_inline _ = Nothing
1135
1136
1137 -- See Note [magicDictId magic] in `basicTypes/MkId.hs`
1138 -- for a description of what is going on here.
1139 match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
1140 match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ]
1141 | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap
1142 , Just (dictTy, _) <- splitFunTy_maybe fieldTy
1143 , Just dictTc <- tyConAppTyCon_maybe dictTy
1144 , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc
1145 = Just
1146 $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a]))
1147 `App` y
1148
1149 match_magicDict _ = Nothing
1150
1151 -------------------------------------------------
1152 -- Integer rules
1153 -- smallInteger (79::Int#) = 79::Integer
1154 -- wordToInteger (79::Word#) = 79::Integer
1155 -- Similarly Int64, Word64
1156
1157 match_IntToInteger :: RuleFun
1158 match_IntToInteger _ id_unf fn [xl]
1159 | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
1160 = case idType fn of
1161 FunTy _ integerTy ->
1162 Just (Lit (LitInteger x integerTy))
1163 _ ->
1164 panic "match_IntToInteger: Id has the wrong type"
1165 match_IntToInteger _ _ _ _ = Nothing
1166
1167 match_WordToInteger :: RuleFun
1168 match_WordToInteger _ id_unf id [xl]
1169 | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
1170 = case idType id of
1171 FunTy _ integerTy ->
1172 Just (Lit (LitInteger x integerTy))
1173 _ ->
1174 panic "match_WordToInteger: Id has the wrong type"
1175 match_WordToInteger _ _ _ _ = Nothing
1176
1177 match_Int64ToInteger :: RuleFun
1178 match_Int64ToInteger _ id_unf id [xl]
1179 | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
1180 = case idType id of
1181 FunTy _ integerTy ->
1182 Just (Lit (LitInteger x integerTy))
1183 _ ->
1184 panic "match_Int64ToInteger: Id has the wrong type"
1185 match_Int64ToInteger _ _ _ _ = Nothing
1186
1187 match_Word64ToInteger :: RuleFun
1188 match_Word64ToInteger _ id_unf id [xl]
1189 | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
1190 = case idType id of
1191 FunTy _ integerTy ->
1192 Just (Lit (LitInteger x integerTy))
1193 _ ->
1194 panic "match_Word64ToInteger: Id has the wrong type"
1195 match_Word64ToInteger _ _ _ _ = Nothing
1196
1197 -------------------------------------------------
1198 match_Integer_convert :: Num a
1199 => (DynFlags -> a -> Expr CoreBndr)
1200 -> RuleFun
1201 match_Integer_convert convert dflags id_unf _ [xl]
1202 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1203 = Just (convert dflags (fromInteger x))
1204 match_Integer_convert _ _ _ _ _ = Nothing
1205
1206 match_Integer_unop :: (Integer -> Integer) -> RuleFun
1207 match_Integer_unop unop _ id_unf _ [xl]
1208 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1209 = Just (Lit (LitInteger (unop x) i))
1210 match_Integer_unop _ _ _ _ _ = Nothing
1211
1212 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
1213 match_Integer_binop binop _ id_unf _ [xl,yl]
1214 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1215 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1216 = Just (Lit (LitInteger (x `binop` y) i))
1217 match_Integer_binop _ _ _ _ _ = Nothing
1218
1219 -- This helper is used for the quotRem and divMod functions
1220 match_Integer_divop_both
1221 :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
1222 match_Integer_divop_both divop _ id_unf _ [xl,yl]
1223 | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
1224 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1225 , y /= 0
1226 , (r,s) <- x `divop` y
1227 = Just $ mkConApp (tupleCon UnboxedTuple 2)
1228 [Type t,
1229 Type t,
1230 Lit (LitInteger r t),
1231 Lit (LitInteger s t)]
1232 match_Integer_divop_both _ _ _ _ _ = Nothing
1233
1234 -- This helper is used for the quot and rem functions
1235 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
1236 match_Integer_divop_one divop _ id_unf _ [xl,yl]
1237 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1238 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1239 , y /= 0
1240 = Just (Lit (LitInteger (x `divop` y) i))
1241 match_Integer_divop_one _ _ _ _ _ = Nothing
1242
1243 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
1244 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
1245 | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
1246 , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
1247 = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
1248 match_Integer_Int_binop _ _ _ _ _ = Nothing
1249
1250 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
1251 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
1252 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1253 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1254 = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
1255 match_Integer_binop_Prim _ _ _ _ _ = Nothing
1256
1257 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
1258 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
1259 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1260 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1261 = Just $ case x `binop` y of
1262 LT -> ltVal
1263 EQ -> eqVal
1264 GT -> gtVal
1265 match_Integer_binop_Ordering _ _ _ _ _ = Nothing
1266
1267 match_Integer_Int_encodeFloat :: RealFloat a
1268 => (a -> Expr CoreBndr)
1269 -> RuleFun
1270 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
1271 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1272 , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl
1273 = Just (mkLit $ encodeFloat x (fromInteger y))
1274 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
1275
1276 ---------------------------------------------------
1277 -- constant folding for Float/Double
1278 --
1279 -- This turns
1280 -- rationalToFloat n d
1281 -- into a literal Float, and similarly for Doubles.
1282 --
1283 -- it's important to not match d == 0, because that may represent a
1284 -- literal "0/0" or similar, and we can't produce a literal value for
1285 -- NaN or +-Inf
1286 match_rationalTo :: RealFloat a
1287 => (a -> Expr CoreBndr)
1288 -> RuleFun
1289 match_rationalTo mkLit _ id_unf _ [xl, yl]
1290 | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
1291 , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
1292 , y /= 0
1293 = Just (mkLit (fromRational (x % y)))
1294 match_rationalTo _ _ _ _ _ = Nothing
1295
1296 match_decodeDouble :: RuleFun
1297 match_decodeDouble _ id_unf fn [xl]
1298 | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
1299 = case idType fn of
1300 FunTy _ (TyConApp _ [integerTy, intHashTy]) ->
1301 case decodeFloat (fromRational x :: Double) of
1302 (y, z) ->
1303 Just $ mkConApp (tupleCon UnboxedTuple 2)
1304 [Type integerTy,
1305 Type intHashTy,
1306 Lit (LitInteger y integerTy),
1307 Lit (MachInt (toInteger z))]
1308 _ ->
1309 panic "match_decodeDouble: Id has the wrong type"
1310 match_decodeDouble _ _ _ _ = Nothing
1311
1312 match_XToIntegerToX :: Name -> RuleFun
1313 match_XToIntegerToX n _ _ _ [App (Var x) y]
1314 | idName x == n
1315 = Just y
1316 match_XToIntegerToX _ _ _ _ _ = Nothing
1317
1318 match_smallIntegerTo :: PrimOp -> RuleFun
1319 match_smallIntegerTo primOp _ _ _ [App (Var x) y]
1320 | idName x == smallIntegerName
1321 = Just $ App (Var (mkPrimOpId primOp)) y
1322 match_smallIntegerTo _ _ _ _ _ = Nothing