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